diff options
959 files changed, 85698 insertions, 28437 deletions
diff --git a/.gitignore b/.gitignore index c7a6ec56d0f..3e84de3ecfa 100644 --- a/.gitignore +++ b/.gitignore @@ -159,6 +159,7 @@ test/manual/etags/CTAGS test/manual/indent/*.new test/lisp/gnus/mml-sec-resources/random_seed test/lisp/play/fortune-resources/fortunes.dat +test/**/*.xml # ctags, etags. TAGS @@ -182,6 +183,7 @@ ID # Executables. *.exe a.out +lib-src/be-resources lib-src/blessmail lib-src/ctags lib-src/ebrowse @@ -203,6 +205,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 @@ -215,6 +218,7 @@ lisp/international/charprop.el lisp/international/charscript.el lisp/international/cp51932.el lisp/international/emoji-zwj.el +lisp/international/emoji-labels.el lisp/international/eucjp-ms.el lisp/international/uni-*.el lisp/language/pinyin.el @@ -313,3 +317,9 @@ lib-src/seccomp-filter.bpf lib-src/seccomp-filter.pfc lib-src/seccomp-filter-exec.bpf lib-src/seccomp-filter-exec.pfc + +# gsettings schema +/etc/*.gschema.valid + +# Ignore directory made by admin/make-manuals. +manual/ 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 <https://www.gnu.org/licenses/>. -# 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/GNUmakefile b/GNUmakefile index 5155487de28..1442cf0a4e8 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -36,31 +36,31 @@ ifeq (help,$(filter help,$(MAKECMDGOALS))) help: - @echo "NOTE: This is a brief summary of some common make targets." - @echo "For more detailed information, please read the files INSTALL," - @echo "INSTALL.REPO, Makefile or visit this URL:" - @echo "https://www.gnu.org/prep/standards/html_node/Standard-Targets.html" - @echo "" - @echo "make all -- compile and build Emacs" - @echo "make install -- install Emacs" - @echo "make TAGS -- update tags tables" - @echo "make clean -- delete built files but preserve configuration" - @echo "make mostlyclean -- like 'make clean', but leave those files that" - @echo " usually do not need to be recompiled" - @echo "make distclean -- delete all build and configuration files," - @echo " leave only files included in source distribution" - @echo "make maintainer-clean -- delete almost everything that can be regenerated" - @echo "make extraclean -- like maintainer-clean, and also delete" - @echo " backup and autosave files" - @echo "make bootstrap -- delete all compiled files to force a new bootstrap" - @echo " from a clean slate, then build in the normal way" - @echo "make uninstall -- remove files installed by 'make install'" - @echo "make check -- run the Emacs test suite" - @echo "make docs -- generate Emacs documentation in info format" - @echo "make html -- generate documentation in html format" - @echo "make ps -- generate documentation in ps format" - @echo "make pdf -- generate documentation in pdf format " - @exit + $(info $ NOTE: This is a brief summary of some common make targets.) + $(info $ For more detailed information, please read the files INSTALL,) + $(info $ INSTALL.REPO, Makefile or visit this URL:) + $(info $ https://www.gnu.org/prep/standards/html_node/Standard-Targets.html) + $(info $ ) + $(info $ make all -- compile and build Emacs) + $(info $ make install -- install Emacs) + $(info $ make TAGS -- update tags tables) + $(info $ make clean -- delete built files but preserve configuration) + $(info $ make mostlyclean -- like 'make clean', but leave those files that) + $(info $ usually do not need to be recompiled) + $(info $ make distclean -- delete all build and configuration files,) + $(info $ leave only files included in source distribution) + $(info $ make maintainer-clean -- delete almost everything that can be regenerated) + $(info $ make extraclean -- like maintainer-clean, and also delete) + $(info $ backup and autosave files) + $(info $ make bootstrap -- delete all compiled files to force a new bootstrap) + $(info $ from a clean slate, then build in the normal way) + $(info $ make uninstall -- remove files installed by 'make install') + $(info $ make check -- run the Emacs test suite) + $(info $ make docs -- generate Emacs documentation in info format) + $(info $ make html -- generate documentation in html format) + $(info $ make ps -- generate documentation in ps format) + $(info $ make pdf -- generate documentation in pdf format ) + @: .PHONY: help @@ -79,7 +79,7 @@ else ifeq ($(filter-out %clean,$(or $(MAKECMDGOALS),default)),) $(MAKECMDGOALS): - @echo >&2 'No Makefile; skipping $@.' + $(warning No Makefile; skipping $@.) else @@ -97,15 +97,20 @@ default $(ORDINARY_GOALS): Makefile .NOTPARALLEL: configure: - @echo >&2 'There seems to be no "configure" file in this directory.' - @echo >&2 Running ./autogen.sh ... + $(warning There seems to be no "configure" file in this directory.) + $(warning Running ./autogen.sh ...) ./autogen.sh @echo >&2 '"configure" file built.' Makefile: configure - @echo >&2 'There seems to be no Makefile in this directory.' - @echo >&2 'Running ./configure ...' + $(warning There seems to be no Makefile in this directory.) +ifeq ($(configure),default) + $(warning Running ./configure ...) ./configure +else + $(warning Running ./configure $(configure)...) + ./configure $(configure) +endif @echo >&2 'Makefile built.' # 'make bootstrap' in a fresh checkout needn't run 'configure' twice. @@ -187,6 +187,7 @@ X11 is being used. X libtiff for TIFF: http://www.simplesystems.org/libtiff/ X libgif for GIF: http://giflib.sourceforge.net/ librsvg2 for SVG: https://wiki.gnome.org/Projects/LibRsvg + libwebp for WebP: https://developers.google.com/speed/webp/ If you supply the appropriate --without-LIB option, 'configure' will omit the corresponding library from Emacs, even if that makes for a @@ -313,6 +314,7 @@ or more of these options: --without-gif for GIF image support --without-png for PNG image support --without-rsvg for SVG image support + --without-webp for WebP image support Although ImageMagick support is disabled by default due to security and stability concerns, you can enable it with --with-imagemagick. @@ -322,6 +324,10 @@ Use --without-toolkit-scroll-bars to disable Motif or Xaw3d scroll bars. Use --without-xim to inhibit the default use of X Input Methods. In this case, the X resource useXIM can be used to turn on use of XIM. +Use --with-xinput2 to enable the use of version 2 of the X Input +Extension. This enables support for touchscreens, pinch gestures, and +scroll wheels that report scroll deltas at pixel-level precision. + Use --disable-largefile to omit support for files larger than 2GB, and --disable-year2038 to omit support for timestamps past the year 2038, on systems which allow omitting such support. This may help when 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 c36882d5bea..e68658272f9 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. @@ -210,6 +212,9 @@ icondir=$(datarootdir)/icons # The source directory for the icon files. iconsrcdir=$(srcdir)/etc/images/icons +# Where to install the gsettings schema file. +gsettingsschemadir = @gsettingsschemadir@ + # ==================== Emacs-specific directories ==================== # These variables hold the values Emacs will actually use. They are @@ -304,6 +309,8 @@ LN_S_FILEONLY = @LN_S_FILEONLY@ # We use gzip to compress installed .el and some .txt files. GZIP_PROG = @GZIP_PROG@ +GLIB_COMPILE_SCHEMAS = glib-compile-schemas + # ============================= Targets ============================== # Program name transformation. @@ -313,6 +320,7 @@ TRANSFORM = @program_transform_name@ EMACS_NAME = `echo emacs | sed '$(TRANSFORM)'` EMACS = ${EMACS_NAME}${EXEEXT} EMACSFULL = `echo emacs-${version} | sed '$(TRANSFORM)'`${EXEEXT} +EMACS_PDMP = `./src/emacs${EXEEXT} --fingerprint`.pdmp # Subdirectories to make recursively. SUBDIR = $(NTDIR) lib lib-src src lisp @@ -342,7 +350,9 @@ BIN_DESTDIR='${ns_appbindir}/' ELN_DESTDIR = ${ns_applibdir}/ endif -all: ${SUBDIR} info +gsettings_SCHEMAS = etc/org.gnu.emacs.defaults.gschema.xml + +all: ${SUBDIR} info $(gsettings_SCHEMAS:.xml=.valid) .PHONY: all ${SUBDIR} blessmail epaths-force epaths-force-w32 epaths-force-ns-self-contained etc-emacsver @@ -424,6 +434,10 @@ epaths-force-ns-self-contained: epaths-force -e 's;${ns_appdir}/;;') && \ ${srcdir}/build-aux/move-if-change epaths.h.$$$$ src/epaths.h +ifneq ($(NTDIR),) +$(NTDIR): lib +endif + lib-src src: $(NTDIR) lib src: lib-src @@ -494,7 +508,7 @@ $(srcdir)/configure: $(srcdir)/configure.ac $(srcdir)/m4/*.m4 ## don't have to duplicate the list of utilities to install in ## this Makefile as well. -install: all install-arch-indep install-etcdoc install-arch-dep install-$(NTDIR) blessmail install-eln +install: all install-arch-indep install-etcdoc install-arch-dep install-$(NTDIR) blessmail install-eln install-gsettings-schemas @true ## Ensure that $subdir contains a subdirs.el file. @@ -520,8 +534,14 @@ 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) - ${INSTALL_DATA} src/emacs.pdmp "$(DESTDIR)${libexecdir}/emacs/${version}/${configuration}"/emacs.pdmp +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)" ifndef NO_BIN_LINK @@ -808,7 +828,7 @@ install-strip: ### create (but not the noninstalled files such as 'make all' would create). ### ### Don't delete the lisp and etc directories if they're in the source tree. -uninstall: uninstall-$(NTDIR) uninstall-doc +uninstall: uninstall-$(NTDIR) uninstall-doc uninstall-gsettings-schemas rm -f "$(DESTDIR)$(includedir)/emacs-module.h" $(MAKE) -C lib-src uninstall -unset CDPATH; \ @@ -904,7 +924,7 @@ clean_dirs = $(mostlyclean_dirs) nextstep admin/charsets admin/unidata $(foreach dir,$(clean_dirs),$(eval $(call submake_template,$(dir),clean))) -clean: $(clean_dirs:=_clean) +clean: $(clean_dirs:=_clean) clean-gsettings-schemas -rm -f ./*.tmp etc/*.tmp* -rm -rf info-dir.* -rm -rf native-lisp @@ -1054,8 +1074,8 @@ info_dir_deps = \ ## but then we would need to depend on ${INFOS}, which would ## slow down parallelization. ${srcdir}/info/dir: ${info_dir_deps} - $(AM_V_at)${MKDIR_P} ${srcdir}/info - $(AM_V_GEN)(cd ${srcdir}/doc && \ + $(AM_V_GEN)${MKDIR_P} ${srcdir}/info + $(AM_V_at)(cd ${srcdir}/doc && \ AWK='${AWK}' ../build-aux/make-info-dir ${info_dir_inputs} \ ) >$@.tmp && mv $@.tmp $@ @@ -1136,14 +1156,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 @@ -1215,3 +1244,10 @@ gitmerge: ${GITMERGE_EMACS} -batch --no-site-file --no-site-lisp \ -l ${srcdir}/admin/gitmerge.el \ --eval '(setq gitmerge-minimum-missing ${GITMERGE_NMIN})' -f gitmerge + +@GSETTINGS_RULES@ + +install-gsettings-schemas: +uninstall-gsettings-schemas: +clean-gsettings-schemas: +$(gsettings_SCHEMAS:.xml=.valid): @@ -2,7 +2,7 @@ Copyright (C) 2001-2021 Free Software Foundation, Inc. See the end of the file for license conditions. -This directory tree holds version 28.0.90 of GNU Emacs, the extensible, +This directory tree holds version 29.0.50 of GNU Emacs, the extensible, customizable, self-documenting real-time display editor. The file INSTALL in this directory says how to build and install GNU diff --git a/admin/CPP-DEFINES b/admin/CPP-DEFINES index 68c12438f5a..620ab0bed05 100644 --- a/admin/CPP-DEFINES +++ b/admin/CPP-DEFINES @@ -287,6 +287,8 @@ HAVE_UTIMENSAT HAVE_UTMP_H HAVE_VFORK HAVE_VFORK_H +HAVE_WEBP +HAVE_SQLITE3 HAVE_WCHAR_H HAVE_WCHAR_T HAVE_WINDOW_SYSTEM 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/admin.el b/admin/admin.el index ad4208beef0..c1bdb13df96 100644 --- a/admin/admin.el +++ b/admin/admin.el @@ -88,6 +88,9 @@ Optional argument DATE is the release date, default today." (kill-buffer) (message "No need to update `%s'" file))) +(defvar admin-git-command (executable-find "git") + "The `git' program to use.") + (defun set-version (root version) "Set Emacs version to VERSION in relevant files under ROOT. Root must be the root of an Emacs source tree." @@ -96,6 +99,8 @@ Root must be the root of an Emacs source tree." (read-string "Version number: " emacs-version))) (unless (file-exists-p (expand-file-name "src/emacs.c" root)) (user-error "%s doesn't seem to be the root of an Emacs source tree" root)) + (unless admin-git-command + (user-error "Could not find git; please install git and move NEWS manually")) (message "Setting version numbers...") ;; There's also a "version 3" (standing for GPLv3) at the end of ;; `README', but since `set-version-in-file' only replaces the first @@ -157,7 +162,13 @@ Root must be the root of an Emacs source tree." Documentation changes might not have been completed!")))) (when (and majorbump (not (file-exists-p oldnewsfile))) - (rename-file newsfile oldnewsfile) + (call-process admin-git-command nil nil nil + "mv" newsfile oldnewsfile) + (when (y-or-n-p "Commit move of NEWS file?") + (call-process admin-git-command nil nil nil + "commit" "-m" (format "; Move etc/%s to etc/%s" + (file-name-nondirectory newsfile) + (file-name-nondirectory oldnewsfile)))) (find-file oldnewsfile) ; to prompt you to commit it (copy-file oldnewsfile newsfile) (with-temp-buffer diff --git a/admin/authors.el b/admin/authors.el index adf6d22a88e..d44bb9bf8e4 100644 --- a/admin/authors.el +++ b/admin/authors.el @@ -391,6 +391,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 61570587d6b..81082f7dc68 100755 --- a/admin/automerge +++ b/admin/automerge @@ -4,7 +4,7 @@ ## Copyright (C) 2018-2021 Free Software Foundation, Inc. ## Author: Glenn Morris <rgm@gnu.org> -## Maintainer: emacs-devel@gnu.org +## Maintainer: Stefan Kangas <stefan@marxist.se> ## This file is part of GNU Emacs. @@ -37,7 +37,7 @@ die () # write error to stderr and exit { - [ $# -gt 0 ] && echo "$PN: $@" >&2 + [ $# -gt 0 ] && echo "$PN: $*" >&2 exit 1 } @@ -108,7 +108,8 @@ OPTIND=1 [ "$nocd" ] || { - cd $PD # this should be the admin directory + # $PD should be the admin directory + cd $PD || die "Could not change directory to $PD" cd ../ } @@ -126,9 +127,13 @@ OPTIND=1 [ "$test" ] && build=1 -tempfile=/tmp/$PN.$$ +if [ -x "$(command -v mktemp)" ]; then + tempfile=$(mktemp "/tmp/$PN.XXXXXXXXXX") +else + tempfile=/tmp/$PN.$$ +fi -trap "rm -f $tempfile 2> /dev/null" EXIT +trap 'rm -f $tempfile 2> /dev/null' EXIT [ -e Makefile ] && [ "$build" ] && { @@ -148,7 +153,7 @@ trap "rm -f $tempfile 2> /dev/null" EXIT rev=$(git rev-parse HEAD) -[ $(git rev-parse @{u}) = $rev ] || die "Local state does not match origin" +[ "$(git rev-parse @{u})" = "$rev" ] || die "Local state does not match origin" merge () @@ -157,12 +162,12 @@ merge () if $emacs --batch -Q -l ./admin/gitmerge.el \ --eval "(setq gitmerge-minimum-missing $nmin)" -f gitmerge \ - >| $tempfile 2>&1; then + >| "$tempfile" 2>&1; then echo "merged ok" return 0 else - grep -E "Nothing to merge|Number of missing commits" $tempfile && \ + grep -E "Nothing to merge|Number of missing commits" "$tempfile" && \ exit 0 cat "$tempfile" 1>&2 @@ -186,13 +191,13 @@ git diff --stat --cached origin/master | grep -q "etc/NEWS " && \ echo "Running autoreconf..." -autoreconf -i -I m4 2>| $tempfile +autoreconf -i -I m4 2>| "$tempfile" retval=$? ## Annoyingly, autoreconf puts the "installing `./foo' messages on stderr. if [ "$quiet" ]; then - grep -v 'installing `\.' $tempfile 1>&2 + grep -v 'installing `\.' "$tempfile" 1>&2 else cat "$tempfile" 1>&2 fi @@ -231,7 +236,7 @@ echo "Tests finished ok" echo "Checking for remote changes..." git fetch || die "fetch error" -[ $(git rev-parse @{u}) = $rev ] || { +[ "$(git rev-parse @{u})" = "$rev" ] || { echo "Upstream has changed" @@ -240,7 +245,7 @@ git fetch || die "fetch error" ## Ref eg https://lists.gnu.org/r/emacs-devel/2014-12/msg01435.html ## Instead, we throw away what we just did, and do the merge again. echo "Resetting..." - git reset --hard $rev + git reset --hard "$rev" echo "Pulling..." git pull --ff-only || die "pull error" diff --git a/admin/emake b/admin/emake index bdaabc026b3..2ff553289da 100755 --- a/admin/emake +++ b/admin/emake @@ -13,7 +13,7 @@ cores=1 # Determine the number of cores. if [ -f /proc/cpuinfo ]; then - cores=$(($(egrep "^physical id|^cpu cores" /proc/cpuinfo |\ + cores=$(($(grep -E "^physical id|^cpu cores" /proc/cpuinfo |\ awk '{ print $4; }' |\ sed '$!N;s/\n/ /' |\ uniq |\ @@ -28,8 +28,9 @@ s#^Installing git hooks...# Installing git hooks...# s#^Running # Running # s#^Configured for # Configured for # s#^./temacs.*# \\& # +s#^make.*Error# \\& # ' | \ -egrep --line-buffered -v "^make|\ +grep -E --line-buffered -v "^make|\ ^Loading|\ SCRAPE|\ INFO.*Scraping.*[.] ?\$|\ @@ -92,4 +93,4 @@ done # changed since last time. make -j$cores check-maybe 2>&1 | \ sed -n '/contained unexpected results/,$p' | \ - egrep --line-buffered -v "^make" + grep -E --line-buffered -v "^make" diff --git a/admin/gitmerge.el b/admin/gitmerge.el index 851212c7bb1..658ceb77f49 100644 --- a/admin/gitmerge.el +++ b/admin/gitmerge.el @@ -37,10 +37,10 @@ ;; up-to-date). ;; - Mark commits you'd like to skip, meaning to only merge their ;; metadata (merge strategy 'ours'). -;; - Hit 'm' to start merging. Skipped commits will be merged separately. +;; - Hit 'm' to start merging. Skipped commits will be merged separately. ;; - If conflicts cannot be resolved automatically, you'll have to do -;; it manually. In that case, resolve the conflicts and restart -;; gitmerge, which will automatically resume. It will add resolved +;; it manually. In that case, resolve the conflicts and restart +;; gitmerge, which will automatically resume. It will add resolved ;; files, commit the pending merge and continue merging the rest. ;; - Inspect master branch, and if everything looks OK, push. @@ -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 @@ -122,13 +121,14 @@ If nil, the function `gitmerge-default-branch' guesses.") (with-temp-buffer (if (not branch) (insert-file-contents "configure.ac") - (call-process "git" nil t nil "show" (format "%s:configure.ac" branch)) + (let ((coding-system-for-read vc-git-log-output-coding-system)) + (call-process "git" nil t nil "show" (format "%s:configure.ac" branch))) (goto-char (point-min))) (re-search-forward "^AC_INIT([^,]+, \\([0-9]+\\)\\.") (string-to-number (match-string 1)))) (defun gitmerge-default-branch () - "Default for branch that should be merged; eg \"origin/emacs-26\"." + "Default for branch that should be merged; e.g. \"origin/emacs-28\"." (or gitmerge-default-branch (format "origin/emacs-%s" (1- (gitmerge-emacs-version))))) @@ -148,7 +148,8 @@ If nil, the function `gitmerge-default-branch' guesses.") (pop-to-buffer (get-buffer-create gitmerge-output-buffer)) (fundamental-mode) (erase-buffer) - (call-process "git" nil t nil "log" "-1" commit) + (let ((coding-system-for-read vc-git-log-output-coding-system)) + (call-process "git" nil t nil "log" "-1" commit)) (goto-char (point-min)) (gitmerge-highlight-skip-regexp))))) @@ -160,7 +161,8 @@ If nil, the function `gitmerge-default-branch' guesses.") (when commit (pop-to-buffer (get-buffer-create gitmerge-output-buffer)) (erase-buffer) - (call-process "git" nil t nil "diff-tree" "-p" commit) + (let ((coding-system-for-read vc-git-log-output-coding-system)) + (call-process "git" nil t nil "diff-tree" "-p" commit)) (goto-char (point-min)) (diff-mode))))) @@ -173,7 +175,9 @@ If nil, the function `gitmerge-default-branch' guesses.") (pop-to-buffer (get-buffer-create gitmerge-output-buffer)) (erase-buffer) (fundamental-mode) - (call-process "git" nil t nil "diff" "--name-only" (concat commit "^!")) + (let ((coding-system-for-read vc-git-log-output-coding-system)) + (call-process "git" nil t nil "diff" "--name-only" + (concat commit "^!"))) (goto-char (point-min)))))) (defun gitmerge-toggle-skip () @@ -216,9 +220,10 @@ if and why this commit should be skipped." ;; Go through the log and remember all commits that match ;; `gitmerge-skip-regexp' or are marked by --cherry-mark. (with-temp-buffer - (call-process "git" nil t nil "log" "--cherry-mark" "--left-only" - "--no-decorate" - (concat from "..." (car (vc-git-branches)))) + (let ((coding-system-for-read vc-git-log-output-coding-system)) + (call-process "git" nil t nil "log" "--cherry-mark" "--left-only" + "--no-decorate" + (concat from "..." (car (vc-git-branches))))) (goto-char (point-max)) (while (re-search-backward "^commit \\(.+\\) \\([0-9a-f]+\\).*" nil t) (let ((cherrymark (match-string 1)) @@ -241,9 +246,10 @@ if and why this commit should be skipped." "Create the buffer for choosing commits." (with-current-buffer (get-buffer-create gitmerge-buffer) (erase-buffer) - (call-process "git" nil t nil "log" "--left-only" - "--pretty=format:%h %<(20,trunc) %an: %<(100,trunc) %s" - (concat from "..." (car (vc-git-branches)))) + (let ((coding-system-for-read vc-git-log-output-coding-system)) + (call-process "git" nil t nil "log" "--left-only" + "--pretty=format:%h %<(20,trunc) %an: %<(100,trunc) %s" + (concat from "..." (car (vc-git-branches))))) (goto-char (point-min)) (while (looking-at "^\\([a-f0-9]+\\)") (let ((skipreason (gitmerge-skip-commit-p (match-string 1) commits))) @@ -326,7 +332,8 @@ Returns non-nil if conflicts remain." ;; (pop-to-buffer (current-buffer)) (debug 'before-resolve) )) ;; Try to resolve the conflicts. - (let (temp) + (let ((coding-system-for-read vc-git-log-output-coding-system) + temp) (cond ;; FIXME when merging release branch to master, we still ;; need to detect and handle the case where NEWS was modified @@ -392,9 +399,10 @@ is nil, only the single commit BEG is merged." (if end "s were " " was ") "skipped:\n\n") "")) - (apply #'call-process "git" nil t nil "log" "--oneline" - (if end (list (concat beg "~.." end)) - `("-1" ,beg))) + (let ((coding-system-for-read vc-git-log-output-coding-system)) + (apply #'call-process "git" nil t nil "log" "--oneline" + (if end (list (concat beg "~.." end)) + `("-1" ,beg)))) (insert "\n") ;; Truncate to 72 chars so that the resulting ChangeLog line fits in 80. (goto-char (point-min)) @@ -408,8 +416,9 @@ MISSING must be a list of SHA1 strings." (with-current-buffer (get-buffer-create gitmerge-output-buffer) (erase-buffer) (let* ((skip (cdar missing)) + (coding-system-for-read vc-git-log-output-coding-system) (beg (car (pop missing))) - end commitmessage) + end commitmessage commitmessage1 commitmessage-file status) ;; Determine last revision with same boolean skip status. (while (and missing (eq (null (cdar missing)) @@ -423,12 +432,32 @@ MISSING must be a list of SHA1 strings." (if end (concat ".." (substring end 0 6)) "")) (unless end (setq end beg)) - (unless (zerop - (apply #'call-process "git" nil t nil "merge" "--no-ff" - (append (when skip '("-s" "ours")) - `("-m" ,commitmessage ,end)))) + (when (eq system-type 'windows-nt) + ;; Command lines on MS-Windows cannot include newlines. + ;; Since "git merge" doesn't accept a -F FILE option, we + ;; commit the merge with a shortened single-line log message, + ;; and then invoke "git commit --amend" with the full log + ;; message from a temporary file. + (setq commitmessage1 + ;; Make sure the commit message is at most a single line. + (car (split-string commitmessage "[\f\n\r\v]+"))) + (setq commitmessage-file (make-nearby-temp-file "gitmerge-msg")) + (let ((coding-system-for-write vc-git-commits-coding-system)) + (write-region commitmessage nil commitmessage-file nil 'silent))) + (unless (setq status + (zerop + (apply #'call-process "git" nil t nil "merge" "--no-ff" + (append (when skip '("-s" "ours")) + (if commitmessage-file + `("-m" ,commitmessage1 ,end) + `("-m" ,commitmessage ,end)))))) (gitmerge-write-missing missing from) - (gitmerge-resolve-unmerged))) + (gitmerge-resolve-unmerged)) + (when (and commitmessage-file (file-exists-p commitmessage-file)) + (if status + (call-process "git" nil t nil + "commit" "--amend" "-F" commitmessage-file)) + (delete-file commitmessage-file))) missing)) (defun gitmerge-resolve-unmerged () @@ -436,12 +465,13 @@ MISSING must be a list of SHA1 strings." Throw an user-error if we cannot resolve automatically." (with-current-buffer (get-buffer-create gitmerge-output-buffer) (erase-buffer) - (let (files conflicted) + (let ((coding-system-for-read vc-git-log-output-coding-system) + files conflicted) ;; List unmerged files (if (not (zerop (call-process "git" nil t nil "diff" "--name-only" "--diff-filter=U"))) - (error "Error listing unmerged files. Resolve manually.") + (error "Error listing unmerged files. Resolve manually.") (goto-char (point-min)) (while (not (eobp)) (push (buffer-substring (point) (line-end-position)) files) @@ -479,17 +509,19 @@ Throw an user-error if we cannot resolve automatically." (defun gitmerge-repo-clean () "Return non-nil if repository is clean." (with-temp-buffer + (let ((coding-system-for-read vc-git-log-output-coding-system)) (call-process "git" nil t nil "diff" "--staged" "--name-only") (call-process "git" nil t nil "diff" "--name-only") - (zerop (buffer-size)))) + (zerop (buffer-size))))) (defun gitmerge-commit () "Commit, and return non-nil if it succeeds." (with-current-buffer (get-buffer-create gitmerge-output-buffer) - (erase-buffer) - (eq 0 (call-process "git" nil t nil "commit" "--no-edit")))) + (let ((coding-system-for-read vc-git-log-output-coding-system)) + (erase-buffer) + (eq 0 (call-process "git" nil t nil "commit" "--no-edit"))))) (defun gitmerge-maybe-resume () "Check if we have to resume a merge. @@ -603,7 +635,7 @@ Branch FROM will be prepended to the list." "(s) Toggle skip, (l) Show log, (d) Show diff, " "(f) Show files, (m) Start merge\n" (propertize "Flags: " 'font-lock-face 'bold) - "(C) Detected backport (cherry-mark), (R) Log matches " + "(C) Detected backport (cherry-mark), (R) Matches skip " "regexp, (M) Manually picked\n\n") (gitmerge-mode) (pop-to-buffer (current-buffer)) diff --git a/admin/notes/emba b/admin/notes/emba index 36b126e7735..2135c7a97cc 100644 --- a/admin/notes/emba +++ b/admin/notes/emba @@ -28,29 +28,45 @@ 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 <https://emba.gnu.org/help/ci/yaml/README.md>. +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', '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 and test parameters. -There are different types of jobs: 'prep-image-base' is responsible to -prepare the environment for the following jobs. 'build-image-*' jobs -are responsible to compile Emacs in different configuration. The -corresponding 'test-*' jobs run the ert tests. +The 'build-image-*' jobs of the different '*-images' stages run only +if there are severe changes in the Emacs sources, like in Makefiles +etc. Otherwise they are skipped, and the corresponding 'test-*' jobs +run just 'make -C test ...' in the respective Docker image from a +previous build run. -A special job is 'test-all-inotify', which runs 'make check-expensive'. -While most of the jobs run as soon as a respective file has been -committed into the Emacs git repository, this test job runs scheduled, -every 8 hours. +Jobs in the 'build-images' and 'normal' stages are triggered by +changes of respective files in the Emacs git repository. All other +jobs run scheduled in a pipeline every 8 hours. The log files for every test job are kept on the server for a week. They can be downloaded from the server, visiting the URL <https://emba.gnu.org/emacs/emacs/-/pipelines>, and selecting the job in question. +Every pipeline generates a JUnit test report for the respective test +jobs, which can be inspected on the pipeline web page. This test +report counts completed ERT tests, aborted tests are not counted. + * Emba configuration The emba configuration files are hosted on diff --git a/admin/notes/git-workflow b/admin/notes/git-workflow index d109cdaa354..265a106bad5 100644 --- a/admin/notes/git-workflow +++ b/admin/notes/git-workflow @@ -16,14 +16,14 @@ Initial setup Then we want to clone the repository. We normally want to have both the current master and (if there is one) the active release branch -(eg emacs-27). +(eg emacs-28). mkdir ~/emacs cd ~/emacs git clone <membername>@git.sv.gnu.org:/srv/git/emacs.git master cd master git config push.default current -git worktree add ../emacs-27 emacs-27 +git worktree add ../emacs-28 emacs-28 You now have both branches conveniently accessible, and you can do "git pull" in them once in a while to keep updated. @@ -67,7 +67,7 @@ which will look like commit 958b768a6534ae6e77a8547a56fc31b46b63710b -cd ~/emacs/emacs-27 +cd ~/emacs/emacs-28 git cherry-pick -xe 958b768a6534ae6e77a8547a56fc31b46b63710b and add "Backport:" to the commit string. Then @@ -109,7 +109,7 @@ up-to-date by doing a pull. Then start Emacs with emacs -l admin/gitmerge.el -f gitmerge You'll be asked for the branch to merge, which will default to -(eg) 'origin/emacs-27', which you should accept. Merging a local tracking +(eg) 'origin/emacs-28', which you should accept. Merging a local tracking branch is discouraged, since it might not be up-to-date, or worse, contain commits from you which are not yet pushed upstream. diff --git a/admin/notes/unicode b/admin/notes/unicode index c41b9a6d26d..be51d09d37a 100644 --- a/admin/notes/unicode +++ b/admin/notes/unicode @@ -21,11 +21,14 @@ Emacs uses the following files from the Unicode Character Database . emoji-sequences.txt . BidiCharacterTest.txt -First, the first 10 files need to be copied into admin/unidata/, and -the file https://www.unicode.org/copyright.html should be copied over -copyright.html in admin/unidata (some of them might need trailing -whitespace removed before they can be committed to the Emacs -repository). +Emacs also uses the file emoji-test.txt which should be imported from +the Unicode's Public/emoji/ directory. + +First, the first 10 files and emoji-test.txt need to be copied into +admin/unidata/, and the file https://www.unicode.org/copyright.html +should be copied over copyright.html in admin/unidata (some of them +might need trailing whitespace removed before they can be committed to +the Emacs repository). Then Emacs should be rebuilt for them to take effect. Rebuilding Emacs updates several derived files elsewhere in the Emacs source diff --git a/admin/nt/dist-build/build-dep-zips.py b/admin/nt/dist-build/build-dep-zips.py index 19168e7ff25..dfff493b640 100755 --- a/admin/nt/dist-build/build-dep-zips.py +++ b/admin/nt/dist-build/build-dep-zips.py @@ -20,6 +20,8 @@ import argparse import os import shutil import re +import functools +import operator from subprocess import check_output @@ -112,7 +114,7 @@ def ntldd_munge(out): ## Packages to fiddle with ## Source for gcc-libs is part of gcc SKIP_SRC_PKGS=["mingw-w64-gcc-libs"] -SKIP_DEP_PKGS=["mingw-w64-glib2"] +SKIP_DEP_PKGS=frozenset(["mingw-w64-x86_64-glib2"]) MUNGE_SRC_PKGS={"mingw-w64-libwinpthread-git":"mingw-w64-winpthreads-git"} MUNGE_DEP_PKGS={ "mingw-w64-x86_64-libwinpthread":"mingw-w64-x86_64-libwinpthread-git", @@ -121,19 +123,17 @@ MUNGE_DEP_PKGS={ ## 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(pkg): - package_info = check_output(["pacman", "-Si", pkg]).decode("utf-8").split("\n") +def immediate_deps(pkgs): + package_info = check_output(["pacman", "-Si"] + pkgs).decode("utf-8").splitlines() - ## Extract the "Depends On" line - depends_on = [x for x in package_info if x.startswith("Depends On")][0] - ## Remove "Depends On" prefix - dependencies = depends_on.split(":")[1] - - ## Split into dependencies - dependencies = dependencies.strip().split(" ") + ## Extract the packages listed for "Depends On:" lines. + dependencies = [line.split(":")[1].split() for line in package_info + if line.startswith("Depends On")] + ## Flatten dependency lists from multiple packages into one list. + dependencies = functools.reduce(operator.iconcat, dependencies, []) ## Remove > signs TODO can we get any other punctuation here? dependencies = [d.split(">")[0] for d in dependencies if d] @@ -149,16 +149,18 @@ def extract_deps(): print( "Extracting deps" ) # Get a list of all dependencies needed for packages mentioned above. - pkgs = PKG_REQ[:] - n = 0 - while n < len(pkgs): - subdeps = immediate_deps(pkgs[n]) - for p in subdeps: - if not (p in pkgs or p in SKIP_DEP_PKGS): - pkgs.append(p) - n = n + 1 + pkgs = set(PKG_REQ) + newdeps = pkgs + print("adding...") + while True: + subdeps = frozenset(immediate_deps(list(newdeps))) + newdeps = subdeps - SKIP_DEP_PKGS - pkgs + if not newdeps: + break + print('\n'.join(newdeps)) + pkgs |= newdeps - return sorted(pkgs) + return list(pkgs) def download_source(tarball): @@ -167,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 ) @@ -255,7 +257,7 @@ DRY_RUN=args.d if( args.l ): print("List of dependencies") - print( extract_deps() ) + print( deps ) exit(0) if args.s: diff --git a/admin/unidata/Makefile.in b/admin/unidata/Makefile.in index a953044a115..011e97b3d10 100644 --- a/admin/unidata/Makefile.in +++ b/admin/unidata/Makefile.in @@ -41,7 +41,7 @@ unifiles = $(addprefix ${unidir}/,$(sort $(shell sed -n 's/^[ \t][ \t]*${lparen} .PHONY: all all: ${top_srcdir}/src/macuvs.h ${unifiles} ${unidir}/charscript.el \ - ${unidir}/charprop.el ${unidir}/emoji-zwj.el + ${unidir}/charprop.el ${unidir}/emoji-zwj.el ${unidir}/emoji-labels.el ## Specify .elc as an order-only prereq so as to not needlessly rebuild ## target just because the .elc is missing. @@ -63,18 +63,21 @@ unidata.txt: ${srcdir}/UnicodeData.txt ## pretend that it does since other Makefiles assume that if charprop ## is up-to-date, the unifiles are too. ${unidir}/charprop.el: ${unifiles} ${srcdir}/unidata-gen.el | ${srcdir}/unidata-gen.elc - $(AM_V_at)[ ! -f $@ ] || chmod +w $@ - $(AM_V_GEN)${emacs} -L ${srcdir} -l unidata-gen \ + $(AM_V_GEN)[ ! -f $@ ] || chmod +w $@ + $(AM_V_at)${emacs} -L ${srcdir} -l unidata-gen \ -f unidata-gen-charprop $@ ${unifiles}: ${srcdir}/unidata-gen.el \ ${srcdir}/UnicodeData.txt ${srcdir}/BidiMirroring.txt \ ${srcdir}/BidiBrackets.txt | \ ${srcdir}/unidata-gen.elc unidata.txt - $(AM_V_at)[ ! -f $@ ] || chmod +w $@ - $(AM_V_GEN)${emacs} -L ${srcdir} -l unidata-gen \ + $(AM_V_GEN)[ ! -f $@ ] || chmod +w $@ + $(AM_V_at)${emacs} -L ${srcdir} -l unidata-gen \ -f unidata-gen-file $@ ${srcdir} +${unidir}/emoji-labels.el: ${unidir}/../international/emoji.el \ + ${srcdir}/emoji-test.txt + $(AM_V_GEN)${emacs} -l emoji.el -f emoji--generate-file $@ .PHONY: charscript.el charscript.el: ${unidir}/charscript.el @@ -113,7 +116,7 @@ gen-clean: rm -f ${unidir}/charscript.el* rm -f ${unidir}/emoji-zwj.el* rm -f ${unifiles} ${unidir}/charprop.el + rm -f ${unidir}/emoji-labels.el* ## ref: https://lists.gnu.org/r/emacs-devel/2013-11/msg01029.html maintainer-clean: gen-clean distclean - diff --git a/admin/unidata/README b/admin/unidata/README index 656ee15c54c..4b8444b0fec 100644 --- a/admin/unidata/README +++ b/admin/unidata/README @@ -44,3 +44,7 @@ https://www.unicode.org/Public/emoji/14.0/emoji-zwj-sequences.txt emoji-sequences.txt https://www.unicode.org/Public/emoji/14.0/emoji-sequences.txt 2020-08-26 + +emoji-test.txt +https://unicode.org/Public/emoji/14.0/emoji-test.txt +2021-10-28 diff --git a/admin/unidata/emoji-test.txt b/admin/unidata/emoji-test.txt new file mode 100644 index 00000000000..42e6210cd28 --- /dev/null +++ b/admin/unidata/emoji-test.txt @@ -0,0 +1,4991 @@ +# emoji-test.txt +# Date: 2021-08-26, 17:22:23 GMT +# © 2021 Unicode®, Inc. +# Unicode and the Unicode Logo are registered trademarks of Unicode, Inc. in the U.S. and other countries. +# For terms of use, see http://www.unicode.org/terms_of_use.html +# +# Emoji Keyboard/Display Test Data for UTS #51 +# Version: 14.0 +# +# For documentation and usage, see http://www.unicode.org/reports/tr51 +# +# This file provides data for testing which emoji forms should be in keyboards and which should also be displayed/processed. +# Format: code points; status # emoji name +# Code points — list of one or more hex code points, separated by spaces +# Status +# component — an Emoji_Component, +# excluding Regional_Indicators, ASCII, and non-Emoji. +# fully-qualified — a fully-qualified emoji (see ED-18 in UTS #51), +# excluding Emoji_Component +# minimally-qualified — a minimally-qualified emoji (see ED-18a in UTS #51) +# unqualified — a unqualified emoji (See ED-19 in UTS #51) +# Notes: +# • This includes the emoji components that need emoji presentation (skin tone and hair) +# when isolated, but omits the components that need not have an emoji +# presentation when isolated. +# • The RGI set is covered by the listed fully-qualified emoji. +# • The listed minimally-qualified and unqualified cover all cases where an +# element of the RGI set is missing one or more emoji presentation selectors. +# • The file is in CLDR order, not codepoint order. This is recommended (but not required!) for keyboard palettes. +# • The groups and subgroups are illustrative. See the Emoji Order chart for more information. + + +# group: Smileys & Emotion + +# subgroup: face-smiling +1F600 ; fully-qualified # 😀 E1.0 grinning face +1F603 ; fully-qualified # 😃 E0.6 grinning face with big eyes +1F604 ; fully-qualified # 😄 E0.6 grinning face with smiling eyes +1F601 ; fully-qualified # 😁 E0.6 beaming face with smiling eyes +1F606 ; fully-qualified # 😆 E0.6 grinning squinting face +1F605 ; fully-qualified # 😅 E0.6 grinning face with sweat +1F923 ; fully-qualified # 🤣 E3.0 rolling on the floor laughing +1F602 ; fully-qualified # 😂 E0.6 face with tears of joy +1F642 ; fully-qualified # 🙂 E1.0 slightly smiling face +1F643 ; fully-qualified # 🙃 E1.0 upside-down face +1FAE0 ; fully-qualified # 🫠 E14.0 melting face +1F609 ; fully-qualified # 😉 E0.6 winking face +1F60A ; fully-qualified # 😊 E0.6 smiling face with smiling eyes +1F607 ; fully-qualified # 😇 E1.0 smiling face with halo + +# subgroup: face-affection +1F970 ; fully-qualified # 🥰 E11.0 smiling face with hearts +1F60D ; fully-qualified # 😍 E0.6 smiling face with heart-eyes +1F929 ; fully-qualified # 🤩 E5.0 star-struck +1F618 ; fully-qualified # 😘 E0.6 face blowing a kiss +1F617 ; fully-qualified # 😗 E1.0 kissing face +263A FE0F ; fully-qualified # ☺️ E0.6 smiling face +263A ; unqualified # ☺ E0.6 smiling face +1F61A ; fully-qualified # 😚 E0.6 kissing face with closed eyes +1F619 ; fully-qualified # 😙 E1.0 kissing face with smiling eyes +1F972 ; fully-qualified # 🥲 E13.0 smiling face with tear + +# subgroup: face-tongue +1F60B ; fully-qualified # 😋 E0.6 face savoring food +1F61B ; fully-qualified # 😛 E1.0 face with tongue +1F61C ; fully-qualified # 😜 E0.6 winking face with tongue +1F92A ; fully-qualified # 🤪 E5.0 zany face +1F61D ; fully-qualified # 😝 E0.6 squinting face with tongue +1F911 ; fully-qualified # 🤑 E1.0 money-mouth face + +# subgroup: face-hand +1F917 ; fully-qualified # 🤗 E1.0 smiling face with open hands +1F92D ; fully-qualified # 🤭 E5.0 face with hand over mouth +1FAE2 ; fully-qualified # 🫢 E14.0 face with open eyes and hand over mouth +1FAE3 ; fully-qualified # 🫣 E14.0 face with peeking eye +1F92B ; fully-qualified # 🤫 E5.0 shushing face +1F914 ; fully-qualified # 🤔 E1.0 thinking face +1FAE1 ; fully-qualified # 🫡 E14.0 saluting face + +# subgroup: face-neutral-skeptical +1F910 ; fully-qualified # 🤐 E1.0 zipper-mouth face +1F928 ; fully-qualified # 🤨 E5.0 face with raised eyebrow +1F610 ; fully-qualified # 😐 E0.7 neutral face +1F611 ; fully-qualified # 😑 E1.0 expressionless face +1F636 ; fully-qualified # 😶 E1.0 face without mouth +1FAE5 ; fully-qualified # 🫥 E14.0 dotted line face +1F636 200D 1F32B FE0F ; fully-qualified # 😶🌫️ E13.1 face in clouds +1F636 200D 1F32B ; minimally-qualified # 😶🌫 E13.1 face in clouds +1F60F ; fully-qualified # 😏 E0.6 smirking face +1F612 ; fully-qualified # 😒 E0.6 unamused face +1F644 ; fully-qualified # 🙄 E1.0 face with rolling eyes +1F62C ; fully-qualified # 😬 E1.0 grimacing face +1F62E 200D 1F4A8 ; fully-qualified # 😮💨 E13.1 face exhaling +1F925 ; fully-qualified # 🤥 E3.0 lying face + +# subgroup: face-sleepy +1F60C ; fully-qualified # 😌 E0.6 relieved face +1F614 ; fully-qualified # 😔 E0.6 pensive face +1F62A ; fully-qualified # 😪 E0.6 sleepy face +1F924 ; fully-qualified # 🤤 E3.0 drooling face +1F634 ; fully-qualified # 😴 E1.0 sleeping face + +# subgroup: face-unwell +1F637 ; fully-qualified # 😷 E0.6 face with medical mask +1F912 ; fully-qualified # 🤒 E1.0 face with thermometer +1F915 ; fully-qualified # 🤕 E1.0 face with head-bandage +1F922 ; fully-qualified # 🤢 E3.0 nauseated face +1F92E ; fully-qualified # 🤮 E5.0 face vomiting +1F927 ; fully-qualified # 🤧 E3.0 sneezing face +1F975 ; fully-qualified # 🥵 E11.0 hot face +1F976 ; fully-qualified # 🥶 E11.0 cold face +1F974 ; fully-qualified # 🥴 E11.0 woozy face +1F635 ; fully-qualified # 😵 E0.6 face with crossed-out eyes +1F635 200D 1F4AB ; fully-qualified # 😵💫 E13.1 face with spiral eyes +1F92F ; fully-qualified # 🤯 E5.0 exploding head + +# subgroup: face-hat +1F920 ; fully-qualified # 🤠 E3.0 cowboy hat face +1F973 ; fully-qualified # 🥳 E11.0 partying face +1F978 ; fully-qualified # 🥸 E13.0 disguised face + +# subgroup: face-glasses +1F60E ; fully-qualified # 😎 E1.0 smiling face with sunglasses +1F913 ; fully-qualified # 🤓 E1.0 nerd face +1F9D0 ; fully-qualified # 🧐 E5.0 face with monocle + +# subgroup: face-concerned +1F615 ; fully-qualified # 😕 E1.0 confused face +1FAE4 ; fully-qualified # 🫤 E14.0 face with diagonal mouth +1F61F ; fully-qualified # 😟 E1.0 worried face +1F641 ; fully-qualified # 🙁 E1.0 slightly frowning face +2639 FE0F ; fully-qualified # ☹️ E0.7 frowning face +2639 ; unqualified # ☹ E0.7 frowning face +1F62E ; fully-qualified # 😮 E1.0 face with open mouth +1F62F ; fully-qualified # 😯 E1.0 hushed face +1F632 ; fully-qualified # 😲 E0.6 astonished face +1F633 ; fully-qualified # 😳 E0.6 flushed face +1F97A ; fully-qualified # 🥺 E11.0 pleading face +1F979 ; fully-qualified # 🥹 E14.0 face holding back tears +1F626 ; fully-qualified # 😦 E1.0 frowning face with open mouth +1F627 ; fully-qualified # 😧 E1.0 anguished face +1F628 ; fully-qualified # 😨 E0.6 fearful face +1F630 ; fully-qualified # 😰 E0.6 anxious face with sweat +1F625 ; fully-qualified # 😥 E0.6 sad but relieved face +1F622 ; fully-qualified # 😢 E0.6 crying face +1F62D ; fully-qualified # 😭 E0.6 loudly crying face +1F631 ; fully-qualified # 😱 E0.6 face screaming in fear +1F616 ; fully-qualified # 😖 E0.6 confounded face +1F623 ; fully-qualified # 😣 E0.6 persevering face +1F61E ; fully-qualified # 😞 E0.6 disappointed face +1F613 ; fully-qualified # 😓 E0.6 downcast face with sweat +1F629 ; fully-qualified # 😩 E0.6 weary face +1F62B ; fully-qualified # 😫 E0.6 tired face +1F971 ; fully-qualified # 🥱 E12.0 yawning face + +# subgroup: face-negative +1F624 ; fully-qualified # 😤 E0.6 face with steam from nose +1F621 ; fully-qualified # 😡 E0.6 pouting face +1F620 ; fully-qualified # 😠 E0.6 angry face +1F92C ; fully-qualified # 🤬 E5.0 face with symbols on mouth +1F608 ; fully-qualified # 😈 E1.0 smiling face with horns +1F47F ; fully-qualified # 👿 E0.6 angry face with horns +1F480 ; fully-qualified # 💀 E0.6 skull +2620 FE0F ; fully-qualified # ☠️ E1.0 skull and crossbones +2620 ; unqualified # ☠ E1.0 skull and crossbones + +# subgroup: face-costume +1F4A9 ; fully-qualified # 💩 E0.6 pile of poo +1F921 ; fully-qualified # 🤡 E3.0 clown face +1F479 ; fully-qualified # 👹 E0.6 ogre +1F47A ; fully-qualified # 👺 E0.6 goblin +1F47B ; fully-qualified # 👻 E0.6 ghost +1F47D ; fully-qualified # 👽 E0.6 alien +1F47E ; fully-qualified # 👾 E0.6 alien monster +1F916 ; fully-qualified # 🤖 E1.0 robot + +# subgroup: cat-face +1F63A ; fully-qualified # 😺 E0.6 grinning cat +1F638 ; fully-qualified # 😸 E0.6 grinning cat with smiling eyes +1F639 ; fully-qualified # 😹 E0.6 cat with tears of joy +1F63B ; fully-qualified # 😻 E0.6 smiling cat with heart-eyes +1F63C ; fully-qualified # 😼 E0.6 cat with wry smile +1F63D ; fully-qualified # 😽 E0.6 kissing cat +1F640 ; fully-qualified # 🙀 E0.6 weary cat +1F63F ; fully-qualified # 😿 E0.6 crying cat +1F63E ; fully-qualified # 😾 E0.6 pouting cat + +# subgroup: monkey-face +1F648 ; fully-qualified # 🙈 E0.6 see-no-evil monkey +1F649 ; fully-qualified # 🙉 E0.6 hear-no-evil monkey +1F64A ; fully-qualified # 🙊 E0.6 speak-no-evil monkey + +# subgroup: emotion +1F48B ; fully-qualified # 💋 E0.6 kiss mark +1F48C ; fully-qualified # 💌 E0.6 love letter +1F498 ; fully-qualified # 💘 E0.6 heart with arrow +1F49D ; fully-qualified # 💝 E0.6 heart with ribbon +1F496 ; fully-qualified # 💖 E0.6 sparkling heart +1F497 ; fully-qualified # 💗 E0.6 growing heart +1F493 ; fully-qualified # 💓 E0.6 beating heart +1F49E ; fully-qualified # 💞 E0.6 revolving hearts +1F495 ; fully-qualified # 💕 E0.6 two hearts +1F49F ; fully-qualified # 💟 E0.6 heart decoration +2763 FE0F ; fully-qualified # ❣️ E1.0 heart exclamation +2763 ; unqualified # ❣ E1.0 heart exclamation +1F494 ; fully-qualified # 💔 E0.6 broken heart +2764 FE0F 200D 1F525 ; fully-qualified # ❤️🔥 E13.1 heart on fire +2764 200D 1F525 ; unqualified # ❤🔥 E13.1 heart on fire +2764 FE0F 200D 1FA79 ; fully-qualified # ❤️🩹 E13.1 mending heart +2764 200D 1FA79 ; unqualified # ❤🩹 E13.1 mending heart +2764 FE0F ; fully-qualified # ❤️ E0.6 red heart +2764 ; unqualified # ❤ E0.6 red heart +1F9E1 ; fully-qualified # 🧡 E5.0 orange heart +1F49B ; fully-qualified # 💛 E0.6 yellow heart +1F49A ; fully-qualified # 💚 E0.6 green heart +1F499 ; fully-qualified # 💙 E0.6 blue heart +1F49C ; fully-qualified # 💜 E0.6 purple heart +1F90E ; fully-qualified # 🤎 E12.0 brown heart +1F5A4 ; fully-qualified # 🖤 E3.0 black heart +1F90D ; fully-qualified # 🤍 E12.0 white heart +1F4AF ; fully-qualified # 💯 E0.6 hundred points +1F4A2 ; fully-qualified # 💢 E0.6 anger symbol +1F4A5 ; fully-qualified # 💥 E0.6 collision +1F4AB ; fully-qualified # 💫 E0.6 dizzy +1F4A6 ; fully-qualified # 💦 E0.6 sweat droplets +1F4A8 ; fully-qualified # 💨 E0.6 dashing away +1F573 FE0F ; fully-qualified # 🕳️ E0.7 hole +1F573 ; unqualified # 🕳 E0.7 hole +1F4A3 ; fully-qualified # 💣 E0.6 bomb +1F4AC ; fully-qualified # 💬 E0.6 speech balloon +1F441 FE0F 200D 1F5E8 FE0F ; fully-qualified # 👁️🗨️ E2.0 eye in speech bubble +1F441 200D 1F5E8 FE0F ; unqualified # 👁🗨️ E2.0 eye in speech bubble +1F441 FE0F 200D 1F5E8 ; unqualified # 👁️🗨 E2.0 eye in speech bubble +1F441 200D 1F5E8 ; unqualified # 👁🗨 E2.0 eye in speech bubble +1F5E8 FE0F ; fully-qualified # 🗨️ E2.0 left speech bubble +1F5E8 ; unqualified # 🗨 E2.0 left speech bubble +1F5EF FE0F ; fully-qualified # 🗯️ E0.7 right anger bubble +1F5EF ; unqualified # 🗯 E0.7 right anger bubble +1F4AD ; fully-qualified # 💭 E1.0 thought balloon +1F4A4 ; fully-qualified # 💤 E0.6 zzz + +# Smileys & Emotion subtotal: 177 +# Smileys & Emotion subtotal: 177 w/o modifiers + +# group: People & Body + +# subgroup: hand-fingers-open +1F44B ; fully-qualified # 👋 E0.6 waving hand +1F44B 1F3FB ; fully-qualified # 👋🏻 E1.0 waving hand: light skin tone +1F44B 1F3FC ; fully-qualified # 👋🏼 E1.0 waving hand: medium-light skin tone +1F44B 1F3FD ; fully-qualified # 👋🏽 E1.0 waving hand: medium skin tone +1F44B 1F3FE ; fully-qualified # 👋🏾 E1.0 waving hand: medium-dark skin tone +1F44B 1F3FF ; fully-qualified # 👋🏿 E1.0 waving hand: dark skin tone +1F91A ; fully-qualified # 🤚 E3.0 raised back of hand +1F91A 1F3FB ; fully-qualified # 🤚🏻 E3.0 raised back of hand: light skin tone +1F91A 1F3FC ; fully-qualified # 🤚🏼 E3.0 raised back of hand: medium-light skin tone +1F91A 1F3FD ; fully-qualified # 🤚🏽 E3.0 raised back of hand: medium skin tone +1F91A 1F3FE ; fully-qualified # 🤚🏾 E3.0 raised back of hand: medium-dark skin tone +1F91A 1F3FF ; fully-qualified # 🤚🏿 E3.0 raised back of hand: dark skin tone +1F590 FE0F ; fully-qualified # 🖐️ E0.7 hand with fingers splayed +1F590 ; unqualified # 🖐 E0.7 hand with fingers splayed +1F590 1F3FB ; fully-qualified # 🖐🏻 E1.0 hand with fingers splayed: light skin tone +1F590 1F3FC ; fully-qualified # 🖐🏼 E1.0 hand with fingers splayed: medium-light skin tone +1F590 1F3FD ; fully-qualified # 🖐🏽 E1.0 hand with fingers splayed: medium skin tone +1F590 1F3FE ; fully-qualified # 🖐🏾 E1.0 hand with fingers splayed: medium-dark skin tone +1F590 1F3FF ; fully-qualified # 🖐🏿 E1.0 hand with fingers splayed: dark skin tone +270B ; fully-qualified # ✋ E0.6 raised hand +270B 1F3FB ; fully-qualified # ✋🏻 E1.0 raised hand: light skin tone +270B 1F3FC ; fully-qualified # ✋🏼 E1.0 raised hand: medium-light skin tone +270B 1F3FD ; fully-qualified # ✋🏽 E1.0 raised hand: medium skin tone +270B 1F3FE ; fully-qualified # ✋🏾 E1.0 raised hand: medium-dark skin tone +270B 1F3FF ; fully-qualified # ✋🏿 E1.0 raised hand: dark skin tone +1F596 ; fully-qualified # 🖖 E1.0 vulcan salute +1F596 1F3FB ; fully-qualified # 🖖🏻 E1.0 vulcan salute: light skin tone +1F596 1F3FC ; fully-qualified # 🖖🏼 E1.0 vulcan salute: medium-light skin tone +1F596 1F3FD ; fully-qualified # 🖖🏽 E1.0 vulcan salute: medium skin tone +1F596 1F3FE ; fully-qualified # 🖖🏾 E1.0 vulcan salute: medium-dark skin tone +1F596 1F3FF ; fully-qualified # 🖖🏿 E1.0 vulcan salute: dark skin tone +1FAF1 ; fully-qualified # 🫱 E14.0 rightwards hand +1FAF1 1F3FB ; fully-qualified # 🫱🏻 E14.0 rightwards hand: light skin tone +1FAF1 1F3FC ; fully-qualified # 🫱🏼 E14.0 rightwards hand: medium-light skin tone +1FAF1 1F3FD ; fully-qualified # 🫱🏽 E14.0 rightwards hand: medium skin tone +1FAF1 1F3FE ; fully-qualified # 🫱🏾 E14.0 rightwards hand: medium-dark skin tone +1FAF1 1F3FF ; fully-qualified # 🫱🏿 E14.0 rightwards hand: dark skin tone +1FAF2 ; fully-qualified # 🫲 E14.0 leftwards hand +1FAF2 1F3FB ; fully-qualified # 🫲🏻 E14.0 leftwards hand: light skin tone +1FAF2 1F3FC ; fully-qualified # 🫲🏼 E14.0 leftwards hand: medium-light skin tone +1FAF2 1F3FD ; fully-qualified # 🫲🏽 E14.0 leftwards hand: medium skin tone +1FAF2 1F3FE ; fully-qualified # 🫲🏾 E14.0 leftwards hand: medium-dark skin tone +1FAF2 1F3FF ; fully-qualified # 🫲🏿 E14.0 leftwards hand: dark skin tone +1FAF3 ; fully-qualified # 🫳 E14.0 palm down hand +1FAF3 1F3FB ; fully-qualified # 🫳🏻 E14.0 palm down hand: light skin tone +1FAF3 1F3FC ; fully-qualified # 🫳🏼 E14.0 palm down hand: medium-light skin tone +1FAF3 1F3FD ; fully-qualified # 🫳🏽 E14.0 palm down hand: medium skin tone +1FAF3 1F3FE ; fully-qualified # 🫳🏾 E14.0 palm down hand: medium-dark skin tone +1FAF3 1F3FF ; fully-qualified # 🫳🏿 E14.0 palm down hand: dark skin tone +1FAF4 ; fully-qualified # 🫴 E14.0 palm up hand +1FAF4 1F3FB ; fully-qualified # 🫴🏻 E14.0 palm up hand: light skin tone +1FAF4 1F3FC ; fully-qualified # 🫴🏼 E14.0 palm up hand: medium-light skin tone +1FAF4 1F3FD ; fully-qualified # 🫴🏽 E14.0 palm up hand: medium skin tone +1FAF4 1F3FE ; fully-qualified # 🫴🏾 E14.0 palm up hand: medium-dark skin tone +1FAF4 1F3FF ; fully-qualified # 🫴🏿 E14.0 palm up hand: dark skin tone + +# subgroup: hand-fingers-partial +1F44C ; fully-qualified # 👌 E0.6 OK hand +1F44C 1F3FB ; fully-qualified # 👌🏻 E1.0 OK hand: light skin tone +1F44C 1F3FC ; fully-qualified # 👌🏼 E1.0 OK hand: medium-light skin tone +1F44C 1F3FD ; fully-qualified # 👌🏽 E1.0 OK hand: medium skin tone +1F44C 1F3FE ; fully-qualified # 👌🏾 E1.0 OK hand: medium-dark skin tone +1F44C 1F3FF ; fully-qualified # 👌🏿 E1.0 OK hand: dark skin tone +1F90C ; fully-qualified # 🤌 E13.0 pinched fingers +1F90C 1F3FB ; fully-qualified # 🤌🏻 E13.0 pinched fingers: light skin tone +1F90C 1F3FC ; fully-qualified # 🤌🏼 E13.0 pinched fingers: medium-light skin tone +1F90C 1F3FD ; fully-qualified # 🤌🏽 E13.0 pinched fingers: medium skin tone +1F90C 1F3FE ; fully-qualified # 🤌🏾 E13.0 pinched fingers: medium-dark skin tone +1F90C 1F3FF ; fully-qualified # 🤌🏿 E13.0 pinched fingers: dark skin tone +1F90F ; fully-qualified # 🤏 E12.0 pinching hand +1F90F 1F3FB ; fully-qualified # 🤏🏻 E12.0 pinching hand: light skin tone +1F90F 1F3FC ; fully-qualified # 🤏🏼 E12.0 pinching hand: medium-light skin tone +1F90F 1F3FD ; fully-qualified # 🤏🏽 E12.0 pinching hand: medium skin tone +1F90F 1F3FE ; fully-qualified # 🤏🏾 E12.0 pinching hand: medium-dark skin tone +1F90F 1F3FF ; fully-qualified # 🤏🏿 E12.0 pinching hand: dark skin tone +270C FE0F ; fully-qualified # ✌️ E0.6 victory hand +270C ; unqualified # ✌ E0.6 victory hand +270C 1F3FB ; fully-qualified # ✌🏻 E1.0 victory hand: light skin tone +270C 1F3FC ; fully-qualified # ✌🏼 E1.0 victory hand: medium-light skin tone +270C 1F3FD ; fully-qualified # ✌🏽 E1.0 victory hand: medium skin tone +270C 1F3FE ; fully-qualified # ✌🏾 E1.0 victory hand: medium-dark skin tone +270C 1F3FF ; fully-qualified # ✌🏿 E1.0 victory hand: dark skin tone +1F91E ; fully-qualified # 🤞 E3.0 crossed fingers +1F91E 1F3FB ; fully-qualified # 🤞🏻 E3.0 crossed fingers: light skin tone +1F91E 1F3FC ; fully-qualified # 🤞🏼 E3.0 crossed fingers: medium-light skin tone +1F91E 1F3FD ; fully-qualified # 🤞🏽 E3.0 crossed fingers: medium skin tone +1F91E 1F3FE ; fully-qualified # 🤞🏾 E3.0 crossed fingers: medium-dark skin tone +1F91E 1F3FF ; fully-qualified # 🤞🏿 E3.0 crossed fingers: dark skin tone +1FAF0 ; fully-qualified # 🫰 E14.0 hand with index finger and thumb crossed +1FAF0 1F3FB ; fully-qualified # 🫰🏻 E14.0 hand with index finger and thumb crossed: light skin tone +1FAF0 1F3FC ; fully-qualified # 🫰🏼 E14.0 hand with index finger and thumb crossed: medium-light skin tone +1FAF0 1F3FD ; fully-qualified # 🫰🏽 E14.0 hand with index finger and thumb crossed: medium skin tone +1FAF0 1F3FE ; fully-qualified # 🫰🏾 E14.0 hand with index finger and thumb crossed: medium-dark skin tone +1FAF0 1F3FF ; fully-qualified # 🫰🏿 E14.0 hand with index finger and thumb crossed: dark skin tone +1F91F ; fully-qualified # 🤟 E5.0 love-you gesture +1F91F 1F3FB ; fully-qualified # 🤟🏻 E5.0 love-you gesture: light skin tone +1F91F 1F3FC ; fully-qualified # 🤟🏼 E5.0 love-you gesture: medium-light skin tone +1F91F 1F3FD ; fully-qualified # 🤟🏽 E5.0 love-you gesture: medium skin tone +1F91F 1F3FE ; fully-qualified # 🤟🏾 E5.0 love-you gesture: medium-dark skin tone +1F91F 1F3FF ; fully-qualified # 🤟🏿 E5.0 love-you gesture: dark skin tone +1F918 ; fully-qualified # 🤘 E1.0 sign of the horns +1F918 1F3FB ; fully-qualified # 🤘🏻 E1.0 sign of the horns: light skin tone +1F918 1F3FC ; fully-qualified # 🤘🏼 E1.0 sign of the horns: medium-light skin tone +1F918 1F3FD ; fully-qualified # 🤘🏽 E1.0 sign of the horns: medium skin tone +1F918 1F3FE ; fully-qualified # 🤘🏾 E1.0 sign of the horns: medium-dark skin tone +1F918 1F3FF ; fully-qualified # 🤘🏿 E1.0 sign of the horns: dark skin tone +1F919 ; fully-qualified # 🤙 E3.0 call me hand +1F919 1F3FB ; fully-qualified # 🤙🏻 E3.0 call me hand: light skin tone +1F919 1F3FC ; fully-qualified # 🤙🏼 E3.0 call me hand: medium-light skin tone +1F919 1F3FD ; fully-qualified # 🤙🏽 E3.0 call me hand: medium skin tone +1F919 1F3FE ; fully-qualified # 🤙🏾 E3.0 call me hand: medium-dark skin tone +1F919 1F3FF ; fully-qualified # 🤙🏿 E3.0 call me hand: dark skin tone + +# subgroup: hand-single-finger +1F448 ; fully-qualified # 👈 E0.6 backhand index pointing left +1F448 1F3FB ; fully-qualified # 👈🏻 E1.0 backhand index pointing left: light skin tone +1F448 1F3FC ; fully-qualified # 👈🏼 E1.0 backhand index pointing left: medium-light skin tone +1F448 1F3FD ; fully-qualified # 👈🏽 E1.0 backhand index pointing left: medium skin tone +1F448 1F3FE ; fully-qualified # 👈🏾 E1.0 backhand index pointing left: medium-dark skin tone +1F448 1F3FF ; fully-qualified # 👈🏿 E1.0 backhand index pointing left: dark skin tone +1F449 ; fully-qualified # 👉 E0.6 backhand index pointing right +1F449 1F3FB ; fully-qualified # 👉🏻 E1.0 backhand index pointing right: light skin tone +1F449 1F3FC ; fully-qualified # 👉🏼 E1.0 backhand index pointing right: medium-light skin tone +1F449 1F3FD ; fully-qualified # 👉🏽 E1.0 backhand index pointing right: medium skin tone +1F449 1F3FE ; fully-qualified # 👉🏾 E1.0 backhand index pointing right: medium-dark skin tone +1F449 1F3FF ; fully-qualified # 👉🏿 E1.0 backhand index pointing right: dark skin tone +1F446 ; fully-qualified # 👆 E0.6 backhand index pointing up +1F446 1F3FB ; fully-qualified # 👆🏻 E1.0 backhand index pointing up: light skin tone +1F446 1F3FC ; fully-qualified # 👆🏼 E1.0 backhand index pointing up: medium-light skin tone +1F446 1F3FD ; fully-qualified # 👆🏽 E1.0 backhand index pointing up: medium skin tone +1F446 1F3FE ; fully-qualified # 👆🏾 E1.0 backhand index pointing up: medium-dark skin tone +1F446 1F3FF ; fully-qualified # 👆🏿 E1.0 backhand index pointing up: dark skin tone +1F595 ; fully-qualified # 🖕 E1.0 middle finger +1F595 1F3FB ; fully-qualified # 🖕🏻 E1.0 middle finger: light skin tone +1F595 1F3FC ; fully-qualified # 🖕🏼 E1.0 middle finger: medium-light skin tone +1F595 1F3FD ; fully-qualified # 🖕🏽 E1.0 middle finger: medium skin tone +1F595 1F3FE ; fully-qualified # 🖕🏾 E1.0 middle finger: medium-dark skin tone +1F595 1F3FF ; fully-qualified # 🖕🏿 E1.0 middle finger: dark skin tone +1F447 ; fully-qualified # 👇 E0.6 backhand index pointing down +1F447 1F3FB ; fully-qualified # 👇🏻 E1.0 backhand index pointing down: light skin tone +1F447 1F3FC ; fully-qualified # 👇🏼 E1.0 backhand index pointing down: medium-light skin tone +1F447 1F3FD ; fully-qualified # 👇🏽 E1.0 backhand index pointing down: medium skin tone +1F447 1F3FE ; fully-qualified # 👇🏾 E1.0 backhand index pointing down: medium-dark skin tone +1F447 1F3FF ; fully-qualified # 👇🏿 E1.0 backhand index pointing down: dark skin tone +261D FE0F ; fully-qualified # ☝️ E0.6 index pointing up +261D ; unqualified # ☝ E0.6 index pointing up +261D 1F3FB ; fully-qualified # ☝🏻 E1.0 index pointing up: light skin tone +261D 1F3FC ; fully-qualified # ☝🏼 E1.0 index pointing up: medium-light skin tone +261D 1F3FD ; fully-qualified # ☝🏽 E1.0 index pointing up: medium skin tone +261D 1F3FE ; fully-qualified # ☝🏾 E1.0 index pointing up: medium-dark skin tone +261D 1F3FF ; fully-qualified # ☝🏿 E1.0 index pointing up: dark skin tone +1FAF5 ; fully-qualified # 🫵 E14.0 index pointing at the viewer +1FAF5 1F3FB ; fully-qualified # 🫵🏻 E14.0 index pointing at the viewer: light skin tone +1FAF5 1F3FC ; fully-qualified # 🫵🏼 E14.0 index pointing at the viewer: medium-light skin tone +1FAF5 1F3FD ; fully-qualified # 🫵🏽 E14.0 index pointing at the viewer: medium skin tone +1FAF5 1F3FE ; fully-qualified # 🫵🏾 E14.0 index pointing at the viewer: medium-dark skin tone +1FAF5 1F3FF ; fully-qualified # 🫵🏿 E14.0 index pointing at the viewer: dark skin tone + +# subgroup: hand-fingers-closed +1F44D ; fully-qualified # 👍 E0.6 thumbs up +1F44D 1F3FB ; fully-qualified # 👍🏻 E1.0 thumbs up: light skin tone +1F44D 1F3FC ; fully-qualified # 👍🏼 E1.0 thumbs up: medium-light skin tone +1F44D 1F3FD ; fully-qualified # 👍🏽 E1.0 thumbs up: medium skin tone +1F44D 1F3FE ; fully-qualified # 👍🏾 E1.0 thumbs up: medium-dark skin tone +1F44D 1F3FF ; fully-qualified # 👍🏿 E1.0 thumbs up: dark skin tone +1F44E ; fully-qualified # 👎 E0.6 thumbs down +1F44E 1F3FB ; fully-qualified # 👎🏻 E1.0 thumbs down: light skin tone +1F44E 1F3FC ; fully-qualified # 👎🏼 E1.0 thumbs down: medium-light skin tone +1F44E 1F3FD ; fully-qualified # 👎🏽 E1.0 thumbs down: medium skin tone +1F44E 1F3FE ; fully-qualified # 👎🏾 E1.0 thumbs down: medium-dark skin tone +1F44E 1F3FF ; fully-qualified # 👎🏿 E1.0 thumbs down: dark skin tone +270A ; fully-qualified # ✊ E0.6 raised fist +270A 1F3FB ; fully-qualified # ✊🏻 E1.0 raised fist: light skin tone +270A 1F3FC ; fully-qualified # ✊🏼 E1.0 raised fist: medium-light skin tone +270A 1F3FD ; fully-qualified # ✊🏽 E1.0 raised fist: medium skin tone +270A 1F3FE ; fully-qualified # ✊🏾 E1.0 raised fist: medium-dark skin tone +270A 1F3FF ; fully-qualified # ✊🏿 E1.0 raised fist: dark skin tone +1F44A ; fully-qualified # 👊 E0.6 oncoming fist +1F44A 1F3FB ; fully-qualified # 👊🏻 E1.0 oncoming fist: light skin tone +1F44A 1F3FC ; fully-qualified # 👊🏼 E1.0 oncoming fist: medium-light skin tone +1F44A 1F3FD ; fully-qualified # 👊🏽 E1.0 oncoming fist: medium skin tone +1F44A 1F3FE ; fully-qualified # 👊🏾 E1.0 oncoming fist: medium-dark skin tone +1F44A 1F3FF ; fully-qualified # 👊🏿 E1.0 oncoming fist: dark skin tone +1F91B ; fully-qualified # 🤛 E3.0 left-facing fist +1F91B 1F3FB ; fully-qualified # 🤛🏻 E3.0 left-facing fist: light skin tone +1F91B 1F3FC ; fully-qualified # 🤛🏼 E3.0 left-facing fist: medium-light skin tone +1F91B 1F3FD ; fully-qualified # 🤛🏽 E3.0 left-facing fist: medium skin tone +1F91B 1F3FE ; fully-qualified # 🤛🏾 E3.0 left-facing fist: medium-dark skin tone +1F91B 1F3FF ; fully-qualified # 🤛🏿 E3.0 left-facing fist: dark skin tone +1F91C ; fully-qualified # 🤜 E3.0 right-facing fist +1F91C 1F3FB ; fully-qualified # 🤜🏻 E3.0 right-facing fist: light skin tone +1F91C 1F3FC ; fully-qualified # 🤜🏼 E3.0 right-facing fist: medium-light skin tone +1F91C 1F3FD ; fully-qualified # 🤜🏽 E3.0 right-facing fist: medium skin tone +1F91C 1F3FE ; fully-qualified # 🤜🏾 E3.0 right-facing fist: medium-dark skin tone +1F91C 1F3FF ; fully-qualified # 🤜🏿 E3.0 right-facing fist: dark skin tone + +# subgroup: hands +1F44F ; fully-qualified # 👏 E0.6 clapping hands +1F44F 1F3FB ; fully-qualified # 👏🏻 E1.0 clapping hands: light skin tone +1F44F 1F3FC ; fully-qualified # 👏🏼 E1.0 clapping hands: medium-light skin tone +1F44F 1F3FD ; fully-qualified # 👏🏽 E1.0 clapping hands: medium skin tone +1F44F 1F3FE ; fully-qualified # 👏🏾 E1.0 clapping hands: medium-dark skin tone +1F44F 1F3FF ; fully-qualified # 👏🏿 E1.0 clapping hands: dark skin tone +1F64C ; fully-qualified # 🙌 E0.6 raising hands +1F64C 1F3FB ; fully-qualified # 🙌🏻 E1.0 raising hands: light skin tone +1F64C 1F3FC ; fully-qualified # 🙌🏼 E1.0 raising hands: medium-light skin tone +1F64C 1F3FD ; fully-qualified # 🙌🏽 E1.0 raising hands: medium skin tone +1F64C 1F3FE ; fully-qualified # 🙌🏾 E1.0 raising hands: medium-dark skin tone +1F64C 1F3FF ; fully-qualified # 🙌🏿 E1.0 raising hands: dark skin tone +1FAF6 ; fully-qualified # 🫶 E14.0 heart hands +1FAF6 1F3FB ; fully-qualified # 🫶🏻 E14.0 heart hands: light skin tone +1FAF6 1F3FC ; fully-qualified # 🫶🏼 E14.0 heart hands: medium-light skin tone +1FAF6 1F3FD ; fully-qualified # 🫶🏽 E14.0 heart hands: medium skin tone +1FAF6 1F3FE ; fully-qualified # 🫶🏾 E14.0 heart hands: medium-dark skin tone +1FAF6 1F3FF ; fully-qualified # 🫶🏿 E14.0 heart hands: dark skin tone +1F450 ; fully-qualified # 👐 E0.6 open hands +1F450 1F3FB ; fully-qualified # 👐🏻 E1.0 open hands: light skin tone +1F450 1F3FC ; fully-qualified # 👐🏼 E1.0 open hands: medium-light skin tone +1F450 1F3FD ; fully-qualified # 👐🏽 E1.0 open hands: medium skin tone +1F450 1F3FE ; fully-qualified # 👐🏾 E1.0 open hands: medium-dark skin tone +1F450 1F3FF ; fully-qualified # 👐🏿 E1.0 open hands: dark skin tone +1F932 ; fully-qualified # 🤲 E5.0 palms up together +1F932 1F3FB ; fully-qualified # 🤲🏻 E5.0 palms up together: light skin tone +1F932 1F3FC ; fully-qualified # 🤲🏼 E5.0 palms up together: medium-light skin tone +1F932 1F3FD ; fully-qualified # 🤲🏽 E5.0 palms up together: medium skin tone +1F932 1F3FE ; fully-qualified # 🤲🏾 E5.0 palms up together: medium-dark skin tone +1F932 1F3FF ; fully-qualified # 🤲🏿 E5.0 palms up together: dark skin tone +1F91D ; fully-qualified # 🤝 E3.0 handshake +1F91D 1F3FB ; fully-qualified # 🤝🏻 E3.0 handshake: light skin tone +1F91D 1F3FC ; fully-qualified # 🤝🏼 E3.0 handshake: medium-light skin tone +1F91D 1F3FD ; fully-qualified # 🤝🏽 E3.0 handshake: medium skin tone +1F91D 1F3FE ; fully-qualified # 🤝🏾 E3.0 handshake: medium-dark skin tone +1F91D 1F3FF ; fully-qualified # 🤝🏿 E3.0 handshake: dark skin tone +1FAF1 1F3FB 200D 1FAF2 1F3FC ; fully-qualified # 🫱🏻🫲🏼 E14.0 handshake: light skin tone, medium-light skin tone +1FAF1 1F3FB 200D 1FAF2 1F3FD ; fully-qualified # 🫱🏻🫲🏽 E14.0 handshake: light skin tone, medium skin tone +1FAF1 1F3FB 200D 1FAF2 1F3FE ; fully-qualified # 🫱🏻🫲🏾 E14.0 handshake: light skin tone, medium-dark skin tone +1FAF1 1F3FB 200D 1FAF2 1F3FF ; fully-qualified # 🫱🏻🫲🏿 E14.0 handshake: light skin tone, dark skin tone +1FAF1 1F3FC 200D 1FAF2 1F3FB ; fully-qualified # 🫱🏼🫲🏻 E14.0 handshake: medium-light skin tone, light skin tone +1FAF1 1F3FC 200D 1FAF2 1F3FD ; fully-qualified # 🫱🏼🫲🏽 E14.0 handshake: medium-light skin tone, medium skin tone +1FAF1 1F3FC 200D 1FAF2 1F3FE ; fully-qualified # 🫱🏼🫲🏾 E14.0 handshake: medium-light skin tone, medium-dark skin tone +1FAF1 1F3FC 200D 1FAF2 1F3FF ; fully-qualified # 🫱🏼🫲🏿 E14.0 handshake: medium-light skin tone, dark skin tone +1FAF1 1F3FD 200D 1FAF2 1F3FB ; fully-qualified # 🫱🏽🫲🏻 E14.0 handshake: medium skin tone, light skin tone +1FAF1 1F3FD 200D 1FAF2 1F3FC ; fully-qualified # 🫱🏽🫲🏼 E14.0 handshake: medium skin tone, medium-light skin tone +1FAF1 1F3FD 200D 1FAF2 1F3FE ; fully-qualified # 🫱🏽🫲🏾 E14.0 handshake: medium skin tone, medium-dark skin tone +1FAF1 1F3FD 200D 1FAF2 1F3FF ; fully-qualified # 🫱🏽🫲🏿 E14.0 handshake: medium skin tone, dark skin tone +1FAF1 1F3FE 200D 1FAF2 1F3FB ; fully-qualified # 🫱🏾🫲🏻 E14.0 handshake: medium-dark skin tone, light skin tone +1FAF1 1F3FE 200D 1FAF2 1F3FC ; fully-qualified # 🫱🏾🫲🏼 E14.0 handshake: medium-dark skin tone, medium-light skin tone +1FAF1 1F3FE 200D 1FAF2 1F3FD ; fully-qualified # 🫱🏾🫲🏽 E14.0 handshake: medium-dark skin tone, medium skin tone +1FAF1 1F3FE 200D 1FAF2 1F3FF ; fully-qualified # 🫱🏾🫲🏿 E14.0 handshake: medium-dark skin tone, dark skin tone +1FAF1 1F3FF 200D 1FAF2 1F3FB ; fully-qualified # 🫱🏿🫲🏻 E14.0 handshake: dark skin tone, light skin tone +1FAF1 1F3FF 200D 1FAF2 1F3FC ; fully-qualified # 🫱🏿🫲🏼 E14.0 handshake: dark skin tone, medium-light skin tone +1FAF1 1F3FF 200D 1FAF2 1F3FD ; fully-qualified # 🫱🏿🫲🏽 E14.0 handshake: dark skin tone, medium skin tone +1FAF1 1F3FF 200D 1FAF2 1F3FE ; fully-qualified # 🫱🏿🫲🏾 E14.0 handshake: dark skin tone, medium-dark skin tone +1F64F ; fully-qualified # 🙏 E0.6 folded hands +1F64F 1F3FB ; fully-qualified # 🙏🏻 E1.0 folded hands: light skin tone +1F64F 1F3FC ; fully-qualified # 🙏🏼 E1.0 folded hands: medium-light skin tone +1F64F 1F3FD ; fully-qualified # 🙏🏽 E1.0 folded hands: medium skin tone +1F64F 1F3FE ; fully-qualified # 🙏🏾 E1.0 folded hands: medium-dark skin tone +1F64F 1F3FF ; fully-qualified # 🙏🏿 E1.0 folded hands: dark skin tone + +# subgroup: hand-prop +270D FE0F ; fully-qualified # ✍️ E0.7 writing hand +270D ; unqualified # ✍ E0.7 writing hand +270D 1F3FB ; fully-qualified # ✍🏻 E1.0 writing hand: light skin tone +270D 1F3FC ; fully-qualified # ✍🏼 E1.0 writing hand: medium-light skin tone +270D 1F3FD ; fully-qualified # ✍🏽 E1.0 writing hand: medium skin tone +270D 1F3FE ; fully-qualified # ✍🏾 E1.0 writing hand: medium-dark skin tone +270D 1F3FF ; fully-qualified # ✍🏿 E1.0 writing hand: dark skin tone +1F485 ; fully-qualified # 💅 E0.6 nail polish +1F485 1F3FB ; fully-qualified # 💅🏻 E1.0 nail polish: light skin tone +1F485 1F3FC ; fully-qualified # 💅🏼 E1.0 nail polish: medium-light skin tone +1F485 1F3FD ; fully-qualified # 💅🏽 E1.0 nail polish: medium skin tone +1F485 1F3FE ; fully-qualified # 💅🏾 E1.0 nail polish: medium-dark skin tone +1F485 1F3FF ; fully-qualified # 💅🏿 E1.0 nail polish: dark skin tone +1F933 ; fully-qualified # 🤳 E3.0 selfie +1F933 1F3FB ; fully-qualified # 🤳🏻 E3.0 selfie: light skin tone +1F933 1F3FC ; fully-qualified # 🤳🏼 E3.0 selfie: medium-light skin tone +1F933 1F3FD ; fully-qualified # 🤳🏽 E3.0 selfie: medium skin tone +1F933 1F3FE ; fully-qualified # 🤳🏾 E3.0 selfie: medium-dark skin tone +1F933 1F3FF ; fully-qualified # 🤳🏿 E3.0 selfie: dark skin tone + +# subgroup: body-parts +1F4AA ; fully-qualified # 💪 E0.6 flexed biceps +1F4AA 1F3FB ; fully-qualified # 💪🏻 E1.0 flexed biceps: light skin tone +1F4AA 1F3FC ; fully-qualified # 💪🏼 E1.0 flexed biceps: medium-light skin tone +1F4AA 1F3FD ; fully-qualified # 💪🏽 E1.0 flexed biceps: medium skin tone +1F4AA 1F3FE ; fully-qualified # 💪🏾 E1.0 flexed biceps: medium-dark skin tone +1F4AA 1F3FF ; fully-qualified # 💪🏿 E1.0 flexed biceps: dark skin tone +1F9BE ; fully-qualified # 🦾 E12.0 mechanical arm +1F9BF ; fully-qualified # 🦿 E12.0 mechanical leg +1F9B5 ; fully-qualified # 🦵 E11.0 leg +1F9B5 1F3FB ; fully-qualified # 🦵🏻 E11.0 leg: light skin tone +1F9B5 1F3FC ; fully-qualified # 🦵🏼 E11.0 leg: medium-light skin tone +1F9B5 1F3FD ; fully-qualified # 🦵🏽 E11.0 leg: medium skin tone +1F9B5 1F3FE ; fully-qualified # 🦵🏾 E11.0 leg: medium-dark skin tone +1F9B5 1F3FF ; fully-qualified # 🦵🏿 E11.0 leg: dark skin tone +1F9B6 ; fully-qualified # 🦶 E11.0 foot +1F9B6 1F3FB ; fully-qualified # 🦶🏻 E11.0 foot: light skin tone +1F9B6 1F3FC ; fully-qualified # 🦶🏼 E11.0 foot: medium-light skin tone +1F9B6 1F3FD ; fully-qualified # 🦶🏽 E11.0 foot: medium skin tone +1F9B6 1F3FE ; fully-qualified # 🦶🏾 E11.0 foot: medium-dark skin tone +1F9B6 1F3FF ; fully-qualified # 🦶🏿 E11.0 foot: dark skin tone +1F442 ; fully-qualified # 👂 E0.6 ear +1F442 1F3FB ; fully-qualified # 👂🏻 E1.0 ear: light skin tone +1F442 1F3FC ; fully-qualified # 👂🏼 E1.0 ear: medium-light skin tone +1F442 1F3FD ; fully-qualified # 👂🏽 E1.0 ear: medium skin tone +1F442 1F3FE ; fully-qualified # 👂🏾 E1.0 ear: medium-dark skin tone +1F442 1F3FF ; fully-qualified # 👂🏿 E1.0 ear: dark skin tone +1F9BB ; fully-qualified # 🦻 E12.0 ear with hearing aid +1F9BB 1F3FB ; fully-qualified # 🦻🏻 E12.0 ear with hearing aid: light skin tone +1F9BB 1F3FC ; fully-qualified # 🦻🏼 E12.0 ear with hearing aid: medium-light skin tone +1F9BB 1F3FD ; fully-qualified # 🦻🏽 E12.0 ear with hearing aid: medium skin tone +1F9BB 1F3FE ; fully-qualified # 🦻🏾 E12.0 ear with hearing aid: medium-dark skin tone +1F9BB 1F3FF ; fully-qualified # 🦻🏿 E12.0 ear with hearing aid: dark skin tone +1F443 ; fully-qualified # 👃 E0.6 nose +1F443 1F3FB ; fully-qualified # 👃🏻 E1.0 nose: light skin tone +1F443 1F3FC ; fully-qualified # 👃🏼 E1.0 nose: medium-light skin tone +1F443 1F3FD ; fully-qualified # 👃🏽 E1.0 nose: medium skin tone +1F443 1F3FE ; fully-qualified # 👃🏾 E1.0 nose: medium-dark skin tone +1F443 1F3FF ; fully-qualified # 👃🏿 E1.0 nose: dark skin tone +1F9E0 ; fully-qualified # 🧠 E5.0 brain +1FAC0 ; fully-qualified # 🫀 E13.0 anatomical heart +1FAC1 ; fully-qualified # 🫁 E13.0 lungs +1F9B7 ; fully-qualified # 🦷 E11.0 tooth +1F9B4 ; fully-qualified # 🦴 E11.0 bone +1F440 ; fully-qualified # 👀 E0.6 eyes +1F441 FE0F ; fully-qualified # 👁️ E0.7 eye +1F441 ; unqualified # 👁 E0.7 eye +1F445 ; fully-qualified # 👅 E0.6 tongue +1F444 ; fully-qualified # 👄 E0.6 mouth +1FAE6 ; fully-qualified # 🫦 E14.0 biting lip + +# subgroup: person +1F476 ; fully-qualified # 👶 E0.6 baby +1F476 1F3FB ; fully-qualified # 👶🏻 E1.0 baby: light skin tone +1F476 1F3FC ; fully-qualified # 👶🏼 E1.0 baby: medium-light skin tone +1F476 1F3FD ; fully-qualified # 👶🏽 E1.0 baby: medium skin tone +1F476 1F3FE ; fully-qualified # 👶🏾 E1.0 baby: medium-dark skin tone +1F476 1F3FF ; fully-qualified # 👶🏿 E1.0 baby: dark skin tone +1F9D2 ; fully-qualified # 🧒 E5.0 child +1F9D2 1F3FB ; fully-qualified # 🧒🏻 E5.0 child: light skin tone +1F9D2 1F3FC ; fully-qualified # 🧒🏼 E5.0 child: medium-light skin tone +1F9D2 1F3FD ; fully-qualified # 🧒🏽 E5.0 child: medium skin tone +1F9D2 1F3FE ; fully-qualified # 🧒🏾 E5.0 child: medium-dark skin tone +1F9D2 1F3FF ; fully-qualified # 🧒🏿 E5.0 child: dark skin tone +1F466 ; fully-qualified # 👦 E0.6 boy +1F466 1F3FB ; fully-qualified # 👦🏻 E1.0 boy: light skin tone +1F466 1F3FC ; fully-qualified # 👦🏼 E1.0 boy: medium-light skin tone +1F466 1F3FD ; fully-qualified # 👦🏽 E1.0 boy: medium skin tone +1F466 1F3FE ; fully-qualified # 👦🏾 E1.0 boy: medium-dark skin tone +1F466 1F3FF ; fully-qualified # 👦🏿 E1.0 boy: dark skin tone +1F467 ; fully-qualified # 👧 E0.6 girl +1F467 1F3FB ; fully-qualified # 👧🏻 E1.0 girl: light skin tone +1F467 1F3FC ; fully-qualified # 👧🏼 E1.0 girl: medium-light skin tone +1F467 1F3FD ; fully-qualified # 👧🏽 E1.0 girl: medium skin tone +1F467 1F3FE ; fully-qualified # 👧🏾 E1.0 girl: medium-dark skin tone +1F467 1F3FF ; fully-qualified # 👧🏿 E1.0 girl: dark skin tone +1F9D1 ; fully-qualified # 🧑 E5.0 person +1F9D1 1F3FB ; fully-qualified # 🧑🏻 E5.0 person: light skin tone +1F9D1 1F3FC ; fully-qualified # 🧑🏼 E5.0 person: medium-light skin tone +1F9D1 1F3FD ; fully-qualified # 🧑🏽 E5.0 person: medium skin tone +1F9D1 1F3FE ; fully-qualified # 🧑🏾 E5.0 person: medium-dark skin tone +1F9D1 1F3FF ; fully-qualified # 🧑🏿 E5.0 person: dark skin tone +1F471 ; fully-qualified # 👱 E0.6 person: blond hair +1F471 1F3FB ; fully-qualified # 👱🏻 E1.0 person: light skin tone, blond hair +1F471 1F3FC ; fully-qualified # 👱🏼 E1.0 person: medium-light skin tone, blond hair +1F471 1F3FD ; fully-qualified # 👱🏽 E1.0 person: medium skin tone, blond hair +1F471 1F3FE ; fully-qualified # 👱🏾 E1.0 person: medium-dark skin tone, blond hair +1F471 1F3FF ; fully-qualified # 👱🏿 E1.0 person: dark skin tone, blond hair +1F468 ; fully-qualified # 👨 E0.6 man +1F468 1F3FB ; fully-qualified # 👨🏻 E1.0 man: light skin tone +1F468 1F3FC ; fully-qualified # 👨🏼 E1.0 man: medium-light skin tone +1F468 1F3FD ; fully-qualified # 👨🏽 E1.0 man: medium skin tone +1F468 1F3FE ; fully-qualified # 👨🏾 E1.0 man: medium-dark skin tone +1F468 1F3FF ; fully-qualified # 👨🏿 E1.0 man: dark skin tone +1F9D4 ; fully-qualified # 🧔 E5.0 person: beard +1F9D4 1F3FB ; fully-qualified # 🧔🏻 E5.0 person: light skin tone, beard +1F9D4 1F3FC ; fully-qualified # 🧔🏼 E5.0 person: medium-light skin tone, beard +1F9D4 1F3FD ; fully-qualified # 🧔🏽 E5.0 person: medium skin tone, beard +1F9D4 1F3FE ; fully-qualified # 🧔🏾 E5.0 person: medium-dark skin tone, beard +1F9D4 1F3FF ; fully-qualified # 🧔🏿 E5.0 person: dark skin tone, beard +1F9D4 200D 2642 FE0F ; fully-qualified # 🧔♂️ E13.1 man: beard +1F9D4 200D 2642 ; minimally-qualified # 🧔♂ E13.1 man: beard +1F9D4 1F3FB 200D 2642 FE0F ; fully-qualified # 🧔🏻♂️ E13.1 man: light skin tone, beard +1F9D4 1F3FB 200D 2642 ; minimally-qualified # 🧔🏻♂ E13.1 man: light skin tone, beard +1F9D4 1F3FC 200D 2642 FE0F ; fully-qualified # 🧔🏼♂️ E13.1 man: medium-light skin tone, beard +1F9D4 1F3FC 200D 2642 ; minimally-qualified # 🧔🏼♂ E13.1 man: medium-light skin tone, beard +1F9D4 1F3FD 200D 2642 FE0F ; fully-qualified # 🧔🏽♂️ E13.1 man: medium skin tone, beard +1F9D4 1F3FD 200D 2642 ; minimally-qualified # 🧔🏽♂ E13.1 man: medium skin tone, beard +1F9D4 1F3FE 200D 2642 FE0F ; fully-qualified # 🧔🏾♂️ E13.1 man: medium-dark skin tone, beard +1F9D4 1F3FE 200D 2642 ; minimally-qualified # 🧔🏾♂ E13.1 man: medium-dark skin tone, beard +1F9D4 1F3FF 200D 2642 FE0F ; fully-qualified # 🧔🏿♂️ E13.1 man: dark skin tone, beard +1F9D4 1F3FF 200D 2642 ; minimally-qualified # 🧔🏿♂ E13.1 man: dark skin tone, beard +1F9D4 200D 2640 FE0F ; fully-qualified # 🧔♀️ E13.1 woman: beard +1F9D4 200D 2640 ; minimally-qualified # 🧔♀ E13.1 woman: beard +1F9D4 1F3FB 200D 2640 FE0F ; fully-qualified # 🧔🏻♀️ E13.1 woman: light skin tone, beard +1F9D4 1F3FB 200D 2640 ; minimally-qualified # 🧔🏻♀ E13.1 woman: light skin tone, beard +1F9D4 1F3FC 200D 2640 FE0F ; fully-qualified # 🧔🏼♀️ E13.1 woman: medium-light skin tone, beard +1F9D4 1F3FC 200D 2640 ; minimally-qualified # 🧔🏼♀ E13.1 woman: medium-light skin tone, beard +1F9D4 1F3FD 200D 2640 FE0F ; fully-qualified # 🧔🏽♀️ E13.1 woman: medium skin tone, beard +1F9D4 1F3FD 200D 2640 ; minimally-qualified # 🧔🏽♀ E13.1 woman: medium skin tone, beard +1F9D4 1F3FE 200D 2640 FE0F ; fully-qualified # 🧔🏾♀️ E13.1 woman: medium-dark skin tone, beard +1F9D4 1F3FE 200D 2640 ; minimally-qualified # 🧔🏾♀ E13.1 woman: medium-dark skin tone, beard +1F9D4 1F3FF 200D 2640 FE0F ; fully-qualified # 🧔🏿♀️ E13.1 woman: dark skin tone, beard +1F9D4 1F3FF 200D 2640 ; minimally-qualified # 🧔🏿♀ E13.1 woman: dark skin tone, beard +1F468 200D 1F9B0 ; fully-qualified # 👨🦰 E11.0 man: red hair +1F468 1F3FB 200D 1F9B0 ; fully-qualified # 👨🏻🦰 E11.0 man: light skin tone, red hair +1F468 1F3FC 200D 1F9B0 ; fully-qualified # 👨🏼🦰 E11.0 man: medium-light skin tone, red hair +1F468 1F3FD 200D 1F9B0 ; fully-qualified # 👨🏽🦰 E11.0 man: medium skin tone, red hair +1F468 1F3FE 200D 1F9B0 ; fully-qualified # 👨🏾🦰 E11.0 man: medium-dark skin tone, red hair +1F468 1F3FF 200D 1F9B0 ; fully-qualified # 👨🏿🦰 E11.0 man: dark skin tone, red hair +1F468 200D 1F9B1 ; fully-qualified # 👨🦱 E11.0 man: curly hair +1F468 1F3FB 200D 1F9B1 ; fully-qualified # 👨🏻🦱 E11.0 man: light skin tone, curly hair +1F468 1F3FC 200D 1F9B1 ; fully-qualified # 👨🏼🦱 E11.0 man: medium-light skin tone, curly hair +1F468 1F3FD 200D 1F9B1 ; fully-qualified # 👨🏽🦱 E11.0 man: medium skin tone, curly hair +1F468 1F3FE 200D 1F9B1 ; fully-qualified # 👨🏾🦱 E11.0 man: medium-dark skin tone, curly hair +1F468 1F3FF 200D 1F9B1 ; fully-qualified # 👨🏿🦱 E11.0 man: dark skin tone, curly hair +1F468 200D 1F9B3 ; fully-qualified # 👨🦳 E11.0 man: white hair +1F468 1F3FB 200D 1F9B3 ; fully-qualified # 👨🏻🦳 E11.0 man: light skin tone, white hair +1F468 1F3FC 200D 1F9B3 ; fully-qualified # 👨🏼🦳 E11.0 man: medium-light skin tone, white hair +1F468 1F3FD 200D 1F9B3 ; fully-qualified # 👨🏽🦳 E11.0 man: medium skin tone, white hair +1F468 1F3FE 200D 1F9B3 ; fully-qualified # 👨🏾🦳 E11.0 man: medium-dark skin tone, white hair +1F468 1F3FF 200D 1F9B3 ; fully-qualified # 👨🏿🦳 E11.0 man: dark skin tone, white hair +1F468 200D 1F9B2 ; fully-qualified # 👨🦲 E11.0 man: bald +1F468 1F3FB 200D 1F9B2 ; fully-qualified # 👨🏻🦲 E11.0 man: light skin tone, bald +1F468 1F3FC 200D 1F9B2 ; fully-qualified # 👨🏼🦲 E11.0 man: medium-light skin tone, bald +1F468 1F3FD 200D 1F9B2 ; fully-qualified # 👨🏽🦲 E11.0 man: medium skin tone, bald +1F468 1F3FE 200D 1F9B2 ; fully-qualified # 👨🏾🦲 E11.0 man: medium-dark skin tone, bald +1F468 1F3FF 200D 1F9B2 ; fully-qualified # 👨🏿🦲 E11.0 man: dark skin tone, bald +1F469 ; fully-qualified # 👩 E0.6 woman +1F469 1F3FB ; fully-qualified # 👩🏻 E1.0 woman: light skin tone +1F469 1F3FC ; fully-qualified # 👩🏼 E1.0 woman: medium-light skin tone +1F469 1F3FD ; fully-qualified # 👩🏽 E1.0 woman: medium skin tone +1F469 1F3FE ; fully-qualified # 👩🏾 E1.0 woman: medium-dark skin tone +1F469 1F3FF ; fully-qualified # 👩🏿 E1.0 woman: dark skin tone +1F469 200D 1F9B0 ; fully-qualified # 👩🦰 E11.0 woman: red hair +1F469 1F3FB 200D 1F9B0 ; fully-qualified # 👩🏻🦰 E11.0 woman: light skin tone, red hair +1F469 1F3FC 200D 1F9B0 ; fully-qualified # 👩🏼🦰 E11.0 woman: medium-light skin tone, red hair +1F469 1F3FD 200D 1F9B0 ; fully-qualified # 👩🏽🦰 E11.0 woman: medium skin tone, red hair +1F469 1F3FE 200D 1F9B0 ; fully-qualified # 👩🏾🦰 E11.0 woman: medium-dark skin tone, red hair +1F469 1F3FF 200D 1F9B0 ; fully-qualified # 👩🏿🦰 E11.0 woman: dark skin tone, red hair +1F9D1 200D 1F9B0 ; fully-qualified # 🧑🦰 E12.1 person: red hair +1F9D1 1F3FB 200D 1F9B0 ; fully-qualified # 🧑🏻🦰 E12.1 person: light skin tone, red hair +1F9D1 1F3FC 200D 1F9B0 ; fully-qualified # 🧑🏼🦰 E12.1 person: medium-light skin tone, red hair +1F9D1 1F3FD 200D 1F9B0 ; fully-qualified # 🧑🏽🦰 E12.1 person: medium skin tone, red hair +1F9D1 1F3FE 200D 1F9B0 ; fully-qualified # 🧑🏾🦰 E12.1 person: medium-dark skin tone, red hair +1F9D1 1F3FF 200D 1F9B0 ; fully-qualified # 🧑🏿🦰 E12.1 person: dark skin tone, red hair +1F469 200D 1F9B1 ; fully-qualified # 👩🦱 E11.0 woman: curly hair +1F469 1F3FB 200D 1F9B1 ; fully-qualified # 👩🏻🦱 E11.0 woman: light skin tone, curly hair +1F469 1F3FC 200D 1F9B1 ; fully-qualified # 👩🏼🦱 E11.0 woman: medium-light skin tone, curly hair +1F469 1F3FD 200D 1F9B1 ; fully-qualified # 👩🏽🦱 E11.0 woman: medium skin tone, curly hair +1F469 1F3FE 200D 1F9B1 ; fully-qualified # 👩🏾🦱 E11.0 woman: medium-dark skin tone, curly hair +1F469 1F3FF 200D 1F9B1 ; fully-qualified # 👩🏿🦱 E11.0 woman: dark skin tone, curly hair +1F9D1 200D 1F9B1 ; fully-qualified # 🧑🦱 E12.1 person: curly hair +1F9D1 1F3FB 200D 1F9B1 ; fully-qualified # 🧑🏻🦱 E12.1 person: light skin tone, curly hair +1F9D1 1F3FC 200D 1F9B1 ; fully-qualified # 🧑🏼🦱 E12.1 person: medium-light skin tone, curly hair +1F9D1 1F3FD 200D 1F9B1 ; fully-qualified # 🧑🏽🦱 E12.1 person: medium skin tone, curly hair +1F9D1 1F3FE 200D 1F9B1 ; fully-qualified # 🧑🏾🦱 E12.1 person: medium-dark skin tone, curly hair +1F9D1 1F3FF 200D 1F9B1 ; fully-qualified # 🧑🏿🦱 E12.1 person: dark skin tone, curly hair +1F469 200D 1F9B3 ; fully-qualified # 👩🦳 E11.0 woman: white hair +1F469 1F3FB 200D 1F9B3 ; fully-qualified # 👩🏻🦳 E11.0 woman: light skin tone, white hair +1F469 1F3FC 200D 1F9B3 ; fully-qualified # 👩🏼🦳 E11.0 woman: medium-light skin tone, white hair +1F469 1F3FD 200D 1F9B3 ; fully-qualified # 👩🏽🦳 E11.0 woman: medium skin tone, white hair +1F469 1F3FE 200D 1F9B3 ; fully-qualified # 👩🏾🦳 E11.0 woman: medium-dark skin tone, white hair +1F469 1F3FF 200D 1F9B3 ; fully-qualified # 👩🏿🦳 E11.0 woman: dark skin tone, white hair +1F9D1 200D 1F9B3 ; fully-qualified # 🧑🦳 E12.1 person: white hair +1F9D1 1F3FB 200D 1F9B3 ; fully-qualified # 🧑🏻🦳 E12.1 person: light skin tone, white hair +1F9D1 1F3FC 200D 1F9B3 ; fully-qualified # 🧑🏼🦳 E12.1 person: medium-light skin tone, white hair +1F9D1 1F3FD 200D 1F9B3 ; fully-qualified # 🧑🏽🦳 E12.1 person: medium skin tone, white hair +1F9D1 1F3FE 200D 1F9B3 ; fully-qualified # 🧑🏾🦳 E12.1 person: medium-dark skin tone, white hair +1F9D1 1F3FF 200D 1F9B3 ; fully-qualified # 🧑🏿🦳 E12.1 person: dark skin tone, white hair +1F469 200D 1F9B2 ; fully-qualified # 👩🦲 E11.0 woman: bald +1F469 1F3FB 200D 1F9B2 ; fully-qualified # 👩🏻🦲 E11.0 woman: light skin tone, bald +1F469 1F3FC 200D 1F9B2 ; fully-qualified # 👩🏼🦲 E11.0 woman: medium-light skin tone, bald +1F469 1F3FD 200D 1F9B2 ; fully-qualified # 👩🏽🦲 E11.0 woman: medium skin tone, bald +1F469 1F3FE 200D 1F9B2 ; fully-qualified # 👩🏾🦲 E11.0 woman: medium-dark skin tone, bald +1F469 1F3FF 200D 1F9B2 ; fully-qualified # 👩🏿🦲 E11.0 woman: dark skin tone, bald +1F9D1 200D 1F9B2 ; fully-qualified # 🧑🦲 E12.1 person: bald +1F9D1 1F3FB 200D 1F9B2 ; fully-qualified # 🧑🏻🦲 E12.1 person: light skin tone, bald +1F9D1 1F3FC 200D 1F9B2 ; fully-qualified # 🧑🏼🦲 E12.1 person: medium-light skin tone, bald +1F9D1 1F3FD 200D 1F9B2 ; fully-qualified # 🧑🏽🦲 E12.1 person: medium skin tone, bald +1F9D1 1F3FE 200D 1F9B2 ; fully-qualified # 🧑🏾🦲 E12.1 person: medium-dark skin tone, bald +1F9D1 1F3FF 200D 1F9B2 ; fully-qualified # 🧑🏿🦲 E12.1 person: dark skin tone, bald +1F471 200D 2640 FE0F ; fully-qualified # 👱♀️ E4.0 woman: blond hair +1F471 200D 2640 ; minimally-qualified # 👱♀ E4.0 woman: blond hair +1F471 1F3FB 200D 2640 FE0F ; fully-qualified # 👱🏻♀️ E4.0 woman: light skin tone, blond hair +1F471 1F3FB 200D 2640 ; minimally-qualified # 👱🏻♀ E4.0 woman: light skin tone, blond hair +1F471 1F3FC 200D 2640 FE0F ; fully-qualified # 👱🏼♀️ E4.0 woman: medium-light skin tone, blond hair +1F471 1F3FC 200D 2640 ; minimally-qualified # 👱🏼♀ E4.0 woman: medium-light skin tone, blond hair +1F471 1F3FD 200D 2640 FE0F ; fully-qualified # 👱🏽♀️ E4.0 woman: medium skin tone, blond hair +1F471 1F3FD 200D 2640 ; minimally-qualified # 👱🏽♀ E4.0 woman: medium skin tone, blond hair +1F471 1F3FE 200D 2640 FE0F ; fully-qualified # 👱🏾♀️ E4.0 woman: medium-dark skin tone, blond hair +1F471 1F3FE 200D 2640 ; minimally-qualified # 👱🏾♀ E4.0 woman: medium-dark skin tone, blond hair +1F471 1F3FF 200D 2640 FE0F ; fully-qualified # 👱🏿♀️ E4.0 woman: dark skin tone, blond hair +1F471 1F3FF 200D 2640 ; minimally-qualified # 👱🏿♀ E4.0 woman: dark skin tone, blond hair +1F471 200D 2642 FE0F ; fully-qualified # 👱♂️ E4.0 man: blond hair +1F471 200D 2642 ; minimally-qualified # 👱♂ E4.0 man: blond hair +1F471 1F3FB 200D 2642 FE0F ; fully-qualified # 👱🏻♂️ E4.0 man: light skin tone, blond hair +1F471 1F3FB 200D 2642 ; minimally-qualified # 👱🏻♂ E4.0 man: light skin tone, blond hair +1F471 1F3FC 200D 2642 FE0F ; fully-qualified # 👱🏼♂️ E4.0 man: medium-light skin tone, blond hair +1F471 1F3FC 200D 2642 ; minimally-qualified # 👱🏼♂ E4.0 man: medium-light skin tone, blond hair +1F471 1F3FD 200D 2642 FE0F ; fully-qualified # 👱🏽♂️ E4.0 man: medium skin tone, blond hair +1F471 1F3FD 200D 2642 ; minimally-qualified # 👱🏽♂ E4.0 man: medium skin tone, blond hair +1F471 1F3FE 200D 2642 FE0F ; fully-qualified # 👱🏾♂️ E4.0 man: medium-dark skin tone, blond hair +1F471 1F3FE 200D 2642 ; minimally-qualified # 👱🏾♂ E4.0 man: medium-dark skin tone, blond hair +1F471 1F3FF 200D 2642 FE0F ; fully-qualified # 👱🏿♂️ E4.0 man: dark skin tone, blond hair +1F471 1F3FF 200D 2642 ; minimally-qualified # 👱🏿♂ E4.0 man: dark skin tone, blond hair +1F9D3 ; fully-qualified # 🧓 E5.0 older person +1F9D3 1F3FB ; fully-qualified # 🧓🏻 E5.0 older person: light skin tone +1F9D3 1F3FC ; fully-qualified # 🧓🏼 E5.0 older person: medium-light skin tone +1F9D3 1F3FD ; fully-qualified # 🧓🏽 E5.0 older person: medium skin tone +1F9D3 1F3FE ; fully-qualified # 🧓🏾 E5.0 older person: medium-dark skin tone +1F9D3 1F3FF ; fully-qualified # 🧓🏿 E5.0 older person: dark skin tone +1F474 ; fully-qualified # 👴 E0.6 old man +1F474 1F3FB ; fully-qualified # 👴🏻 E1.0 old man: light skin tone +1F474 1F3FC ; fully-qualified # 👴🏼 E1.0 old man: medium-light skin tone +1F474 1F3FD ; fully-qualified # 👴🏽 E1.0 old man: medium skin tone +1F474 1F3FE ; fully-qualified # 👴🏾 E1.0 old man: medium-dark skin tone +1F474 1F3FF ; fully-qualified # 👴🏿 E1.0 old man: dark skin tone +1F475 ; fully-qualified # 👵 E0.6 old woman +1F475 1F3FB ; fully-qualified # 👵🏻 E1.0 old woman: light skin tone +1F475 1F3FC ; fully-qualified # 👵🏼 E1.0 old woman: medium-light skin tone +1F475 1F3FD ; fully-qualified # 👵🏽 E1.0 old woman: medium skin tone +1F475 1F3FE ; fully-qualified # 👵🏾 E1.0 old woman: medium-dark skin tone +1F475 1F3FF ; fully-qualified # 👵🏿 E1.0 old woman: dark skin tone + +# subgroup: person-gesture +1F64D ; fully-qualified # 🙍 E0.6 person frowning +1F64D 1F3FB ; fully-qualified # 🙍🏻 E1.0 person frowning: light skin tone +1F64D 1F3FC ; fully-qualified # 🙍🏼 E1.0 person frowning: medium-light skin tone +1F64D 1F3FD ; fully-qualified # 🙍🏽 E1.0 person frowning: medium skin tone +1F64D 1F3FE ; fully-qualified # 🙍🏾 E1.0 person frowning: medium-dark skin tone +1F64D 1F3FF ; fully-qualified # 🙍🏿 E1.0 person frowning: dark skin tone +1F64D 200D 2642 FE0F ; fully-qualified # 🙍♂️ E4.0 man frowning +1F64D 200D 2642 ; minimally-qualified # 🙍♂ E4.0 man frowning +1F64D 1F3FB 200D 2642 FE0F ; fully-qualified # 🙍🏻♂️ E4.0 man frowning: light skin tone +1F64D 1F3FB 200D 2642 ; minimally-qualified # 🙍🏻♂ E4.0 man frowning: light skin tone +1F64D 1F3FC 200D 2642 FE0F ; fully-qualified # 🙍🏼♂️ E4.0 man frowning: medium-light skin tone +1F64D 1F3FC 200D 2642 ; minimally-qualified # 🙍🏼♂ E4.0 man frowning: medium-light skin tone +1F64D 1F3FD 200D 2642 FE0F ; fully-qualified # 🙍🏽♂️ E4.0 man frowning: medium skin tone +1F64D 1F3FD 200D 2642 ; minimally-qualified # 🙍🏽♂ E4.0 man frowning: medium skin tone +1F64D 1F3FE 200D 2642 FE0F ; fully-qualified # 🙍🏾♂️ E4.0 man frowning: medium-dark skin tone +1F64D 1F3FE 200D 2642 ; minimally-qualified # 🙍🏾♂ E4.0 man frowning: medium-dark skin tone +1F64D 1F3FF 200D 2642 FE0F ; fully-qualified # 🙍🏿♂️ E4.0 man frowning: dark skin tone +1F64D 1F3FF 200D 2642 ; minimally-qualified # 🙍🏿♂ E4.0 man frowning: dark skin tone +1F64D 200D 2640 FE0F ; fully-qualified # 🙍♀️ E4.0 woman frowning +1F64D 200D 2640 ; minimally-qualified # 🙍♀ E4.0 woman frowning +1F64D 1F3FB 200D 2640 FE0F ; fully-qualified # 🙍🏻♀️ E4.0 woman frowning: light skin tone +1F64D 1F3FB 200D 2640 ; minimally-qualified # 🙍🏻♀ E4.0 woman frowning: light skin tone +1F64D 1F3FC 200D 2640 FE0F ; fully-qualified # 🙍🏼♀️ E4.0 woman frowning: medium-light skin tone +1F64D 1F3FC 200D 2640 ; minimally-qualified # 🙍🏼♀ E4.0 woman frowning: medium-light skin tone +1F64D 1F3FD 200D 2640 FE0F ; fully-qualified # 🙍🏽♀️ E4.0 woman frowning: medium skin tone +1F64D 1F3FD 200D 2640 ; minimally-qualified # 🙍🏽♀ E4.0 woman frowning: medium skin tone +1F64D 1F3FE 200D 2640 FE0F ; fully-qualified # 🙍🏾♀️ E4.0 woman frowning: medium-dark skin tone +1F64D 1F3FE 200D 2640 ; minimally-qualified # 🙍🏾♀ E4.0 woman frowning: medium-dark skin tone +1F64D 1F3FF 200D 2640 FE0F ; fully-qualified # 🙍🏿♀️ E4.0 woman frowning: dark skin tone +1F64D 1F3FF 200D 2640 ; minimally-qualified # 🙍🏿♀ E4.0 woman frowning: dark skin tone +1F64E ; fully-qualified # 🙎 E0.6 person pouting +1F64E 1F3FB ; fully-qualified # 🙎🏻 E1.0 person pouting: light skin tone +1F64E 1F3FC ; fully-qualified # 🙎🏼 E1.0 person pouting: medium-light skin tone +1F64E 1F3FD ; fully-qualified # 🙎🏽 E1.0 person pouting: medium skin tone +1F64E 1F3FE ; fully-qualified # 🙎🏾 E1.0 person pouting: medium-dark skin tone +1F64E 1F3FF ; fully-qualified # 🙎🏿 E1.0 person pouting: dark skin tone +1F64E 200D 2642 FE0F ; fully-qualified # 🙎♂️ E4.0 man pouting +1F64E 200D 2642 ; minimally-qualified # 🙎♂ E4.0 man pouting +1F64E 1F3FB 200D 2642 FE0F ; fully-qualified # 🙎🏻♂️ E4.0 man pouting: light skin tone +1F64E 1F3FB 200D 2642 ; minimally-qualified # 🙎🏻♂ E4.0 man pouting: light skin tone +1F64E 1F3FC 200D 2642 FE0F ; fully-qualified # 🙎🏼♂️ E4.0 man pouting: medium-light skin tone +1F64E 1F3FC 200D 2642 ; minimally-qualified # 🙎🏼♂ E4.0 man pouting: medium-light skin tone +1F64E 1F3FD 200D 2642 FE0F ; fully-qualified # 🙎🏽♂️ E4.0 man pouting: medium skin tone +1F64E 1F3FD 200D 2642 ; minimally-qualified # 🙎🏽♂ E4.0 man pouting: medium skin tone +1F64E 1F3FE 200D 2642 FE0F ; fully-qualified # 🙎🏾♂️ E4.0 man pouting: medium-dark skin tone +1F64E 1F3FE 200D 2642 ; minimally-qualified # 🙎🏾♂ E4.0 man pouting: medium-dark skin tone +1F64E 1F3FF 200D 2642 FE0F ; fully-qualified # 🙎🏿♂️ E4.0 man pouting: dark skin tone +1F64E 1F3FF 200D 2642 ; minimally-qualified # 🙎🏿♂ E4.0 man pouting: dark skin tone +1F64E 200D 2640 FE0F ; fully-qualified # 🙎♀️ E4.0 woman pouting +1F64E 200D 2640 ; minimally-qualified # 🙎♀ E4.0 woman pouting +1F64E 1F3FB 200D 2640 FE0F ; fully-qualified # 🙎🏻♀️ E4.0 woman pouting: light skin tone +1F64E 1F3FB 200D 2640 ; minimally-qualified # 🙎🏻♀ E4.0 woman pouting: light skin tone +1F64E 1F3FC 200D 2640 FE0F ; fully-qualified # 🙎🏼♀️ E4.0 woman pouting: medium-light skin tone +1F64E 1F3FC 200D 2640 ; minimally-qualified # 🙎🏼♀ E4.0 woman pouting: medium-light skin tone +1F64E 1F3FD 200D 2640 FE0F ; fully-qualified # 🙎🏽♀️ E4.0 woman pouting: medium skin tone +1F64E 1F3FD 200D 2640 ; minimally-qualified # 🙎🏽♀ E4.0 woman pouting: medium skin tone +1F64E 1F3FE 200D 2640 FE0F ; fully-qualified # 🙎🏾♀️ E4.0 woman pouting: medium-dark skin tone +1F64E 1F3FE 200D 2640 ; minimally-qualified # 🙎🏾♀ E4.0 woman pouting: medium-dark skin tone +1F64E 1F3FF 200D 2640 FE0F ; fully-qualified # 🙎🏿♀️ E4.0 woman pouting: dark skin tone +1F64E 1F3FF 200D 2640 ; minimally-qualified # 🙎🏿♀ E4.0 woman pouting: dark skin tone +1F645 ; fully-qualified # 🙅 E0.6 person gesturing NO +1F645 1F3FB ; fully-qualified # 🙅🏻 E1.0 person gesturing NO: light skin tone +1F645 1F3FC ; fully-qualified # 🙅🏼 E1.0 person gesturing NO: medium-light skin tone +1F645 1F3FD ; fully-qualified # 🙅🏽 E1.0 person gesturing NO: medium skin tone +1F645 1F3FE ; fully-qualified # 🙅🏾 E1.0 person gesturing NO: medium-dark skin tone +1F645 1F3FF ; fully-qualified # 🙅🏿 E1.0 person gesturing NO: dark skin tone +1F645 200D 2642 FE0F ; fully-qualified # 🙅♂️ E4.0 man gesturing NO +1F645 200D 2642 ; minimally-qualified # 🙅♂ E4.0 man gesturing NO +1F645 1F3FB 200D 2642 FE0F ; fully-qualified # 🙅🏻♂️ E4.0 man gesturing NO: light skin tone +1F645 1F3FB 200D 2642 ; minimally-qualified # 🙅🏻♂ E4.0 man gesturing NO: light skin tone +1F645 1F3FC 200D 2642 FE0F ; fully-qualified # 🙅🏼♂️ E4.0 man gesturing NO: medium-light skin tone +1F645 1F3FC 200D 2642 ; minimally-qualified # 🙅🏼♂ E4.0 man gesturing NO: medium-light skin tone +1F645 1F3FD 200D 2642 FE0F ; fully-qualified # 🙅🏽♂️ E4.0 man gesturing NO: medium skin tone +1F645 1F3FD 200D 2642 ; minimally-qualified # 🙅🏽♂ E4.0 man gesturing NO: medium skin tone +1F645 1F3FE 200D 2642 FE0F ; fully-qualified # 🙅🏾♂️ E4.0 man gesturing NO: medium-dark skin tone +1F645 1F3FE 200D 2642 ; minimally-qualified # 🙅🏾♂ E4.0 man gesturing NO: medium-dark skin tone +1F645 1F3FF 200D 2642 FE0F ; fully-qualified # 🙅🏿♂️ E4.0 man gesturing NO: dark skin tone +1F645 1F3FF 200D 2642 ; minimally-qualified # 🙅🏿♂ E4.0 man gesturing NO: dark skin tone +1F645 200D 2640 FE0F ; fully-qualified # 🙅♀️ E4.0 woman gesturing NO +1F645 200D 2640 ; minimally-qualified # 🙅♀ E4.0 woman gesturing NO +1F645 1F3FB 200D 2640 FE0F ; fully-qualified # 🙅🏻♀️ E4.0 woman gesturing NO: light skin tone +1F645 1F3FB 200D 2640 ; minimally-qualified # 🙅🏻♀ E4.0 woman gesturing NO: light skin tone +1F645 1F3FC 200D 2640 FE0F ; fully-qualified # 🙅🏼♀️ E4.0 woman gesturing NO: medium-light skin tone +1F645 1F3FC 200D 2640 ; minimally-qualified # 🙅🏼♀ E4.0 woman gesturing NO: medium-light skin tone +1F645 1F3FD 200D 2640 FE0F ; fully-qualified # 🙅🏽♀️ E4.0 woman gesturing NO: medium skin tone +1F645 1F3FD 200D 2640 ; minimally-qualified # 🙅🏽♀ E4.0 woman gesturing NO: medium skin tone +1F645 1F3FE 200D 2640 FE0F ; fully-qualified # 🙅🏾♀️ E4.0 woman gesturing NO: medium-dark skin tone +1F645 1F3FE 200D 2640 ; minimally-qualified # 🙅🏾♀ E4.0 woman gesturing NO: medium-dark skin tone +1F645 1F3FF 200D 2640 FE0F ; fully-qualified # 🙅🏿♀️ E4.0 woman gesturing NO: dark skin tone +1F645 1F3FF 200D 2640 ; minimally-qualified # 🙅🏿♀ E4.0 woman gesturing NO: dark skin tone +1F646 ; fully-qualified # 🙆 E0.6 person gesturing OK +1F646 1F3FB ; fully-qualified # 🙆🏻 E1.0 person gesturing OK: light skin tone +1F646 1F3FC ; fully-qualified # 🙆🏼 E1.0 person gesturing OK: medium-light skin tone +1F646 1F3FD ; fully-qualified # 🙆🏽 E1.0 person gesturing OK: medium skin tone +1F646 1F3FE ; fully-qualified # 🙆🏾 E1.0 person gesturing OK: medium-dark skin tone +1F646 1F3FF ; fully-qualified # 🙆🏿 E1.0 person gesturing OK: dark skin tone +1F646 200D 2642 FE0F ; fully-qualified # 🙆♂️ E4.0 man gesturing OK +1F646 200D 2642 ; minimally-qualified # 🙆♂ E4.0 man gesturing OK +1F646 1F3FB 200D 2642 FE0F ; fully-qualified # 🙆🏻♂️ E4.0 man gesturing OK: light skin tone +1F646 1F3FB 200D 2642 ; minimally-qualified # 🙆🏻♂ E4.0 man gesturing OK: light skin tone +1F646 1F3FC 200D 2642 FE0F ; fully-qualified # 🙆🏼♂️ E4.0 man gesturing OK: medium-light skin tone +1F646 1F3FC 200D 2642 ; minimally-qualified # 🙆🏼♂ E4.0 man gesturing OK: medium-light skin tone +1F646 1F3FD 200D 2642 FE0F ; fully-qualified # 🙆🏽♂️ E4.0 man gesturing OK: medium skin tone +1F646 1F3FD 200D 2642 ; minimally-qualified # 🙆🏽♂ E4.0 man gesturing OK: medium skin tone +1F646 1F3FE 200D 2642 FE0F ; fully-qualified # 🙆🏾♂️ E4.0 man gesturing OK: medium-dark skin tone +1F646 1F3FE 200D 2642 ; minimally-qualified # 🙆🏾♂ E4.0 man gesturing OK: medium-dark skin tone +1F646 1F3FF 200D 2642 FE0F ; fully-qualified # 🙆🏿♂️ E4.0 man gesturing OK: dark skin tone +1F646 1F3FF 200D 2642 ; minimally-qualified # 🙆🏿♂ E4.0 man gesturing OK: dark skin tone +1F646 200D 2640 FE0F ; fully-qualified # 🙆♀️ E4.0 woman gesturing OK +1F646 200D 2640 ; minimally-qualified # 🙆♀ E4.0 woman gesturing OK +1F646 1F3FB 200D 2640 FE0F ; fully-qualified # 🙆🏻♀️ E4.0 woman gesturing OK: light skin tone +1F646 1F3FB 200D 2640 ; minimally-qualified # 🙆🏻♀ E4.0 woman gesturing OK: light skin tone +1F646 1F3FC 200D 2640 FE0F ; fully-qualified # 🙆🏼♀️ E4.0 woman gesturing OK: medium-light skin tone +1F646 1F3FC 200D 2640 ; minimally-qualified # 🙆🏼♀ E4.0 woman gesturing OK: medium-light skin tone +1F646 1F3FD 200D 2640 FE0F ; fully-qualified # 🙆🏽♀️ E4.0 woman gesturing OK: medium skin tone +1F646 1F3FD 200D 2640 ; minimally-qualified # 🙆🏽♀ E4.0 woman gesturing OK: medium skin tone +1F646 1F3FE 200D 2640 FE0F ; fully-qualified # 🙆🏾♀️ E4.0 woman gesturing OK: medium-dark skin tone +1F646 1F3FE 200D 2640 ; minimally-qualified # 🙆🏾♀ E4.0 woman gesturing OK: medium-dark skin tone +1F646 1F3FF 200D 2640 FE0F ; fully-qualified # 🙆🏿♀️ E4.0 woman gesturing OK: dark skin tone +1F646 1F3FF 200D 2640 ; minimally-qualified # 🙆🏿♀ E4.0 woman gesturing OK: dark skin tone +1F481 ; fully-qualified # 💁 E0.6 person tipping hand +1F481 1F3FB ; fully-qualified # 💁🏻 E1.0 person tipping hand: light skin tone +1F481 1F3FC ; fully-qualified # 💁🏼 E1.0 person tipping hand: medium-light skin tone +1F481 1F3FD ; fully-qualified # 💁🏽 E1.0 person tipping hand: medium skin tone +1F481 1F3FE ; fully-qualified # 💁🏾 E1.0 person tipping hand: medium-dark skin tone +1F481 1F3FF ; fully-qualified # 💁🏿 E1.0 person tipping hand: dark skin tone +1F481 200D 2642 FE0F ; fully-qualified # 💁♂️ E4.0 man tipping hand +1F481 200D 2642 ; minimally-qualified # 💁♂ E4.0 man tipping hand +1F481 1F3FB 200D 2642 FE0F ; fully-qualified # 💁🏻♂️ E4.0 man tipping hand: light skin tone +1F481 1F3FB 200D 2642 ; minimally-qualified # 💁🏻♂ E4.0 man tipping hand: light skin tone +1F481 1F3FC 200D 2642 FE0F ; fully-qualified # 💁🏼♂️ E4.0 man tipping hand: medium-light skin tone +1F481 1F3FC 200D 2642 ; minimally-qualified # 💁🏼♂ E4.0 man tipping hand: medium-light skin tone +1F481 1F3FD 200D 2642 FE0F ; fully-qualified # 💁🏽♂️ E4.0 man tipping hand: medium skin tone +1F481 1F3FD 200D 2642 ; minimally-qualified # 💁🏽♂ E4.0 man tipping hand: medium skin tone +1F481 1F3FE 200D 2642 FE0F ; fully-qualified # 💁🏾♂️ E4.0 man tipping hand: medium-dark skin tone +1F481 1F3FE 200D 2642 ; minimally-qualified # 💁🏾♂ E4.0 man tipping hand: medium-dark skin tone +1F481 1F3FF 200D 2642 FE0F ; fully-qualified # 💁🏿♂️ E4.0 man tipping hand: dark skin tone +1F481 1F3FF 200D 2642 ; minimally-qualified # 💁🏿♂ E4.0 man tipping hand: dark skin tone +1F481 200D 2640 FE0F ; fully-qualified # 💁♀️ E4.0 woman tipping hand +1F481 200D 2640 ; minimally-qualified # 💁♀ E4.0 woman tipping hand +1F481 1F3FB 200D 2640 FE0F ; fully-qualified # 💁🏻♀️ E4.0 woman tipping hand: light skin tone +1F481 1F3FB 200D 2640 ; minimally-qualified # 💁🏻♀ E4.0 woman tipping hand: light skin tone +1F481 1F3FC 200D 2640 FE0F ; fully-qualified # 💁🏼♀️ E4.0 woman tipping hand: medium-light skin tone +1F481 1F3FC 200D 2640 ; minimally-qualified # 💁🏼♀ E4.0 woman tipping hand: medium-light skin tone +1F481 1F3FD 200D 2640 FE0F ; fully-qualified # 💁🏽♀️ E4.0 woman tipping hand: medium skin tone +1F481 1F3FD 200D 2640 ; minimally-qualified # 💁🏽♀ E4.0 woman tipping hand: medium skin tone +1F481 1F3FE 200D 2640 FE0F ; fully-qualified # 💁🏾♀️ E4.0 woman tipping hand: medium-dark skin tone +1F481 1F3FE 200D 2640 ; minimally-qualified # 💁🏾♀ E4.0 woman tipping hand: medium-dark skin tone +1F481 1F3FF 200D 2640 FE0F ; fully-qualified # 💁🏿♀️ E4.0 woman tipping hand: dark skin tone +1F481 1F3FF 200D 2640 ; minimally-qualified # 💁🏿♀ E4.0 woman tipping hand: dark skin tone +1F64B ; fully-qualified # 🙋 E0.6 person raising hand +1F64B 1F3FB ; fully-qualified # 🙋🏻 E1.0 person raising hand: light skin tone +1F64B 1F3FC ; fully-qualified # 🙋🏼 E1.0 person raising hand: medium-light skin tone +1F64B 1F3FD ; fully-qualified # 🙋🏽 E1.0 person raising hand: medium skin tone +1F64B 1F3FE ; fully-qualified # 🙋🏾 E1.0 person raising hand: medium-dark skin tone +1F64B 1F3FF ; fully-qualified # 🙋🏿 E1.0 person raising hand: dark skin tone +1F64B 200D 2642 FE0F ; fully-qualified # 🙋♂️ E4.0 man raising hand +1F64B 200D 2642 ; minimally-qualified # 🙋♂ E4.0 man raising hand +1F64B 1F3FB 200D 2642 FE0F ; fully-qualified # 🙋🏻♂️ E4.0 man raising hand: light skin tone +1F64B 1F3FB 200D 2642 ; minimally-qualified # 🙋🏻♂ E4.0 man raising hand: light skin tone +1F64B 1F3FC 200D 2642 FE0F ; fully-qualified # 🙋🏼♂️ E4.0 man raising hand: medium-light skin tone +1F64B 1F3FC 200D 2642 ; minimally-qualified # 🙋🏼♂ E4.0 man raising hand: medium-light skin tone +1F64B 1F3FD 200D 2642 FE0F ; fully-qualified # 🙋🏽♂️ E4.0 man raising hand: medium skin tone +1F64B 1F3FD 200D 2642 ; minimally-qualified # 🙋🏽♂ E4.0 man raising hand: medium skin tone +1F64B 1F3FE 200D 2642 FE0F ; fully-qualified # 🙋🏾♂️ E4.0 man raising hand: medium-dark skin tone +1F64B 1F3FE 200D 2642 ; minimally-qualified # 🙋🏾♂ E4.0 man raising hand: medium-dark skin tone +1F64B 1F3FF 200D 2642 FE0F ; fully-qualified # 🙋🏿♂️ E4.0 man raising hand: dark skin tone +1F64B 1F3FF 200D 2642 ; minimally-qualified # 🙋🏿♂ E4.0 man raising hand: dark skin tone +1F64B 200D 2640 FE0F ; fully-qualified # 🙋♀️ E4.0 woman raising hand +1F64B 200D 2640 ; minimally-qualified # 🙋♀ E4.0 woman raising hand +1F64B 1F3FB 200D 2640 FE0F ; fully-qualified # 🙋🏻♀️ E4.0 woman raising hand: light skin tone +1F64B 1F3FB 200D 2640 ; minimally-qualified # 🙋🏻♀ E4.0 woman raising hand: light skin tone +1F64B 1F3FC 200D 2640 FE0F ; fully-qualified # 🙋🏼♀️ E4.0 woman raising hand: medium-light skin tone +1F64B 1F3FC 200D 2640 ; minimally-qualified # 🙋🏼♀ E4.0 woman raising hand: medium-light skin tone +1F64B 1F3FD 200D 2640 FE0F ; fully-qualified # 🙋🏽♀️ E4.0 woman raising hand: medium skin tone +1F64B 1F3FD 200D 2640 ; minimally-qualified # 🙋🏽♀ E4.0 woman raising hand: medium skin tone +1F64B 1F3FE 200D 2640 FE0F ; fully-qualified # 🙋🏾♀️ E4.0 woman raising hand: medium-dark skin tone +1F64B 1F3FE 200D 2640 ; minimally-qualified # 🙋🏾♀ E4.0 woman raising hand: medium-dark skin tone +1F64B 1F3FF 200D 2640 FE0F ; fully-qualified # 🙋🏿♀️ E4.0 woman raising hand: dark skin tone +1F64B 1F3FF 200D 2640 ; minimally-qualified # 🙋🏿♀ E4.0 woman raising hand: dark skin tone +1F9CF ; fully-qualified # 🧏 E12.0 deaf person +1F9CF 1F3FB ; fully-qualified # 🧏🏻 E12.0 deaf person: light skin tone +1F9CF 1F3FC ; fully-qualified # 🧏🏼 E12.0 deaf person: medium-light skin tone +1F9CF 1F3FD ; fully-qualified # 🧏🏽 E12.0 deaf person: medium skin tone +1F9CF 1F3FE ; fully-qualified # 🧏🏾 E12.0 deaf person: medium-dark skin tone +1F9CF 1F3FF ; fully-qualified # 🧏🏿 E12.0 deaf person: dark skin tone +1F9CF 200D 2642 FE0F ; fully-qualified # 🧏♂️ E12.0 deaf man +1F9CF 200D 2642 ; minimally-qualified # 🧏♂ E12.0 deaf man +1F9CF 1F3FB 200D 2642 FE0F ; fully-qualified # 🧏🏻♂️ E12.0 deaf man: light skin tone +1F9CF 1F3FB 200D 2642 ; minimally-qualified # 🧏🏻♂ E12.0 deaf man: light skin tone +1F9CF 1F3FC 200D 2642 FE0F ; fully-qualified # 🧏🏼♂️ E12.0 deaf man: medium-light skin tone +1F9CF 1F3FC 200D 2642 ; minimally-qualified # 🧏🏼♂ E12.0 deaf man: medium-light skin tone +1F9CF 1F3FD 200D 2642 FE0F ; fully-qualified # 🧏🏽♂️ E12.0 deaf man: medium skin tone +1F9CF 1F3FD 200D 2642 ; minimally-qualified # 🧏🏽♂ E12.0 deaf man: medium skin tone +1F9CF 1F3FE 200D 2642 FE0F ; fully-qualified # 🧏🏾♂️ E12.0 deaf man: medium-dark skin tone +1F9CF 1F3FE 200D 2642 ; minimally-qualified # 🧏🏾♂ E12.0 deaf man: medium-dark skin tone +1F9CF 1F3FF 200D 2642 FE0F ; fully-qualified # 🧏🏿♂️ E12.0 deaf man: dark skin tone +1F9CF 1F3FF 200D 2642 ; minimally-qualified # 🧏🏿♂ E12.0 deaf man: dark skin tone +1F9CF 200D 2640 FE0F ; fully-qualified # 🧏♀️ E12.0 deaf woman +1F9CF 200D 2640 ; minimally-qualified # 🧏♀ E12.0 deaf woman +1F9CF 1F3FB 200D 2640 FE0F ; fully-qualified # 🧏🏻♀️ E12.0 deaf woman: light skin tone +1F9CF 1F3FB 200D 2640 ; minimally-qualified # 🧏🏻♀ E12.0 deaf woman: light skin tone +1F9CF 1F3FC 200D 2640 FE0F ; fully-qualified # 🧏🏼♀️ E12.0 deaf woman: medium-light skin tone +1F9CF 1F3FC 200D 2640 ; minimally-qualified # 🧏🏼♀ E12.0 deaf woman: medium-light skin tone +1F9CF 1F3FD 200D 2640 FE0F ; fully-qualified # 🧏🏽♀️ E12.0 deaf woman: medium skin tone +1F9CF 1F3FD 200D 2640 ; minimally-qualified # 🧏🏽♀ E12.0 deaf woman: medium skin tone +1F9CF 1F3FE 200D 2640 FE0F ; fully-qualified # 🧏🏾♀️ E12.0 deaf woman: medium-dark skin tone +1F9CF 1F3FE 200D 2640 ; minimally-qualified # 🧏🏾♀ E12.0 deaf woman: medium-dark skin tone +1F9CF 1F3FF 200D 2640 FE0F ; fully-qualified # 🧏🏿♀️ E12.0 deaf woman: dark skin tone +1F9CF 1F3FF 200D 2640 ; minimally-qualified # 🧏🏿♀ E12.0 deaf woman: dark skin tone +1F647 ; fully-qualified # 🙇 E0.6 person bowing +1F647 1F3FB ; fully-qualified # 🙇🏻 E1.0 person bowing: light skin tone +1F647 1F3FC ; fully-qualified # 🙇🏼 E1.0 person bowing: medium-light skin tone +1F647 1F3FD ; fully-qualified # 🙇🏽 E1.0 person bowing: medium skin tone +1F647 1F3FE ; fully-qualified # 🙇🏾 E1.0 person bowing: medium-dark skin tone +1F647 1F3FF ; fully-qualified # 🙇🏿 E1.0 person bowing: dark skin tone +1F647 200D 2642 FE0F ; fully-qualified # 🙇♂️ E4.0 man bowing +1F647 200D 2642 ; minimally-qualified # 🙇♂ E4.0 man bowing +1F647 1F3FB 200D 2642 FE0F ; fully-qualified # 🙇🏻♂️ E4.0 man bowing: light skin tone +1F647 1F3FB 200D 2642 ; minimally-qualified # 🙇🏻♂ E4.0 man bowing: light skin tone +1F647 1F3FC 200D 2642 FE0F ; fully-qualified # 🙇🏼♂️ E4.0 man bowing: medium-light skin tone +1F647 1F3FC 200D 2642 ; minimally-qualified # 🙇🏼♂ E4.0 man bowing: medium-light skin tone +1F647 1F3FD 200D 2642 FE0F ; fully-qualified # 🙇🏽♂️ E4.0 man bowing: medium skin tone +1F647 1F3FD 200D 2642 ; minimally-qualified # 🙇🏽♂ E4.0 man bowing: medium skin tone +1F647 1F3FE 200D 2642 FE0F ; fully-qualified # 🙇🏾♂️ E4.0 man bowing: medium-dark skin tone +1F647 1F3FE 200D 2642 ; minimally-qualified # 🙇🏾♂ E4.0 man bowing: medium-dark skin tone +1F647 1F3FF 200D 2642 FE0F ; fully-qualified # 🙇🏿♂️ E4.0 man bowing: dark skin tone +1F647 1F3FF 200D 2642 ; minimally-qualified # 🙇🏿♂ E4.0 man bowing: dark skin tone +1F647 200D 2640 FE0F ; fully-qualified # 🙇♀️ E4.0 woman bowing +1F647 200D 2640 ; minimally-qualified # 🙇♀ E4.0 woman bowing +1F647 1F3FB 200D 2640 FE0F ; fully-qualified # 🙇🏻♀️ E4.0 woman bowing: light skin tone +1F647 1F3FB 200D 2640 ; minimally-qualified # 🙇🏻♀ E4.0 woman bowing: light skin tone +1F647 1F3FC 200D 2640 FE0F ; fully-qualified # 🙇🏼♀️ E4.0 woman bowing: medium-light skin tone +1F647 1F3FC 200D 2640 ; minimally-qualified # 🙇🏼♀ E4.0 woman bowing: medium-light skin tone +1F647 1F3FD 200D 2640 FE0F ; fully-qualified # 🙇🏽♀️ E4.0 woman bowing: medium skin tone +1F647 1F3FD 200D 2640 ; minimally-qualified # 🙇🏽♀ E4.0 woman bowing: medium skin tone +1F647 1F3FE 200D 2640 FE0F ; fully-qualified # 🙇🏾♀️ E4.0 woman bowing: medium-dark skin tone +1F647 1F3FE 200D 2640 ; minimally-qualified # 🙇🏾♀ E4.0 woman bowing: medium-dark skin tone +1F647 1F3FF 200D 2640 FE0F ; fully-qualified # 🙇🏿♀️ E4.0 woman bowing: dark skin tone +1F647 1F3FF 200D 2640 ; minimally-qualified # 🙇🏿♀ E4.0 woman bowing: dark skin tone +1F926 ; fully-qualified # 🤦 E3.0 person facepalming +1F926 1F3FB ; fully-qualified # 🤦🏻 E3.0 person facepalming: light skin tone +1F926 1F3FC ; fully-qualified # 🤦🏼 E3.0 person facepalming: medium-light skin tone +1F926 1F3FD ; fully-qualified # 🤦🏽 E3.0 person facepalming: medium skin tone +1F926 1F3FE ; fully-qualified # 🤦🏾 E3.0 person facepalming: medium-dark skin tone +1F926 1F3FF ; fully-qualified # 🤦🏿 E3.0 person facepalming: dark skin tone +1F926 200D 2642 FE0F ; fully-qualified # 🤦♂️ E4.0 man facepalming +1F926 200D 2642 ; minimally-qualified # 🤦♂ E4.0 man facepalming +1F926 1F3FB 200D 2642 FE0F ; fully-qualified # 🤦🏻♂️ E4.0 man facepalming: light skin tone +1F926 1F3FB 200D 2642 ; minimally-qualified # 🤦🏻♂ E4.0 man facepalming: light skin tone +1F926 1F3FC 200D 2642 FE0F ; fully-qualified # 🤦🏼♂️ E4.0 man facepalming: medium-light skin tone +1F926 1F3FC 200D 2642 ; minimally-qualified # 🤦🏼♂ E4.0 man facepalming: medium-light skin tone +1F926 1F3FD 200D 2642 FE0F ; fully-qualified # 🤦🏽♂️ E4.0 man facepalming: medium skin tone +1F926 1F3FD 200D 2642 ; minimally-qualified # 🤦🏽♂ E4.0 man facepalming: medium skin tone +1F926 1F3FE 200D 2642 FE0F ; fully-qualified # 🤦🏾♂️ E4.0 man facepalming: medium-dark skin tone +1F926 1F3FE 200D 2642 ; minimally-qualified # 🤦🏾♂ E4.0 man facepalming: medium-dark skin tone +1F926 1F3FF 200D 2642 FE0F ; fully-qualified # 🤦🏿♂️ E4.0 man facepalming: dark skin tone +1F926 1F3FF 200D 2642 ; minimally-qualified # 🤦🏿♂ E4.0 man facepalming: dark skin tone +1F926 200D 2640 FE0F ; fully-qualified # 🤦♀️ E4.0 woman facepalming +1F926 200D 2640 ; minimally-qualified # 🤦♀ E4.0 woman facepalming +1F926 1F3FB 200D 2640 FE0F ; fully-qualified # 🤦🏻♀️ E4.0 woman facepalming: light skin tone +1F926 1F3FB 200D 2640 ; minimally-qualified # 🤦🏻♀ E4.0 woman facepalming: light skin tone +1F926 1F3FC 200D 2640 FE0F ; fully-qualified # 🤦🏼♀️ E4.0 woman facepalming: medium-light skin tone +1F926 1F3FC 200D 2640 ; minimally-qualified # 🤦🏼♀ E4.0 woman facepalming: medium-light skin tone +1F926 1F3FD 200D 2640 FE0F ; fully-qualified # 🤦🏽♀️ E4.0 woman facepalming: medium skin tone +1F926 1F3FD 200D 2640 ; minimally-qualified # 🤦🏽♀ E4.0 woman facepalming: medium skin tone +1F926 1F3FE 200D 2640 FE0F ; fully-qualified # 🤦🏾♀️ E4.0 woman facepalming: medium-dark skin tone +1F926 1F3FE 200D 2640 ; minimally-qualified # 🤦🏾♀ E4.0 woman facepalming: medium-dark skin tone +1F926 1F3FF 200D 2640 FE0F ; fully-qualified # 🤦🏿♀️ E4.0 woman facepalming: dark skin tone +1F926 1F3FF 200D 2640 ; minimally-qualified # 🤦🏿♀ E4.0 woman facepalming: dark skin tone +1F937 ; fully-qualified # 🤷 E3.0 person shrugging +1F937 1F3FB ; fully-qualified # 🤷🏻 E3.0 person shrugging: light skin tone +1F937 1F3FC ; fully-qualified # 🤷🏼 E3.0 person shrugging: medium-light skin tone +1F937 1F3FD ; fully-qualified # 🤷🏽 E3.0 person shrugging: medium skin tone +1F937 1F3FE ; fully-qualified # 🤷🏾 E3.0 person shrugging: medium-dark skin tone +1F937 1F3FF ; fully-qualified # 🤷🏿 E3.0 person shrugging: dark skin tone +1F937 200D 2642 FE0F ; fully-qualified # 🤷♂️ E4.0 man shrugging +1F937 200D 2642 ; minimally-qualified # 🤷♂ E4.0 man shrugging +1F937 1F3FB 200D 2642 FE0F ; fully-qualified # 🤷🏻♂️ E4.0 man shrugging: light skin tone +1F937 1F3FB 200D 2642 ; minimally-qualified # 🤷🏻♂ E4.0 man shrugging: light skin tone +1F937 1F3FC 200D 2642 FE0F ; fully-qualified # 🤷🏼♂️ E4.0 man shrugging: medium-light skin tone +1F937 1F3FC 200D 2642 ; minimally-qualified # 🤷🏼♂ E4.0 man shrugging: medium-light skin tone +1F937 1F3FD 200D 2642 FE0F ; fully-qualified # 🤷🏽♂️ E4.0 man shrugging: medium skin tone +1F937 1F3FD 200D 2642 ; minimally-qualified # 🤷🏽♂ E4.0 man shrugging: medium skin tone +1F937 1F3FE 200D 2642 FE0F ; fully-qualified # 🤷🏾♂️ E4.0 man shrugging: medium-dark skin tone +1F937 1F3FE 200D 2642 ; minimally-qualified # 🤷🏾♂ E4.0 man shrugging: medium-dark skin tone +1F937 1F3FF 200D 2642 FE0F ; fully-qualified # 🤷🏿♂️ E4.0 man shrugging: dark skin tone +1F937 1F3FF 200D 2642 ; minimally-qualified # 🤷🏿♂ E4.0 man shrugging: dark skin tone +1F937 200D 2640 FE0F ; fully-qualified # 🤷♀️ E4.0 woman shrugging +1F937 200D 2640 ; minimally-qualified # 🤷♀ E4.0 woman shrugging +1F937 1F3FB 200D 2640 FE0F ; fully-qualified # 🤷🏻♀️ E4.0 woman shrugging: light skin tone +1F937 1F3FB 200D 2640 ; minimally-qualified # 🤷🏻♀ E4.0 woman shrugging: light skin tone +1F937 1F3FC 200D 2640 FE0F ; fully-qualified # 🤷🏼♀️ E4.0 woman shrugging: medium-light skin tone +1F937 1F3FC 200D 2640 ; minimally-qualified # 🤷🏼♀ E4.0 woman shrugging: medium-light skin tone +1F937 1F3FD 200D 2640 FE0F ; fully-qualified # 🤷🏽♀️ E4.0 woman shrugging: medium skin tone +1F937 1F3FD 200D 2640 ; minimally-qualified # 🤷🏽♀ E4.0 woman shrugging: medium skin tone +1F937 1F3FE 200D 2640 FE0F ; fully-qualified # 🤷🏾♀️ E4.0 woman shrugging: medium-dark skin tone +1F937 1F3FE 200D 2640 ; minimally-qualified # 🤷🏾♀ E4.0 woman shrugging: medium-dark skin tone +1F937 1F3FF 200D 2640 FE0F ; fully-qualified # 🤷🏿♀️ E4.0 woman shrugging: dark skin tone +1F937 1F3FF 200D 2640 ; minimally-qualified # 🤷🏿♀ E4.0 woman shrugging: dark skin tone + +# subgroup: person-role +1F9D1 200D 2695 FE0F ; fully-qualified # 🧑⚕️ E12.1 health worker +1F9D1 200D 2695 ; minimally-qualified # 🧑⚕ E12.1 health worker +1F9D1 1F3FB 200D 2695 FE0F ; fully-qualified # 🧑🏻⚕️ E12.1 health worker: light skin tone +1F9D1 1F3FB 200D 2695 ; minimally-qualified # 🧑🏻⚕ E12.1 health worker: light skin tone +1F9D1 1F3FC 200D 2695 FE0F ; fully-qualified # 🧑🏼⚕️ E12.1 health worker: medium-light skin tone +1F9D1 1F3FC 200D 2695 ; minimally-qualified # 🧑🏼⚕ E12.1 health worker: medium-light skin tone +1F9D1 1F3FD 200D 2695 FE0F ; fully-qualified # 🧑🏽⚕️ E12.1 health worker: medium skin tone +1F9D1 1F3FD 200D 2695 ; minimally-qualified # 🧑🏽⚕ E12.1 health worker: medium skin tone +1F9D1 1F3FE 200D 2695 FE0F ; fully-qualified # 🧑🏾⚕️ E12.1 health worker: medium-dark skin tone +1F9D1 1F3FE 200D 2695 ; minimally-qualified # 🧑🏾⚕ E12.1 health worker: medium-dark skin tone +1F9D1 1F3FF 200D 2695 FE0F ; fully-qualified # 🧑🏿⚕️ E12.1 health worker: dark skin tone +1F9D1 1F3FF 200D 2695 ; minimally-qualified # 🧑🏿⚕ E12.1 health worker: dark skin tone +1F468 200D 2695 FE0F ; fully-qualified # 👨⚕️ E4.0 man health worker +1F468 200D 2695 ; minimally-qualified # 👨⚕ E4.0 man health worker +1F468 1F3FB 200D 2695 FE0F ; fully-qualified # 👨🏻⚕️ E4.0 man health worker: light skin tone +1F468 1F3FB 200D 2695 ; minimally-qualified # 👨🏻⚕ E4.0 man health worker: light skin tone +1F468 1F3FC 200D 2695 FE0F ; fully-qualified # 👨🏼⚕️ E4.0 man health worker: medium-light skin tone +1F468 1F3FC 200D 2695 ; minimally-qualified # 👨🏼⚕ E4.0 man health worker: medium-light skin tone +1F468 1F3FD 200D 2695 FE0F ; fully-qualified # 👨🏽⚕️ E4.0 man health worker: medium skin tone +1F468 1F3FD 200D 2695 ; minimally-qualified # 👨🏽⚕ E4.0 man health worker: medium skin tone +1F468 1F3FE 200D 2695 FE0F ; fully-qualified # 👨🏾⚕️ E4.0 man health worker: medium-dark skin tone +1F468 1F3FE 200D 2695 ; minimally-qualified # 👨🏾⚕ E4.0 man health worker: medium-dark skin tone +1F468 1F3FF 200D 2695 FE0F ; fully-qualified # 👨🏿⚕️ E4.0 man health worker: dark skin tone +1F468 1F3FF 200D 2695 ; minimally-qualified # 👨🏿⚕ E4.0 man health worker: dark skin tone +1F469 200D 2695 FE0F ; fully-qualified # 👩⚕️ E4.0 woman health worker +1F469 200D 2695 ; minimally-qualified # 👩⚕ E4.0 woman health worker +1F469 1F3FB 200D 2695 FE0F ; fully-qualified # 👩🏻⚕️ E4.0 woman health worker: light skin tone +1F469 1F3FB 200D 2695 ; minimally-qualified # 👩🏻⚕ E4.0 woman health worker: light skin tone +1F469 1F3FC 200D 2695 FE0F ; fully-qualified # 👩🏼⚕️ E4.0 woman health worker: medium-light skin tone +1F469 1F3FC 200D 2695 ; minimally-qualified # 👩🏼⚕ E4.0 woman health worker: medium-light skin tone +1F469 1F3FD 200D 2695 FE0F ; fully-qualified # 👩🏽⚕️ E4.0 woman health worker: medium skin tone +1F469 1F3FD 200D 2695 ; minimally-qualified # 👩🏽⚕ E4.0 woman health worker: medium skin tone +1F469 1F3FE 200D 2695 FE0F ; fully-qualified # 👩🏾⚕️ E4.0 woman health worker: medium-dark skin tone +1F469 1F3FE 200D 2695 ; minimally-qualified # 👩🏾⚕ E4.0 woman health worker: medium-dark skin tone +1F469 1F3FF 200D 2695 FE0F ; fully-qualified # 👩🏿⚕️ E4.0 woman health worker: dark skin tone +1F469 1F3FF 200D 2695 ; minimally-qualified # 👩🏿⚕ E4.0 woman health worker: dark skin tone +1F9D1 200D 1F393 ; fully-qualified # 🧑🎓 E12.1 student +1F9D1 1F3FB 200D 1F393 ; fully-qualified # 🧑🏻🎓 E12.1 student: light skin tone +1F9D1 1F3FC 200D 1F393 ; fully-qualified # 🧑🏼🎓 E12.1 student: medium-light skin tone +1F9D1 1F3FD 200D 1F393 ; fully-qualified # 🧑🏽🎓 E12.1 student: medium skin tone +1F9D1 1F3FE 200D 1F393 ; fully-qualified # 🧑🏾🎓 E12.1 student: medium-dark skin tone +1F9D1 1F3FF 200D 1F393 ; fully-qualified # 🧑🏿🎓 E12.1 student: dark skin tone +1F468 200D 1F393 ; fully-qualified # 👨🎓 E4.0 man student +1F468 1F3FB 200D 1F393 ; fully-qualified # 👨🏻🎓 E4.0 man student: light skin tone +1F468 1F3FC 200D 1F393 ; fully-qualified # 👨🏼🎓 E4.0 man student: medium-light skin tone +1F468 1F3FD 200D 1F393 ; fully-qualified # 👨🏽🎓 E4.0 man student: medium skin tone +1F468 1F3FE 200D 1F393 ; fully-qualified # 👨🏾🎓 E4.0 man student: medium-dark skin tone +1F468 1F3FF 200D 1F393 ; fully-qualified # 👨🏿🎓 E4.0 man student: dark skin tone +1F469 200D 1F393 ; fully-qualified # 👩🎓 E4.0 woman student +1F469 1F3FB 200D 1F393 ; fully-qualified # 👩🏻🎓 E4.0 woman student: light skin tone +1F469 1F3FC 200D 1F393 ; fully-qualified # 👩🏼🎓 E4.0 woman student: medium-light skin tone +1F469 1F3FD 200D 1F393 ; fully-qualified # 👩🏽🎓 E4.0 woman student: medium skin tone +1F469 1F3FE 200D 1F393 ; fully-qualified # 👩🏾🎓 E4.0 woman student: medium-dark skin tone +1F469 1F3FF 200D 1F393 ; fully-qualified # 👩🏿🎓 E4.0 woman student: dark skin tone +1F9D1 200D 1F3EB ; fully-qualified # 🧑🏫 E12.1 teacher +1F9D1 1F3FB 200D 1F3EB ; fully-qualified # 🧑🏻🏫 E12.1 teacher: light skin tone +1F9D1 1F3FC 200D 1F3EB ; fully-qualified # 🧑🏼🏫 E12.1 teacher: medium-light skin tone +1F9D1 1F3FD 200D 1F3EB ; fully-qualified # 🧑🏽🏫 E12.1 teacher: medium skin tone +1F9D1 1F3FE 200D 1F3EB ; fully-qualified # 🧑🏾🏫 E12.1 teacher: medium-dark skin tone +1F9D1 1F3FF 200D 1F3EB ; fully-qualified # 🧑🏿🏫 E12.1 teacher: dark skin tone +1F468 200D 1F3EB ; fully-qualified # 👨🏫 E4.0 man teacher +1F468 1F3FB 200D 1F3EB ; fully-qualified # 👨🏻🏫 E4.0 man teacher: light skin tone +1F468 1F3FC 200D 1F3EB ; fully-qualified # 👨🏼🏫 E4.0 man teacher: medium-light skin tone +1F468 1F3FD 200D 1F3EB ; fully-qualified # 👨🏽🏫 E4.0 man teacher: medium skin tone +1F468 1F3FE 200D 1F3EB ; fully-qualified # 👨🏾🏫 E4.0 man teacher: medium-dark skin tone +1F468 1F3FF 200D 1F3EB ; fully-qualified # 👨🏿🏫 E4.0 man teacher: dark skin tone +1F469 200D 1F3EB ; fully-qualified # 👩🏫 E4.0 woman teacher +1F469 1F3FB 200D 1F3EB ; fully-qualified # 👩🏻🏫 E4.0 woman teacher: light skin tone +1F469 1F3FC 200D 1F3EB ; fully-qualified # 👩🏼🏫 E4.0 woman teacher: medium-light skin tone +1F469 1F3FD 200D 1F3EB ; fully-qualified # 👩🏽🏫 E4.0 woman teacher: medium skin tone +1F469 1F3FE 200D 1F3EB ; fully-qualified # 👩🏾🏫 E4.0 woman teacher: medium-dark skin tone +1F469 1F3FF 200D 1F3EB ; fully-qualified # 👩🏿🏫 E4.0 woman teacher: dark skin tone +1F9D1 200D 2696 FE0F ; fully-qualified # 🧑⚖️ E12.1 judge +1F9D1 200D 2696 ; minimally-qualified # 🧑⚖ E12.1 judge +1F9D1 1F3FB 200D 2696 FE0F ; fully-qualified # 🧑🏻⚖️ E12.1 judge: light skin tone +1F9D1 1F3FB 200D 2696 ; minimally-qualified # 🧑🏻⚖ E12.1 judge: light skin tone +1F9D1 1F3FC 200D 2696 FE0F ; fully-qualified # 🧑🏼⚖️ E12.1 judge: medium-light skin tone +1F9D1 1F3FC 200D 2696 ; minimally-qualified # 🧑🏼⚖ E12.1 judge: medium-light skin tone +1F9D1 1F3FD 200D 2696 FE0F ; fully-qualified # 🧑🏽⚖️ E12.1 judge: medium skin tone +1F9D1 1F3FD 200D 2696 ; minimally-qualified # 🧑🏽⚖ E12.1 judge: medium skin tone +1F9D1 1F3FE 200D 2696 FE0F ; fully-qualified # 🧑🏾⚖️ E12.1 judge: medium-dark skin tone +1F9D1 1F3FE 200D 2696 ; minimally-qualified # 🧑🏾⚖ E12.1 judge: medium-dark skin tone +1F9D1 1F3FF 200D 2696 FE0F ; fully-qualified # 🧑🏿⚖️ E12.1 judge: dark skin tone +1F9D1 1F3FF 200D 2696 ; minimally-qualified # 🧑🏿⚖ E12.1 judge: dark skin tone +1F468 200D 2696 FE0F ; fully-qualified # 👨⚖️ E4.0 man judge +1F468 200D 2696 ; minimally-qualified # 👨⚖ E4.0 man judge +1F468 1F3FB 200D 2696 FE0F ; fully-qualified # 👨🏻⚖️ E4.0 man judge: light skin tone +1F468 1F3FB 200D 2696 ; minimally-qualified # 👨🏻⚖ E4.0 man judge: light skin tone +1F468 1F3FC 200D 2696 FE0F ; fully-qualified # 👨🏼⚖️ E4.0 man judge: medium-light skin tone +1F468 1F3FC 200D 2696 ; minimally-qualified # 👨🏼⚖ E4.0 man judge: medium-light skin tone +1F468 1F3FD 200D 2696 FE0F ; fully-qualified # 👨🏽⚖️ E4.0 man judge: medium skin tone +1F468 1F3FD 200D 2696 ; minimally-qualified # 👨🏽⚖ E4.0 man judge: medium skin tone +1F468 1F3FE 200D 2696 FE0F ; fully-qualified # 👨🏾⚖️ E4.0 man judge: medium-dark skin tone +1F468 1F3FE 200D 2696 ; minimally-qualified # 👨🏾⚖ E4.0 man judge: medium-dark skin tone +1F468 1F3FF 200D 2696 FE0F ; fully-qualified # 👨🏿⚖️ E4.0 man judge: dark skin tone +1F468 1F3FF 200D 2696 ; minimally-qualified # 👨🏿⚖ E4.0 man judge: dark skin tone +1F469 200D 2696 FE0F ; fully-qualified # 👩⚖️ E4.0 woman judge +1F469 200D 2696 ; minimally-qualified # 👩⚖ E4.0 woman judge +1F469 1F3FB 200D 2696 FE0F ; fully-qualified # 👩🏻⚖️ E4.0 woman judge: light skin tone +1F469 1F3FB 200D 2696 ; minimally-qualified # 👩🏻⚖ E4.0 woman judge: light skin tone +1F469 1F3FC 200D 2696 FE0F ; fully-qualified # 👩🏼⚖️ E4.0 woman judge: medium-light skin tone +1F469 1F3FC 200D 2696 ; minimally-qualified # 👩🏼⚖ E4.0 woman judge: medium-light skin tone +1F469 1F3FD 200D 2696 FE0F ; fully-qualified # 👩🏽⚖️ E4.0 woman judge: medium skin tone +1F469 1F3FD 200D 2696 ; minimally-qualified # 👩🏽⚖ E4.0 woman judge: medium skin tone +1F469 1F3FE 200D 2696 FE0F ; fully-qualified # 👩🏾⚖️ E4.0 woman judge: medium-dark skin tone +1F469 1F3FE 200D 2696 ; minimally-qualified # 👩🏾⚖ E4.0 woman judge: medium-dark skin tone +1F469 1F3FF 200D 2696 FE0F ; fully-qualified # 👩🏿⚖️ E4.0 woman judge: dark skin tone +1F469 1F3FF 200D 2696 ; minimally-qualified # 👩🏿⚖ E4.0 woman judge: dark skin tone +1F9D1 200D 1F33E ; fully-qualified # 🧑🌾 E12.1 farmer +1F9D1 1F3FB 200D 1F33E ; fully-qualified # 🧑🏻🌾 E12.1 farmer: light skin tone +1F9D1 1F3FC 200D 1F33E ; fully-qualified # 🧑🏼🌾 E12.1 farmer: medium-light skin tone +1F9D1 1F3FD 200D 1F33E ; fully-qualified # 🧑🏽🌾 E12.1 farmer: medium skin tone +1F9D1 1F3FE 200D 1F33E ; fully-qualified # 🧑🏾🌾 E12.1 farmer: medium-dark skin tone +1F9D1 1F3FF 200D 1F33E ; fully-qualified # 🧑🏿🌾 E12.1 farmer: dark skin tone +1F468 200D 1F33E ; fully-qualified # 👨🌾 E4.0 man farmer +1F468 1F3FB 200D 1F33E ; fully-qualified # 👨🏻🌾 E4.0 man farmer: light skin tone +1F468 1F3FC 200D 1F33E ; fully-qualified # 👨🏼🌾 E4.0 man farmer: medium-light skin tone +1F468 1F3FD 200D 1F33E ; fully-qualified # 👨🏽🌾 E4.0 man farmer: medium skin tone +1F468 1F3FE 200D 1F33E ; fully-qualified # 👨🏾🌾 E4.0 man farmer: medium-dark skin tone +1F468 1F3FF 200D 1F33E ; fully-qualified # 👨🏿🌾 E4.0 man farmer: dark skin tone +1F469 200D 1F33E ; fully-qualified # 👩🌾 E4.0 woman farmer +1F469 1F3FB 200D 1F33E ; fully-qualified # 👩🏻🌾 E4.0 woman farmer: light skin tone +1F469 1F3FC 200D 1F33E ; fully-qualified # 👩🏼🌾 E4.0 woman farmer: medium-light skin tone +1F469 1F3FD 200D 1F33E ; fully-qualified # 👩🏽🌾 E4.0 woman farmer: medium skin tone +1F469 1F3FE 200D 1F33E ; fully-qualified # 👩🏾🌾 E4.0 woman farmer: medium-dark skin tone +1F469 1F3FF 200D 1F33E ; fully-qualified # 👩🏿🌾 E4.0 woman farmer: dark skin tone +1F9D1 200D 1F373 ; fully-qualified # 🧑🍳 E12.1 cook +1F9D1 1F3FB 200D 1F373 ; fully-qualified # 🧑🏻🍳 E12.1 cook: light skin tone +1F9D1 1F3FC 200D 1F373 ; fully-qualified # 🧑🏼🍳 E12.1 cook: medium-light skin tone +1F9D1 1F3FD 200D 1F373 ; fully-qualified # 🧑🏽🍳 E12.1 cook: medium skin tone +1F9D1 1F3FE 200D 1F373 ; fully-qualified # 🧑🏾🍳 E12.1 cook: medium-dark skin tone +1F9D1 1F3FF 200D 1F373 ; fully-qualified # 🧑🏿🍳 E12.1 cook: dark skin tone +1F468 200D 1F373 ; fully-qualified # 👨🍳 E4.0 man cook +1F468 1F3FB 200D 1F373 ; fully-qualified # 👨🏻🍳 E4.0 man cook: light skin tone +1F468 1F3FC 200D 1F373 ; fully-qualified # 👨🏼🍳 E4.0 man cook: medium-light skin tone +1F468 1F3FD 200D 1F373 ; fully-qualified # 👨🏽🍳 E4.0 man cook: medium skin tone +1F468 1F3FE 200D 1F373 ; fully-qualified # 👨🏾🍳 E4.0 man cook: medium-dark skin tone +1F468 1F3FF 200D 1F373 ; fully-qualified # 👨🏿🍳 E4.0 man cook: dark skin tone +1F469 200D 1F373 ; fully-qualified # 👩🍳 E4.0 woman cook +1F469 1F3FB 200D 1F373 ; fully-qualified # 👩🏻🍳 E4.0 woman cook: light skin tone +1F469 1F3FC 200D 1F373 ; fully-qualified # 👩🏼🍳 E4.0 woman cook: medium-light skin tone +1F469 1F3FD 200D 1F373 ; fully-qualified # 👩🏽🍳 E4.0 woman cook: medium skin tone +1F469 1F3FE 200D 1F373 ; fully-qualified # 👩🏾🍳 E4.0 woman cook: medium-dark skin tone +1F469 1F3FF 200D 1F373 ; fully-qualified # 👩🏿🍳 E4.0 woman cook: dark skin tone +1F9D1 200D 1F527 ; fully-qualified # 🧑🔧 E12.1 mechanic +1F9D1 1F3FB 200D 1F527 ; fully-qualified # 🧑🏻🔧 E12.1 mechanic: light skin tone +1F9D1 1F3FC 200D 1F527 ; fully-qualified # 🧑🏼🔧 E12.1 mechanic: medium-light skin tone +1F9D1 1F3FD 200D 1F527 ; fully-qualified # 🧑🏽🔧 E12.1 mechanic: medium skin tone +1F9D1 1F3FE 200D 1F527 ; fully-qualified # 🧑🏾🔧 E12.1 mechanic: medium-dark skin tone +1F9D1 1F3FF 200D 1F527 ; fully-qualified # 🧑🏿🔧 E12.1 mechanic: dark skin tone +1F468 200D 1F527 ; fully-qualified # 👨🔧 E4.0 man mechanic +1F468 1F3FB 200D 1F527 ; fully-qualified # 👨🏻🔧 E4.0 man mechanic: light skin tone +1F468 1F3FC 200D 1F527 ; fully-qualified # 👨🏼🔧 E4.0 man mechanic: medium-light skin tone +1F468 1F3FD 200D 1F527 ; fully-qualified # 👨🏽🔧 E4.0 man mechanic: medium skin tone +1F468 1F3FE 200D 1F527 ; fully-qualified # 👨🏾🔧 E4.0 man mechanic: medium-dark skin tone +1F468 1F3FF 200D 1F527 ; fully-qualified # 👨🏿🔧 E4.0 man mechanic: dark skin tone +1F469 200D 1F527 ; fully-qualified # 👩🔧 E4.0 woman mechanic +1F469 1F3FB 200D 1F527 ; fully-qualified # 👩🏻🔧 E4.0 woman mechanic: light skin tone +1F469 1F3FC 200D 1F527 ; fully-qualified # 👩🏼🔧 E4.0 woman mechanic: medium-light skin tone +1F469 1F3FD 200D 1F527 ; fully-qualified # 👩🏽🔧 E4.0 woman mechanic: medium skin tone +1F469 1F3FE 200D 1F527 ; fully-qualified # 👩🏾🔧 E4.0 woman mechanic: medium-dark skin tone +1F469 1F3FF 200D 1F527 ; fully-qualified # 👩🏿🔧 E4.0 woman mechanic: dark skin tone +1F9D1 200D 1F3ED ; fully-qualified # 🧑🏭 E12.1 factory worker +1F9D1 1F3FB 200D 1F3ED ; fully-qualified # 🧑🏻🏭 E12.1 factory worker: light skin tone +1F9D1 1F3FC 200D 1F3ED ; fully-qualified # 🧑🏼🏭 E12.1 factory worker: medium-light skin tone +1F9D1 1F3FD 200D 1F3ED ; fully-qualified # 🧑🏽🏭 E12.1 factory worker: medium skin tone +1F9D1 1F3FE 200D 1F3ED ; fully-qualified # 🧑🏾🏭 E12.1 factory worker: medium-dark skin tone +1F9D1 1F3FF 200D 1F3ED ; fully-qualified # 🧑🏿🏭 E12.1 factory worker: dark skin tone +1F468 200D 1F3ED ; fully-qualified # 👨🏭 E4.0 man factory worker +1F468 1F3FB 200D 1F3ED ; fully-qualified # 👨🏻🏭 E4.0 man factory worker: light skin tone +1F468 1F3FC 200D 1F3ED ; fully-qualified # 👨🏼🏭 E4.0 man factory worker: medium-light skin tone +1F468 1F3FD 200D 1F3ED ; fully-qualified # 👨🏽🏭 E4.0 man factory worker: medium skin tone +1F468 1F3FE 200D 1F3ED ; fully-qualified # 👨🏾🏭 E4.0 man factory worker: medium-dark skin tone +1F468 1F3FF 200D 1F3ED ; fully-qualified # 👨🏿🏭 E4.0 man factory worker: dark skin tone +1F469 200D 1F3ED ; fully-qualified # 👩🏭 E4.0 woman factory worker +1F469 1F3FB 200D 1F3ED ; fully-qualified # 👩🏻🏭 E4.0 woman factory worker: light skin tone +1F469 1F3FC 200D 1F3ED ; fully-qualified # 👩🏼🏭 E4.0 woman factory worker: medium-light skin tone +1F469 1F3FD 200D 1F3ED ; fully-qualified # 👩🏽🏭 E4.0 woman factory worker: medium skin tone +1F469 1F3FE 200D 1F3ED ; fully-qualified # 👩🏾🏭 E4.0 woman factory worker: medium-dark skin tone +1F469 1F3FF 200D 1F3ED ; fully-qualified # 👩🏿🏭 E4.0 woman factory worker: dark skin tone +1F9D1 200D 1F4BC ; fully-qualified # 🧑💼 E12.1 office worker +1F9D1 1F3FB 200D 1F4BC ; fully-qualified # 🧑🏻💼 E12.1 office worker: light skin tone +1F9D1 1F3FC 200D 1F4BC ; fully-qualified # 🧑🏼💼 E12.1 office worker: medium-light skin tone +1F9D1 1F3FD 200D 1F4BC ; fully-qualified # 🧑🏽💼 E12.1 office worker: medium skin tone +1F9D1 1F3FE 200D 1F4BC ; fully-qualified # 🧑🏾💼 E12.1 office worker: medium-dark skin tone +1F9D1 1F3FF 200D 1F4BC ; fully-qualified # 🧑🏿💼 E12.1 office worker: dark skin tone +1F468 200D 1F4BC ; fully-qualified # 👨💼 E4.0 man office worker +1F468 1F3FB 200D 1F4BC ; fully-qualified # 👨🏻💼 E4.0 man office worker: light skin tone +1F468 1F3FC 200D 1F4BC ; fully-qualified # 👨🏼💼 E4.0 man office worker: medium-light skin tone +1F468 1F3FD 200D 1F4BC ; fully-qualified # 👨🏽💼 E4.0 man office worker: medium skin tone +1F468 1F3FE 200D 1F4BC ; fully-qualified # 👨🏾💼 E4.0 man office worker: medium-dark skin tone +1F468 1F3FF 200D 1F4BC ; fully-qualified # 👨🏿💼 E4.0 man office worker: dark skin tone +1F469 200D 1F4BC ; fully-qualified # 👩💼 E4.0 woman office worker +1F469 1F3FB 200D 1F4BC ; fully-qualified # 👩🏻💼 E4.0 woman office worker: light skin tone +1F469 1F3FC 200D 1F4BC ; fully-qualified # 👩🏼💼 E4.0 woman office worker: medium-light skin tone +1F469 1F3FD 200D 1F4BC ; fully-qualified # 👩🏽💼 E4.0 woman office worker: medium skin tone +1F469 1F3FE 200D 1F4BC ; fully-qualified # 👩🏾💼 E4.0 woman office worker: medium-dark skin tone +1F469 1F3FF 200D 1F4BC ; fully-qualified # 👩🏿💼 E4.0 woman office worker: dark skin tone +1F9D1 200D 1F52C ; fully-qualified # 🧑🔬 E12.1 scientist +1F9D1 1F3FB 200D 1F52C ; fully-qualified # 🧑🏻🔬 E12.1 scientist: light skin tone +1F9D1 1F3FC 200D 1F52C ; fully-qualified # 🧑🏼🔬 E12.1 scientist: medium-light skin tone +1F9D1 1F3FD 200D 1F52C ; fully-qualified # 🧑🏽🔬 E12.1 scientist: medium skin tone +1F9D1 1F3FE 200D 1F52C ; fully-qualified # 🧑🏾🔬 E12.1 scientist: medium-dark skin tone +1F9D1 1F3FF 200D 1F52C ; fully-qualified # 🧑🏿🔬 E12.1 scientist: dark skin tone +1F468 200D 1F52C ; fully-qualified # 👨🔬 E4.0 man scientist +1F468 1F3FB 200D 1F52C ; fully-qualified # 👨🏻🔬 E4.0 man scientist: light skin tone +1F468 1F3FC 200D 1F52C ; fully-qualified # 👨🏼🔬 E4.0 man scientist: medium-light skin tone +1F468 1F3FD 200D 1F52C ; fully-qualified # 👨🏽🔬 E4.0 man scientist: medium skin tone +1F468 1F3FE 200D 1F52C ; fully-qualified # 👨🏾🔬 E4.0 man scientist: medium-dark skin tone +1F468 1F3FF 200D 1F52C ; fully-qualified # 👨🏿🔬 E4.0 man scientist: dark skin tone +1F469 200D 1F52C ; fully-qualified # 👩🔬 E4.0 woman scientist +1F469 1F3FB 200D 1F52C ; fully-qualified # 👩🏻🔬 E4.0 woman scientist: light skin tone +1F469 1F3FC 200D 1F52C ; fully-qualified # 👩🏼🔬 E4.0 woman scientist: medium-light skin tone +1F469 1F3FD 200D 1F52C ; fully-qualified # 👩🏽🔬 E4.0 woman scientist: medium skin tone +1F469 1F3FE 200D 1F52C ; fully-qualified # 👩🏾🔬 E4.0 woman scientist: medium-dark skin tone +1F469 1F3FF 200D 1F52C ; fully-qualified # 👩🏿🔬 E4.0 woman scientist: dark skin tone +1F9D1 200D 1F4BB ; fully-qualified # 🧑💻 E12.1 technologist +1F9D1 1F3FB 200D 1F4BB ; fully-qualified # 🧑🏻💻 E12.1 technologist: light skin tone +1F9D1 1F3FC 200D 1F4BB ; fully-qualified # 🧑🏼💻 E12.1 technologist: medium-light skin tone +1F9D1 1F3FD 200D 1F4BB ; fully-qualified # 🧑🏽💻 E12.1 technologist: medium skin tone +1F9D1 1F3FE 200D 1F4BB ; fully-qualified # 🧑🏾💻 E12.1 technologist: medium-dark skin tone +1F9D1 1F3FF 200D 1F4BB ; fully-qualified # 🧑🏿💻 E12.1 technologist: dark skin tone +1F468 200D 1F4BB ; fully-qualified # 👨💻 E4.0 man technologist +1F468 1F3FB 200D 1F4BB ; fully-qualified # 👨🏻💻 E4.0 man technologist: light skin tone +1F468 1F3FC 200D 1F4BB ; fully-qualified # 👨🏼💻 E4.0 man technologist: medium-light skin tone +1F468 1F3FD 200D 1F4BB ; fully-qualified # 👨🏽💻 E4.0 man technologist: medium skin tone +1F468 1F3FE 200D 1F4BB ; fully-qualified # 👨🏾💻 E4.0 man technologist: medium-dark skin tone +1F468 1F3FF 200D 1F4BB ; fully-qualified # 👨🏿💻 E4.0 man technologist: dark skin tone +1F469 200D 1F4BB ; fully-qualified # 👩💻 E4.0 woman technologist +1F469 1F3FB 200D 1F4BB ; fully-qualified # 👩🏻💻 E4.0 woman technologist: light skin tone +1F469 1F3FC 200D 1F4BB ; fully-qualified # 👩🏼💻 E4.0 woman technologist: medium-light skin tone +1F469 1F3FD 200D 1F4BB ; fully-qualified # 👩🏽💻 E4.0 woman technologist: medium skin tone +1F469 1F3FE 200D 1F4BB ; fully-qualified # 👩🏾💻 E4.0 woman technologist: medium-dark skin tone +1F469 1F3FF 200D 1F4BB ; fully-qualified # 👩🏿💻 E4.0 woman technologist: dark skin tone +1F9D1 200D 1F3A4 ; fully-qualified # 🧑🎤 E12.1 singer +1F9D1 1F3FB 200D 1F3A4 ; fully-qualified # 🧑🏻🎤 E12.1 singer: light skin tone +1F9D1 1F3FC 200D 1F3A4 ; fully-qualified # 🧑🏼🎤 E12.1 singer: medium-light skin tone +1F9D1 1F3FD 200D 1F3A4 ; fully-qualified # 🧑🏽🎤 E12.1 singer: medium skin tone +1F9D1 1F3FE 200D 1F3A4 ; fully-qualified # 🧑🏾🎤 E12.1 singer: medium-dark skin tone +1F9D1 1F3FF 200D 1F3A4 ; fully-qualified # 🧑🏿🎤 E12.1 singer: dark skin tone +1F468 200D 1F3A4 ; fully-qualified # 👨🎤 E4.0 man singer +1F468 1F3FB 200D 1F3A4 ; fully-qualified # 👨🏻🎤 E4.0 man singer: light skin tone +1F468 1F3FC 200D 1F3A4 ; fully-qualified # 👨🏼🎤 E4.0 man singer: medium-light skin tone +1F468 1F3FD 200D 1F3A4 ; fully-qualified # 👨🏽🎤 E4.0 man singer: medium skin tone +1F468 1F3FE 200D 1F3A4 ; fully-qualified # 👨🏾🎤 E4.0 man singer: medium-dark skin tone +1F468 1F3FF 200D 1F3A4 ; fully-qualified # 👨🏿🎤 E4.0 man singer: dark skin tone +1F469 200D 1F3A4 ; fully-qualified # 👩🎤 E4.0 woman singer +1F469 1F3FB 200D 1F3A4 ; fully-qualified # 👩🏻🎤 E4.0 woman singer: light skin tone +1F469 1F3FC 200D 1F3A4 ; fully-qualified # 👩🏼🎤 E4.0 woman singer: medium-light skin tone +1F469 1F3FD 200D 1F3A4 ; fully-qualified # 👩🏽🎤 E4.0 woman singer: medium skin tone +1F469 1F3FE 200D 1F3A4 ; fully-qualified # 👩🏾🎤 E4.0 woman singer: medium-dark skin tone +1F469 1F3FF 200D 1F3A4 ; fully-qualified # 👩🏿🎤 E4.0 woman singer: dark skin tone +1F9D1 200D 1F3A8 ; fully-qualified # 🧑🎨 E12.1 artist +1F9D1 1F3FB 200D 1F3A8 ; fully-qualified # 🧑🏻🎨 E12.1 artist: light skin tone +1F9D1 1F3FC 200D 1F3A8 ; fully-qualified # 🧑🏼🎨 E12.1 artist: medium-light skin tone +1F9D1 1F3FD 200D 1F3A8 ; fully-qualified # 🧑🏽🎨 E12.1 artist: medium skin tone +1F9D1 1F3FE 200D 1F3A8 ; fully-qualified # 🧑🏾🎨 E12.1 artist: medium-dark skin tone +1F9D1 1F3FF 200D 1F3A8 ; fully-qualified # 🧑🏿🎨 E12.1 artist: dark skin tone +1F468 200D 1F3A8 ; fully-qualified # 👨🎨 E4.0 man artist +1F468 1F3FB 200D 1F3A8 ; fully-qualified # 👨🏻🎨 E4.0 man artist: light skin tone +1F468 1F3FC 200D 1F3A8 ; fully-qualified # 👨🏼🎨 E4.0 man artist: medium-light skin tone +1F468 1F3FD 200D 1F3A8 ; fully-qualified # 👨🏽🎨 E4.0 man artist: medium skin tone +1F468 1F3FE 200D 1F3A8 ; fully-qualified # 👨🏾🎨 E4.0 man artist: medium-dark skin tone +1F468 1F3FF 200D 1F3A8 ; fully-qualified # 👨🏿🎨 E4.0 man artist: dark skin tone +1F469 200D 1F3A8 ; fully-qualified # 👩🎨 E4.0 woman artist +1F469 1F3FB 200D 1F3A8 ; fully-qualified # 👩🏻🎨 E4.0 woman artist: light skin tone +1F469 1F3FC 200D 1F3A8 ; fully-qualified # 👩🏼🎨 E4.0 woman artist: medium-light skin tone +1F469 1F3FD 200D 1F3A8 ; fully-qualified # 👩🏽🎨 E4.0 woman artist: medium skin tone +1F469 1F3FE 200D 1F3A8 ; fully-qualified # 👩🏾🎨 E4.0 woman artist: medium-dark skin tone +1F469 1F3FF 200D 1F3A8 ; fully-qualified # 👩🏿🎨 E4.0 woman artist: dark skin tone +1F9D1 200D 2708 FE0F ; fully-qualified # 🧑✈️ E12.1 pilot +1F9D1 200D 2708 ; minimally-qualified # 🧑✈ E12.1 pilot +1F9D1 1F3FB 200D 2708 FE0F ; fully-qualified # 🧑🏻✈️ E12.1 pilot: light skin tone +1F9D1 1F3FB 200D 2708 ; minimally-qualified # 🧑🏻✈ E12.1 pilot: light skin tone +1F9D1 1F3FC 200D 2708 FE0F ; fully-qualified # 🧑🏼✈️ E12.1 pilot: medium-light skin tone +1F9D1 1F3FC 200D 2708 ; minimally-qualified # 🧑🏼✈ E12.1 pilot: medium-light skin tone +1F9D1 1F3FD 200D 2708 FE0F ; fully-qualified # 🧑🏽✈️ E12.1 pilot: medium skin tone +1F9D1 1F3FD 200D 2708 ; minimally-qualified # 🧑🏽✈ E12.1 pilot: medium skin tone +1F9D1 1F3FE 200D 2708 FE0F ; fully-qualified # 🧑🏾✈️ E12.1 pilot: medium-dark skin tone +1F9D1 1F3FE 200D 2708 ; minimally-qualified # 🧑🏾✈ E12.1 pilot: medium-dark skin tone +1F9D1 1F3FF 200D 2708 FE0F ; fully-qualified # 🧑🏿✈️ E12.1 pilot: dark skin tone +1F9D1 1F3FF 200D 2708 ; minimally-qualified # 🧑🏿✈ E12.1 pilot: dark skin tone +1F468 200D 2708 FE0F ; fully-qualified # 👨✈️ E4.0 man pilot +1F468 200D 2708 ; minimally-qualified # 👨✈ E4.0 man pilot +1F468 1F3FB 200D 2708 FE0F ; fully-qualified # 👨🏻✈️ E4.0 man pilot: light skin tone +1F468 1F3FB 200D 2708 ; minimally-qualified # 👨🏻✈ E4.0 man pilot: light skin tone +1F468 1F3FC 200D 2708 FE0F ; fully-qualified # 👨🏼✈️ E4.0 man pilot: medium-light skin tone +1F468 1F3FC 200D 2708 ; minimally-qualified # 👨🏼✈ E4.0 man pilot: medium-light skin tone +1F468 1F3FD 200D 2708 FE0F ; fully-qualified # 👨🏽✈️ E4.0 man pilot: medium skin tone +1F468 1F3FD 200D 2708 ; minimally-qualified # 👨🏽✈ E4.0 man pilot: medium skin tone +1F468 1F3FE 200D 2708 FE0F ; fully-qualified # 👨🏾✈️ E4.0 man pilot: medium-dark skin tone +1F468 1F3FE 200D 2708 ; minimally-qualified # 👨🏾✈ E4.0 man pilot: medium-dark skin tone +1F468 1F3FF 200D 2708 FE0F ; fully-qualified # 👨🏿✈️ E4.0 man pilot: dark skin tone +1F468 1F3FF 200D 2708 ; minimally-qualified # 👨🏿✈ E4.0 man pilot: dark skin tone +1F469 200D 2708 FE0F ; fully-qualified # 👩✈️ E4.0 woman pilot +1F469 200D 2708 ; minimally-qualified # 👩✈ E4.0 woman pilot +1F469 1F3FB 200D 2708 FE0F ; fully-qualified # 👩🏻✈️ E4.0 woman pilot: light skin tone +1F469 1F3FB 200D 2708 ; minimally-qualified # 👩🏻✈ E4.0 woman pilot: light skin tone +1F469 1F3FC 200D 2708 FE0F ; fully-qualified # 👩🏼✈️ E4.0 woman pilot: medium-light skin tone +1F469 1F3FC 200D 2708 ; minimally-qualified # 👩🏼✈ E4.0 woman pilot: medium-light skin tone +1F469 1F3FD 200D 2708 FE0F ; fully-qualified # 👩🏽✈️ E4.0 woman pilot: medium skin tone +1F469 1F3FD 200D 2708 ; minimally-qualified # 👩🏽✈ E4.0 woman pilot: medium skin tone +1F469 1F3FE 200D 2708 FE0F ; fully-qualified # 👩🏾✈️ E4.0 woman pilot: medium-dark skin tone +1F469 1F3FE 200D 2708 ; minimally-qualified # 👩🏾✈ E4.0 woman pilot: medium-dark skin tone +1F469 1F3FF 200D 2708 FE0F ; fully-qualified # 👩🏿✈️ E4.0 woman pilot: dark skin tone +1F469 1F3FF 200D 2708 ; minimally-qualified # 👩🏿✈ E4.0 woman pilot: dark skin tone +1F9D1 200D 1F680 ; fully-qualified # 🧑🚀 E12.1 astronaut +1F9D1 1F3FB 200D 1F680 ; fully-qualified # 🧑🏻🚀 E12.1 astronaut: light skin tone +1F9D1 1F3FC 200D 1F680 ; fully-qualified # 🧑🏼🚀 E12.1 astronaut: medium-light skin tone +1F9D1 1F3FD 200D 1F680 ; fully-qualified # 🧑🏽🚀 E12.1 astronaut: medium skin tone +1F9D1 1F3FE 200D 1F680 ; fully-qualified # 🧑🏾🚀 E12.1 astronaut: medium-dark skin tone +1F9D1 1F3FF 200D 1F680 ; fully-qualified # 🧑🏿🚀 E12.1 astronaut: dark skin tone +1F468 200D 1F680 ; fully-qualified # 👨🚀 E4.0 man astronaut +1F468 1F3FB 200D 1F680 ; fully-qualified # 👨🏻🚀 E4.0 man astronaut: light skin tone +1F468 1F3FC 200D 1F680 ; fully-qualified # 👨🏼🚀 E4.0 man astronaut: medium-light skin tone +1F468 1F3FD 200D 1F680 ; fully-qualified # 👨🏽🚀 E4.0 man astronaut: medium skin tone +1F468 1F3FE 200D 1F680 ; fully-qualified # 👨🏾🚀 E4.0 man astronaut: medium-dark skin tone +1F468 1F3FF 200D 1F680 ; fully-qualified # 👨🏿🚀 E4.0 man astronaut: dark skin tone +1F469 200D 1F680 ; fully-qualified # 👩🚀 E4.0 woman astronaut +1F469 1F3FB 200D 1F680 ; fully-qualified # 👩🏻🚀 E4.0 woman astronaut: light skin tone +1F469 1F3FC 200D 1F680 ; fully-qualified # 👩🏼🚀 E4.0 woman astronaut: medium-light skin tone +1F469 1F3FD 200D 1F680 ; fully-qualified # 👩🏽🚀 E4.0 woman astronaut: medium skin tone +1F469 1F3FE 200D 1F680 ; fully-qualified # 👩🏾🚀 E4.0 woman astronaut: medium-dark skin tone +1F469 1F3FF 200D 1F680 ; fully-qualified # 👩🏿🚀 E4.0 woman astronaut: dark skin tone +1F9D1 200D 1F692 ; fully-qualified # 🧑🚒 E12.1 firefighter +1F9D1 1F3FB 200D 1F692 ; fully-qualified # 🧑🏻🚒 E12.1 firefighter: light skin tone +1F9D1 1F3FC 200D 1F692 ; fully-qualified # 🧑🏼🚒 E12.1 firefighter: medium-light skin tone +1F9D1 1F3FD 200D 1F692 ; fully-qualified # 🧑🏽🚒 E12.1 firefighter: medium skin tone +1F9D1 1F3FE 200D 1F692 ; fully-qualified # 🧑🏾🚒 E12.1 firefighter: medium-dark skin tone +1F9D1 1F3FF 200D 1F692 ; fully-qualified # 🧑🏿🚒 E12.1 firefighter: dark skin tone +1F468 200D 1F692 ; fully-qualified # 👨🚒 E4.0 man firefighter +1F468 1F3FB 200D 1F692 ; fully-qualified # 👨🏻🚒 E4.0 man firefighter: light skin tone +1F468 1F3FC 200D 1F692 ; fully-qualified # 👨🏼🚒 E4.0 man firefighter: medium-light skin tone +1F468 1F3FD 200D 1F692 ; fully-qualified # 👨🏽🚒 E4.0 man firefighter: medium skin tone +1F468 1F3FE 200D 1F692 ; fully-qualified # 👨🏾🚒 E4.0 man firefighter: medium-dark skin tone +1F468 1F3FF 200D 1F692 ; fully-qualified # 👨🏿🚒 E4.0 man firefighter: dark skin tone +1F469 200D 1F692 ; fully-qualified # 👩🚒 E4.0 woman firefighter +1F469 1F3FB 200D 1F692 ; fully-qualified # 👩🏻🚒 E4.0 woman firefighter: light skin tone +1F469 1F3FC 200D 1F692 ; fully-qualified # 👩🏼🚒 E4.0 woman firefighter: medium-light skin tone +1F469 1F3FD 200D 1F692 ; fully-qualified # 👩🏽🚒 E4.0 woman firefighter: medium skin tone +1F469 1F3FE 200D 1F692 ; fully-qualified # 👩🏾🚒 E4.0 woman firefighter: medium-dark skin tone +1F469 1F3FF 200D 1F692 ; fully-qualified # 👩🏿🚒 E4.0 woman firefighter: dark skin tone +1F46E ; fully-qualified # 👮 E0.6 police officer +1F46E 1F3FB ; fully-qualified # 👮🏻 E1.0 police officer: light skin tone +1F46E 1F3FC ; fully-qualified # 👮🏼 E1.0 police officer: medium-light skin tone +1F46E 1F3FD ; fully-qualified # 👮🏽 E1.0 police officer: medium skin tone +1F46E 1F3FE ; fully-qualified # 👮🏾 E1.0 police officer: medium-dark skin tone +1F46E 1F3FF ; fully-qualified # 👮🏿 E1.0 police officer: dark skin tone +1F46E 200D 2642 FE0F ; fully-qualified # 👮♂️ E4.0 man police officer +1F46E 200D 2642 ; minimally-qualified # 👮♂ E4.0 man police officer +1F46E 1F3FB 200D 2642 FE0F ; fully-qualified # 👮🏻♂️ E4.0 man police officer: light skin tone +1F46E 1F3FB 200D 2642 ; minimally-qualified # 👮🏻♂ E4.0 man police officer: light skin tone +1F46E 1F3FC 200D 2642 FE0F ; fully-qualified # 👮🏼♂️ E4.0 man police officer: medium-light skin tone +1F46E 1F3FC 200D 2642 ; minimally-qualified # 👮🏼♂ E4.0 man police officer: medium-light skin tone +1F46E 1F3FD 200D 2642 FE0F ; fully-qualified # 👮🏽♂️ E4.0 man police officer: medium skin tone +1F46E 1F3FD 200D 2642 ; minimally-qualified # 👮🏽♂ E4.0 man police officer: medium skin tone +1F46E 1F3FE 200D 2642 FE0F ; fully-qualified # 👮🏾♂️ E4.0 man police officer: medium-dark skin tone +1F46E 1F3FE 200D 2642 ; minimally-qualified # 👮🏾♂ E4.0 man police officer: medium-dark skin tone +1F46E 1F3FF 200D 2642 FE0F ; fully-qualified # 👮🏿♂️ E4.0 man police officer: dark skin tone +1F46E 1F3FF 200D 2642 ; minimally-qualified # 👮🏿♂ E4.0 man police officer: dark skin tone +1F46E 200D 2640 FE0F ; fully-qualified # 👮♀️ E4.0 woman police officer +1F46E 200D 2640 ; minimally-qualified # 👮♀ E4.0 woman police officer +1F46E 1F3FB 200D 2640 FE0F ; fully-qualified # 👮🏻♀️ E4.0 woman police officer: light skin tone +1F46E 1F3FB 200D 2640 ; minimally-qualified # 👮🏻♀ E4.0 woman police officer: light skin tone +1F46E 1F3FC 200D 2640 FE0F ; fully-qualified # 👮🏼♀️ E4.0 woman police officer: medium-light skin tone +1F46E 1F3FC 200D 2640 ; minimally-qualified # 👮🏼♀ E4.0 woman police officer: medium-light skin tone +1F46E 1F3FD 200D 2640 FE0F ; fully-qualified # 👮🏽♀️ E4.0 woman police officer: medium skin tone +1F46E 1F3FD 200D 2640 ; minimally-qualified # 👮🏽♀ E4.0 woman police officer: medium skin tone +1F46E 1F3FE 200D 2640 FE0F ; fully-qualified # 👮🏾♀️ E4.0 woman police officer: medium-dark skin tone +1F46E 1F3FE 200D 2640 ; minimally-qualified # 👮🏾♀ E4.0 woman police officer: medium-dark skin tone +1F46E 1F3FF 200D 2640 FE0F ; fully-qualified # 👮🏿♀️ E4.0 woman police officer: dark skin tone +1F46E 1F3FF 200D 2640 ; minimally-qualified # 👮🏿♀ E4.0 woman police officer: dark skin tone +1F575 FE0F ; fully-qualified # 🕵️ E0.7 detective +1F575 ; unqualified # 🕵 E0.7 detective +1F575 1F3FB ; fully-qualified # 🕵🏻 E2.0 detective: light skin tone +1F575 1F3FC ; fully-qualified # 🕵🏼 E2.0 detective: medium-light skin tone +1F575 1F3FD ; fully-qualified # 🕵🏽 E2.0 detective: medium skin tone +1F575 1F3FE ; fully-qualified # 🕵🏾 E2.0 detective: medium-dark skin tone +1F575 1F3FF ; fully-qualified # 🕵🏿 E2.0 detective: dark skin tone +1F575 FE0F 200D 2642 FE0F ; fully-qualified # 🕵️♂️ E4.0 man detective +1F575 200D 2642 FE0F ; unqualified # 🕵♂️ E4.0 man detective +1F575 FE0F 200D 2642 ; unqualified # 🕵️♂ E4.0 man detective +1F575 200D 2642 ; unqualified # 🕵♂ E4.0 man detective +1F575 1F3FB 200D 2642 FE0F ; fully-qualified # 🕵🏻♂️ E4.0 man detective: light skin tone +1F575 1F3FB 200D 2642 ; minimally-qualified # 🕵🏻♂ E4.0 man detective: light skin tone +1F575 1F3FC 200D 2642 FE0F ; fully-qualified # 🕵🏼♂️ E4.0 man detective: medium-light skin tone +1F575 1F3FC 200D 2642 ; minimally-qualified # 🕵🏼♂ E4.0 man detective: medium-light skin tone +1F575 1F3FD 200D 2642 FE0F ; fully-qualified # 🕵🏽♂️ E4.0 man detective: medium skin tone +1F575 1F3FD 200D 2642 ; minimally-qualified # 🕵🏽♂ E4.0 man detective: medium skin tone +1F575 1F3FE 200D 2642 FE0F ; fully-qualified # 🕵🏾♂️ E4.0 man detective: medium-dark skin tone +1F575 1F3FE 200D 2642 ; minimally-qualified # 🕵🏾♂ E4.0 man detective: medium-dark skin tone +1F575 1F3FF 200D 2642 FE0F ; fully-qualified # 🕵🏿♂️ E4.0 man detective: dark skin tone +1F575 1F3FF 200D 2642 ; minimally-qualified # 🕵🏿♂ E4.0 man detective: dark skin tone +1F575 FE0F 200D 2640 FE0F ; fully-qualified # 🕵️♀️ E4.0 woman detective +1F575 200D 2640 FE0F ; unqualified # 🕵♀️ E4.0 woman detective +1F575 FE0F 200D 2640 ; unqualified # 🕵️♀ E4.0 woman detective +1F575 200D 2640 ; unqualified # 🕵♀ E4.0 woman detective +1F575 1F3FB 200D 2640 FE0F ; fully-qualified # 🕵🏻♀️ E4.0 woman detective: light skin tone +1F575 1F3FB 200D 2640 ; minimally-qualified # 🕵🏻♀ E4.0 woman detective: light skin tone +1F575 1F3FC 200D 2640 FE0F ; fully-qualified # 🕵🏼♀️ E4.0 woman detective: medium-light skin tone +1F575 1F3FC 200D 2640 ; minimally-qualified # 🕵🏼♀ E4.0 woman detective: medium-light skin tone +1F575 1F3FD 200D 2640 FE0F ; fully-qualified # 🕵🏽♀️ E4.0 woman detective: medium skin tone +1F575 1F3FD 200D 2640 ; minimally-qualified # 🕵🏽♀ E4.0 woman detective: medium skin tone +1F575 1F3FE 200D 2640 FE0F ; fully-qualified # 🕵🏾♀️ E4.0 woman detective: medium-dark skin tone +1F575 1F3FE 200D 2640 ; minimally-qualified # 🕵🏾♀ E4.0 woman detective: medium-dark skin tone +1F575 1F3FF 200D 2640 FE0F ; fully-qualified # 🕵🏿♀️ E4.0 woman detective: dark skin tone +1F575 1F3FF 200D 2640 ; minimally-qualified # 🕵🏿♀ E4.0 woman detective: dark skin tone +1F482 ; fully-qualified # 💂 E0.6 guard +1F482 1F3FB ; fully-qualified # 💂🏻 E1.0 guard: light skin tone +1F482 1F3FC ; fully-qualified # 💂🏼 E1.0 guard: medium-light skin tone +1F482 1F3FD ; fully-qualified # 💂🏽 E1.0 guard: medium skin tone +1F482 1F3FE ; fully-qualified # 💂🏾 E1.0 guard: medium-dark skin tone +1F482 1F3FF ; fully-qualified # 💂🏿 E1.0 guard: dark skin tone +1F482 200D 2642 FE0F ; fully-qualified # 💂♂️ E4.0 man guard +1F482 200D 2642 ; minimally-qualified # 💂♂ E4.0 man guard +1F482 1F3FB 200D 2642 FE0F ; fully-qualified # 💂🏻♂️ E4.0 man guard: light skin tone +1F482 1F3FB 200D 2642 ; minimally-qualified # 💂🏻♂ E4.0 man guard: light skin tone +1F482 1F3FC 200D 2642 FE0F ; fully-qualified # 💂🏼♂️ E4.0 man guard: medium-light skin tone +1F482 1F3FC 200D 2642 ; minimally-qualified # 💂🏼♂ E4.0 man guard: medium-light skin tone +1F482 1F3FD 200D 2642 FE0F ; fully-qualified # 💂🏽♂️ E4.0 man guard: medium skin tone +1F482 1F3FD 200D 2642 ; minimally-qualified # 💂🏽♂ E4.0 man guard: medium skin tone +1F482 1F3FE 200D 2642 FE0F ; fully-qualified # 💂🏾♂️ E4.0 man guard: medium-dark skin tone +1F482 1F3FE 200D 2642 ; minimally-qualified # 💂🏾♂ E4.0 man guard: medium-dark skin tone +1F482 1F3FF 200D 2642 FE0F ; fully-qualified # 💂🏿♂️ E4.0 man guard: dark skin tone +1F482 1F3FF 200D 2642 ; minimally-qualified # 💂🏿♂ E4.0 man guard: dark skin tone +1F482 200D 2640 FE0F ; fully-qualified # 💂♀️ E4.0 woman guard +1F482 200D 2640 ; minimally-qualified # 💂♀ E4.0 woman guard +1F482 1F3FB 200D 2640 FE0F ; fully-qualified # 💂🏻♀️ E4.0 woman guard: light skin tone +1F482 1F3FB 200D 2640 ; minimally-qualified # 💂🏻♀ E4.0 woman guard: light skin tone +1F482 1F3FC 200D 2640 FE0F ; fully-qualified # 💂🏼♀️ E4.0 woman guard: medium-light skin tone +1F482 1F3FC 200D 2640 ; minimally-qualified # 💂🏼♀ E4.0 woman guard: medium-light skin tone +1F482 1F3FD 200D 2640 FE0F ; fully-qualified # 💂🏽♀️ E4.0 woman guard: medium skin tone +1F482 1F3FD 200D 2640 ; minimally-qualified # 💂🏽♀ E4.0 woman guard: medium skin tone +1F482 1F3FE 200D 2640 FE0F ; fully-qualified # 💂🏾♀️ E4.0 woman guard: medium-dark skin tone +1F482 1F3FE 200D 2640 ; minimally-qualified # 💂🏾♀ E4.0 woman guard: medium-dark skin tone +1F482 1F3FF 200D 2640 FE0F ; fully-qualified # 💂🏿♀️ E4.0 woman guard: dark skin tone +1F482 1F3FF 200D 2640 ; minimally-qualified # 💂🏿♀ E4.0 woman guard: dark skin tone +1F977 ; fully-qualified # 🥷 E13.0 ninja +1F977 1F3FB ; fully-qualified # 🥷🏻 E13.0 ninja: light skin tone +1F977 1F3FC ; fully-qualified # 🥷🏼 E13.0 ninja: medium-light skin tone +1F977 1F3FD ; fully-qualified # 🥷🏽 E13.0 ninja: medium skin tone +1F977 1F3FE ; fully-qualified # 🥷🏾 E13.0 ninja: medium-dark skin tone +1F977 1F3FF ; fully-qualified # 🥷🏿 E13.0 ninja: dark skin tone +1F477 ; fully-qualified # 👷 E0.6 construction worker +1F477 1F3FB ; fully-qualified # 👷🏻 E1.0 construction worker: light skin tone +1F477 1F3FC ; fully-qualified # 👷🏼 E1.0 construction worker: medium-light skin tone +1F477 1F3FD ; fully-qualified # 👷🏽 E1.0 construction worker: medium skin tone +1F477 1F3FE ; fully-qualified # 👷🏾 E1.0 construction worker: medium-dark skin tone +1F477 1F3FF ; fully-qualified # 👷🏿 E1.0 construction worker: dark skin tone +1F477 200D 2642 FE0F ; fully-qualified # 👷♂️ E4.0 man construction worker +1F477 200D 2642 ; minimally-qualified # 👷♂ E4.0 man construction worker +1F477 1F3FB 200D 2642 FE0F ; fully-qualified # 👷🏻♂️ E4.0 man construction worker: light skin tone +1F477 1F3FB 200D 2642 ; minimally-qualified # 👷🏻♂ E4.0 man construction worker: light skin tone +1F477 1F3FC 200D 2642 FE0F ; fully-qualified # 👷🏼♂️ E4.0 man construction worker: medium-light skin tone +1F477 1F3FC 200D 2642 ; minimally-qualified # 👷🏼♂ E4.0 man construction worker: medium-light skin tone +1F477 1F3FD 200D 2642 FE0F ; fully-qualified # 👷🏽♂️ E4.0 man construction worker: medium skin tone +1F477 1F3FD 200D 2642 ; minimally-qualified # 👷🏽♂ E4.0 man construction worker: medium skin tone +1F477 1F3FE 200D 2642 FE0F ; fully-qualified # 👷🏾♂️ E4.0 man construction worker: medium-dark skin tone +1F477 1F3FE 200D 2642 ; minimally-qualified # 👷🏾♂ E4.0 man construction worker: medium-dark skin tone +1F477 1F3FF 200D 2642 FE0F ; fully-qualified # 👷🏿♂️ E4.0 man construction worker: dark skin tone +1F477 1F3FF 200D 2642 ; minimally-qualified # 👷🏿♂ E4.0 man construction worker: dark skin tone +1F477 200D 2640 FE0F ; fully-qualified # 👷♀️ E4.0 woman construction worker +1F477 200D 2640 ; minimally-qualified # 👷♀ E4.0 woman construction worker +1F477 1F3FB 200D 2640 FE0F ; fully-qualified # 👷🏻♀️ E4.0 woman construction worker: light skin tone +1F477 1F3FB 200D 2640 ; minimally-qualified # 👷🏻♀ E4.0 woman construction worker: light skin tone +1F477 1F3FC 200D 2640 FE0F ; fully-qualified # 👷🏼♀️ E4.0 woman construction worker: medium-light skin tone +1F477 1F3FC 200D 2640 ; minimally-qualified # 👷🏼♀ E4.0 woman construction worker: medium-light skin tone +1F477 1F3FD 200D 2640 FE0F ; fully-qualified # 👷🏽♀️ E4.0 woman construction worker: medium skin tone +1F477 1F3FD 200D 2640 ; minimally-qualified # 👷🏽♀ E4.0 woman construction worker: medium skin tone +1F477 1F3FE 200D 2640 FE0F ; fully-qualified # 👷🏾♀️ E4.0 woman construction worker: medium-dark skin tone +1F477 1F3FE 200D 2640 ; minimally-qualified # 👷🏾♀ E4.0 woman construction worker: medium-dark skin tone +1F477 1F3FF 200D 2640 FE0F ; fully-qualified # 👷🏿♀️ E4.0 woman construction worker: dark skin tone +1F477 1F3FF 200D 2640 ; minimally-qualified # 👷🏿♀ E4.0 woman construction worker: dark skin tone +1FAC5 ; fully-qualified # 🫅 E14.0 person with crown +1FAC5 1F3FB ; fully-qualified # 🫅🏻 E14.0 person with crown: light skin tone +1FAC5 1F3FC ; fully-qualified # 🫅🏼 E14.0 person with crown: medium-light skin tone +1FAC5 1F3FD ; fully-qualified # 🫅🏽 E14.0 person with crown: medium skin tone +1FAC5 1F3FE ; fully-qualified # 🫅🏾 E14.0 person with crown: medium-dark skin tone +1FAC5 1F3FF ; fully-qualified # 🫅🏿 E14.0 person with crown: dark skin tone +1F934 ; fully-qualified # 🤴 E3.0 prince +1F934 1F3FB ; fully-qualified # 🤴🏻 E3.0 prince: light skin tone +1F934 1F3FC ; fully-qualified # 🤴🏼 E3.0 prince: medium-light skin tone +1F934 1F3FD ; fully-qualified # 🤴🏽 E3.0 prince: medium skin tone +1F934 1F3FE ; fully-qualified # 🤴🏾 E3.0 prince: medium-dark skin tone +1F934 1F3FF ; fully-qualified # 🤴🏿 E3.0 prince: dark skin tone +1F478 ; fully-qualified # 👸 E0.6 princess +1F478 1F3FB ; fully-qualified # 👸🏻 E1.0 princess: light skin tone +1F478 1F3FC ; fully-qualified # 👸🏼 E1.0 princess: medium-light skin tone +1F478 1F3FD ; fully-qualified # 👸🏽 E1.0 princess: medium skin tone +1F478 1F3FE ; fully-qualified # 👸🏾 E1.0 princess: medium-dark skin tone +1F478 1F3FF ; fully-qualified # 👸🏿 E1.0 princess: dark skin tone +1F473 ; fully-qualified # 👳 E0.6 person wearing turban +1F473 1F3FB ; fully-qualified # 👳🏻 E1.0 person wearing turban: light skin tone +1F473 1F3FC ; fully-qualified # 👳🏼 E1.0 person wearing turban: medium-light skin tone +1F473 1F3FD ; fully-qualified # 👳🏽 E1.0 person wearing turban: medium skin tone +1F473 1F3FE ; fully-qualified # 👳🏾 E1.0 person wearing turban: medium-dark skin tone +1F473 1F3FF ; fully-qualified # 👳🏿 E1.0 person wearing turban: dark skin tone +1F473 200D 2642 FE0F ; fully-qualified # 👳♂️ E4.0 man wearing turban +1F473 200D 2642 ; minimally-qualified # 👳♂ E4.0 man wearing turban +1F473 1F3FB 200D 2642 FE0F ; fully-qualified # 👳🏻♂️ E4.0 man wearing turban: light skin tone +1F473 1F3FB 200D 2642 ; minimally-qualified # 👳🏻♂ E4.0 man wearing turban: light skin tone +1F473 1F3FC 200D 2642 FE0F ; fully-qualified # 👳🏼♂️ E4.0 man wearing turban: medium-light skin tone +1F473 1F3FC 200D 2642 ; minimally-qualified # 👳🏼♂ E4.0 man wearing turban: medium-light skin tone +1F473 1F3FD 200D 2642 FE0F ; fully-qualified # 👳🏽♂️ E4.0 man wearing turban: medium skin tone +1F473 1F3FD 200D 2642 ; minimally-qualified # 👳🏽♂ E4.0 man wearing turban: medium skin tone +1F473 1F3FE 200D 2642 FE0F ; fully-qualified # 👳🏾♂️ E4.0 man wearing turban: medium-dark skin tone +1F473 1F3FE 200D 2642 ; minimally-qualified # 👳🏾♂ E4.0 man wearing turban: medium-dark skin tone +1F473 1F3FF 200D 2642 FE0F ; fully-qualified # 👳🏿♂️ E4.0 man wearing turban: dark skin tone +1F473 1F3FF 200D 2642 ; minimally-qualified # 👳🏿♂ E4.0 man wearing turban: dark skin tone +1F473 200D 2640 FE0F ; fully-qualified # 👳♀️ E4.0 woman wearing turban +1F473 200D 2640 ; minimally-qualified # 👳♀ E4.0 woman wearing turban +1F473 1F3FB 200D 2640 FE0F ; fully-qualified # 👳🏻♀️ E4.0 woman wearing turban: light skin tone +1F473 1F3FB 200D 2640 ; minimally-qualified # 👳🏻♀ E4.0 woman wearing turban: light skin tone +1F473 1F3FC 200D 2640 FE0F ; fully-qualified # 👳🏼♀️ E4.0 woman wearing turban: medium-light skin tone +1F473 1F3FC 200D 2640 ; minimally-qualified # 👳🏼♀ E4.0 woman wearing turban: medium-light skin tone +1F473 1F3FD 200D 2640 FE0F ; fully-qualified # 👳🏽♀️ E4.0 woman wearing turban: medium skin tone +1F473 1F3FD 200D 2640 ; minimally-qualified # 👳🏽♀ E4.0 woman wearing turban: medium skin tone +1F473 1F3FE 200D 2640 FE0F ; fully-qualified # 👳🏾♀️ E4.0 woman wearing turban: medium-dark skin tone +1F473 1F3FE 200D 2640 ; minimally-qualified # 👳🏾♀ E4.0 woman wearing turban: medium-dark skin tone +1F473 1F3FF 200D 2640 FE0F ; fully-qualified # 👳🏿♀️ E4.0 woman wearing turban: dark skin tone +1F473 1F3FF 200D 2640 ; minimally-qualified # 👳🏿♀ E4.0 woman wearing turban: dark skin tone +1F472 ; fully-qualified # 👲 E0.6 person with skullcap +1F472 1F3FB ; fully-qualified # 👲🏻 E1.0 person with skullcap: light skin tone +1F472 1F3FC ; fully-qualified # 👲🏼 E1.0 person with skullcap: medium-light skin tone +1F472 1F3FD ; fully-qualified # 👲🏽 E1.0 person with skullcap: medium skin tone +1F472 1F3FE ; fully-qualified # 👲🏾 E1.0 person with skullcap: medium-dark skin tone +1F472 1F3FF ; fully-qualified # 👲🏿 E1.0 person with skullcap: dark skin tone +1F9D5 ; fully-qualified # 🧕 E5.0 woman with headscarf +1F9D5 1F3FB ; fully-qualified # 🧕🏻 E5.0 woman with headscarf: light skin tone +1F9D5 1F3FC ; fully-qualified # 🧕🏼 E5.0 woman with headscarf: medium-light skin tone +1F9D5 1F3FD ; fully-qualified # 🧕🏽 E5.0 woman with headscarf: medium skin tone +1F9D5 1F3FE ; fully-qualified # 🧕🏾 E5.0 woman with headscarf: medium-dark skin tone +1F9D5 1F3FF ; fully-qualified # 🧕🏿 E5.0 woman with headscarf: dark skin tone +1F935 ; fully-qualified # 🤵 E3.0 person in tuxedo +1F935 1F3FB ; fully-qualified # 🤵🏻 E3.0 person in tuxedo: light skin tone +1F935 1F3FC ; fully-qualified # 🤵🏼 E3.0 person in tuxedo: medium-light skin tone +1F935 1F3FD ; fully-qualified # 🤵🏽 E3.0 person in tuxedo: medium skin tone +1F935 1F3FE ; fully-qualified # 🤵🏾 E3.0 person in tuxedo: medium-dark skin tone +1F935 1F3FF ; fully-qualified # 🤵🏿 E3.0 person in tuxedo: dark skin tone +1F935 200D 2642 FE0F ; fully-qualified # 🤵♂️ E13.0 man in tuxedo +1F935 200D 2642 ; minimally-qualified # 🤵♂ E13.0 man in tuxedo +1F935 1F3FB 200D 2642 FE0F ; fully-qualified # 🤵🏻♂️ E13.0 man in tuxedo: light skin tone +1F935 1F3FB 200D 2642 ; minimally-qualified # 🤵🏻♂ E13.0 man in tuxedo: light skin tone +1F935 1F3FC 200D 2642 FE0F ; fully-qualified # 🤵🏼♂️ E13.0 man in tuxedo: medium-light skin tone +1F935 1F3FC 200D 2642 ; minimally-qualified # 🤵🏼♂ E13.0 man in tuxedo: medium-light skin tone +1F935 1F3FD 200D 2642 FE0F ; fully-qualified # 🤵🏽♂️ E13.0 man in tuxedo: medium skin tone +1F935 1F3FD 200D 2642 ; minimally-qualified # 🤵🏽♂ E13.0 man in tuxedo: medium skin tone +1F935 1F3FE 200D 2642 FE0F ; fully-qualified # 🤵🏾♂️ E13.0 man in tuxedo: medium-dark skin tone +1F935 1F3FE 200D 2642 ; minimally-qualified # 🤵🏾♂ E13.0 man in tuxedo: medium-dark skin tone +1F935 1F3FF 200D 2642 FE0F ; fully-qualified # 🤵🏿♂️ E13.0 man in tuxedo: dark skin tone +1F935 1F3FF 200D 2642 ; minimally-qualified # 🤵🏿♂ E13.0 man in tuxedo: dark skin tone +1F935 200D 2640 FE0F ; fully-qualified # 🤵♀️ E13.0 woman in tuxedo +1F935 200D 2640 ; minimally-qualified # 🤵♀ E13.0 woman in tuxedo +1F935 1F3FB 200D 2640 FE0F ; fully-qualified # 🤵🏻♀️ E13.0 woman in tuxedo: light skin tone +1F935 1F3FB 200D 2640 ; minimally-qualified # 🤵🏻♀ E13.0 woman in tuxedo: light skin tone +1F935 1F3FC 200D 2640 FE0F ; fully-qualified # 🤵🏼♀️ E13.0 woman in tuxedo: medium-light skin tone +1F935 1F3FC 200D 2640 ; minimally-qualified # 🤵🏼♀ E13.0 woman in tuxedo: medium-light skin tone +1F935 1F3FD 200D 2640 FE0F ; fully-qualified # 🤵🏽♀️ E13.0 woman in tuxedo: medium skin tone +1F935 1F3FD 200D 2640 ; minimally-qualified # 🤵🏽♀ E13.0 woman in tuxedo: medium skin tone +1F935 1F3FE 200D 2640 FE0F ; fully-qualified # 🤵🏾♀️ E13.0 woman in tuxedo: medium-dark skin tone +1F935 1F3FE 200D 2640 ; minimally-qualified # 🤵🏾♀ E13.0 woman in tuxedo: medium-dark skin tone +1F935 1F3FF 200D 2640 FE0F ; fully-qualified # 🤵🏿♀️ E13.0 woman in tuxedo: dark skin tone +1F935 1F3FF 200D 2640 ; minimally-qualified # 🤵🏿♀ E13.0 woman in tuxedo: dark skin tone +1F470 ; fully-qualified # 👰 E0.6 person with veil +1F470 1F3FB ; fully-qualified # 👰🏻 E1.0 person with veil: light skin tone +1F470 1F3FC ; fully-qualified # 👰🏼 E1.0 person with veil: medium-light skin tone +1F470 1F3FD ; fully-qualified # 👰🏽 E1.0 person with veil: medium skin tone +1F470 1F3FE ; fully-qualified # 👰🏾 E1.0 person with veil: medium-dark skin tone +1F470 1F3FF ; fully-qualified # 👰🏿 E1.0 person with veil: dark skin tone +1F470 200D 2642 FE0F ; fully-qualified # 👰♂️ E13.0 man with veil +1F470 200D 2642 ; minimally-qualified # 👰♂ E13.0 man with veil +1F470 1F3FB 200D 2642 FE0F ; fully-qualified # 👰🏻♂️ E13.0 man with veil: light skin tone +1F470 1F3FB 200D 2642 ; minimally-qualified # 👰🏻♂ E13.0 man with veil: light skin tone +1F470 1F3FC 200D 2642 FE0F ; fully-qualified # 👰🏼♂️ E13.0 man with veil: medium-light skin tone +1F470 1F3FC 200D 2642 ; minimally-qualified # 👰🏼♂ E13.0 man with veil: medium-light skin tone +1F470 1F3FD 200D 2642 FE0F ; fully-qualified # 👰🏽♂️ E13.0 man with veil: medium skin tone +1F470 1F3FD 200D 2642 ; minimally-qualified # 👰🏽♂ E13.0 man with veil: medium skin tone +1F470 1F3FE 200D 2642 FE0F ; fully-qualified # 👰🏾♂️ E13.0 man with veil: medium-dark skin tone +1F470 1F3FE 200D 2642 ; minimally-qualified # 👰🏾♂ E13.0 man with veil: medium-dark skin tone +1F470 1F3FF 200D 2642 FE0F ; fully-qualified # 👰🏿♂️ E13.0 man with veil: dark skin tone +1F470 1F3FF 200D 2642 ; minimally-qualified # 👰🏿♂ E13.0 man with veil: dark skin tone +1F470 200D 2640 FE0F ; fully-qualified # 👰♀️ E13.0 woman with veil +1F470 200D 2640 ; minimally-qualified # 👰♀ E13.0 woman with veil +1F470 1F3FB 200D 2640 FE0F ; fully-qualified # 👰🏻♀️ E13.0 woman with veil: light skin tone +1F470 1F3FB 200D 2640 ; minimally-qualified # 👰🏻♀ E13.0 woman with veil: light skin tone +1F470 1F3FC 200D 2640 FE0F ; fully-qualified # 👰🏼♀️ E13.0 woman with veil: medium-light skin tone +1F470 1F3FC 200D 2640 ; minimally-qualified # 👰🏼♀ E13.0 woman with veil: medium-light skin tone +1F470 1F3FD 200D 2640 FE0F ; fully-qualified # 👰🏽♀️ E13.0 woman with veil: medium skin tone +1F470 1F3FD 200D 2640 ; minimally-qualified # 👰🏽♀ E13.0 woman with veil: medium skin tone +1F470 1F3FE 200D 2640 FE0F ; fully-qualified # 👰🏾♀️ E13.0 woman with veil: medium-dark skin tone +1F470 1F3FE 200D 2640 ; minimally-qualified # 👰🏾♀ E13.0 woman with veil: medium-dark skin tone +1F470 1F3FF 200D 2640 FE0F ; fully-qualified # 👰🏿♀️ E13.0 woman with veil: dark skin tone +1F470 1F3FF 200D 2640 ; minimally-qualified # 👰🏿♀ E13.0 woman with veil: dark skin tone +1F930 ; fully-qualified # 🤰 E3.0 pregnant woman +1F930 1F3FB ; fully-qualified # 🤰🏻 E3.0 pregnant woman: light skin tone +1F930 1F3FC ; fully-qualified # 🤰🏼 E3.0 pregnant woman: medium-light skin tone +1F930 1F3FD ; fully-qualified # 🤰🏽 E3.0 pregnant woman: medium skin tone +1F930 1F3FE ; fully-qualified # 🤰🏾 E3.0 pregnant woman: medium-dark skin tone +1F930 1F3FF ; fully-qualified # 🤰🏿 E3.0 pregnant woman: dark skin tone +1FAC3 ; fully-qualified # 🫃 E14.0 pregnant man +1FAC3 1F3FB ; fully-qualified # 🫃🏻 E14.0 pregnant man: light skin tone +1FAC3 1F3FC ; fully-qualified # 🫃🏼 E14.0 pregnant man: medium-light skin tone +1FAC3 1F3FD ; fully-qualified # 🫃🏽 E14.0 pregnant man: medium skin tone +1FAC3 1F3FE ; fully-qualified # 🫃🏾 E14.0 pregnant man: medium-dark skin tone +1FAC3 1F3FF ; fully-qualified # 🫃🏿 E14.0 pregnant man: dark skin tone +1FAC4 ; fully-qualified # 🫄 E14.0 pregnant person +1FAC4 1F3FB ; fully-qualified # 🫄🏻 E14.0 pregnant person: light skin tone +1FAC4 1F3FC ; fully-qualified # 🫄🏼 E14.0 pregnant person: medium-light skin tone +1FAC4 1F3FD ; fully-qualified # 🫄🏽 E14.0 pregnant person: medium skin tone +1FAC4 1F3FE ; fully-qualified # 🫄🏾 E14.0 pregnant person: medium-dark skin tone +1FAC4 1F3FF ; fully-qualified # 🫄🏿 E14.0 pregnant person: dark skin tone +1F931 ; fully-qualified # 🤱 E5.0 breast-feeding +1F931 1F3FB ; fully-qualified # 🤱🏻 E5.0 breast-feeding: light skin tone +1F931 1F3FC ; fully-qualified # 🤱🏼 E5.0 breast-feeding: medium-light skin tone +1F931 1F3FD ; fully-qualified # 🤱🏽 E5.0 breast-feeding: medium skin tone +1F931 1F3FE ; fully-qualified # 🤱🏾 E5.0 breast-feeding: medium-dark skin tone +1F931 1F3FF ; fully-qualified # 🤱🏿 E5.0 breast-feeding: dark skin tone +1F469 200D 1F37C ; fully-qualified # 👩🍼 E13.0 woman feeding baby +1F469 1F3FB 200D 1F37C ; fully-qualified # 👩🏻🍼 E13.0 woman feeding baby: light skin tone +1F469 1F3FC 200D 1F37C ; fully-qualified # 👩🏼🍼 E13.0 woman feeding baby: medium-light skin tone +1F469 1F3FD 200D 1F37C ; fully-qualified # 👩🏽🍼 E13.0 woman feeding baby: medium skin tone +1F469 1F3FE 200D 1F37C ; fully-qualified # 👩🏾🍼 E13.0 woman feeding baby: medium-dark skin tone +1F469 1F3FF 200D 1F37C ; fully-qualified # 👩🏿🍼 E13.0 woman feeding baby: dark skin tone +1F468 200D 1F37C ; fully-qualified # 👨🍼 E13.0 man feeding baby +1F468 1F3FB 200D 1F37C ; fully-qualified # 👨🏻🍼 E13.0 man feeding baby: light skin tone +1F468 1F3FC 200D 1F37C ; fully-qualified # 👨🏼🍼 E13.0 man feeding baby: medium-light skin tone +1F468 1F3FD 200D 1F37C ; fully-qualified # 👨🏽🍼 E13.0 man feeding baby: medium skin tone +1F468 1F3FE 200D 1F37C ; fully-qualified # 👨🏾🍼 E13.0 man feeding baby: medium-dark skin tone +1F468 1F3FF 200D 1F37C ; fully-qualified # 👨🏿🍼 E13.0 man feeding baby: dark skin tone +1F9D1 200D 1F37C ; fully-qualified # 🧑🍼 E13.0 person feeding baby +1F9D1 1F3FB 200D 1F37C ; fully-qualified # 🧑🏻🍼 E13.0 person feeding baby: light skin tone +1F9D1 1F3FC 200D 1F37C ; fully-qualified # 🧑🏼🍼 E13.0 person feeding baby: medium-light skin tone +1F9D1 1F3FD 200D 1F37C ; fully-qualified # 🧑🏽🍼 E13.0 person feeding baby: medium skin tone +1F9D1 1F3FE 200D 1F37C ; fully-qualified # 🧑🏾🍼 E13.0 person feeding baby: medium-dark skin tone +1F9D1 1F3FF 200D 1F37C ; fully-qualified # 🧑🏿🍼 E13.0 person feeding baby: dark skin tone + +# subgroup: person-fantasy +1F47C ; fully-qualified # 👼 E0.6 baby angel +1F47C 1F3FB ; fully-qualified # 👼🏻 E1.0 baby angel: light skin tone +1F47C 1F3FC ; fully-qualified # 👼🏼 E1.0 baby angel: medium-light skin tone +1F47C 1F3FD ; fully-qualified # 👼🏽 E1.0 baby angel: medium skin tone +1F47C 1F3FE ; fully-qualified # 👼🏾 E1.0 baby angel: medium-dark skin tone +1F47C 1F3FF ; fully-qualified # 👼🏿 E1.0 baby angel: dark skin tone +1F385 ; fully-qualified # 🎅 E0.6 Santa Claus +1F385 1F3FB ; fully-qualified # 🎅🏻 E1.0 Santa Claus: light skin tone +1F385 1F3FC ; fully-qualified # 🎅🏼 E1.0 Santa Claus: medium-light skin tone +1F385 1F3FD ; fully-qualified # 🎅🏽 E1.0 Santa Claus: medium skin tone +1F385 1F3FE ; fully-qualified # 🎅🏾 E1.0 Santa Claus: medium-dark skin tone +1F385 1F3FF ; fully-qualified # 🎅🏿 E1.0 Santa Claus: dark skin tone +1F936 ; fully-qualified # 🤶 E3.0 Mrs. Claus +1F936 1F3FB ; fully-qualified # 🤶🏻 E3.0 Mrs. Claus: light skin tone +1F936 1F3FC ; fully-qualified # 🤶🏼 E3.0 Mrs. Claus: medium-light skin tone +1F936 1F3FD ; fully-qualified # 🤶🏽 E3.0 Mrs. Claus: medium skin tone +1F936 1F3FE ; fully-qualified # 🤶🏾 E3.0 Mrs. Claus: medium-dark skin tone +1F936 1F3FF ; fully-qualified # 🤶🏿 E3.0 Mrs. Claus: dark skin tone +1F9D1 200D 1F384 ; fully-qualified # 🧑🎄 E13.0 mx claus +1F9D1 1F3FB 200D 1F384 ; fully-qualified # 🧑🏻🎄 E13.0 mx claus: light skin tone +1F9D1 1F3FC 200D 1F384 ; fully-qualified # 🧑🏼🎄 E13.0 mx claus: medium-light skin tone +1F9D1 1F3FD 200D 1F384 ; fully-qualified # 🧑🏽🎄 E13.0 mx claus: medium skin tone +1F9D1 1F3FE 200D 1F384 ; fully-qualified # 🧑🏾🎄 E13.0 mx claus: medium-dark skin tone +1F9D1 1F3FF 200D 1F384 ; fully-qualified # 🧑🏿🎄 E13.0 mx claus: dark skin tone +1F9B8 ; fully-qualified # 🦸 E11.0 superhero +1F9B8 1F3FB ; fully-qualified # 🦸🏻 E11.0 superhero: light skin tone +1F9B8 1F3FC ; fully-qualified # 🦸🏼 E11.0 superhero: medium-light skin tone +1F9B8 1F3FD ; fully-qualified # 🦸🏽 E11.0 superhero: medium skin tone +1F9B8 1F3FE ; fully-qualified # 🦸🏾 E11.0 superhero: medium-dark skin tone +1F9B8 1F3FF ; fully-qualified # 🦸🏿 E11.0 superhero: dark skin tone +1F9B8 200D 2642 FE0F ; fully-qualified # 🦸♂️ E11.0 man superhero +1F9B8 200D 2642 ; minimally-qualified # 🦸♂ E11.0 man superhero +1F9B8 1F3FB 200D 2642 FE0F ; fully-qualified # 🦸🏻♂️ E11.0 man superhero: light skin tone +1F9B8 1F3FB 200D 2642 ; minimally-qualified # 🦸🏻♂ E11.0 man superhero: light skin tone +1F9B8 1F3FC 200D 2642 FE0F ; fully-qualified # 🦸🏼♂️ E11.0 man superhero: medium-light skin tone +1F9B8 1F3FC 200D 2642 ; minimally-qualified # 🦸🏼♂ E11.0 man superhero: medium-light skin tone +1F9B8 1F3FD 200D 2642 FE0F ; fully-qualified # 🦸🏽♂️ E11.0 man superhero: medium skin tone +1F9B8 1F3FD 200D 2642 ; minimally-qualified # 🦸🏽♂ E11.0 man superhero: medium skin tone +1F9B8 1F3FE 200D 2642 FE0F ; fully-qualified # 🦸🏾♂️ E11.0 man superhero: medium-dark skin tone +1F9B8 1F3FE 200D 2642 ; minimally-qualified # 🦸🏾♂ E11.0 man superhero: medium-dark skin tone +1F9B8 1F3FF 200D 2642 FE0F ; fully-qualified # 🦸🏿♂️ E11.0 man superhero: dark skin tone +1F9B8 1F3FF 200D 2642 ; minimally-qualified # 🦸🏿♂ E11.0 man superhero: dark skin tone +1F9B8 200D 2640 FE0F ; fully-qualified # 🦸♀️ E11.0 woman superhero +1F9B8 200D 2640 ; minimally-qualified # 🦸♀ E11.0 woman superhero +1F9B8 1F3FB 200D 2640 FE0F ; fully-qualified # 🦸🏻♀️ E11.0 woman superhero: light skin tone +1F9B8 1F3FB 200D 2640 ; minimally-qualified # 🦸🏻♀ E11.0 woman superhero: light skin tone +1F9B8 1F3FC 200D 2640 FE0F ; fully-qualified # 🦸🏼♀️ E11.0 woman superhero: medium-light skin tone +1F9B8 1F3FC 200D 2640 ; minimally-qualified # 🦸🏼♀ E11.0 woman superhero: medium-light skin tone +1F9B8 1F3FD 200D 2640 FE0F ; fully-qualified # 🦸🏽♀️ E11.0 woman superhero: medium skin tone +1F9B8 1F3FD 200D 2640 ; minimally-qualified # 🦸🏽♀ E11.0 woman superhero: medium skin tone +1F9B8 1F3FE 200D 2640 FE0F ; fully-qualified # 🦸🏾♀️ E11.0 woman superhero: medium-dark skin tone +1F9B8 1F3FE 200D 2640 ; minimally-qualified # 🦸🏾♀ E11.0 woman superhero: medium-dark skin tone +1F9B8 1F3FF 200D 2640 FE0F ; fully-qualified # 🦸🏿♀️ E11.0 woman superhero: dark skin tone +1F9B8 1F3FF 200D 2640 ; minimally-qualified # 🦸🏿♀ E11.0 woman superhero: dark skin tone +1F9B9 ; fully-qualified # 🦹 E11.0 supervillain +1F9B9 1F3FB ; fully-qualified # 🦹🏻 E11.0 supervillain: light skin tone +1F9B9 1F3FC ; fully-qualified # 🦹🏼 E11.0 supervillain: medium-light skin tone +1F9B9 1F3FD ; fully-qualified # 🦹🏽 E11.0 supervillain: medium skin tone +1F9B9 1F3FE ; fully-qualified # 🦹🏾 E11.0 supervillain: medium-dark skin tone +1F9B9 1F3FF ; fully-qualified # 🦹🏿 E11.0 supervillain: dark skin tone +1F9B9 200D 2642 FE0F ; fully-qualified # 🦹♂️ E11.0 man supervillain +1F9B9 200D 2642 ; minimally-qualified # 🦹♂ E11.0 man supervillain +1F9B9 1F3FB 200D 2642 FE0F ; fully-qualified # 🦹🏻♂️ E11.0 man supervillain: light skin tone +1F9B9 1F3FB 200D 2642 ; minimally-qualified # 🦹🏻♂ E11.0 man supervillain: light skin tone +1F9B9 1F3FC 200D 2642 FE0F ; fully-qualified # 🦹🏼♂️ E11.0 man supervillain: medium-light skin tone +1F9B9 1F3FC 200D 2642 ; minimally-qualified # 🦹🏼♂ E11.0 man supervillain: medium-light skin tone +1F9B9 1F3FD 200D 2642 FE0F ; fully-qualified # 🦹🏽♂️ E11.0 man supervillain: medium skin tone +1F9B9 1F3FD 200D 2642 ; minimally-qualified # 🦹🏽♂ E11.0 man supervillain: medium skin tone +1F9B9 1F3FE 200D 2642 FE0F ; fully-qualified # 🦹🏾♂️ E11.0 man supervillain: medium-dark skin tone +1F9B9 1F3FE 200D 2642 ; minimally-qualified # 🦹🏾♂ E11.0 man supervillain: medium-dark skin tone +1F9B9 1F3FF 200D 2642 FE0F ; fully-qualified # 🦹🏿♂️ E11.0 man supervillain: dark skin tone +1F9B9 1F3FF 200D 2642 ; minimally-qualified # 🦹🏿♂ E11.0 man supervillain: dark skin tone +1F9B9 200D 2640 FE0F ; fully-qualified # 🦹♀️ E11.0 woman supervillain +1F9B9 200D 2640 ; minimally-qualified # 🦹♀ E11.0 woman supervillain +1F9B9 1F3FB 200D 2640 FE0F ; fully-qualified # 🦹🏻♀️ E11.0 woman supervillain: light skin tone +1F9B9 1F3FB 200D 2640 ; minimally-qualified # 🦹🏻♀ E11.0 woman supervillain: light skin tone +1F9B9 1F3FC 200D 2640 FE0F ; fully-qualified # 🦹🏼♀️ E11.0 woman supervillain: medium-light skin tone +1F9B9 1F3FC 200D 2640 ; minimally-qualified # 🦹🏼♀ E11.0 woman supervillain: medium-light skin tone +1F9B9 1F3FD 200D 2640 FE0F ; fully-qualified # 🦹🏽♀️ E11.0 woman supervillain: medium skin tone +1F9B9 1F3FD 200D 2640 ; minimally-qualified # 🦹🏽♀ E11.0 woman supervillain: medium skin tone +1F9B9 1F3FE 200D 2640 FE0F ; fully-qualified # 🦹🏾♀️ E11.0 woman supervillain: medium-dark skin tone +1F9B9 1F3FE 200D 2640 ; minimally-qualified # 🦹🏾♀ E11.0 woman supervillain: medium-dark skin tone +1F9B9 1F3FF 200D 2640 FE0F ; fully-qualified # 🦹🏿♀️ E11.0 woman supervillain: dark skin tone +1F9B9 1F3FF 200D 2640 ; minimally-qualified # 🦹🏿♀ E11.0 woman supervillain: dark skin tone +1F9D9 ; fully-qualified # 🧙 E5.0 mage +1F9D9 1F3FB ; fully-qualified # 🧙🏻 E5.0 mage: light skin tone +1F9D9 1F3FC ; fully-qualified # 🧙🏼 E5.0 mage: medium-light skin tone +1F9D9 1F3FD ; fully-qualified # 🧙🏽 E5.0 mage: medium skin tone +1F9D9 1F3FE ; fully-qualified # 🧙🏾 E5.0 mage: medium-dark skin tone +1F9D9 1F3FF ; fully-qualified # 🧙🏿 E5.0 mage: dark skin tone +1F9D9 200D 2642 FE0F ; fully-qualified # 🧙♂️ E5.0 man mage +1F9D9 200D 2642 ; minimally-qualified # 🧙♂ E5.0 man mage +1F9D9 1F3FB 200D 2642 FE0F ; fully-qualified # 🧙🏻♂️ E5.0 man mage: light skin tone +1F9D9 1F3FB 200D 2642 ; minimally-qualified # 🧙🏻♂ E5.0 man mage: light skin tone +1F9D9 1F3FC 200D 2642 FE0F ; fully-qualified # 🧙🏼♂️ E5.0 man mage: medium-light skin tone +1F9D9 1F3FC 200D 2642 ; minimally-qualified # 🧙🏼♂ E5.0 man mage: medium-light skin tone +1F9D9 1F3FD 200D 2642 FE0F ; fully-qualified # 🧙🏽♂️ E5.0 man mage: medium skin tone +1F9D9 1F3FD 200D 2642 ; minimally-qualified # 🧙🏽♂ E5.0 man mage: medium skin tone +1F9D9 1F3FE 200D 2642 FE0F ; fully-qualified # 🧙🏾♂️ E5.0 man mage: medium-dark skin tone +1F9D9 1F3FE 200D 2642 ; minimally-qualified # 🧙🏾♂ E5.0 man mage: medium-dark skin tone +1F9D9 1F3FF 200D 2642 FE0F ; fully-qualified # 🧙🏿♂️ E5.0 man mage: dark skin tone +1F9D9 1F3FF 200D 2642 ; minimally-qualified # 🧙🏿♂ E5.0 man mage: dark skin tone +1F9D9 200D 2640 FE0F ; fully-qualified # 🧙♀️ E5.0 woman mage +1F9D9 200D 2640 ; minimally-qualified # 🧙♀ E5.0 woman mage +1F9D9 1F3FB 200D 2640 FE0F ; fully-qualified # 🧙🏻♀️ E5.0 woman mage: light skin tone +1F9D9 1F3FB 200D 2640 ; minimally-qualified # 🧙🏻♀ E5.0 woman mage: light skin tone +1F9D9 1F3FC 200D 2640 FE0F ; fully-qualified # 🧙🏼♀️ E5.0 woman mage: medium-light skin tone +1F9D9 1F3FC 200D 2640 ; minimally-qualified # 🧙🏼♀ E5.0 woman mage: medium-light skin tone +1F9D9 1F3FD 200D 2640 FE0F ; fully-qualified # 🧙🏽♀️ E5.0 woman mage: medium skin tone +1F9D9 1F3FD 200D 2640 ; minimally-qualified # 🧙🏽♀ E5.0 woman mage: medium skin tone +1F9D9 1F3FE 200D 2640 FE0F ; fully-qualified # 🧙🏾♀️ E5.0 woman mage: medium-dark skin tone +1F9D9 1F3FE 200D 2640 ; minimally-qualified # 🧙🏾♀ E5.0 woman mage: medium-dark skin tone +1F9D9 1F3FF 200D 2640 FE0F ; fully-qualified # 🧙🏿♀️ E5.0 woman mage: dark skin tone +1F9D9 1F3FF 200D 2640 ; minimally-qualified # 🧙🏿♀ E5.0 woman mage: dark skin tone +1F9DA ; fully-qualified # 🧚 E5.0 fairy +1F9DA 1F3FB ; fully-qualified # 🧚🏻 E5.0 fairy: light skin tone +1F9DA 1F3FC ; fully-qualified # 🧚🏼 E5.0 fairy: medium-light skin tone +1F9DA 1F3FD ; fully-qualified # 🧚🏽 E5.0 fairy: medium skin tone +1F9DA 1F3FE ; fully-qualified # 🧚🏾 E5.0 fairy: medium-dark skin tone +1F9DA 1F3FF ; fully-qualified # 🧚🏿 E5.0 fairy: dark skin tone +1F9DA 200D 2642 FE0F ; fully-qualified # 🧚♂️ E5.0 man fairy +1F9DA 200D 2642 ; minimally-qualified # 🧚♂ E5.0 man fairy +1F9DA 1F3FB 200D 2642 FE0F ; fully-qualified # 🧚🏻♂️ E5.0 man fairy: light skin tone +1F9DA 1F3FB 200D 2642 ; minimally-qualified # 🧚🏻♂ E5.0 man fairy: light skin tone +1F9DA 1F3FC 200D 2642 FE0F ; fully-qualified # 🧚🏼♂️ E5.0 man fairy: medium-light skin tone +1F9DA 1F3FC 200D 2642 ; minimally-qualified # 🧚🏼♂ E5.0 man fairy: medium-light skin tone +1F9DA 1F3FD 200D 2642 FE0F ; fully-qualified # 🧚🏽♂️ E5.0 man fairy: medium skin tone +1F9DA 1F3FD 200D 2642 ; minimally-qualified # 🧚🏽♂ E5.0 man fairy: medium skin tone +1F9DA 1F3FE 200D 2642 FE0F ; fully-qualified # 🧚🏾♂️ E5.0 man fairy: medium-dark skin tone +1F9DA 1F3FE 200D 2642 ; minimally-qualified # 🧚🏾♂ E5.0 man fairy: medium-dark skin tone +1F9DA 1F3FF 200D 2642 FE0F ; fully-qualified # 🧚🏿♂️ E5.0 man fairy: dark skin tone +1F9DA 1F3FF 200D 2642 ; minimally-qualified # 🧚🏿♂ E5.0 man fairy: dark skin tone +1F9DA 200D 2640 FE0F ; fully-qualified # 🧚♀️ E5.0 woman fairy +1F9DA 200D 2640 ; minimally-qualified # 🧚♀ E5.0 woman fairy +1F9DA 1F3FB 200D 2640 FE0F ; fully-qualified # 🧚🏻♀️ E5.0 woman fairy: light skin tone +1F9DA 1F3FB 200D 2640 ; minimally-qualified # 🧚🏻♀ E5.0 woman fairy: light skin tone +1F9DA 1F3FC 200D 2640 FE0F ; fully-qualified # 🧚🏼♀️ E5.0 woman fairy: medium-light skin tone +1F9DA 1F3FC 200D 2640 ; minimally-qualified # 🧚🏼♀ E5.0 woman fairy: medium-light skin tone +1F9DA 1F3FD 200D 2640 FE0F ; fully-qualified # 🧚🏽♀️ E5.0 woman fairy: medium skin tone +1F9DA 1F3FD 200D 2640 ; minimally-qualified # 🧚🏽♀ E5.0 woman fairy: medium skin tone +1F9DA 1F3FE 200D 2640 FE0F ; fully-qualified # 🧚🏾♀️ E5.0 woman fairy: medium-dark skin tone +1F9DA 1F3FE 200D 2640 ; minimally-qualified # 🧚🏾♀ E5.0 woman fairy: medium-dark skin tone +1F9DA 1F3FF 200D 2640 FE0F ; fully-qualified # 🧚🏿♀️ E5.0 woman fairy: dark skin tone +1F9DA 1F3FF 200D 2640 ; minimally-qualified # 🧚🏿♀ E5.0 woman fairy: dark skin tone +1F9DB ; fully-qualified # 🧛 E5.0 vampire +1F9DB 1F3FB ; fully-qualified # 🧛🏻 E5.0 vampire: light skin tone +1F9DB 1F3FC ; fully-qualified # 🧛🏼 E5.0 vampire: medium-light skin tone +1F9DB 1F3FD ; fully-qualified # 🧛🏽 E5.0 vampire: medium skin tone +1F9DB 1F3FE ; fully-qualified # 🧛🏾 E5.0 vampire: medium-dark skin tone +1F9DB 1F3FF ; fully-qualified # 🧛🏿 E5.0 vampire: dark skin tone +1F9DB 200D 2642 FE0F ; fully-qualified # 🧛♂️ E5.0 man vampire +1F9DB 200D 2642 ; minimally-qualified # 🧛♂ E5.0 man vampire +1F9DB 1F3FB 200D 2642 FE0F ; fully-qualified # 🧛🏻♂️ E5.0 man vampire: light skin tone +1F9DB 1F3FB 200D 2642 ; minimally-qualified # 🧛🏻♂ E5.0 man vampire: light skin tone +1F9DB 1F3FC 200D 2642 FE0F ; fully-qualified # 🧛🏼♂️ E5.0 man vampire: medium-light skin tone +1F9DB 1F3FC 200D 2642 ; minimally-qualified # 🧛🏼♂ E5.0 man vampire: medium-light skin tone +1F9DB 1F3FD 200D 2642 FE0F ; fully-qualified # 🧛🏽♂️ E5.0 man vampire: medium skin tone +1F9DB 1F3FD 200D 2642 ; minimally-qualified # 🧛🏽♂ E5.0 man vampire: medium skin tone +1F9DB 1F3FE 200D 2642 FE0F ; fully-qualified # 🧛🏾♂️ E5.0 man vampire: medium-dark skin tone +1F9DB 1F3FE 200D 2642 ; minimally-qualified # 🧛🏾♂ E5.0 man vampire: medium-dark skin tone +1F9DB 1F3FF 200D 2642 FE0F ; fully-qualified # 🧛🏿♂️ E5.0 man vampire: dark skin tone +1F9DB 1F3FF 200D 2642 ; minimally-qualified # 🧛🏿♂ E5.0 man vampire: dark skin tone +1F9DB 200D 2640 FE0F ; fully-qualified # 🧛♀️ E5.0 woman vampire +1F9DB 200D 2640 ; minimally-qualified # 🧛♀ E5.0 woman vampire +1F9DB 1F3FB 200D 2640 FE0F ; fully-qualified # 🧛🏻♀️ E5.0 woman vampire: light skin tone +1F9DB 1F3FB 200D 2640 ; minimally-qualified # 🧛🏻♀ E5.0 woman vampire: light skin tone +1F9DB 1F3FC 200D 2640 FE0F ; fully-qualified # 🧛🏼♀️ E5.0 woman vampire: medium-light skin tone +1F9DB 1F3FC 200D 2640 ; minimally-qualified # 🧛🏼♀ E5.0 woman vampire: medium-light skin tone +1F9DB 1F3FD 200D 2640 FE0F ; fully-qualified # 🧛🏽♀️ E5.0 woman vampire: medium skin tone +1F9DB 1F3FD 200D 2640 ; minimally-qualified # 🧛🏽♀ E5.0 woman vampire: medium skin tone +1F9DB 1F3FE 200D 2640 FE0F ; fully-qualified # 🧛🏾♀️ E5.0 woman vampire: medium-dark skin tone +1F9DB 1F3FE 200D 2640 ; minimally-qualified # 🧛🏾♀ E5.0 woman vampire: medium-dark skin tone +1F9DB 1F3FF 200D 2640 FE0F ; fully-qualified # 🧛🏿♀️ E5.0 woman vampire: dark skin tone +1F9DB 1F3FF 200D 2640 ; minimally-qualified # 🧛🏿♀ E5.0 woman vampire: dark skin tone +1F9DC ; fully-qualified # 🧜 E5.0 merperson +1F9DC 1F3FB ; fully-qualified # 🧜🏻 E5.0 merperson: light skin tone +1F9DC 1F3FC ; fully-qualified # 🧜🏼 E5.0 merperson: medium-light skin tone +1F9DC 1F3FD ; fully-qualified # 🧜🏽 E5.0 merperson: medium skin tone +1F9DC 1F3FE ; fully-qualified # 🧜🏾 E5.0 merperson: medium-dark skin tone +1F9DC 1F3FF ; fully-qualified # 🧜🏿 E5.0 merperson: dark skin tone +1F9DC 200D 2642 FE0F ; fully-qualified # 🧜♂️ E5.0 merman +1F9DC 200D 2642 ; minimally-qualified # 🧜♂ E5.0 merman +1F9DC 1F3FB 200D 2642 FE0F ; fully-qualified # 🧜🏻♂️ E5.0 merman: light skin tone +1F9DC 1F3FB 200D 2642 ; minimally-qualified # 🧜🏻♂ E5.0 merman: light skin tone +1F9DC 1F3FC 200D 2642 FE0F ; fully-qualified # 🧜🏼♂️ E5.0 merman: medium-light skin tone +1F9DC 1F3FC 200D 2642 ; minimally-qualified # 🧜🏼♂ E5.0 merman: medium-light skin tone +1F9DC 1F3FD 200D 2642 FE0F ; fully-qualified # 🧜🏽♂️ E5.0 merman: medium skin tone +1F9DC 1F3FD 200D 2642 ; minimally-qualified # 🧜🏽♂ E5.0 merman: medium skin tone +1F9DC 1F3FE 200D 2642 FE0F ; fully-qualified # 🧜🏾♂️ E5.0 merman: medium-dark skin tone +1F9DC 1F3FE 200D 2642 ; minimally-qualified # 🧜🏾♂ E5.0 merman: medium-dark skin tone +1F9DC 1F3FF 200D 2642 FE0F ; fully-qualified # 🧜🏿♂️ E5.0 merman: dark skin tone +1F9DC 1F3FF 200D 2642 ; minimally-qualified # 🧜🏿♂ E5.0 merman: dark skin tone +1F9DC 200D 2640 FE0F ; fully-qualified # 🧜♀️ E5.0 mermaid +1F9DC 200D 2640 ; minimally-qualified # 🧜♀ E5.0 mermaid +1F9DC 1F3FB 200D 2640 FE0F ; fully-qualified # 🧜🏻♀️ E5.0 mermaid: light skin tone +1F9DC 1F3FB 200D 2640 ; minimally-qualified # 🧜🏻♀ E5.0 mermaid: light skin tone +1F9DC 1F3FC 200D 2640 FE0F ; fully-qualified # 🧜🏼♀️ E5.0 mermaid: medium-light skin tone +1F9DC 1F3FC 200D 2640 ; minimally-qualified # 🧜🏼♀ E5.0 mermaid: medium-light skin tone +1F9DC 1F3FD 200D 2640 FE0F ; fully-qualified # 🧜🏽♀️ E5.0 mermaid: medium skin tone +1F9DC 1F3FD 200D 2640 ; minimally-qualified # 🧜🏽♀ E5.0 mermaid: medium skin tone +1F9DC 1F3FE 200D 2640 FE0F ; fully-qualified # 🧜🏾♀️ E5.0 mermaid: medium-dark skin tone +1F9DC 1F3FE 200D 2640 ; minimally-qualified # 🧜🏾♀ E5.0 mermaid: medium-dark skin tone +1F9DC 1F3FF 200D 2640 FE0F ; fully-qualified # 🧜🏿♀️ E5.0 mermaid: dark skin tone +1F9DC 1F3FF 200D 2640 ; minimally-qualified # 🧜🏿♀ E5.0 mermaid: dark skin tone +1F9DD ; fully-qualified # 🧝 E5.0 elf +1F9DD 1F3FB ; fully-qualified # 🧝🏻 E5.0 elf: light skin tone +1F9DD 1F3FC ; fully-qualified # 🧝🏼 E5.0 elf: medium-light skin tone +1F9DD 1F3FD ; fully-qualified # 🧝🏽 E5.0 elf: medium skin tone +1F9DD 1F3FE ; fully-qualified # 🧝🏾 E5.0 elf: medium-dark skin tone +1F9DD 1F3FF ; fully-qualified # 🧝🏿 E5.0 elf: dark skin tone +1F9DD 200D 2642 FE0F ; fully-qualified # 🧝♂️ E5.0 man elf +1F9DD 200D 2642 ; minimally-qualified # 🧝♂ E5.0 man elf +1F9DD 1F3FB 200D 2642 FE0F ; fully-qualified # 🧝🏻♂️ E5.0 man elf: light skin tone +1F9DD 1F3FB 200D 2642 ; minimally-qualified # 🧝🏻♂ E5.0 man elf: light skin tone +1F9DD 1F3FC 200D 2642 FE0F ; fully-qualified # 🧝🏼♂️ E5.0 man elf: medium-light skin tone +1F9DD 1F3FC 200D 2642 ; minimally-qualified # 🧝🏼♂ E5.0 man elf: medium-light skin tone +1F9DD 1F3FD 200D 2642 FE0F ; fully-qualified # 🧝🏽♂️ E5.0 man elf: medium skin tone +1F9DD 1F3FD 200D 2642 ; minimally-qualified # 🧝🏽♂ E5.0 man elf: medium skin tone +1F9DD 1F3FE 200D 2642 FE0F ; fully-qualified # 🧝🏾♂️ E5.0 man elf: medium-dark skin tone +1F9DD 1F3FE 200D 2642 ; minimally-qualified # 🧝🏾♂ E5.0 man elf: medium-dark skin tone +1F9DD 1F3FF 200D 2642 FE0F ; fully-qualified # 🧝🏿♂️ E5.0 man elf: dark skin tone +1F9DD 1F3FF 200D 2642 ; minimally-qualified # 🧝🏿♂ E5.0 man elf: dark skin tone +1F9DD 200D 2640 FE0F ; fully-qualified # 🧝♀️ E5.0 woman elf +1F9DD 200D 2640 ; minimally-qualified # 🧝♀ E5.0 woman elf +1F9DD 1F3FB 200D 2640 FE0F ; fully-qualified # 🧝🏻♀️ E5.0 woman elf: light skin tone +1F9DD 1F3FB 200D 2640 ; minimally-qualified # 🧝🏻♀ E5.0 woman elf: light skin tone +1F9DD 1F3FC 200D 2640 FE0F ; fully-qualified # 🧝🏼♀️ E5.0 woman elf: medium-light skin tone +1F9DD 1F3FC 200D 2640 ; minimally-qualified # 🧝🏼♀ E5.0 woman elf: medium-light skin tone +1F9DD 1F3FD 200D 2640 FE0F ; fully-qualified # 🧝🏽♀️ E5.0 woman elf: medium skin tone +1F9DD 1F3FD 200D 2640 ; minimally-qualified # 🧝🏽♀ E5.0 woman elf: medium skin tone +1F9DD 1F3FE 200D 2640 FE0F ; fully-qualified # 🧝🏾♀️ E5.0 woman elf: medium-dark skin tone +1F9DD 1F3FE 200D 2640 ; minimally-qualified # 🧝🏾♀ E5.0 woman elf: medium-dark skin tone +1F9DD 1F3FF 200D 2640 FE0F ; fully-qualified # 🧝🏿♀️ E5.0 woman elf: dark skin tone +1F9DD 1F3FF 200D 2640 ; minimally-qualified # 🧝🏿♀ E5.0 woman elf: dark skin tone +1F9DE ; fully-qualified # 🧞 E5.0 genie +1F9DE 200D 2642 FE0F ; fully-qualified # 🧞♂️ E5.0 man genie +1F9DE 200D 2642 ; minimally-qualified # 🧞♂ E5.0 man genie +1F9DE 200D 2640 FE0F ; fully-qualified # 🧞♀️ E5.0 woman genie +1F9DE 200D 2640 ; minimally-qualified # 🧞♀ E5.0 woman genie +1F9DF ; fully-qualified # 🧟 E5.0 zombie +1F9DF 200D 2642 FE0F ; fully-qualified # 🧟♂️ E5.0 man zombie +1F9DF 200D 2642 ; minimally-qualified # 🧟♂ E5.0 man zombie +1F9DF 200D 2640 FE0F ; fully-qualified # 🧟♀️ E5.0 woman zombie +1F9DF 200D 2640 ; minimally-qualified # 🧟♀ E5.0 woman zombie +1F9CC ; fully-qualified # 🧌 E14.0 troll + +# subgroup: person-activity +1F486 ; fully-qualified # 💆 E0.6 person getting massage +1F486 1F3FB ; fully-qualified # 💆🏻 E1.0 person getting massage: light skin tone +1F486 1F3FC ; fully-qualified # 💆🏼 E1.0 person getting massage: medium-light skin tone +1F486 1F3FD ; fully-qualified # 💆🏽 E1.0 person getting massage: medium skin tone +1F486 1F3FE ; fully-qualified # 💆🏾 E1.0 person getting massage: medium-dark skin tone +1F486 1F3FF ; fully-qualified # 💆🏿 E1.0 person getting massage: dark skin tone +1F486 200D 2642 FE0F ; fully-qualified # 💆♂️ E4.0 man getting massage +1F486 200D 2642 ; minimally-qualified # 💆♂ E4.0 man getting massage +1F486 1F3FB 200D 2642 FE0F ; fully-qualified # 💆🏻♂️ E4.0 man getting massage: light skin tone +1F486 1F3FB 200D 2642 ; minimally-qualified # 💆🏻♂ E4.0 man getting massage: light skin tone +1F486 1F3FC 200D 2642 FE0F ; fully-qualified # 💆🏼♂️ E4.0 man getting massage: medium-light skin tone +1F486 1F3FC 200D 2642 ; minimally-qualified # 💆🏼♂ E4.0 man getting massage: medium-light skin tone +1F486 1F3FD 200D 2642 FE0F ; fully-qualified # 💆🏽♂️ E4.0 man getting massage: medium skin tone +1F486 1F3FD 200D 2642 ; minimally-qualified # 💆🏽♂ E4.0 man getting massage: medium skin tone +1F486 1F3FE 200D 2642 FE0F ; fully-qualified # 💆🏾♂️ E4.0 man getting massage: medium-dark skin tone +1F486 1F3FE 200D 2642 ; minimally-qualified # 💆🏾♂ E4.0 man getting massage: medium-dark skin tone +1F486 1F3FF 200D 2642 FE0F ; fully-qualified # 💆🏿♂️ E4.0 man getting massage: dark skin tone +1F486 1F3FF 200D 2642 ; minimally-qualified # 💆🏿♂ E4.0 man getting massage: dark skin tone +1F486 200D 2640 FE0F ; fully-qualified # 💆♀️ E4.0 woman getting massage +1F486 200D 2640 ; minimally-qualified # 💆♀ E4.0 woman getting massage +1F486 1F3FB 200D 2640 FE0F ; fully-qualified # 💆🏻♀️ E4.0 woman getting massage: light skin tone +1F486 1F3FB 200D 2640 ; minimally-qualified # 💆🏻♀ E4.0 woman getting massage: light skin tone +1F486 1F3FC 200D 2640 FE0F ; fully-qualified # 💆🏼♀️ E4.0 woman getting massage: medium-light skin tone +1F486 1F3FC 200D 2640 ; minimally-qualified # 💆🏼♀ E4.0 woman getting massage: medium-light skin tone +1F486 1F3FD 200D 2640 FE0F ; fully-qualified # 💆🏽♀️ E4.0 woman getting massage: medium skin tone +1F486 1F3FD 200D 2640 ; minimally-qualified # 💆🏽♀ E4.0 woman getting massage: medium skin tone +1F486 1F3FE 200D 2640 FE0F ; fully-qualified # 💆🏾♀️ E4.0 woman getting massage: medium-dark skin tone +1F486 1F3FE 200D 2640 ; minimally-qualified # 💆🏾♀ E4.0 woman getting massage: medium-dark skin tone +1F486 1F3FF 200D 2640 FE0F ; fully-qualified # 💆🏿♀️ E4.0 woman getting massage: dark skin tone +1F486 1F3FF 200D 2640 ; minimally-qualified # 💆🏿♀ E4.0 woman getting massage: dark skin tone +1F487 ; fully-qualified # 💇 E0.6 person getting haircut +1F487 1F3FB ; fully-qualified # 💇🏻 E1.0 person getting haircut: light skin tone +1F487 1F3FC ; fully-qualified # 💇🏼 E1.0 person getting haircut: medium-light skin tone +1F487 1F3FD ; fully-qualified # 💇🏽 E1.0 person getting haircut: medium skin tone +1F487 1F3FE ; fully-qualified # 💇🏾 E1.0 person getting haircut: medium-dark skin tone +1F487 1F3FF ; fully-qualified # 💇🏿 E1.0 person getting haircut: dark skin tone +1F487 200D 2642 FE0F ; fully-qualified # 💇♂️ E4.0 man getting haircut +1F487 200D 2642 ; minimally-qualified # 💇♂ E4.0 man getting haircut +1F487 1F3FB 200D 2642 FE0F ; fully-qualified # 💇🏻♂️ E4.0 man getting haircut: light skin tone +1F487 1F3FB 200D 2642 ; minimally-qualified # 💇🏻♂ E4.0 man getting haircut: light skin tone +1F487 1F3FC 200D 2642 FE0F ; fully-qualified # 💇🏼♂️ E4.0 man getting haircut: medium-light skin tone +1F487 1F3FC 200D 2642 ; minimally-qualified # 💇🏼♂ E4.0 man getting haircut: medium-light skin tone +1F487 1F3FD 200D 2642 FE0F ; fully-qualified # 💇🏽♂️ E4.0 man getting haircut: medium skin tone +1F487 1F3FD 200D 2642 ; minimally-qualified # 💇🏽♂ E4.0 man getting haircut: medium skin tone +1F487 1F3FE 200D 2642 FE0F ; fully-qualified # 💇🏾♂️ E4.0 man getting haircut: medium-dark skin tone +1F487 1F3FE 200D 2642 ; minimally-qualified # 💇🏾♂ E4.0 man getting haircut: medium-dark skin tone +1F487 1F3FF 200D 2642 FE0F ; fully-qualified # 💇🏿♂️ E4.0 man getting haircut: dark skin tone +1F487 1F3FF 200D 2642 ; minimally-qualified # 💇🏿♂ E4.0 man getting haircut: dark skin tone +1F487 200D 2640 FE0F ; fully-qualified # 💇♀️ E4.0 woman getting haircut +1F487 200D 2640 ; minimally-qualified # 💇♀ E4.0 woman getting haircut +1F487 1F3FB 200D 2640 FE0F ; fully-qualified # 💇🏻♀️ E4.0 woman getting haircut: light skin tone +1F487 1F3FB 200D 2640 ; minimally-qualified # 💇🏻♀ E4.0 woman getting haircut: light skin tone +1F487 1F3FC 200D 2640 FE0F ; fully-qualified # 💇🏼♀️ E4.0 woman getting haircut: medium-light skin tone +1F487 1F3FC 200D 2640 ; minimally-qualified # 💇🏼♀ E4.0 woman getting haircut: medium-light skin tone +1F487 1F3FD 200D 2640 FE0F ; fully-qualified # 💇🏽♀️ E4.0 woman getting haircut: medium skin tone +1F487 1F3FD 200D 2640 ; minimally-qualified # 💇🏽♀ E4.0 woman getting haircut: medium skin tone +1F487 1F3FE 200D 2640 FE0F ; fully-qualified # 💇🏾♀️ E4.0 woman getting haircut: medium-dark skin tone +1F487 1F3FE 200D 2640 ; minimally-qualified # 💇🏾♀ E4.0 woman getting haircut: medium-dark skin tone +1F487 1F3FF 200D 2640 FE0F ; fully-qualified # 💇🏿♀️ E4.0 woman getting haircut: dark skin tone +1F487 1F3FF 200D 2640 ; minimally-qualified # 💇🏿♀ E4.0 woman getting haircut: dark skin tone +1F6B6 ; fully-qualified # 🚶 E0.6 person walking +1F6B6 1F3FB ; fully-qualified # 🚶🏻 E1.0 person walking: light skin tone +1F6B6 1F3FC ; fully-qualified # 🚶🏼 E1.0 person walking: medium-light skin tone +1F6B6 1F3FD ; fully-qualified # 🚶🏽 E1.0 person walking: medium skin tone +1F6B6 1F3FE ; fully-qualified # 🚶🏾 E1.0 person walking: medium-dark skin tone +1F6B6 1F3FF ; fully-qualified # 🚶🏿 E1.0 person walking: dark skin tone +1F6B6 200D 2642 FE0F ; fully-qualified # 🚶♂️ E4.0 man walking +1F6B6 200D 2642 ; minimally-qualified # 🚶♂ E4.0 man walking +1F6B6 1F3FB 200D 2642 FE0F ; fully-qualified # 🚶🏻♂️ E4.0 man walking: light skin tone +1F6B6 1F3FB 200D 2642 ; minimally-qualified # 🚶🏻♂ E4.0 man walking: light skin tone +1F6B6 1F3FC 200D 2642 FE0F ; fully-qualified # 🚶🏼♂️ E4.0 man walking: medium-light skin tone +1F6B6 1F3FC 200D 2642 ; minimally-qualified # 🚶🏼♂ E4.0 man walking: medium-light skin tone +1F6B6 1F3FD 200D 2642 FE0F ; fully-qualified # 🚶🏽♂️ E4.0 man walking: medium skin tone +1F6B6 1F3FD 200D 2642 ; minimally-qualified # 🚶🏽♂ E4.0 man walking: medium skin tone +1F6B6 1F3FE 200D 2642 FE0F ; fully-qualified # 🚶🏾♂️ E4.0 man walking: medium-dark skin tone +1F6B6 1F3FE 200D 2642 ; minimally-qualified # 🚶🏾♂ E4.0 man walking: medium-dark skin tone +1F6B6 1F3FF 200D 2642 FE0F ; fully-qualified # 🚶🏿♂️ E4.0 man walking: dark skin tone +1F6B6 1F3FF 200D 2642 ; minimally-qualified # 🚶🏿♂ E4.0 man walking: dark skin tone +1F6B6 200D 2640 FE0F ; fully-qualified # 🚶♀️ E4.0 woman walking +1F6B6 200D 2640 ; minimally-qualified # 🚶♀ E4.0 woman walking +1F6B6 1F3FB 200D 2640 FE0F ; fully-qualified # 🚶🏻♀️ E4.0 woman walking: light skin tone +1F6B6 1F3FB 200D 2640 ; minimally-qualified # 🚶🏻♀ E4.0 woman walking: light skin tone +1F6B6 1F3FC 200D 2640 FE0F ; fully-qualified # 🚶🏼♀️ E4.0 woman walking: medium-light skin tone +1F6B6 1F3FC 200D 2640 ; minimally-qualified # 🚶🏼♀ E4.0 woman walking: medium-light skin tone +1F6B6 1F3FD 200D 2640 FE0F ; fully-qualified # 🚶🏽♀️ E4.0 woman walking: medium skin tone +1F6B6 1F3FD 200D 2640 ; minimally-qualified # 🚶🏽♀ E4.0 woman walking: medium skin tone +1F6B6 1F3FE 200D 2640 FE0F ; fully-qualified # 🚶🏾♀️ E4.0 woman walking: medium-dark skin tone +1F6B6 1F3FE 200D 2640 ; minimally-qualified # 🚶🏾♀ E4.0 woman walking: medium-dark skin tone +1F6B6 1F3FF 200D 2640 FE0F ; fully-qualified # 🚶🏿♀️ E4.0 woman walking: dark skin tone +1F6B6 1F3FF 200D 2640 ; minimally-qualified # 🚶🏿♀ E4.0 woman walking: dark skin tone +1F9CD ; fully-qualified # 🧍 E12.0 person standing +1F9CD 1F3FB ; fully-qualified # 🧍🏻 E12.0 person standing: light skin tone +1F9CD 1F3FC ; fully-qualified # 🧍🏼 E12.0 person standing: medium-light skin tone +1F9CD 1F3FD ; fully-qualified # 🧍🏽 E12.0 person standing: medium skin tone +1F9CD 1F3FE ; fully-qualified # 🧍🏾 E12.0 person standing: medium-dark skin tone +1F9CD 1F3FF ; fully-qualified # 🧍🏿 E12.0 person standing: dark skin tone +1F9CD 200D 2642 FE0F ; fully-qualified # 🧍♂️ E12.0 man standing +1F9CD 200D 2642 ; minimally-qualified # 🧍♂ E12.0 man standing +1F9CD 1F3FB 200D 2642 FE0F ; fully-qualified # 🧍🏻♂️ E12.0 man standing: light skin tone +1F9CD 1F3FB 200D 2642 ; minimally-qualified # 🧍🏻♂ E12.0 man standing: light skin tone +1F9CD 1F3FC 200D 2642 FE0F ; fully-qualified # 🧍🏼♂️ E12.0 man standing: medium-light skin tone +1F9CD 1F3FC 200D 2642 ; minimally-qualified # 🧍🏼♂ E12.0 man standing: medium-light skin tone +1F9CD 1F3FD 200D 2642 FE0F ; fully-qualified # 🧍🏽♂️ E12.0 man standing: medium skin tone +1F9CD 1F3FD 200D 2642 ; minimally-qualified # 🧍🏽♂ E12.0 man standing: medium skin tone +1F9CD 1F3FE 200D 2642 FE0F ; fully-qualified # 🧍🏾♂️ E12.0 man standing: medium-dark skin tone +1F9CD 1F3FE 200D 2642 ; minimally-qualified # 🧍🏾♂ E12.0 man standing: medium-dark skin tone +1F9CD 1F3FF 200D 2642 FE0F ; fully-qualified # 🧍🏿♂️ E12.0 man standing: dark skin tone +1F9CD 1F3FF 200D 2642 ; minimally-qualified # 🧍🏿♂ E12.0 man standing: dark skin tone +1F9CD 200D 2640 FE0F ; fully-qualified # 🧍♀️ E12.0 woman standing +1F9CD 200D 2640 ; minimally-qualified # 🧍♀ E12.0 woman standing +1F9CD 1F3FB 200D 2640 FE0F ; fully-qualified # 🧍🏻♀️ E12.0 woman standing: light skin tone +1F9CD 1F3FB 200D 2640 ; minimally-qualified # 🧍🏻♀ E12.0 woman standing: light skin tone +1F9CD 1F3FC 200D 2640 FE0F ; fully-qualified # 🧍🏼♀️ E12.0 woman standing: medium-light skin tone +1F9CD 1F3FC 200D 2640 ; minimally-qualified # 🧍🏼♀ E12.0 woman standing: medium-light skin tone +1F9CD 1F3FD 200D 2640 FE0F ; fully-qualified # 🧍🏽♀️ E12.0 woman standing: medium skin tone +1F9CD 1F3FD 200D 2640 ; minimally-qualified # 🧍🏽♀ E12.0 woman standing: medium skin tone +1F9CD 1F3FE 200D 2640 FE0F ; fully-qualified # 🧍🏾♀️ E12.0 woman standing: medium-dark skin tone +1F9CD 1F3FE 200D 2640 ; minimally-qualified # 🧍🏾♀ E12.0 woman standing: medium-dark skin tone +1F9CD 1F3FF 200D 2640 FE0F ; fully-qualified # 🧍🏿♀️ E12.0 woman standing: dark skin tone +1F9CD 1F3FF 200D 2640 ; minimally-qualified # 🧍🏿♀ E12.0 woman standing: dark skin tone +1F9CE ; fully-qualified # 🧎 E12.0 person kneeling +1F9CE 1F3FB ; fully-qualified # 🧎🏻 E12.0 person kneeling: light skin tone +1F9CE 1F3FC ; fully-qualified # 🧎🏼 E12.0 person kneeling: medium-light skin tone +1F9CE 1F3FD ; fully-qualified # 🧎🏽 E12.0 person kneeling: medium skin tone +1F9CE 1F3FE ; fully-qualified # 🧎🏾 E12.0 person kneeling: medium-dark skin tone +1F9CE 1F3FF ; fully-qualified # 🧎🏿 E12.0 person kneeling: dark skin tone +1F9CE 200D 2642 FE0F ; fully-qualified # 🧎♂️ E12.0 man kneeling +1F9CE 200D 2642 ; minimally-qualified # 🧎♂ E12.0 man kneeling +1F9CE 1F3FB 200D 2642 FE0F ; fully-qualified # 🧎🏻♂️ E12.0 man kneeling: light skin tone +1F9CE 1F3FB 200D 2642 ; minimally-qualified # 🧎🏻♂ E12.0 man kneeling: light skin tone +1F9CE 1F3FC 200D 2642 FE0F ; fully-qualified # 🧎🏼♂️ E12.0 man kneeling: medium-light skin tone +1F9CE 1F3FC 200D 2642 ; minimally-qualified # 🧎🏼♂ E12.0 man kneeling: medium-light skin tone +1F9CE 1F3FD 200D 2642 FE0F ; fully-qualified # 🧎🏽♂️ E12.0 man kneeling: medium skin tone +1F9CE 1F3FD 200D 2642 ; minimally-qualified # 🧎🏽♂ E12.0 man kneeling: medium skin tone +1F9CE 1F3FE 200D 2642 FE0F ; fully-qualified # 🧎🏾♂️ E12.0 man kneeling: medium-dark skin tone +1F9CE 1F3FE 200D 2642 ; minimally-qualified # 🧎🏾♂ E12.0 man kneeling: medium-dark skin tone +1F9CE 1F3FF 200D 2642 FE0F ; fully-qualified # 🧎🏿♂️ E12.0 man kneeling: dark skin tone +1F9CE 1F3FF 200D 2642 ; minimally-qualified # 🧎🏿♂ E12.0 man kneeling: dark skin tone +1F9CE 200D 2640 FE0F ; fully-qualified # 🧎♀️ E12.0 woman kneeling +1F9CE 200D 2640 ; minimally-qualified # 🧎♀ E12.0 woman kneeling +1F9CE 1F3FB 200D 2640 FE0F ; fully-qualified # 🧎🏻♀️ E12.0 woman kneeling: light skin tone +1F9CE 1F3FB 200D 2640 ; minimally-qualified # 🧎🏻♀ E12.0 woman kneeling: light skin tone +1F9CE 1F3FC 200D 2640 FE0F ; fully-qualified # 🧎🏼♀️ E12.0 woman kneeling: medium-light skin tone +1F9CE 1F3FC 200D 2640 ; minimally-qualified # 🧎🏼♀ E12.0 woman kneeling: medium-light skin tone +1F9CE 1F3FD 200D 2640 FE0F ; fully-qualified # 🧎🏽♀️ E12.0 woman kneeling: medium skin tone +1F9CE 1F3FD 200D 2640 ; minimally-qualified # 🧎🏽♀ E12.0 woman kneeling: medium skin tone +1F9CE 1F3FE 200D 2640 FE0F ; fully-qualified # 🧎🏾♀️ E12.0 woman kneeling: medium-dark skin tone +1F9CE 1F3FE 200D 2640 ; minimally-qualified # 🧎🏾♀ E12.0 woman kneeling: medium-dark skin tone +1F9CE 1F3FF 200D 2640 FE0F ; fully-qualified # 🧎🏿♀️ E12.0 woman kneeling: dark skin tone +1F9CE 1F3FF 200D 2640 ; minimally-qualified # 🧎🏿♀ E12.0 woman kneeling: dark skin tone +1F9D1 200D 1F9AF ; fully-qualified # 🧑🦯 E12.1 person with white cane +1F9D1 1F3FB 200D 1F9AF ; fully-qualified # 🧑🏻🦯 E12.1 person with white cane: light skin tone +1F9D1 1F3FC 200D 1F9AF ; fully-qualified # 🧑🏼🦯 E12.1 person with white cane: medium-light skin tone +1F9D1 1F3FD 200D 1F9AF ; fully-qualified # 🧑🏽🦯 E12.1 person with white cane: medium skin tone +1F9D1 1F3FE 200D 1F9AF ; fully-qualified # 🧑🏾🦯 E12.1 person with white cane: medium-dark skin tone +1F9D1 1F3FF 200D 1F9AF ; fully-qualified # 🧑🏿🦯 E12.1 person with white cane: dark skin tone +1F468 200D 1F9AF ; fully-qualified # 👨🦯 E12.0 man with white cane +1F468 1F3FB 200D 1F9AF ; fully-qualified # 👨🏻🦯 E12.0 man with white cane: light skin tone +1F468 1F3FC 200D 1F9AF ; fully-qualified # 👨🏼🦯 E12.0 man with white cane: medium-light skin tone +1F468 1F3FD 200D 1F9AF ; fully-qualified # 👨🏽🦯 E12.0 man with white cane: medium skin tone +1F468 1F3FE 200D 1F9AF ; fully-qualified # 👨🏾🦯 E12.0 man with white cane: medium-dark skin tone +1F468 1F3FF 200D 1F9AF ; fully-qualified # 👨🏿🦯 E12.0 man with white cane: dark skin tone +1F469 200D 1F9AF ; fully-qualified # 👩🦯 E12.0 woman with white cane +1F469 1F3FB 200D 1F9AF ; fully-qualified # 👩🏻🦯 E12.0 woman with white cane: light skin tone +1F469 1F3FC 200D 1F9AF ; fully-qualified # 👩🏼🦯 E12.0 woman with white cane: medium-light skin tone +1F469 1F3FD 200D 1F9AF ; fully-qualified # 👩🏽🦯 E12.0 woman with white cane: medium skin tone +1F469 1F3FE 200D 1F9AF ; fully-qualified # 👩🏾🦯 E12.0 woman with white cane: medium-dark skin tone +1F469 1F3FF 200D 1F9AF ; fully-qualified # 👩🏿🦯 E12.0 woman with white cane: dark skin tone +1F9D1 200D 1F9BC ; fully-qualified # 🧑🦼 E12.1 person in motorized wheelchair +1F9D1 1F3FB 200D 1F9BC ; fully-qualified # 🧑🏻🦼 E12.1 person in motorized wheelchair: light skin tone +1F9D1 1F3FC 200D 1F9BC ; fully-qualified # 🧑🏼🦼 E12.1 person in motorized wheelchair: medium-light skin tone +1F9D1 1F3FD 200D 1F9BC ; fully-qualified # 🧑🏽🦼 E12.1 person in motorized wheelchair: medium skin tone +1F9D1 1F3FE 200D 1F9BC ; fully-qualified # 🧑🏾🦼 E12.1 person in motorized wheelchair: medium-dark skin tone +1F9D1 1F3FF 200D 1F9BC ; fully-qualified # 🧑🏿🦼 E12.1 person in motorized wheelchair: dark skin tone +1F468 200D 1F9BC ; fully-qualified # 👨🦼 E12.0 man in motorized wheelchair +1F468 1F3FB 200D 1F9BC ; fully-qualified # 👨🏻🦼 E12.0 man in motorized wheelchair: light skin tone +1F468 1F3FC 200D 1F9BC ; fully-qualified # 👨🏼🦼 E12.0 man in motorized wheelchair: medium-light skin tone +1F468 1F3FD 200D 1F9BC ; fully-qualified # 👨🏽🦼 E12.0 man in motorized wheelchair: medium skin tone +1F468 1F3FE 200D 1F9BC ; fully-qualified # 👨🏾🦼 E12.0 man in motorized wheelchair: medium-dark skin tone +1F468 1F3FF 200D 1F9BC ; fully-qualified # 👨🏿🦼 E12.0 man in motorized wheelchair: dark skin tone +1F469 200D 1F9BC ; fully-qualified # 👩🦼 E12.0 woman in motorized wheelchair +1F469 1F3FB 200D 1F9BC ; fully-qualified # 👩🏻🦼 E12.0 woman in motorized wheelchair: light skin tone +1F469 1F3FC 200D 1F9BC ; fully-qualified # 👩🏼🦼 E12.0 woman in motorized wheelchair: medium-light skin tone +1F469 1F3FD 200D 1F9BC ; fully-qualified # 👩🏽🦼 E12.0 woman in motorized wheelchair: medium skin tone +1F469 1F3FE 200D 1F9BC ; fully-qualified # 👩🏾🦼 E12.0 woman in motorized wheelchair: medium-dark skin tone +1F469 1F3FF 200D 1F9BC ; fully-qualified # 👩🏿🦼 E12.0 woman in motorized wheelchair: dark skin tone +1F9D1 200D 1F9BD ; fully-qualified # 🧑🦽 E12.1 person in manual wheelchair +1F9D1 1F3FB 200D 1F9BD ; fully-qualified # 🧑🏻🦽 E12.1 person in manual wheelchair: light skin tone +1F9D1 1F3FC 200D 1F9BD ; fully-qualified # 🧑🏼🦽 E12.1 person in manual wheelchair: medium-light skin tone +1F9D1 1F3FD 200D 1F9BD ; fully-qualified # 🧑🏽🦽 E12.1 person in manual wheelchair: medium skin tone +1F9D1 1F3FE 200D 1F9BD ; fully-qualified # 🧑🏾🦽 E12.1 person in manual wheelchair: medium-dark skin tone +1F9D1 1F3FF 200D 1F9BD ; fully-qualified # 🧑🏿🦽 E12.1 person in manual wheelchair: dark skin tone +1F468 200D 1F9BD ; fully-qualified # 👨🦽 E12.0 man in manual wheelchair +1F468 1F3FB 200D 1F9BD ; fully-qualified # 👨🏻🦽 E12.0 man in manual wheelchair: light skin tone +1F468 1F3FC 200D 1F9BD ; fully-qualified # 👨🏼🦽 E12.0 man in manual wheelchair: medium-light skin tone +1F468 1F3FD 200D 1F9BD ; fully-qualified # 👨🏽🦽 E12.0 man in manual wheelchair: medium skin tone +1F468 1F3FE 200D 1F9BD ; fully-qualified # 👨🏾🦽 E12.0 man in manual wheelchair: medium-dark skin tone +1F468 1F3FF 200D 1F9BD ; fully-qualified # 👨🏿🦽 E12.0 man in manual wheelchair: dark skin tone +1F469 200D 1F9BD ; fully-qualified # 👩🦽 E12.0 woman in manual wheelchair +1F469 1F3FB 200D 1F9BD ; fully-qualified # 👩🏻🦽 E12.0 woman in manual wheelchair: light skin tone +1F469 1F3FC 200D 1F9BD ; fully-qualified # 👩🏼🦽 E12.0 woman in manual wheelchair: medium-light skin tone +1F469 1F3FD 200D 1F9BD ; fully-qualified # 👩🏽🦽 E12.0 woman in manual wheelchair: medium skin tone +1F469 1F3FE 200D 1F9BD ; fully-qualified # 👩🏾🦽 E12.0 woman in manual wheelchair: medium-dark skin tone +1F469 1F3FF 200D 1F9BD ; fully-qualified # 👩🏿🦽 E12.0 woman in manual wheelchair: dark skin tone +1F3C3 ; fully-qualified # 🏃 E0.6 person running +1F3C3 1F3FB ; fully-qualified # 🏃🏻 E1.0 person running: light skin tone +1F3C3 1F3FC ; fully-qualified # 🏃🏼 E1.0 person running: medium-light skin tone +1F3C3 1F3FD ; fully-qualified # 🏃🏽 E1.0 person running: medium skin tone +1F3C3 1F3FE ; fully-qualified # 🏃🏾 E1.0 person running: medium-dark skin tone +1F3C3 1F3FF ; fully-qualified # 🏃🏿 E1.0 person running: dark skin tone +1F3C3 200D 2642 FE0F ; fully-qualified # 🏃♂️ E4.0 man running +1F3C3 200D 2642 ; minimally-qualified # 🏃♂ E4.0 man running +1F3C3 1F3FB 200D 2642 FE0F ; fully-qualified # 🏃🏻♂️ E4.0 man running: light skin tone +1F3C3 1F3FB 200D 2642 ; minimally-qualified # 🏃🏻♂ E4.0 man running: light skin tone +1F3C3 1F3FC 200D 2642 FE0F ; fully-qualified # 🏃🏼♂️ E4.0 man running: medium-light skin tone +1F3C3 1F3FC 200D 2642 ; minimally-qualified # 🏃🏼♂ E4.0 man running: medium-light skin tone +1F3C3 1F3FD 200D 2642 FE0F ; fully-qualified # 🏃🏽♂️ E4.0 man running: medium skin tone +1F3C3 1F3FD 200D 2642 ; minimally-qualified # 🏃🏽♂ E4.0 man running: medium skin tone +1F3C3 1F3FE 200D 2642 FE0F ; fully-qualified # 🏃🏾♂️ E4.0 man running: medium-dark skin tone +1F3C3 1F3FE 200D 2642 ; minimally-qualified # 🏃🏾♂ E4.0 man running: medium-dark skin tone +1F3C3 1F3FF 200D 2642 FE0F ; fully-qualified # 🏃🏿♂️ E4.0 man running: dark skin tone +1F3C3 1F3FF 200D 2642 ; minimally-qualified # 🏃🏿♂ E4.0 man running: dark skin tone +1F3C3 200D 2640 FE0F ; fully-qualified # 🏃♀️ E4.0 woman running +1F3C3 200D 2640 ; minimally-qualified # 🏃♀ E4.0 woman running +1F3C3 1F3FB 200D 2640 FE0F ; fully-qualified # 🏃🏻♀️ E4.0 woman running: light skin tone +1F3C3 1F3FB 200D 2640 ; minimally-qualified # 🏃🏻♀ E4.0 woman running: light skin tone +1F3C3 1F3FC 200D 2640 FE0F ; fully-qualified # 🏃🏼♀️ E4.0 woman running: medium-light skin tone +1F3C3 1F3FC 200D 2640 ; minimally-qualified # 🏃🏼♀ E4.0 woman running: medium-light skin tone +1F3C3 1F3FD 200D 2640 FE0F ; fully-qualified # 🏃🏽♀️ E4.0 woman running: medium skin tone +1F3C3 1F3FD 200D 2640 ; minimally-qualified # 🏃🏽♀ E4.0 woman running: medium skin tone +1F3C3 1F3FE 200D 2640 FE0F ; fully-qualified # 🏃🏾♀️ E4.0 woman running: medium-dark skin tone +1F3C3 1F3FE 200D 2640 ; minimally-qualified # 🏃🏾♀ E4.0 woman running: medium-dark skin tone +1F3C3 1F3FF 200D 2640 FE0F ; fully-qualified # 🏃🏿♀️ E4.0 woman running: dark skin tone +1F3C3 1F3FF 200D 2640 ; minimally-qualified # 🏃🏿♀ E4.0 woman running: dark skin tone +1F483 ; fully-qualified # 💃 E0.6 woman dancing +1F483 1F3FB ; fully-qualified # 💃🏻 E1.0 woman dancing: light skin tone +1F483 1F3FC ; fully-qualified # 💃🏼 E1.0 woman dancing: medium-light skin tone +1F483 1F3FD ; fully-qualified # 💃🏽 E1.0 woman dancing: medium skin tone +1F483 1F3FE ; fully-qualified # 💃🏾 E1.0 woman dancing: medium-dark skin tone +1F483 1F3FF ; fully-qualified # 💃🏿 E1.0 woman dancing: dark skin tone +1F57A ; fully-qualified # 🕺 E3.0 man dancing +1F57A 1F3FB ; fully-qualified # 🕺🏻 E3.0 man dancing: light skin tone +1F57A 1F3FC ; fully-qualified # 🕺🏼 E3.0 man dancing: medium-light skin tone +1F57A 1F3FD ; fully-qualified # 🕺🏽 E3.0 man dancing: medium skin tone +1F57A 1F3FE ; fully-qualified # 🕺🏾 E3.0 man dancing: medium-dark skin tone +1F57A 1F3FF ; fully-qualified # 🕺🏿 E3.0 man dancing: dark skin tone +1F574 FE0F ; fully-qualified # 🕴️ E0.7 person in suit levitating +1F574 ; unqualified # 🕴 E0.7 person in suit levitating +1F574 1F3FB ; fully-qualified # 🕴🏻 E4.0 person in suit levitating: light skin tone +1F574 1F3FC ; fully-qualified # 🕴🏼 E4.0 person in suit levitating: medium-light skin tone +1F574 1F3FD ; fully-qualified # 🕴🏽 E4.0 person in suit levitating: medium skin tone +1F574 1F3FE ; fully-qualified # 🕴🏾 E4.0 person in suit levitating: medium-dark skin tone +1F574 1F3FF ; fully-qualified # 🕴🏿 E4.0 person in suit levitating: dark skin tone +1F46F ; fully-qualified # 👯 E0.6 people with bunny ears +1F46F 200D 2642 FE0F ; fully-qualified # 👯♂️ E4.0 men with bunny ears +1F46F 200D 2642 ; minimally-qualified # 👯♂ E4.0 men with bunny ears +1F46F 200D 2640 FE0F ; fully-qualified # 👯♀️ E4.0 women with bunny ears +1F46F 200D 2640 ; minimally-qualified # 👯♀ E4.0 women with bunny ears +1F9D6 ; fully-qualified # 🧖 E5.0 person in steamy room +1F9D6 1F3FB ; fully-qualified # 🧖🏻 E5.0 person in steamy room: light skin tone +1F9D6 1F3FC ; fully-qualified # 🧖🏼 E5.0 person in steamy room: medium-light skin tone +1F9D6 1F3FD ; fully-qualified # 🧖🏽 E5.0 person in steamy room: medium skin tone +1F9D6 1F3FE ; fully-qualified # 🧖🏾 E5.0 person in steamy room: medium-dark skin tone +1F9D6 1F3FF ; fully-qualified # 🧖🏿 E5.0 person in steamy room: dark skin tone +1F9D6 200D 2642 FE0F ; fully-qualified # 🧖♂️ E5.0 man in steamy room +1F9D6 200D 2642 ; minimally-qualified # 🧖♂ E5.0 man in steamy room +1F9D6 1F3FB 200D 2642 FE0F ; fully-qualified # 🧖🏻♂️ E5.0 man in steamy room: light skin tone +1F9D6 1F3FB 200D 2642 ; minimally-qualified # 🧖🏻♂ E5.0 man in steamy room: light skin tone +1F9D6 1F3FC 200D 2642 FE0F ; fully-qualified # 🧖🏼♂️ E5.0 man in steamy room: medium-light skin tone +1F9D6 1F3FC 200D 2642 ; minimally-qualified # 🧖🏼♂ E5.0 man in steamy room: medium-light skin tone +1F9D6 1F3FD 200D 2642 FE0F ; fully-qualified # 🧖🏽♂️ E5.0 man in steamy room: medium skin tone +1F9D6 1F3FD 200D 2642 ; minimally-qualified # 🧖🏽♂ E5.0 man in steamy room: medium skin tone +1F9D6 1F3FE 200D 2642 FE0F ; fully-qualified # 🧖🏾♂️ E5.0 man in steamy room: medium-dark skin tone +1F9D6 1F3FE 200D 2642 ; minimally-qualified # 🧖🏾♂ E5.0 man in steamy room: medium-dark skin tone +1F9D6 1F3FF 200D 2642 FE0F ; fully-qualified # 🧖🏿♂️ E5.0 man in steamy room: dark skin tone +1F9D6 1F3FF 200D 2642 ; minimally-qualified # 🧖🏿♂ E5.0 man in steamy room: dark skin tone +1F9D6 200D 2640 FE0F ; fully-qualified # 🧖♀️ E5.0 woman in steamy room +1F9D6 200D 2640 ; minimally-qualified # 🧖♀ E5.0 woman in steamy room +1F9D6 1F3FB 200D 2640 FE0F ; fully-qualified # 🧖🏻♀️ E5.0 woman in steamy room: light skin tone +1F9D6 1F3FB 200D 2640 ; minimally-qualified # 🧖🏻♀ E5.0 woman in steamy room: light skin tone +1F9D6 1F3FC 200D 2640 FE0F ; fully-qualified # 🧖🏼♀️ E5.0 woman in steamy room: medium-light skin tone +1F9D6 1F3FC 200D 2640 ; minimally-qualified # 🧖🏼♀ E5.0 woman in steamy room: medium-light skin tone +1F9D6 1F3FD 200D 2640 FE0F ; fully-qualified # 🧖🏽♀️ E5.0 woman in steamy room: medium skin tone +1F9D6 1F3FD 200D 2640 ; minimally-qualified # 🧖🏽♀ E5.0 woman in steamy room: medium skin tone +1F9D6 1F3FE 200D 2640 FE0F ; fully-qualified # 🧖🏾♀️ E5.0 woman in steamy room: medium-dark skin tone +1F9D6 1F3FE 200D 2640 ; minimally-qualified # 🧖🏾♀ E5.0 woman in steamy room: medium-dark skin tone +1F9D6 1F3FF 200D 2640 FE0F ; fully-qualified # 🧖🏿♀️ E5.0 woman in steamy room: dark skin tone +1F9D6 1F3FF 200D 2640 ; minimally-qualified # 🧖🏿♀ E5.0 woman in steamy room: dark skin tone +1F9D7 ; fully-qualified # 🧗 E5.0 person climbing +1F9D7 1F3FB ; fully-qualified # 🧗🏻 E5.0 person climbing: light skin tone +1F9D7 1F3FC ; fully-qualified # 🧗🏼 E5.0 person climbing: medium-light skin tone +1F9D7 1F3FD ; fully-qualified # 🧗🏽 E5.0 person climbing: medium skin tone +1F9D7 1F3FE ; fully-qualified # 🧗🏾 E5.0 person climbing: medium-dark skin tone +1F9D7 1F3FF ; fully-qualified # 🧗🏿 E5.0 person climbing: dark skin tone +1F9D7 200D 2642 FE0F ; fully-qualified # 🧗♂️ E5.0 man climbing +1F9D7 200D 2642 ; minimally-qualified # 🧗♂ E5.0 man climbing +1F9D7 1F3FB 200D 2642 FE0F ; fully-qualified # 🧗🏻♂️ E5.0 man climbing: light skin tone +1F9D7 1F3FB 200D 2642 ; minimally-qualified # 🧗🏻♂ E5.0 man climbing: light skin tone +1F9D7 1F3FC 200D 2642 FE0F ; fully-qualified # 🧗🏼♂️ E5.0 man climbing: medium-light skin tone +1F9D7 1F3FC 200D 2642 ; minimally-qualified # 🧗🏼♂ E5.0 man climbing: medium-light skin tone +1F9D7 1F3FD 200D 2642 FE0F ; fully-qualified # 🧗🏽♂️ E5.0 man climbing: medium skin tone +1F9D7 1F3FD 200D 2642 ; minimally-qualified # 🧗🏽♂ E5.0 man climbing: medium skin tone +1F9D7 1F3FE 200D 2642 FE0F ; fully-qualified # 🧗🏾♂️ E5.0 man climbing: medium-dark skin tone +1F9D7 1F3FE 200D 2642 ; minimally-qualified # 🧗🏾♂ E5.0 man climbing: medium-dark skin tone +1F9D7 1F3FF 200D 2642 FE0F ; fully-qualified # 🧗🏿♂️ E5.0 man climbing: dark skin tone +1F9D7 1F3FF 200D 2642 ; minimally-qualified # 🧗🏿♂ E5.0 man climbing: dark skin tone +1F9D7 200D 2640 FE0F ; fully-qualified # 🧗♀️ E5.0 woman climbing +1F9D7 200D 2640 ; minimally-qualified # 🧗♀ E5.0 woman climbing +1F9D7 1F3FB 200D 2640 FE0F ; fully-qualified # 🧗🏻♀️ E5.0 woman climbing: light skin tone +1F9D7 1F3FB 200D 2640 ; minimally-qualified # 🧗🏻♀ E5.0 woman climbing: light skin tone +1F9D7 1F3FC 200D 2640 FE0F ; fully-qualified # 🧗🏼♀️ E5.0 woman climbing: medium-light skin tone +1F9D7 1F3FC 200D 2640 ; minimally-qualified # 🧗🏼♀ E5.0 woman climbing: medium-light skin tone +1F9D7 1F3FD 200D 2640 FE0F ; fully-qualified # 🧗🏽♀️ E5.0 woman climbing: medium skin tone +1F9D7 1F3FD 200D 2640 ; minimally-qualified # 🧗🏽♀ E5.0 woman climbing: medium skin tone +1F9D7 1F3FE 200D 2640 FE0F ; fully-qualified # 🧗🏾♀️ E5.0 woman climbing: medium-dark skin tone +1F9D7 1F3FE 200D 2640 ; minimally-qualified # 🧗🏾♀ E5.0 woman climbing: medium-dark skin tone +1F9D7 1F3FF 200D 2640 FE0F ; fully-qualified # 🧗🏿♀️ E5.0 woman climbing: dark skin tone +1F9D7 1F3FF 200D 2640 ; minimally-qualified # 🧗🏿♀ E5.0 woman climbing: dark skin tone + +# subgroup: person-sport +1F93A ; fully-qualified # 🤺 E3.0 person fencing +1F3C7 ; fully-qualified # 🏇 E1.0 horse racing +1F3C7 1F3FB ; fully-qualified # 🏇🏻 E1.0 horse racing: light skin tone +1F3C7 1F3FC ; fully-qualified # 🏇🏼 E1.0 horse racing: medium-light skin tone +1F3C7 1F3FD ; fully-qualified # 🏇🏽 E1.0 horse racing: medium skin tone +1F3C7 1F3FE ; fully-qualified # 🏇🏾 E1.0 horse racing: medium-dark skin tone +1F3C7 1F3FF ; fully-qualified # 🏇🏿 E1.0 horse racing: dark skin tone +26F7 FE0F ; fully-qualified # ⛷️ E0.7 skier +26F7 ; unqualified # ⛷ E0.7 skier +1F3C2 ; fully-qualified # 🏂 E0.6 snowboarder +1F3C2 1F3FB ; fully-qualified # 🏂🏻 E1.0 snowboarder: light skin tone +1F3C2 1F3FC ; fully-qualified # 🏂🏼 E1.0 snowboarder: medium-light skin tone +1F3C2 1F3FD ; fully-qualified # 🏂🏽 E1.0 snowboarder: medium skin tone +1F3C2 1F3FE ; fully-qualified # 🏂🏾 E1.0 snowboarder: medium-dark skin tone +1F3C2 1F3FF ; fully-qualified # 🏂🏿 E1.0 snowboarder: dark skin tone +1F3CC FE0F ; fully-qualified # 🏌️ E0.7 person golfing +1F3CC ; unqualified # 🏌 E0.7 person golfing +1F3CC 1F3FB ; fully-qualified # 🏌🏻 E4.0 person golfing: light skin tone +1F3CC 1F3FC ; fully-qualified # 🏌🏼 E4.0 person golfing: medium-light skin tone +1F3CC 1F3FD ; fully-qualified # 🏌🏽 E4.0 person golfing: medium skin tone +1F3CC 1F3FE ; fully-qualified # 🏌🏾 E4.0 person golfing: medium-dark skin tone +1F3CC 1F3FF ; fully-qualified # 🏌🏿 E4.0 person golfing: dark skin tone +1F3CC FE0F 200D 2642 FE0F ; fully-qualified # 🏌️♂️ E4.0 man golfing +1F3CC 200D 2642 FE0F ; unqualified # 🏌♂️ E4.0 man golfing +1F3CC FE0F 200D 2642 ; unqualified # 🏌️♂ E4.0 man golfing +1F3CC 200D 2642 ; unqualified # 🏌♂ E4.0 man golfing +1F3CC 1F3FB 200D 2642 FE0F ; fully-qualified # 🏌🏻♂️ E4.0 man golfing: light skin tone +1F3CC 1F3FB 200D 2642 ; minimally-qualified # 🏌🏻♂ E4.0 man golfing: light skin tone +1F3CC 1F3FC 200D 2642 FE0F ; fully-qualified # 🏌🏼♂️ E4.0 man golfing: medium-light skin tone +1F3CC 1F3FC 200D 2642 ; minimally-qualified # 🏌🏼♂ E4.0 man golfing: medium-light skin tone +1F3CC 1F3FD 200D 2642 FE0F ; fully-qualified # 🏌🏽♂️ E4.0 man golfing: medium skin tone +1F3CC 1F3FD 200D 2642 ; minimally-qualified # 🏌🏽♂ E4.0 man golfing: medium skin tone +1F3CC 1F3FE 200D 2642 FE0F ; fully-qualified # 🏌🏾♂️ E4.0 man golfing: medium-dark skin tone +1F3CC 1F3FE 200D 2642 ; minimally-qualified # 🏌🏾♂ E4.0 man golfing: medium-dark skin tone +1F3CC 1F3FF 200D 2642 FE0F ; fully-qualified # 🏌🏿♂️ E4.0 man golfing: dark skin tone +1F3CC 1F3FF 200D 2642 ; minimally-qualified # 🏌🏿♂ E4.0 man golfing: dark skin tone +1F3CC FE0F 200D 2640 FE0F ; fully-qualified # 🏌️♀️ E4.0 woman golfing +1F3CC 200D 2640 FE0F ; unqualified # 🏌♀️ E4.0 woman golfing +1F3CC FE0F 200D 2640 ; unqualified # 🏌️♀ E4.0 woman golfing +1F3CC 200D 2640 ; unqualified # 🏌♀ E4.0 woman golfing +1F3CC 1F3FB 200D 2640 FE0F ; fully-qualified # 🏌🏻♀️ E4.0 woman golfing: light skin tone +1F3CC 1F3FB 200D 2640 ; minimally-qualified # 🏌🏻♀ E4.0 woman golfing: light skin tone +1F3CC 1F3FC 200D 2640 FE0F ; fully-qualified # 🏌🏼♀️ E4.0 woman golfing: medium-light skin tone +1F3CC 1F3FC 200D 2640 ; minimally-qualified # 🏌🏼♀ E4.0 woman golfing: medium-light skin tone +1F3CC 1F3FD 200D 2640 FE0F ; fully-qualified # 🏌🏽♀️ E4.0 woman golfing: medium skin tone +1F3CC 1F3FD 200D 2640 ; minimally-qualified # 🏌🏽♀ E4.0 woman golfing: medium skin tone +1F3CC 1F3FE 200D 2640 FE0F ; fully-qualified # 🏌🏾♀️ E4.0 woman golfing: medium-dark skin tone +1F3CC 1F3FE 200D 2640 ; minimally-qualified # 🏌🏾♀ E4.0 woman golfing: medium-dark skin tone +1F3CC 1F3FF 200D 2640 FE0F ; fully-qualified # 🏌🏿♀️ E4.0 woman golfing: dark skin tone +1F3CC 1F3FF 200D 2640 ; minimally-qualified # 🏌🏿♀ E4.0 woman golfing: dark skin tone +1F3C4 ; fully-qualified # 🏄 E0.6 person surfing +1F3C4 1F3FB ; fully-qualified # 🏄🏻 E1.0 person surfing: light skin tone +1F3C4 1F3FC ; fully-qualified # 🏄🏼 E1.0 person surfing: medium-light skin tone +1F3C4 1F3FD ; fully-qualified # 🏄🏽 E1.0 person surfing: medium skin tone +1F3C4 1F3FE ; fully-qualified # 🏄🏾 E1.0 person surfing: medium-dark skin tone +1F3C4 1F3FF ; fully-qualified # 🏄🏿 E1.0 person surfing: dark skin tone +1F3C4 200D 2642 FE0F ; fully-qualified # 🏄♂️ E4.0 man surfing +1F3C4 200D 2642 ; minimally-qualified # 🏄♂ E4.0 man surfing +1F3C4 1F3FB 200D 2642 FE0F ; fully-qualified # 🏄🏻♂️ E4.0 man surfing: light skin tone +1F3C4 1F3FB 200D 2642 ; minimally-qualified # 🏄🏻♂ E4.0 man surfing: light skin tone +1F3C4 1F3FC 200D 2642 FE0F ; fully-qualified # 🏄🏼♂️ E4.0 man surfing: medium-light skin tone +1F3C4 1F3FC 200D 2642 ; minimally-qualified # 🏄🏼♂ E4.0 man surfing: medium-light skin tone +1F3C4 1F3FD 200D 2642 FE0F ; fully-qualified # 🏄🏽♂️ E4.0 man surfing: medium skin tone +1F3C4 1F3FD 200D 2642 ; minimally-qualified # 🏄🏽♂ E4.0 man surfing: medium skin tone +1F3C4 1F3FE 200D 2642 FE0F ; fully-qualified # 🏄🏾♂️ E4.0 man surfing: medium-dark skin tone +1F3C4 1F3FE 200D 2642 ; minimally-qualified # 🏄🏾♂ E4.0 man surfing: medium-dark skin tone +1F3C4 1F3FF 200D 2642 FE0F ; fully-qualified # 🏄🏿♂️ E4.0 man surfing: dark skin tone +1F3C4 1F3FF 200D 2642 ; minimally-qualified # 🏄🏿♂ E4.0 man surfing: dark skin tone +1F3C4 200D 2640 FE0F ; fully-qualified # 🏄♀️ E4.0 woman surfing +1F3C4 200D 2640 ; minimally-qualified # 🏄♀ E4.0 woman surfing +1F3C4 1F3FB 200D 2640 FE0F ; fully-qualified # 🏄🏻♀️ E4.0 woman surfing: light skin tone +1F3C4 1F3FB 200D 2640 ; minimally-qualified # 🏄🏻♀ E4.0 woman surfing: light skin tone +1F3C4 1F3FC 200D 2640 FE0F ; fully-qualified # 🏄🏼♀️ E4.0 woman surfing: medium-light skin tone +1F3C4 1F3FC 200D 2640 ; minimally-qualified # 🏄🏼♀ E4.0 woman surfing: medium-light skin tone +1F3C4 1F3FD 200D 2640 FE0F ; fully-qualified # 🏄🏽♀️ E4.0 woman surfing: medium skin tone +1F3C4 1F3FD 200D 2640 ; minimally-qualified # 🏄🏽♀ E4.0 woman surfing: medium skin tone +1F3C4 1F3FE 200D 2640 FE0F ; fully-qualified # 🏄🏾♀️ E4.0 woman surfing: medium-dark skin tone +1F3C4 1F3FE 200D 2640 ; minimally-qualified # 🏄🏾♀ E4.0 woman surfing: medium-dark skin tone +1F3C4 1F3FF 200D 2640 FE0F ; fully-qualified # 🏄🏿♀️ E4.0 woman surfing: dark skin tone +1F3C4 1F3FF 200D 2640 ; minimally-qualified # 🏄🏿♀ E4.0 woman surfing: dark skin tone +1F6A3 ; fully-qualified # 🚣 E1.0 person rowing boat +1F6A3 1F3FB ; fully-qualified # 🚣🏻 E1.0 person rowing boat: light skin tone +1F6A3 1F3FC ; fully-qualified # 🚣🏼 E1.0 person rowing boat: medium-light skin tone +1F6A3 1F3FD ; fully-qualified # 🚣🏽 E1.0 person rowing boat: medium skin tone +1F6A3 1F3FE ; fully-qualified # 🚣🏾 E1.0 person rowing boat: medium-dark skin tone +1F6A3 1F3FF ; fully-qualified # 🚣🏿 E1.0 person rowing boat: dark skin tone +1F6A3 200D 2642 FE0F ; fully-qualified # 🚣♂️ E4.0 man rowing boat +1F6A3 200D 2642 ; minimally-qualified # 🚣♂ E4.0 man rowing boat +1F6A3 1F3FB 200D 2642 FE0F ; fully-qualified # 🚣🏻♂️ E4.0 man rowing boat: light skin tone +1F6A3 1F3FB 200D 2642 ; minimally-qualified # 🚣🏻♂ E4.0 man rowing boat: light skin tone +1F6A3 1F3FC 200D 2642 FE0F ; fully-qualified # 🚣🏼♂️ E4.0 man rowing boat: medium-light skin tone +1F6A3 1F3FC 200D 2642 ; minimally-qualified # 🚣🏼♂ E4.0 man rowing boat: medium-light skin tone +1F6A3 1F3FD 200D 2642 FE0F ; fully-qualified # 🚣🏽♂️ E4.0 man rowing boat: medium skin tone +1F6A3 1F3FD 200D 2642 ; minimally-qualified # 🚣🏽♂ E4.0 man rowing boat: medium skin tone +1F6A3 1F3FE 200D 2642 FE0F ; fully-qualified # 🚣🏾♂️ E4.0 man rowing boat: medium-dark skin tone +1F6A3 1F3FE 200D 2642 ; minimally-qualified # 🚣🏾♂ E4.0 man rowing boat: medium-dark skin tone +1F6A3 1F3FF 200D 2642 FE0F ; fully-qualified # 🚣🏿♂️ E4.0 man rowing boat: dark skin tone +1F6A3 1F3FF 200D 2642 ; minimally-qualified # 🚣🏿♂ E4.0 man rowing boat: dark skin tone +1F6A3 200D 2640 FE0F ; fully-qualified # 🚣♀️ E4.0 woman rowing boat +1F6A3 200D 2640 ; minimally-qualified # 🚣♀ E4.0 woman rowing boat +1F6A3 1F3FB 200D 2640 FE0F ; fully-qualified # 🚣🏻♀️ E4.0 woman rowing boat: light skin tone +1F6A3 1F3FB 200D 2640 ; minimally-qualified # 🚣🏻♀ E4.0 woman rowing boat: light skin tone +1F6A3 1F3FC 200D 2640 FE0F ; fully-qualified # 🚣🏼♀️ E4.0 woman rowing boat: medium-light skin tone +1F6A3 1F3FC 200D 2640 ; minimally-qualified # 🚣🏼♀ E4.0 woman rowing boat: medium-light skin tone +1F6A3 1F3FD 200D 2640 FE0F ; fully-qualified # 🚣🏽♀️ E4.0 woman rowing boat: medium skin tone +1F6A3 1F3FD 200D 2640 ; minimally-qualified # 🚣🏽♀ E4.0 woman rowing boat: medium skin tone +1F6A3 1F3FE 200D 2640 FE0F ; fully-qualified # 🚣🏾♀️ E4.0 woman rowing boat: medium-dark skin tone +1F6A3 1F3FE 200D 2640 ; minimally-qualified # 🚣🏾♀ E4.0 woman rowing boat: medium-dark skin tone +1F6A3 1F3FF 200D 2640 FE0F ; fully-qualified # 🚣🏿♀️ E4.0 woman rowing boat: dark skin tone +1F6A3 1F3FF 200D 2640 ; minimally-qualified # 🚣🏿♀ E4.0 woman rowing boat: dark skin tone +1F3CA ; fully-qualified # 🏊 E0.6 person swimming +1F3CA 1F3FB ; fully-qualified # 🏊🏻 E1.0 person swimming: light skin tone +1F3CA 1F3FC ; fully-qualified # 🏊🏼 E1.0 person swimming: medium-light skin tone +1F3CA 1F3FD ; fully-qualified # 🏊🏽 E1.0 person swimming: medium skin tone +1F3CA 1F3FE ; fully-qualified # 🏊🏾 E1.0 person swimming: medium-dark skin tone +1F3CA 1F3FF ; fully-qualified # 🏊🏿 E1.0 person swimming: dark skin tone +1F3CA 200D 2642 FE0F ; fully-qualified # 🏊♂️ E4.0 man swimming +1F3CA 200D 2642 ; minimally-qualified # 🏊♂ E4.0 man swimming +1F3CA 1F3FB 200D 2642 FE0F ; fully-qualified # 🏊🏻♂️ E4.0 man swimming: light skin tone +1F3CA 1F3FB 200D 2642 ; minimally-qualified # 🏊🏻♂ E4.0 man swimming: light skin tone +1F3CA 1F3FC 200D 2642 FE0F ; fully-qualified # 🏊🏼♂️ E4.0 man swimming: medium-light skin tone +1F3CA 1F3FC 200D 2642 ; minimally-qualified # 🏊🏼♂ E4.0 man swimming: medium-light skin tone +1F3CA 1F3FD 200D 2642 FE0F ; fully-qualified # 🏊🏽♂️ E4.0 man swimming: medium skin tone +1F3CA 1F3FD 200D 2642 ; minimally-qualified # 🏊🏽♂ E4.0 man swimming: medium skin tone +1F3CA 1F3FE 200D 2642 FE0F ; fully-qualified # 🏊🏾♂️ E4.0 man swimming: medium-dark skin tone +1F3CA 1F3FE 200D 2642 ; minimally-qualified # 🏊🏾♂ E4.0 man swimming: medium-dark skin tone +1F3CA 1F3FF 200D 2642 FE0F ; fully-qualified # 🏊🏿♂️ E4.0 man swimming: dark skin tone +1F3CA 1F3FF 200D 2642 ; minimally-qualified # 🏊🏿♂ E4.0 man swimming: dark skin tone +1F3CA 200D 2640 FE0F ; fully-qualified # 🏊♀️ E4.0 woman swimming +1F3CA 200D 2640 ; minimally-qualified # 🏊♀ E4.0 woman swimming +1F3CA 1F3FB 200D 2640 FE0F ; fully-qualified # 🏊🏻♀️ E4.0 woman swimming: light skin tone +1F3CA 1F3FB 200D 2640 ; minimally-qualified # 🏊🏻♀ E4.0 woman swimming: light skin tone +1F3CA 1F3FC 200D 2640 FE0F ; fully-qualified # 🏊🏼♀️ E4.0 woman swimming: medium-light skin tone +1F3CA 1F3FC 200D 2640 ; minimally-qualified # 🏊🏼♀ E4.0 woman swimming: medium-light skin tone +1F3CA 1F3FD 200D 2640 FE0F ; fully-qualified # 🏊🏽♀️ E4.0 woman swimming: medium skin tone +1F3CA 1F3FD 200D 2640 ; minimally-qualified # 🏊🏽♀ E4.0 woman swimming: medium skin tone +1F3CA 1F3FE 200D 2640 FE0F ; fully-qualified # 🏊🏾♀️ E4.0 woman swimming: medium-dark skin tone +1F3CA 1F3FE 200D 2640 ; minimally-qualified # 🏊🏾♀ E4.0 woman swimming: medium-dark skin tone +1F3CA 1F3FF 200D 2640 FE0F ; fully-qualified # 🏊🏿♀️ E4.0 woman swimming: dark skin tone +1F3CA 1F3FF 200D 2640 ; minimally-qualified # 🏊🏿♀ E4.0 woman swimming: dark skin tone +26F9 FE0F ; fully-qualified # ⛹️ E0.7 person bouncing ball +26F9 ; unqualified # ⛹ E0.7 person bouncing ball +26F9 1F3FB ; fully-qualified # ⛹🏻 E2.0 person bouncing ball: light skin tone +26F9 1F3FC ; fully-qualified # ⛹🏼 E2.0 person bouncing ball: medium-light skin tone +26F9 1F3FD ; fully-qualified # ⛹🏽 E2.0 person bouncing ball: medium skin tone +26F9 1F3FE ; fully-qualified # ⛹🏾 E2.0 person bouncing ball: medium-dark skin tone +26F9 1F3FF ; fully-qualified # ⛹🏿 E2.0 person bouncing ball: dark skin tone +26F9 FE0F 200D 2642 FE0F ; fully-qualified # ⛹️♂️ E4.0 man bouncing ball +26F9 200D 2642 FE0F ; unqualified # ⛹♂️ E4.0 man bouncing ball +26F9 FE0F 200D 2642 ; unqualified # ⛹️♂ E4.0 man bouncing ball +26F9 200D 2642 ; unqualified # ⛹♂ E4.0 man bouncing ball +26F9 1F3FB 200D 2642 FE0F ; fully-qualified # ⛹🏻♂️ E4.0 man bouncing ball: light skin tone +26F9 1F3FB 200D 2642 ; minimally-qualified # ⛹🏻♂ E4.0 man bouncing ball: light skin tone +26F9 1F3FC 200D 2642 FE0F ; fully-qualified # ⛹🏼♂️ E4.0 man bouncing ball: medium-light skin tone +26F9 1F3FC 200D 2642 ; minimally-qualified # ⛹🏼♂ E4.0 man bouncing ball: medium-light skin tone +26F9 1F3FD 200D 2642 FE0F ; fully-qualified # ⛹🏽♂️ E4.0 man bouncing ball: medium skin tone +26F9 1F3FD 200D 2642 ; minimally-qualified # ⛹🏽♂ E4.0 man bouncing ball: medium skin tone +26F9 1F3FE 200D 2642 FE0F ; fully-qualified # ⛹🏾♂️ E4.0 man bouncing ball: medium-dark skin tone +26F9 1F3FE 200D 2642 ; minimally-qualified # ⛹🏾♂ E4.0 man bouncing ball: medium-dark skin tone +26F9 1F3FF 200D 2642 FE0F ; fully-qualified # ⛹🏿♂️ E4.0 man bouncing ball: dark skin tone +26F9 1F3FF 200D 2642 ; minimally-qualified # ⛹🏿♂ E4.0 man bouncing ball: dark skin tone +26F9 FE0F 200D 2640 FE0F ; fully-qualified # ⛹️♀️ E4.0 woman bouncing ball +26F9 200D 2640 FE0F ; unqualified # ⛹♀️ E4.0 woman bouncing ball +26F9 FE0F 200D 2640 ; unqualified # ⛹️♀ E4.0 woman bouncing ball +26F9 200D 2640 ; unqualified # ⛹♀ E4.0 woman bouncing ball +26F9 1F3FB 200D 2640 FE0F ; fully-qualified # ⛹🏻♀️ E4.0 woman bouncing ball: light skin tone +26F9 1F3FB 200D 2640 ; minimally-qualified # ⛹🏻♀ E4.0 woman bouncing ball: light skin tone +26F9 1F3FC 200D 2640 FE0F ; fully-qualified # ⛹🏼♀️ E4.0 woman bouncing ball: medium-light skin tone +26F9 1F3FC 200D 2640 ; minimally-qualified # ⛹🏼♀ E4.0 woman bouncing ball: medium-light skin tone +26F9 1F3FD 200D 2640 FE0F ; fully-qualified # ⛹🏽♀️ E4.0 woman bouncing ball: medium skin tone +26F9 1F3FD 200D 2640 ; minimally-qualified # ⛹🏽♀ E4.0 woman bouncing ball: medium skin tone +26F9 1F3FE 200D 2640 FE0F ; fully-qualified # ⛹🏾♀️ E4.0 woman bouncing ball: medium-dark skin tone +26F9 1F3FE 200D 2640 ; minimally-qualified # ⛹🏾♀ E4.0 woman bouncing ball: medium-dark skin tone +26F9 1F3FF 200D 2640 FE0F ; fully-qualified # ⛹🏿♀️ E4.0 woman bouncing ball: dark skin tone +26F9 1F3FF 200D 2640 ; minimally-qualified # ⛹🏿♀ E4.0 woman bouncing ball: dark skin tone +1F3CB FE0F ; fully-qualified # 🏋️ E0.7 person lifting weights +1F3CB ; unqualified # 🏋 E0.7 person lifting weights +1F3CB 1F3FB ; fully-qualified # 🏋🏻 E2.0 person lifting weights: light skin tone +1F3CB 1F3FC ; fully-qualified # 🏋🏼 E2.0 person lifting weights: medium-light skin tone +1F3CB 1F3FD ; fully-qualified # 🏋🏽 E2.0 person lifting weights: medium skin tone +1F3CB 1F3FE ; fully-qualified # 🏋🏾 E2.0 person lifting weights: medium-dark skin tone +1F3CB 1F3FF ; fully-qualified # 🏋🏿 E2.0 person lifting weights: dark skin tone +1F3CB FE0F 200D 2642 FE0F ; fully-qualified # 🏋️♂️ E4.0 man lifting weights +1F3CB 200D 2642 FE0F ; unqualified # 🏋♂️ E4.0 man lifting weights +1F3CB FE0F 200D 2642 ; unqualified # 🏋️♂ E4.0 man lifting weights +1F3CB 200D 2642 ; unqualified # 🏋♂ E4.0 man lifting weights +1F3CB 1F3FB 200D 2642 FE0F ; fully-qualified # 🏋🏻♂️ E4.0 man lifting weights: light skin tone +1F3CB 1F3FB 200D 2642 ; minimally-qualified # 🏋🏻♂ E4.0 man lifting weights: light skin tone +1F3CB 1F3FC 200D 2642 FE0F ; fully-qualified # 🏋🏼♂️ E4.0 man lifting weights: medium-light skin tone +1F3CB 1F3FC 200D 2642 ; minimally-qualified # 🏋🏼♂ E4.0 man lifting weights: medium-light skin tone +1F3CB 1F3FD 200D 2642 FE0F ; fully-qualified # 🏋🏽♂️ E4.0 man lifting weights: medium skin tone +1F3CB 1F3FD 200D 2642 ; minimally-qualified # 🏋🏽♂ E4.0 man lifting weights: medium skin tone +1F3CB 1F3FE 200D 2642 FE0F ; fully-qualified # 🏋🏾♂️ E4.0 man lifting weights: medium-dark skin tone +1F3CB 1F3FE 200D 2642 ; minimally-qualified # 🏋🏾♂ E4.0 man lifting weights: medium-dark skin tone +1F3CB 1F3FF 200D 2642 FE0F ; fully-qualified # 🏋🏿♂️ E4.0 man lifting weights: dark skin tone +1F3CB 1F3FF 200D 2642 ; minimally-qualified # 🏋🏿♂ E4.0 man lifting weights: dark skin tone +1F3CB FE0F 200D 2640 FE0F ; fully-qualified # 🏋️♀️ E4.0 woman lifting weights +1F3CB 200D 2640 FE0F ; unqualified # 🏋♀️ E4.0 woman lifting weights +1F3CB FE0F 200D 2640 ; unqualified # 🏋️♀ E4.0 woman lifting weights +1F3CB 200D 2640 ; unqualified # 🏋♀ E4.0 woman lifting weights +1F3CB 1F3FB 200D 2640 FE0F ; fully-qualified # 🏋🏻♀️ E4.0 woman lifting weights: light skin tone +1F3CB 1F3FB 200D 2640 ; minimally-qualified # 🏋🏻♀ E4.0 woman lifting weights: light skin tone +1F3CB 1F3FC 200D 2640 FE0F ; fully-qualified # 🏋🏼♀️ E4.0 woman lifting weights: medium-light skin tone +1F3CB 1F3FC 200D 2640 ; minimally-qualified # 🏋🏼♀ E4.0 woman lifting weights: medium-light skin tone +1F3CB 1F3FD 200D 2640 FE0F ; fully-qualified # 🏋🏽♀️ E4.0 woman lifting weights: medium skin tone +1F3CB 1F3FD 200D 2640 ; minimally-qualified # 🏋🏽♀ E4.0 woman lifting weights: medium skin tone +1F3CB 1F3FE 200D 2640 FE0F ; fully-qualified # 🏋🏾♀️ E4.0 woman lifting weights: medium-dark skin tone +1F3CB 1F3FE 200D 2640 ; minimally-qualified # 🏋🏾♀ E4.0 woman lifting weights: medium-dark skin tone +1F3CB 1F3FF 200D 2640 FE0F ; fully-qualified # 🏋🏿♀️ E4.0 woman lifting weights: dark skin tone +1F3CB 1F3FF 200D 2640 ; minimally-qualified # 🏋🏿♀ E4.0 woman lifting weights: dark skin tone +1F6B4 ; fully-qualified # 🚴 E1.0 person biking +1F6B4 1F3FB ; fully-qualified # 🚴🏻 E1.0 person biking: light skin tone +1F6B4 1F3FC ; fully-qualified # 🚴🏼 E1.0 person biking: medium-light skin tone +1F6B4 1F3FD ; fully-qualified # 🚴🏽 E1.0 person biking: medium skin tone +1F6B4 1F3FE ; fully-qualified # 🚴🏾 E1.0 person biking: medium-dark skin tone +1F6B4 1F3FF ; fully-qualified # 🚴🏿 E1.0 person biking: dark skin tone +1F6B4 200D 2642 FE0F ; fully-qualified # 🚴♂️ E4.0 man biking +1F6B4 200D 2642 ; minimally-qualified # 🚴♂ E4.0 man biking +1F6B4 1F3FB 200D 2642 FE0F ; fully-qualified # 🚴🏻♂️ E4.0 man biking: light skin tone +1F6B4 1F3FB 200D 2642 ; minimally-qualified # 🚴🏻♂ E4.0 man biking: light skin tone +1F6B4 1F3FC 200D 2642 FE0F ; fully-qualified # 🚴🏼♂️ E4.0 man biking: medium-light skin tone +1F6B4 1F3FC 200D 2642 ; minimally-qualified # 🚴🏼♂ E4.0 man biking: medium-light skin tone +1F6B4 1F3FD 200D 2642 FE0F ; fully-qualified # 🚴🏽♂️ E4.0 man biking: medium skin tone +1F6B4 1F3FD 200D 2642 ; minimally-qualified # 🚴🏽♂ E4.0 man biking: medium skin tone +1F6B4 1F3FE 200D 2642 FE0F ; fully-qualified # 🚴🏾♂️ E4.0 man biking: medium-dark skin tone +1F6B4 1F3FE 200D 2642 ; minimally-qualified # 🚴🏾♂ E4.0 man biking: medium-dark skin tone +1F6B4 1F3FF 200D 2642 FE0F ; fully-qualified # 🚴🏿♂️ E4.0 man biking: dark skin tone +1F6B4 1F3FF 200D 2642 ; minimally-qualified # 🚴🏿♂ E4.0 man biking: dark skin tone +1F6B4 200D 2640 FE0F ; fully-qualified # 🚴♀️ E4.0 woman biking +1F6B4 200D 2640 ; minimally-qualified # 🚴♀ E4.0 woman biking +1F6B4 1F3FB 200D 2640 FE0F ; fully-qualified # 🚴🏻♀️ E4.0 woman biking: light skin tone +1F6B4 1F3FB 200D 2640 ; minimally-qualified # 🚴🏻♀ E4.0 woman biking: light skin tone +1F6B4 1F3FC 200D 2640 FE0F ; fully-qualified # 🚴🏼♀️ E4.0 woman biking: medium-light skin tone +1F6B4 1F3FC 200D 2640 ; minimally-qualified # 🚴🏼♀ E4.0 woman biking: medium-light skin tone +1F6B4 1F3FD 200D 2640 FE0F ; fully-qualified # 🚴🏽♀️ E4.0 woman biking: medium skin tone +1F6B4 1F3FD 200D 2640 ; minimally-qualified # 🚴🏽♀ E4.0 woman biking: medium skin tone +1F6B4 1F3FE 200D 2640 FE0F ; fully-qualified # 🚴🏾♀️ E4.0 woman biking: medium-dark skin tone +1F6B4 1F3FE 200D 2640 ; minimally-qualified # 🚴🏾♀ E4.0 woman biking: medium-dark skin tone +1F6B4 1F3FF 200D 2640 FE0F ; fully-qualified # 🚴🏿♀️ E4.0 woman biking: dark skin tone +1F6B4 1F3FF 200D 2640 ; minimally-qualified # 🚴🏿♀ E4.0 woman biking: dark skin tone +1F6B5 ; fully-qualified # 🚵 E1.0 person mountain biking +1F6B5 1F3FB ; fully-qualified # 🚵🏻 E1.0 person mountain biking: light skin tone +1F6B5 1F3FC ; fully-qualified # 🚵🏼 E1.0 person mountain biking: medium-light skin tone +1F6B5 1F3FD ; fully-qualified # 🚵🏽 E1.0 person mountain biking: medium skin tone +1F6B5 1F3FE ; fully-qualified # 🚵🏾 E1.0 person mountain biking: medium-dark skin tone +1F6B5 1F3FF ; fully-qualified # 🚵🏿 E1.0 person mountain biking: dark skin tone +1F6B5 200D 2642 FE0F ; fully-qualified # 🚵♂️ E4.0 man mountain biking +1F6B5 200D 2642 ; minimally-qualified # 🚵♂ E4.0 man mountain biking +1F6B5 1F3FB 200D 2642 FE0F ; fully-qualified # 🚵🏻♂️ E4.0 man mountain biking: light skin tone +1F6B5 1F3FB 200D 2642 ; minimally-qualified # 🚵🏻♂ E4.0 man mountain biking: light skin tone +1F6B5 1F3FC 200D 2642 FE0F ; fully-qualified # 🚵🏼♂️ E4.0 man mountain biking: medium-light skin tone +1F6B5 1F3FC 200D 2642 ; minimally-qualified # 🚵🏼♂ E4.0 man mountain biking: medium-light skin tone +1F6B5 1F3FD 200D 2642 FE0F ; fully-qualified # 🚵🏽♂️ E4.0 man mountain biking: medium skin tone +1F6B5 1F3FD 200D 2642 ; minimally-qualified # 🚵🏽♂ E4.0 man mountain biking: medium skin tone +1F6B5 1F3FE 200D 2642 FE0F ; fully-qualified # 🚵🏾♂️ E4.0 man mountain biking: medium-dark skin tone +1F6B5 1F3FE 200D 2642 ; minimally-qualified # 🚵🏾♂ E4.0 man mountain biking: medium-dark skin tone +1F6B5 1F3FF 200D 2642 FE0F ; fully-qualified # 🚵🏿♂️ E4.0 man mountain biking: dark skin tone +1F6B5 1F3FF 200D 2642 ; minimally-qualified # 🚵🏿♂ E4.0 man mountain biking: dark skin tone +1F6B5 200D 2640 FE0F ; fully-qualified # 🚵♀️ E4.0 woman mountain biking +1F6B5 200D 2640 ; minimally-qualified # 🚵♀ E4.0 woman mountain biking +1F6B5 1F3FB 200D 2640 FE0F ; fully-qualified # 🚵🏻♀️ E4.0 woman mountain biking: light skin tone +1F6B5 1F3FB 200D 2640 ; minimally-qualified # 🚵🏻♀ E4.0 woman mountain biking: light skin tone +1F6B5 1F3FC 200D 2640 FE0F ; fully-qualified # 🚵🏼♀️ E4.0 woman mountain biking: medium-light skin tone +1F6B5 1F3FC 200D 2640 ; minimally-qualified # 🚵🏼♀ E4.0 woman mountain biking: medium-light skin tone +1F6B5 1F3FD 200D 2640 FE0F ; fully-qualified # 🚵🏽♀️ E4.0 woman mountain biking: medium skin tone +1F6B5 1F3FD 200D 2640 ; minimally-qualified # 🚵🏽♀ E4.0 woman mountain biking: medium skin tone +1F6B5 1F3FE 200D 2640 FE0F ; fully-qualified # 🚵🏾♀️ E4.0 woman mountain biking: medium-dark skin tone +1F6B5 1F3FE 200D 2640 ; minimally-qualified # 🚵🏾♀ E4.0 woman mountain biking: medium-dark skin tone +1F6B5 1F3FF 200D 2640 FE0F ; fully-qualified # 🚵🏿♀️ E4.0 woman mountain biking: dark skin tone +1F6B5 1F3FF 200D 2640 ; minimally-qualified # 🚵🏿♀ E4.0 woman mountain biking: dark skin tone +1F938 ; fully-qualified # 🤸 E3.0 person cartwheeling +1F938 1F3FB ; fully-qualified # 🤸🏻 E3.0 person cartwheeling: light skin tone +1F938 1F3FC ; fully-qualified # 🤸🏼 E3.0 person cartwheeling: medium-light skin tone +1F938 1F3FD ; fully-qualified # 🤸🏽 E3.0 person cartwheeling: medium skin tone +1F938 1F3FE ; fully-qualified # 🤸🏾 E3.0 person cartwheeling: medium-dark skin tone +1F938 1F3FF ; fully-qualified # 🤸🏿 E3.0 person cartwheeling: dark skin tone +1F938 200D 2642 FE0F ; fully-qualified # 🤸♂️ E4.0 man cartwheeling +1F938 200D 2642 ; minimally-qualified # 🤸♂ E4.0 man cartwheeling +1F938 1F3FB 200D 2642 FE0F ; fully-qualified # 🤸🏻♂️ E4.0 man cartwheeling: light skin tone +1F938 1F3FB 200D 2642 ; minimally-qualified # 🤸🏻♂ E4.0 man cartwheeling: light skin tone +1F938 1F3FC 200D 2642 FE0F ; fully-qualified # 🤸🏼♂️ E4.0 man cartwheeling: medium-light skin tone +1F938 1F3FC 200D 2642 ; minimally-qualified # 🤸🏼♂ E4.0 man cartwheeling: medium-light skin tone +1F938 1F3FD 200D 2642 FE0F ; fully-qualified # 🤸🏽♂️ E4.0 man cartwheeling: medium skin tone +1F938 1F3FD 200D 2642 ; minimally-qualified # 🤸🏽♂ E4.0 man cartwheeling: medium skin tone +1F938 1F3FE 200D 2642 FE0F ; fully-qualified # 🤸🏾♂️ E4.0 man cartwheeling: medium-dark skin tone +1F938 1F3FE 200D 2642 ; minimally-qualified # 🤸🏾♂ E4.0 man cartwheeling: medium-dark skin tone +1F938 1F3FF 200D 2642 FE0F ; fully-qualified # 🤸🏿♂️ E4.0 man cartwheeling: dark skin tone +1F938 1F3FF 200D 2642 ; minimally-qualified # 🤸🏿♂ E4.0 man cartwheeling: dark skin tone +1F938 200D 2640 FE0F ; fully-qualified # 🤸♀️ E4.0 woman cartwheeling +1F938 200D 2640 ; minimally-qualified # 🤸♀ E4.0 woman cartwheeling +1F938 1F3FB 200D 2640 FE0F ; fully-qualified # 🤸🏻♀️ E4.0 woman cartwheeling: light skin tone +1F938 1F3FB 200D 2640 ; minimally-qualified # 🤸🏻♀ E4.0 woman cartwheeling: light skin tone +1F938 1F3FC 200D 2640 FE0F ; fully-qualified # 🤸🏼♀️ E4.0 woman cartwheeling: medium-light skin tone +1F938 1F3FC 200D 2640 ; minimally-qualified # 🤸🏼♀ E4.0 woman cartwheeling: medium-light skin tone +1F938 1F3FD 200D 2640 FE0F ; fully-qualified # 🤸🏽♀️ E4.0 woman cartwheeling: medium skin tone +1F938 1F3FD 200D 2640 ; minimally-qualified # 🤸🏽♀ E4.0 woman cartwheeling: medium skin tone +1F938 1F3FE 200D 2640 FE0F ; fully-qualified # 🤸🏾♀️ E4.0 woman cartwheeling: medium-dark skin tone +1F938 1F3FE 200D 2640 ; minimally-qualified # 🤸🏾♀ E4.0 woman cartwheeling: medium-dark skin tone +1F938 1F3FF 200D 2640 FE0F ; fully-qualified # 🤸🏿♀️ E4.0 woman cartwheeling: dark skin tone +1F938 1F3FF 200D 2640 ; minimally-qualified # 🤸🏿♀ E4.0 woman cartwheeling: dark skin tone +1F93C ; fully-qualified # 🤼 E3.0 people wrestling +1F93C 200D 2642 FE0F ; fully-qualified # 🤼♂️ E4.0 men wrestling +1F93C 200D 2642 ; minimally-qualified # 🤼♂ E4.0 men wrestling +1F93C 200D 2640 FE0F ; fully-qualified # 🤼♀️ E4.0 women wrestling +1F93C 200D 2640 ; minimally-qualified # 🤼♀ E4.0 women wrestling +1F93D ; fully-qualified # 🤽 E3.0 person playing water polo +1F93D 1F3FB ; fully-qualified # 🤽🏻 E3.0 person playing water polo: light skin tone +1F93D 1F3FC ; fully-qualified # 🤽🏼 E3.0 person playing water polo: medium-light skin tone +1F93D 1F3FD ; fully-qualified # 🤽🏽 E3.0 person playing water polo: medium skin tone +1F93D 1F3FE ; fully-qualified # 🤽🏾 E3.0 person playing water polo: medium-dark skin tone +1F93D 1F3FF ; fully-qualified # 🤽🏿 E3.0 person playing water polo: dark skin tone +1F93D 200D 2642 FE0F ; fully-qualified # 🤽♂️ E4.0 man playing water polo +1F93D 200D 2642 ; minimally-qualified # 🤽♂ E4.0 man playing water polo +1F93D 1F3FB 200D 2642 FE0F ; fully-qualified # 🤽🏻♂️ E4.0 man playing water polo: light skin tone +1F93D 1F3FB 200D 2642 ; minimally-qualified # 🤽🏻♂ E4.0 man playing water polo: light skin tone +1F93D 1F3FC 200D 2642 FE0F ; fully-qualified # 🤽🏼♂️ E4.0 man playing water polo: medium-light skin tone +1F93D 1F3FC 200D 2642 ; minimally-qualified # 🤽🏼♂ E4.0 man playing water polo: medium-light skin tone +1F93D 1F3FD 200D 2642 FE0F ; fully-qualified # 🤽🏽♂️ E4.0 man playing water polo: medium skin tone +1F93D 1F3FD 200D 2642 ; minimally-qualified # 🤽🏽♂ E4.0 man playing water polo: medium skin tone +1F93D 1F3FE 200D 2642 FE0F ; fully-qualified # 🤽🏾♂️ E4.0 man playing water polo: medium-dark skin tone +1F93D 1F3FE 200D 2642 ; minimally-qualified # 🤽🏾♂ E4.0 man playing water polo: medium-dark skin tone +1F93D 1F3FF 200D 2642 FE0F ; fully-qualified # 🤽🏿♂️ E4.0 man playing water polo: dark skin tone +1F93D 1F3FF 200D 2642 ; minimally-qualified # 🤽🏿♂ E4.0 man playing water polo: dark skin tone +1F93D 200D 2640 FE0F ; fully-qualified # 🤽♀️ E4.0 woman playing water polo +1F93D 200D 2640 ; minimally-qualified # 🤽♀ E4.0 woman playing water polo +1F93D 1F3FB 200D 2640 FE0F ; fully-qualified # 🤽🏻♀️ E4.0 woman playing water polo: light skin tone +1F93D 1F3FB 200D 2640 ; minimally-qualified # 🤽🏻♀ E4.0 woman playing water polo: light skin tone +1F93D 1F3FC 200D 2640 FE0F ; fully-qualified # 🤽🏼♀️ E4.0 woman playing water polo: medium-light skin tone +1F93D 1F3FC 200D 2640 ; minimally-qualified # 🤽🏼♀ E4.0 woman playing water polo: medium-light skin tone +1F93D 1F3FD 200D 2640 FE0F ; fully-qualified # 🤽🏽♀️ E4.0 woman playing water polo: medium skin tone +1F93D 1F3FD 200D 2640 ; minimally-qualified # 🤽🏽♀ E4.0 woman playing water polo: medium skin tone +1F93D 1F3FE 200D 2640 FE0F ; fully-qualified # 🤽🏾♀️ E4.0 woman playing water polo: medium-dark skin tone +1F93D 1F3FE 200D 2640 ; minimally-qualified # 🤽🏾♀ E4.0 woman playing water polo: medium-dark skin tone +1F93D 1F3FF 200D 2640 FE0F ; fully-qualified # 🤽🏿♀️ E4.0 woman playing water polo: dark skin tone +1F93D 1F3FF 200D 2640 ; minimally-qualified # 🤽🏿♀ E4.0 woman playing water polo: dark skin tone +1F93E ; fully-qualified # 🤾 E3.0 person playing handball +1F93E 1F3FB ; fully-qualified # 🤾🏻 E3.0 person playing handball: light skin tone +1F93E 1F3FC ; fully-qualified # 🤾🏼 E3.0 person playing handball: medium-light skin tone +1F93E 1F3FD ; fully-qualified # 🤾🏽 E3.0 person playing handball: medium skin tone +1F93E 1F3FE ; fully-qualified # 🤾🏾 E3.0 person playing handball: medium-dark skin tone +1F93E 1F3FF ; fully-qualified # 🤾🏿 E3.0 person playing handball: dark skin tone +1F93E 200D 2642 FE0F ; fully-qualified # 🤾♂️ E4.0 man playing handball +1F93E 200D 2642 ; minimally-qualified # 🤾♂ E4.0 man playing handball +1F93E 1F3FB 200D 2642 FE0F ; fully-qualified # 🤾🏻♂️ E4.0 man playing handball: light skin tone +1F93E 1F3FB 200D 2642 ; minimally-qualified # 🤾🏻♂ E4.0 man playing handball: light skin tone +1F93E 1F3FC 200D 2642 FE0F ; fully-qualified # 🤾🏼♂️ E4.0 man playing handball: medium-light skin tone +1F93E 1F3FC 200D 2642 ; minimally-qualified # 🤾🏼♂ E4.0 man playing handball: medium-light skin tone +1F93E 1F3FD 200D 2642 FE0F ; fully-qualified # 🤾🏽♂️ E4.0 man playing handball: medium skin tone +1F93E 1F3FD 200D 2642 ; minimally-qualified # 🤾🏽♂ E4.0 man playing handball: medium skin tone +1F93E 1F3FE 200D 2642 FE0F ; fully-qualified # 🤾🏾♂️ E4.0 man playing handball: medium-dark skin tone +1F93E 1F3FE 200D 2642 ; minimally-qualified # 🤾🏾♂ E4.0 man playing handball: medium-dark skin tone +1F93E 1F3FF 200D 2642 FE0F ; fully-qualified # 🤾🏿♂️ E4.0 man playing handball: dark skin tone +1F93E 1F3FF 200D 2642 ; minimally-qualified # 🤾🏿♂ E4.0 man playing handball: dark skin tone +1F93E 200D 2640 FE0F ; fully-qualified # 🤾♀️ E4.0 woman playing handball +1F93E 200D 2640 ; minimally-qualified # 🤾♀ E4.0 woman playing handball +1F93E 1F3FB 200D 2640 FE0F ; fully-qualified # 🤾🏻♀️ E4.0 woman playing handball: light skin tone +1F93E 1F3FB 200D 2640 ; minimally-qualified # 🤾🏻♀ E4.0 woman playing handball: light skin tone +1F93E 1F3FC 200D 2640 FE0F ; fully-qualified # 🤾🏼♀️ E4.0 woman playing handball: medium-light skin tone +1F93E 1F3FC 200D 2640 ; minimally-qualified # 🤾🏼♀ E4.0 woman playing handball: medium-light skin tone +1F93E 1F3FD 200D 2640 FE0F ; fully-qualified # 🤾🏽♀️ E4.0 woman playing handball: medium skin tone +1F93E 1F3FD 200D 2640 ; minimally-qualified # 🤾🏽♀ E4.0 woman playing handball: medium skin tone +1F93E 1F3FE 200D 2640 FE0F ; fully-qualified # 🤾🏾♀️ E4.0 woman playing handball: medium-dark skin tone +1F93E 1F3FE 200D 2640 ; minimally-qualified # 🤾🏾♀ E4.0 woman playing handball: medium-dark skin tone +1F93E 1F3FF 200D 2640 FE0F ; fully-qualified # 🤾🏿♀️ E4.0 woman playing handball: dark skin tone +1F93E 1F3FF 200D 2640 ; minimally-qualified # 🤾🏿♀ E4.0 woman playing handball: dark skin tone +1F939 ; fully-qualified # 🤹 E3.0 person juggling +1F939 1F3FB ; fully-qualified # 🤹🏻 E3.0 person juggling: light skin tone +1F939 1F3FC ; fully-qualified # 🤹🏼 E3.0 person juggling: medium-light skin tone +1F939 1F3FD ; fully-qualified # 🤹🏽 E3.0 person juggling: medium skin tone +1F939 1F3FE ; fully-qualified # 🤹🏾 E3.0 person juggling: medium-dark skin tone +1F939 1F3FF ; fully-qualified # 🤹🏿 E3.0 person juggling: dark skin tone +1F939 200D 2642 FE0F ; fully-qualified # 🤹♂️ E4.0 man juggling +1F939 200D 2642 ; minimally-qualified # 🤹♂ E4.0 man juggling +1F939 1F3FB 200D 2642 FE0F ; fully-qualified # 🤹🏻♂️ E4.0 man juggling: light skin tone +1F939 1F3FB 200D 2642 ; minimally-qualified # 🤹🏻♂ E4.0 man juggling: light skin tone +1F939 1F3FC 200D 2642 FE0F ; fully-qualified # 🤹🏼♂️ E4.0 man juggling: medium-light skin tone +1F939 1F3FC 200D 2642 ; minimally-qualified # 🤹🏼♂ E4.0 man juggling: medium-light skin tone +1F939 1F3FD 200D 2642 FE0F ; fully-qualified # 🤹🏽♂️ E4.0 man juggling: medium skin tone +1F939 1F3FD 200D 2642 ; minimally-qualified # 🤹🏽♂ E4.0 man juggling: medium skin tone +1F939 1F3FE 200D 2642 FE0F ; fully-qualified # 🤹🏾♂️ E4.0 man juggling: medium-dark skin tone +1F939 1F3FE 200D 2642 ; minimally-qualified # 🤹🏾♂ E4.0 man juggling: medium-dark skin tone +1F939 1F3FF 200D 2642 FE0F ; fully-qualified # 🤹🏿♂️ E4.0 man juggling: dark skin tone +1F939 1F3FF 200D 2642 ; minimally-qualified # 🤹🏿♂ E4.0 man juggling: dark skin tone +1F939 200D 2640 FE0F ; fully-qualified # 🤹♀️ E4.0 woman juggling +1F939 200D 2640 ; minimally-qualified # 🤹♀ E4.0 woman juggling +1F939 1F3FB 200D 2640 FE0F ; fully-qualified # 🤹🏻♀️ E4.0 woman juggling: light skin tone +1F939 1F3FB 200D 2640 ; minimally-qualified # 🤹🏻♀ E4.0 woman juggling: light skin tone +1F939 1F3FC 200D 2640 FE0F ; fully-qualified # 🤹🏼♀️ E4.0 woman juggling: medium-light skin tone +1F939 1F3FC 200D 2640 ; minimally-qualified # 🤹🏼♀ E4.0 woman juggling: medium-light skin tone +1F939 1F3FD 200D 2640 FE0F ; fully-qualified # 🤹🏽♀️ E4.0 woman juggling: medium skin tone +1F939 1F3FD 200D 2640 ; minimally-qualified # 🤹🏽♀ E4.0 woman juggling: medium skin tone +1F939 1F3FE 200D 2640 FE0F ; fully-qualified # 🤹🏾♀️ E4.0 woman juggling: medium-dark skin tone +1F939 1F3FE 200D 2640 ; minimally-qualified # 🤹🏾♀ E4.0 woman juggling: medium-dark skin tone +1F939 1F3FF 200D 2640 FE0F ; fully-qualified # 🤹🏿♀️ E4.0 woman juggling: dark skin tone +1F939 1F3FF 200D 2640 ; minimally-qualified # 🤹🏿♀ E4.0 woman juggling: dark skin tone + +# subgroup: person-resting +1F9D8 ; fully-qualified # 🧘 E5.0 person in lotus position +1F9D8 1F3FB ; fully-qualified # 🧘🏻 E5.0 person in lotus position: light skin tone +1F9D8 1F3FC ; fully-qualified # 🧘🏼 E5.0 person in lotus position: medium-light skin tone +1F9D8 1F3FD ; fully-qualified # 🧘🏽 E5.0 person in lotus position: medium skin tone +1F9D8 1F3FE ; fully-qualified # 🧘🏾 E5.0 person in lotus position: medium-dark skin tone +1F9D8 1F3FF ; fully-qualified # 🧘🏿 E5.0 person in lotus position: dark skin tone +1F9D8 200D 2642 FE0F ; fully-qualified # 🧘♂️ E5.0 man in lotus position +1F9D8 200D 2642 ; minimally-qualified # 🧘♂ E5.0 man in lotus position +1F9D8 1F3FB 200D 2642 FE0F ; fully-qualified # 🧘🏻♂️ E5.0 man in lotus position: light skin tone +1F9D8 1F3FB 200D 2642 ; minimally-qualified # 🧘🏻♂ E5.0 man in lotus position: light skin tone +1F9D8 1F3FC 200D 2642 FE0F ; fully-qualified # 🧘🏼♂️ E5.0 man in lotus position: medium-light skin tone +1F9D8 1F3FC 200D 2642 ; minimally-qualified # 🧘🏼♂ E5.0 man in lotus position: medium-light skin tone +1F9D8 1F3FD 200D 2642 FE0F ; fully-qualified # 🧘🏽♂️ E5.0 man in lotus position: medium skin tone +1F9D8 1F3FD 200D 2642 ; minimally-qualified # 🧘🏽♂ E5.0 man in lotus position: medium skin tone +1F9D8 1F3FE 200D 2642 FE0F ; fully-qualified # 🧘🏾♂️ E5.0 man in lotus position: medium-dark skin tone +1F9D8 1F3FE 200D 2642 ; minimally-qualified # 🧘🏾♂ E5.0 man in lotus position: medium-dark skin tone +1F9D8 1F3FF 200D 2642 FE0F ; fully-qualified # 🧘🏿♂️ E5.0 man in lotus position: dark skin tone +1F9D8 1F3FF 200D 2642 ; minimally-qualified # 🧘🏿♂ E5.0 man in lotus position: dark skin tone +1F9D8 200D 2640 FE0F ; fully-qualified # 🧘♀️ E5.0 woman in lotus position +1F9D8 200D 2640 ; minimally-qualified # 🧘♀ E5.0 woman in lotus position +1F9D8 1F3FB 200D 2640 FE0F ; fully-qualified # 🧘🏻♀️ E5.0 woman in lotus position: light skin tone +1F9D8 1F3FB 200D 2640 ; minimally-qualified # 🧘🏻♀ E5.0 woman in lotus position: light skin tone +1F9D8 1F3FC 200D 2640 FE0F ; fully-qualified # 🧘🏼♀️ E5.0 woman in lotus position: medium-light skin tone +1F9D8 1F3FC 200D 2640 ; minimally-qualified # 🧘🏼♀ E5.0 woman in lotus position: medium-light skin tone +1F9D8 1F3FD 200D 2640 FE0F ; fully-qualified # 🧘🏽♀️ E5.0 woman in lotus position: medium skin tone +1F9D8 1F3FD 200D 2640 ; minimally-qualified # 🧘🏽♀ E5.0 woman in lotus position: medium skin tone +1F9D8 1F3FE 200D 2640 FE0F ; fully-qualified # 🧘🏾♀️ E5.0 woman in lotus position: medium-dark skin tone +1F9D8 1F3FE 200D 2640 ; minimally-qualified # 🧘🏾♀ E5.0 woman in lotus position: medium-dark skin tone +1F9D8 1F3FF 200D 2640 FE0F ; fully-qualified # 🧘🏿♀️ E5.0 woman in lotus position: dark skin tone +1F9D8 1F3FF 200D 2640 ; minimally-qualified # 🧘🏿♀ E5.0 woman in lotus position: dark skin tone +1F6C0 ; fully-qualified # 🛀 E0.6 person taking bath +1F6C0 1F3FB ; fully-qualified # 🛀🏻 E1.0 person taking bath: light skin tone +1F6C0 1F3FC ; fully-qualified # 🛀🏼 E1.0 person taking bath: medium-light skin tone +1F6C0 1F3FD ; fully-qualified # 🛀🏽 E1.0 person taking bath: medium skin tone +1F6C0 1F3FE ; fully-qualified # 🛀🏾 E1.0 person taking bath: medium-dark skin tone +1F6C0 1F3FF ; fully-qualified # 🛀🏿 E1.0 person taking bath: dark skin tone +1F6CC ; fully-qualified # 🛌 E1.0 person in bed +1F6CC 1F3FB ; fully-qualified # 🛌🏻 E4.0 person in bed: light skin tone +1F6CC 1F3FC ; fully-qualified # 🛌🏼 E4.0 person in bed: medium-light skin tone +1F6CC 1F3FD ; fully-qualified # 🛌🏽 E4.0 person in bed: medium skin tone +1F6CC 1F3FE ; fully-qualified # 🛌🏾 E4.0 person in bed: medium-dark skin tone +1F6CC 1F3FF ; fully-qualified # 🛌🏿 E4.0 person in bed: dark skin tone + +# subgroup: family +1F9D1 200D 1F91D 200D 1F9D1 ; fully-qualified # 🧑🤝🧑 E12.0 people holding hands +1F9D1 1F3FB 200D 1F91D 200D 1F9D1 1F3FB ; fully-qualified # 🧑🏻🤝🧑🏻 E12.0 people holding hands: light skin tone +1F9D1 1F3FB 200D 1F91D 200D 1F9D1 1F3FC ; fully-qualified # 🧑🏻🤝🧑🏼 E12.1 people holding hands: light skin tone, medium-light skin tone +1F9D1 1F3FB 200D 1F91D 200D 1F9D1 1F3FD ; fully-qualified # 🧑🏻🤝🧑🏽 E12.1 people holding hands: light skin tone, medium skin tone +1F9D1 1F3FB 200D 1F91D 200D 1F9D1 1F3FE ; fully-qualified # 🧑🏻🤝🧑🏾 E12.1 people holding hands: light skin tone, medium-dark skin tone +1F9D1 1F3FB 200D 1F91D 200D 1F9D1 1F3FF ; fully-qualified # 🧑🏻🤝🧑🏿 E12.1 people holding hands: light skin tone, dark skin tone +1F9D1 1F3FC 200D 1F91D 200D 1F9D1 1F3FB ; fully-qualified # 🧑🏼🤝🧑🏻 E12.0 people holding hands: medium-light skin tone, light skin tone +1F9D1 1F3FC 200D 1F91D 200D 1F9D1 1F3FC ; fully-qualified # 🧑🏼🤝🧑🏼 E12.0 people holding hands: medium-light skin tone +1F9D1 1F3FC 200D 1F91D 200D 1F9D1 1F3FD ; fully-qualified # 🧑🏼🤝🧑🏽 E12.1 people holding hands: medium-light skin tone, medium skin tone +1F9D1 1F3FC 200D 1F91D 200D 1F9D1 1F3FE ; fully-qualified # 🧑🏼🤝🧑🏾 E12.1 people holding hands: medium-light skin tone, medium-dark skin tone +1F9D1 1F3FC 200D 1F91D 200D 1F9D1 1F3FF ; fully-qualified # 🧑🏼🤝🧑🏿 E12.1 people holding hands: medium-light skin tone, dark skin tone +1F9D1 1F3FD 200D 1F91D 200D 1F9D1 1F3FB ; fully-qualified # 🧑🏽🤝🧑🏻 E12.0 people holding hands: medium skin tone, light skin tone +1F9D1 1F3FD 200D 1F91D 200D 1F9D1 1F3FC ; fully-qualified # 🧑🏽🤝🧑🏼 E12.0 people holding hands: medium skin tone, medium-light skin tone +1F9D1 1F3FD 200D 1F91D 200D 1F9D1 1F3FD ; fully-qualified # 🧑🏽🤝🧑🏽 E12.0 people holding hands: medium skin tone +1F9D1 1F3FD 200D 1F91D 200D 1F9D1 1F3FE ; fully-qualified # 🧑🏽🤝🧑🏾 E12.1 people holding hands: medium skin tone, medium-dark skin tone +1F9D1 1F3FD 200D 1F91D 200D 1F9D1 1F3FF ; fully-qualified # 🧑🏽🤝🧑🏿 E12.1 people holding hands: medium skin tone, dark skin tone +1F9D1 1F3FE 200D 1F91D 200D 1F9D1 1F3FB ; fully-qualified # 🧑🏾🤝🧑🏻 E12.0 people holding hands: medium-dark skin tone, light skin tone +1F9D1 1F3FE 200D 1F91D 200D 1F9D1 1F3FC ; fully-qualified # 🧑🏾🤝🧑🏼 E12.0 people holding hands: medium-dark skin tone, medium-light skin tone +1F9D1 1F3FE 200D 1F91D 200D 1F9D1 1F3FD ; fully-qualified # 🧑🏾🤝🧑🏽 E12.0 people holding hands: medium-dark skin tone, medium skin tone +1F9D1 1F3FE 200D 1F91D 200D 1F9D1 1F3FE ; fully-qualified # 🧑🏾🤝🧑🏾 E12.0 people holding hands: medium-dark skin tone +1F9D1 1F3FE 200D 1F91D 200D 1F9D1 1F3FF ; fully-qualified # 🧑🏾🤝🧑🏿 E12.1 people holding hands: medium-dark skin tone, dark skin tone +1F9D1 1F3FF 200D 1F91D 200D 1F9D1 1F3FB ; fully-qualified # 🧑🏿🤝🧑🏻 E12.0 people holding hands: dark skin tone, light skin tone +1F9D1 1F3FF 200D 1F91D 200D 1F9D1 1F3FC ; fully-qualified # 🧑🏿🤝🧑🏼 E12.0 people holding hands: dark skin tone, medium-light skin tone +1F9D1 1F3FF 200D 1F91D 200D 1F9D1 1F3FD ; fully-qualified # 🧑🏿🤝🧑🏽 E12.0 people holding hands: dark skin tone, medium skin tone +1F9D1 1F3FF 200D 1F91D 200D 1F9D1 1F3FE ; fully-qualified # 🧑🏿🤝🧑🏾 E12.0 people holding hands: dark skin tone, medium-dark skin tone +1F9D1 1F3FF 200D 1F91D 200D 1F9D1 1F3FF ; fully-qualified # 🧑🏿🤝🧑🏿 E12.0 people holding hands: dark skin tone +1F46D ; fully-qualified # 👭 E1.0 women holding hands +1F46D 1F3FB ; fully-qualified # 👭🏻 E12.0 women holding hands: light skin tone +1F469 1F3FB 200D 1F91D 200D 1F469 1F3FC ; fully-qualified # 👩🏻🤝👩🏼 E12.1 women holding hands: light skin tone, medium-light skin tone +1F469 1F3FB 200D 1F91D 200D 1F469 1F3FD ; fully-qualified # 👩🏻🤝👩🏽 E12.1 women holding hands: light skin tone, medium skin tone +1F469 1F3FB 200D 1F91D 200D 1F469 1F3FE ; fully-qualified # 👩🏻🤝👩🏾 E12.1 women holding hands: light skin tone, medium-dark skin tone +1F469 1F3FB 200D 1F91D 200D 1F469 1F3FF ; fully-qualified # 👩🏻🤝👩🏿 E12.1 women holding hands: light skin tone, dark skin tone +1F469 1F3FC 200D 1F91D 200D 1F469 1F3FB ; fully-qualified # 👩🏼🤝👩🏻 E12.0 women holding hands: medium-light skin tone, light skin tone +1F46D 1F3FC ; fully-qualified # 👭🏼 E12.0 women holding hands: medium-light skin tone +1F469 1F3FC 200D 1F91D 200D 1F469 1F3FD ; fully-qualified # 👩🏼🤝👩🏽 E12.1 women holding hands: medium-light skin tone, medium skin tone +1F469 1F3FC 200D 1F91D 200D 1F469 1F3FE ; fully-qualified # 👩🏼🤝👩🏾 E12.1 women holding hands: medium-light skin tone, medium-dark skin tone +1F469 1F3FC 200D 1F91D 200D 1F469 1F3FF ; fully-qualified # 👩🏼🤝👩🏿 E12.1 women holding hands: medium-light skin tone, dark skin tone +1F469 1F3FD 200D 1F91D 200D 1F469 1F3FB ; fully-qualified # 👩🏽🤝👩🏻 E12.0 women holding hands: medium skin tone, light skin tone +1F469 1F3FD 200D 1F91D 200D 1F469 1F3FC ; fully-qualified # 👩🏽🤝👩🏼 E12.0 women holding hands: medium skin tone, medium-light skin tone +1F46D 1F3FD ; fully-qualified # 👭🏽 E12.0 women holding hands: medium skin tone +1F469 1F3FD 200D 1F91D 200D 1F469 1F3FE ; fully-qualified # 👩🏽🤝👩🏾 E12.1 women holding hands: medium skin tone, medium-dark skin tone +1F469 1F3FD 200D 1F91D 200D 1F469 1F3FF ; fully-qualified # 👩🏽🤝👩🏿 E12.1 women holding hands: medium skin tone, dark skin tone +1F469 1F3FE 200D 1F91D 200D 1F469 1F3FB ; fully-qualified # 👩🏾🤝👩🏻 E12.0 women holding hands: medium-dark skin tone, light skin tone +1F469 1F3FE 200D 1F91D 200D 1F469 1F3FC ; fully-qualified # 👩🏾🤝👩🏼 E12.0 women holding hands: medium-dark skin tone, medium-light skin tone +1F469 1F3FE 200D 1F91D 200D 1F469 1F3FD ; fully-qualified # 👩🏾🤝👩🏽 E12.0 women holding hands: medium-dark skin tone, medium skin tone +1F46D 1F3FE ; fully-qualified # 👭🏾 E12.0 women holding hands: medium-dark skin tone +1F469 1F3FE 200D 1F91D 200D 1F469 1F3FF ; fully-qualified # 👩🏾🤝👩🏿 E12.1 women holding hands: medium-dark skin tone, dark skin tone +1F469 1F3FF 200D 1F91D 200D 1F469 1F3FB ; fully-qualified # 👩🏿🤝👩🏻 E12.0 women holding hands: dark skin tone, light skin tone +1F469 1F3FF 200D 1F91D 200D 1F469 1F3FC ; fully-qualified # 👩🏿🤝👩🏼 E12.0 women holding hands: dark skin tone, medium-light skin tone +1F469 1F3FF 200D 1F91D 200D 1F469 1F3FD ; fully-qualified # 👩🏿🤝👩🏽 E12.0 women holding hands: dark skin tone, medium skin tone +1F469 1F3FF 200D 1F91D 200D 1F469 1F3FE ; fully-qualified # 👩🏿🤝👩🏾 E12.0 women holding hands: dark skin tone, medium-dark skin tone +1F46D 1F3FF ; fully-qualified # 👭🏿 E12.0 women holding hands: dark skin tone +1F46B ; fully-qualified # 👫 E0.6 woman and man holding hands +1F46B 1F3FB ; fully-qualified # 👫🏻 E12.0 woman and man holding hands: light skin tone +1F469 1F3FB 200D 1F91D 200D 1F468 1F3FC ; fully-qualified # 👩🏻🤝👨🏼 E12.0 woman and man holding hands: light skin tone, medium-light skin tone +1F469 1F3FB 200D 1F91D 200D 1F468 1F3FD ; fully-qualified # 👩🏻🤝👨🏽 E12.0 woman and man holding hands: light skin tone, medium skin tone +1F469 1F3FB 200D 1F91D 200D 1F468 1F3FE ; fully-qualified # 👩🏻🤝👨🏾 E12.0 woman and man holding hands: light skin tone, medium-dark skin tone +1F469 1F3FB 200D 1F91D 200D 1F468 1F3FF ; fully-qualified # 👩🏻🤝👨🏿 E12.0 woman and man holding hands: light skin tone, dark skin tone +1F469 1F3FC 200D 1F91D 200D 1F468 1F3FB ; fully-qualified # 👩🏼🤝👨🏻 E12.0 woman and man holding hands: medium-light skin tone, light skin tone +1F46B 1F3FC ; fully-qualified # 👫🏼 E12.0 woman and man holding hands: medium-light skin tone +1F469 1F3FC 200D 1F91D 200D 1F468 1F3FD ; fully-qualified # 👩🏼🤝👨🏽 E12.0 woman and man holding hands: medium-light skin tone, medium skin tone +1F469 1F3FC 200D 1F91D 200D 1F468 1F3FE ; fully-qualified # 👩🏼🤝👨🏾 E12.0 woman and man holding hands: medium-light skin tone, medium-dark skin tone +1F469 1F3FC 200D 1F91D 200D 1F468 1F3FF ; fully-qualified # 👩🏼🤝👨🏿 E12.0 woman and man holding hands: medium-light skin tone, dark skin tone +1F469 1F3FD 200D 1F91D 200D 1F468 1F3FB ; fully-qualified # 👩🏽🤝👨🏻 E12.0 woman and man holding hands: medium skin tone, light skin tone +1F469 1F3FD 200D 1F91D 200D 1F468 1F3FC ; fully-qualified # 👩🏽🤝👨🏼 E12.0 woman and man holding hands: medium skin tone, medium-light skin tone +1F46B 1F3FD ; fully-qualified # 👫🏽 E12.0 woman and man holding hands: medium skin tone +1F469 1F3FD 200D 1F91D 200D 1F468 1F3FE ; fully-qualified # 👩🏽🤝👨🏾 E12.0 woman and man holding hands: medium skin tone, medium-dark skin tone +1F469 1F3FD 200D 1F91D 200D 1F468 1F3FF ; fully-qualified # 👩🏽🤝👨🏿 E12.0 woman and man holding hands: medium skin tone, dark skin tone +1F469 1F3FE 200D 1F91D 200D 1F468 1F3FB ; fully-qualified # 👩🏾🤝👨🏻 E12.0 woman and man holding hands: medium-dark skin tone, light skin tone +1F469 1F3FE 200D 1F91D 200D 1F468 1F3FC ; fully-qualified # 👩🏾🤝👨🏼 E12.0 woman and man holding hands: medium-dark skin tone, medium-light skin tone +1F469 1F3FE 200D 1F91D 200D 1F468 1F3FD ; fully-qualified # 👩🏾🤝👨🏽 E12.0 woman and man holding hands: medium-dark skin tone, medium skin tone +1F46B 1F3FE ; fully-qualified # 👫🏾 E12.0 woman and man holding hands: medium-dark skin tone +1F469 1F3FE 200D 1F91D 200D 1F468 1F3FF ; fully-qualified # 👩🏾🤝👨🏿 E12.0 woman and man holding hands: medium-dark skin tone, dark skin tone +1F469 1F3FF 200D 1F91D 200D 1F468 1F3FB ; fully-qualified # 👩🏿🤝👨🏻 E12.0 woman and man holding hands: dark skin tone, light skin tone +1F469 1F3FF 200D 1F91D 200D 1F468 1F3FC ; fully-qualified # 👩🏿🤝👨🏼 E12.0 woman and man holding hands: dark skin tone, medium-light skin tone +1F469 1F3FF 200D 1F91D 200D 1F468 1F3FD ; fully-qualified # 👩🏿🤝👨🏽 E12.0 woman and man holding hands: dark skin tone, medium skin tone +1F469 1F3FF 200D 1F91D 200D 1F468 1F3FE ; fully-qualified # 👩🏿🤝👨🏾 E12.0 woman and man holding hands: dark skin tone, medium-dark skin tone +1F46B 1F3FF ; fully-qualified # 👫🏿 E12.0 woman and man holding hands: dark skin tone +1F46C ; fully-qualified # 👬 E1.0 men holding hands +1F46C 1F3FB ; fully-qualified # 👬🏻 E12.0 men holding hands: light skin tone +1F468 1F3FB 200D 1F91D 200D 1F468 1F3FC ; fully-qualified # 👨🏻🤝👨🏼 E12.1 men holding hands: light skin tone, medium-light skin tone +1F468 1F3FB 200D 1F91D 200D 1F468 1F3FD ; fully-qualified # 👨🏻🤝👨🏽 E12.1 men holding hands: light skin tone, medium skin tone +1F468 1F3FB 200D 1F91D 200D 1F468 1F3FE ; fully-qualified # 👨🏻🤝👨🏾 E12.1 men holding hands: light skin tone, medium-dark skin tone +1F468 1F3FB 200D 1F91D 200D 1F468 1F3FF ; fully-qualified # 👨🏻🤝👨🏿 E12.1 men holding hands: light skin tone, dark skin tone +1F468 1F3FC 200D 1F91D 200D 1F468 1F3FB ; fully-qualified # 👨🏼🤝👨🏻 E12.0 men holding hands: medium-light skin tone, light skin tone +1F46C 1F3FC ; fully-qualified # 👬🏼 E12.0 men holding hands: medium-light skin tone +1F468 1F3FC 200D 1F91D 200D 1F468 1F3FD ; fully-qualified # 👨🏼🤝👨🏽 E12.1 men holding hands: medium-light skin tone, medium skin tone +1F468 1F3FC 200D 1F91D 200D 1F468 1F3FE ; fully-qualified # 👨🏼🤝👨🏾 E12.1 men holding hands: medium-light skin tone, medium-dark skin tone +1F468 1F3FC 200D 1F91D 200D 1F468 1F3FF ; fully-qualified # 👨🏼🤝👨🏿 E12.1 men holding hands: medium-light skin tone, dark skin tone +1F468 1F3FD 200D 1F91D 200D 1F468 1F3FB ; fully-qualified # 👨🏽🤝👨🏻 E12.0 men holding hands: medium skin tone, light skin tone +1F468 1F3FD 200D 1F91D 200D 1F468 1F3FC ; fully-qualified # 👨🏽🤝👨🏼 E12.0 men holding hands: medium skin tone, medium-light skin tone +1F46C 1F3FD ; fully-qualified # 👬🏽 E12.0 men holding hands: medium skin tone +1F468 1F3FD 200D 1F91D 200D 1F468 1F3FE ; fully-qualified # 👨🏽🤝👨🏾 E12.1 men holding hands: medium skin tone, medium-dark skin tone +1F468 1F3FD 200D 1F91D 200D 1F468 1F3FF ; fully-qualified # 👨🏽🤝👨🏿 E12.1 men holding hands: medium skin tone, dark skin tone +1F468 1F3FE 200D 1F91D 200D 1F468 1F3FB ; fully-qualified # 👨🏾🤝👨🏻 E12.0 men holding hands: medium-dark skin tone, light skin tone +1F468 1F3FE 200D 1F91D 200D 1F468 1F3FC ; fully-qualified # 👨🏾🤝👨🏼 E12.0 men holding hands: medium-dark skin tone, medium-light skin tone +1F468 1F3FE 200D 1F91D 200D 1F468 1F3FD ; fully-qualified # 👨🏾🤝👨🏽 E12.0 men holding hands: medium-dark skin tone, medium skin tone +1F46C 1F3FE ; fully-qualified # 👬🏾 E12.0 men holding hands: medium-dark skin tone +1F468 1F3FE 200D 1F91D 200D 1F468 1F3FF ; fully-qualified # 👨🏾🤝👨🏿 E12.1 men holding hands: medium-dark skin tone, dark skin tone +1F468 1F3FF 200D 1F91D 200D 1F468 1F3FB ; fully-qualified # 👨🏿🤝👨🏻 E12.0 men holding hands: dark skin tone, light skin tone +1F468 1F3FF 200D 1F91D 200D 1F468 1F3FC ; fully-qualified # 👨🏿🤝👨🏼 E12.0 men holding hands: dark skin tone, medium-light skin tone +1F468 1F3FF 200D 1F91D 200D 1F468 1F3FD ; fully-qualified # 👨🏿🤝👨🏽 E12.0 men holding hands: dark skin tone, medium skin tone +1F468 1F3FF 200D 1F91D 200D 1F468 1F3FE ; fully-qualified # 👨🏿🤝👨🏾 E12.0 men holding hands: dark skin tone, medium-dark skin tone +1F46C 1F3FF ; fully-qualified # 👬🏿 E12.0 men holding hands: dark skin tone +1F48F ; fully-qualified # 💏 E0.6 kiss +1F48F 1F3FB ; fully-qualified # 💏🏻 E13.1 kiss: light skin tone +1F48F 1F3FC ; fully-qualified # 💏🏼 E13.1 kiss: medium-light skin tone +1F48F 1F3FD ; fully-qualified # 💏🏽 E13.1 kiss: medium skin tone +1F48F 1F3FE ; fully-qualified # 💏🏾 E13.1 kiss: medium-dark skin tone +1F48F 1F3FF ; fully-qualified # 💏🏿 E13.1 kiss: dark skin tone +1F9D1 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FC ; fully-qualified # 🧑🏻❤️💋🧑🏼 E13.1 kiss: person, person, light skin tone, medium-light skin tone +1F9D1 1F3FB 200D 2764 200D 1F48B 200D 1F9D1 1F3FC ; minimally-qualified # 🧑🏻❤💋🧑🏼 E13.1 kiss: person, person, light skin tone, medium-light skin tone +1F9D1 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FD ; fully-qualified # 🧑🏻❤️💋🧑🏽 E13.1 kiss: person, person, light skin tone, medium skin tone +1F9D1 1F3FB 200D 2764 200D 1F48B 200D 1F9D1 1F3FD ; minimally-qualified # 🧑🏻❤💋🧑🏽 E13.1 kiss: person, person, light skin tone, medium skin tone +1F9D1 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FE ; fully-qualified # 🧑🏻❤️💋🧑🏾 E13.1 kiss: person, person, light skin tone, medium-dark skin tone +1F9D1 1F3FB 200D 2764 200D 1F48B 200D 1F9D1 1F3FE ; minimally-qualified # 🧑🏻❤💋🧑🏾 E13.1 kiss: person, person, light skin tone, medium-dark skin tone +1F9D1 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FF ; fully-qualified # 🧑🏻❤️💋🧑🏿 E13.1 kiss: person, person, light skin tone, dark skin tone +1F9D1 1F3FB 200D 2764 200D 1F48B 200D 1F9D1 1F3FF ; minimally-qualified # 🧑🏻❤💋🧑🏿 E13.1 kiss: person, person, light skin tone, dark skin tone +1F9D1 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FB ; fully-qualified # 🧑🏼❤️💋🧑🏻 E13.1 kiss: person, person, medium-light skin tone, light skin tone +1F9D1 1F3FC 200D 2764 200D 1F48B 200D 1F9D1 1F3FB ; minimally-qualified # 🧑🏼❤💋🧑🏻 E13.1 kiss: person, person, medium-light skin tone, light skin tone +1F9D1 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FD ; fully-qualified # 🧑🏼❤️💋🧑🏽 E13.1 kiss: person, person, medium-light skin tone, medium skin tone +1F9D1 1F3FC 200D 2764 200D 1F48B 200D 1F9D1 1F3FD ; minimally-qualified # 🧑🏼❤💋🧑🏽 E13.1 kiss: person, person, medium-light skin tone, medium skin tone +1F9D1 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FE ; fully-qualified # 🧑🏼❤️💋🧑🏾 E13.1 kiss: person, person, medium-light skin tone, medium-dark skin tone +1F9D1 1F3FC 200D 2764 200D 1F48B 200D 1F9D1 1F3FE ; minimally-qualified # 🧑🏼❤💋🧑🏾 E13.1 kiss: person, person, medium-light skin tone, medium-dark skin tone +1F9D1 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FF ; fully-qualified # 🧑🏼❤️💋🧑🏿 E13.1 kiss: person, person, medium-light skin tone, dark skin tone +1F9D1 1F3FC 200D 2764 200D 1F48B 200D 1F9D1 1F3FF ; minimally-qualified # 🧑🏼❤💋🧑🏿 E13.1 kiss: person, person, medium-light skin tone, dark skin tone +1F9D1 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FB ; fully-qualified # 🧑🏽❤️💋🧑🏻 E13.1 kiss: person, person, medium skin tone, light skin tone +1F9D1 1F3FD 200D 2764 200D 1F48B 200D 1F9D1 1F3FB ; minimally-qualified # 🧑🏽❤💋🧑🏻 E13.1 kiss: person, person, medium skin tone, light skin tone +1F9D1 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FC ; fully-qualified # 🧑🏽❤️💋🧑🏼 E13.1 kiss: person, person, medium skin tone, medium-light skin tone +1F9D1 1F3FD 200D 2764 200D 1F48B 200D 1F9D1 1F3FC ; minimally-qualified # 🧑🏽❤💋🧑🏼 E13.1 kiss: person, person, medium skin tone, medium-light skin tone +1F9D1 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FE ; fully-qualified # 🧑🏽❤️💋🧑🏾 E13.1 kiss: person, person, medium skin tone, medium-dark skin tone +1F9D1 1F3FD 200D 2764 200D 1F48B 200D 1F9D1 1F3FE ; minimally-qualified # 🧑🏽❤💋🧑🏾 E13.1 kiss: person, person, medium skin tone, medium-dark skin tone +1F9D1 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FF ; fully-qualified # 🧑🏽❤️💋🧑🏿 E13.1 kiss: person, person, medium skin tone, dark skin tone +1F9D1 1F3FD 200D 2764 200D 1F48B 200D 1F9D1 1F3FF ; minimally-qualified # 🧑🏽❤💋🧑🏿 E13.1 kiss: person, person, medium skin tone, dark skin tone +1F9D1 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FB ; fully-qualified # 🧑🏾❤️💋🧑🏻 E13.1 kiss: person, person, medium-dark skin tone, light skin tone +1F9D1 1F3FE 200D 2764 200D 1F48B 200D 1F9D1 1F3FB ; minimally-qualified # 🧑🏾❤💋🧑🏻 E13.1 kiss: person, person, medium-dark skin tone, light skin tone +1F9D1 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FC ; fully-qualified # 🧑🏾❤️💋🧑🏼 E13.1 kiss: person, person, medium-dark skin tone, medium-light skin tone +1F9D1 1F3FE 200D 2764 200D 1F48B 200D 1F9D1 1F3FC ; minimally-qualified # 🧑🏾❤💋🧑🏼 E13.1 kiss: person, person, medium-dark skin tone, medium-light skin tone +1F9D1 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FD ; fully-qualified # 🧑🏾❤️💋🧑🏽 E13.1 kiss: person, person, medium-dark skin tone, medium skin tone +1F9D1 1F3FE 200D 2764 200D 1F48B 200D 1F9D1 1F3FD ; minimally-qualified # 🧑🏾❤💋🧑🏽 E13.1 kiss: person, person, medium-dark skin tone, medium skin tone +1F9D1 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FF ; fully-qualified # 🧑🏾❤️💋🧑🏿 E13.1 kiss: person, person, medium-dark skin tone, dark skin tone +1F9D1 1F3FE 200D 2764 200D 1F48B 200D 1F9D1 1F3FF ; minimally-qualified # 🧑🏾❤💋🧑🏿 E13.1 kiss: person, person, medium-dark skin tone, dark skin tone +1F9D1 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FB ; fully-qualified # 🧑🏿❤️💋🧑🏻 E13.1 kiss: person, person, dark skin tone, light skin tone +1F9D1 1F3FF 200D 2764 200D 1F48B 200D 1F9D1 1F3FB ; minimally-qualified # 🧑🏿❤💋🧑🏻 E13.1 kiss: person, person, dark skin tone, light skin tone +1F9D1 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FC ; fully-qualified # 🧑🏿❤️💋🧑🏼 E13.1 kiss: person, person, dark skin tone, medium-light skin tone +1F9D1 1F3FF 200D 2764 200D 1F48B 200D 1F9D1 1F3FC ; minimally-qualified # 🧑🏿❤💋🧑🏼 E13.1 kiss: person, person, dark skin tone, medium-light skin tone +1F9D1 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FD ; fully-qualified # 🧑🏿❤️💋🧑🏽 E13.1 kiss: person, person, dark skin tone, medium skin tone +1F9D1 1F3FF 200D 2764 200D 1F48B 200D 1F9D1 1F3FD ; minimally-qualified # 🧑🏿❤💋🧑🏽 E13.1 kiss: person, person, dark skin tone, medium skin tone +1F9D1 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FE ; fully-qualified # 🧑🏿❤️💋🧑🏾 E13.1 kiss: person, person, dark skin tone, medium-dark skin tone +1F9D1 1F3FF 200D 2764 200D 1F48B 200D 1F9D1 1F3FE ; minimally-qualified # 🧑🏿❤💋🧑🏾 E13.1 kiss: person, person, dark skin tone, medium-dark skin tone +1F469 200D 2764 FE0F 200D 1F48B 200D 1F468 ; fully-qualified # 👩❤️💋👨 E2.0 kiss: woman, man +1F469 200D 2764 200D 1F48B 200D 1F468 ; minimally-qualified # 👩❤💋👨 E2.0 kiss: woman, man +1F469 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FB ; fully-qualified # 👩🏻❤️💋👨🏻 E13.1 kiss: woman, man, light skin tone +1F469 1F3FB 200D 2764 200D 1F48B 200D 1F468 1F3FB ; minimally-qualified # 👩🏻❤💋👨🏻 E13.1 kiss: woman, man, light skin tone +1F469 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FC ; fully-qualified # 👩🏻❤️💋👨🏼 E13.1 kiss: woman, man, light skin tone, medium-light skin tone +1F469 1F3FB 200D 2764 200D 1F48B 200D 1F468 1F3FC ; minimally-qualified # 👩🏻❤💋👨🏼 E13.1 kiss: woman, man, light skin tone, medium-light skin tone +1F469 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FD ; fully-qualified # 👩🏻❤️💋👨🏽 E13.1 kiss: woman, man, light skin tone, medium skin tone +1F469 1F3FB 200D 2764 200D 1F48B 200D 1F468 1F3FD ; minimally-qualified # 👩🏻❤💋👨🏽 E13.1 kiss: woman, man, light skin tone, medium skin tone +1F469 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FE ; fully-qualified # 👩🏻❤️💋👨🏾 E13.1 kiss: woman, man, light skin tone, medium-dark skin tone +1F469 1F3FB 200D 2764 200D 1F48B 200D 1F468 1F3FE ; minimally-qualified # 👩🏻❤💋👨🏾 E13.1 kiss: woman, man, light skin tone, medium-dark skin tone +1F469 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FF ; fully-qualified # 👩🏻❤️💋👨🏿 E13.1 kiss: woman, man, light skin tone, dark skin tone +1F469 1F3FB 200D 2764 200D 1F48B 200D 1F468 1F3FF ; minimally-qualified # 👩🏻❤💋👨🏿 E13.1 kiss: woman, man, light skin tone, dark skin tone +1F469 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FB ; fully-qualified # 👩🏼❤️💋👨🏻 E13.1 kiss: woman, man, medium-light skin tone, light skin tone +1F469 1F3FC 200D 2764 200D 1F48B 200D 1F468 1F3FB ; minimally-qualified # 👩🏼❤💋👨🏻 E13.1 kiss: woman, man, medium-light skin tone, light skin tone +1F469 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FC ; fully-qualified # 👩🏼❤️💋👨🏼 E13.1 kiss: woman, man, medium-light skin tone +1F469 1F3FC 200D 2764 200D 1F48B 200D 1F468 1F3FC ; minimally-qualified # 👩🏼❤💋👨🏼 E13.1 kiss: woman, man, medium-light skin tone +1F469 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FD ; fully-qualified # 👩🏼❤️💋👨🏽 E13.1 kiss: woman, man, medium-light skin tone, medium skin tone +1F469 1F3FC 200D 2764 200D 1F48B 200D 1F468 1F3FD ; minimally-qualified # 👩🏼❤💋👨🏽 E13.1 kiss: woman, man, medium-light skin tone, medium skin tone +1F469 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FE ; fully-qualified # 👩🏼❤️💋👨🏾 E13.1 kiss: woman, man, medium-light skin tone, medium-dark skin tone +1F469 1F3FC 200D 2764 200D 1F48B 200D 1F468 1F3FE ; minimally-qualified # 👩🏼❤💋👨🏾 E13.1 kiss: woman, man, medium-light skin tone, medium-dark skin tone +1F469 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FF ; fully-qualified # 👩🏼❤️💋👨🏿 E13.1 kiss: woman, man, medium-light skin tone, dark skin tone +1F469 1F3FC 200D 2764 200D 1F48B 200D 1F468 1F3FF ; minimally-qualified # 👩🏼❤💋👨🏿 E13.1 kiss: woman, man, medium-light skin tone, dark skin tone +1F469 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FB ; fully-qualified # 👩🏽❤️💋👨🏻 E13.1 kiss: woman, man, medium skin tone, light skin tone +1F469 1F3FD 200D 2764 200D 1F48B 200D 1F468 1F3FB ; minimally-qualified # 👩🏽❤💋👨🏻 E13.1 kiss: woman, man, medium skin tone, light skin tone +1F469 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FC ; fully-qualified # 👩🏽❤️💋👨🏼 E13.1 kiss: woman, man, medium skin tone, medium-light skin tone +1F469 1F3FD 200D 2764 200D 1F48B 200D 1F468 1F3FC ; minimally-qualified # 👩🏽❤💋👨🏼 E13.1 kiss: woman, man, medium skin tone, medium-light skin tone +1F469 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FD ; fully-qualified # 👩🏽❤️💋👨🏽 E13.1 kiss: woman, man, medium skin tone +1F469 1F3FD 200D 2764 200D 1F48B 200D 1F468 1F3FD ; minimally-qualified # 👩🏽❤💋👨🏽 E13.1 kiss: woman, man, medium skin tone +1F469 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FE ; fully-qualified # 👩🏽❤️💋👨🏾 E13.1 kiss: woman, man, medium skin tone, medium-dark skin tone +1F469 1F3FD 200D 2764 200D 1F48B 200D 1F468 1F3FE ; minimally-qualified # 👩🏽❤💋👨🏾 E13.1 kiss: woman, man, medium skin tone, medium-dark skin tone +1F469 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FF ; fully-qualified # 👩🏽❤️💋👨🏿 E13.1 kiss: woman, man, medium skin tone, dark skin tone +1F469 1F3FD 200D 2764 200D 1F48B 200D 1F468 1F3FF ; minimally-qualified # 👩🏽❤💋👨🏿 E13.1 kiss: woman, man, medium skin tone, dark skin tone +1F469 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FB ; fully-qualified # 👩🏾❤️💋👨🏻 E13.1 kiss: woman, man, medium-dark skin tone, light skin tone +1F469 1F3FE 200D 2764 200D 1F48B 200D 1F468 1F3FB ; minimally-qualified # 👩🏾❤💋👨🏻 E13.1 kiss: woman, man, medium-dark skin tone, light skin tone +1F469 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FC ; fully-qualified # 👩🏾❤️💋👨🏼 E13.1 kiss: woman, man, medium-dark skin tone, medium-light skin tone +1F469 1F3FE 200D 2764 200D 1F48B 200D 1F468 1F3FC ; minimally-qualified # 👩🏾❤💋👨🏼 E13.1 kiss: woman, man, medium-dark skin tone, medium-light skin tone +1F469 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FD ; fully-qualified # 👩🏾❤️💋👨🏽 E13.1 kiss: woman, man, medium-dark skin tone, medium skin tone +1F469 1F3FE 200D 2764 200D 1F48B 200D 1F468 1F3FD ; minimally-qualified # 👩🏾❤💋👨🏽 E13.1 kiss: woman, man, medium-dark skin tone, medium skin tone +1F469 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FE ; fully-qualified # 👩🏾❤️💋👨🏾 E13.1 kiss: woman, man, medium-dark skin tone +1F469 1F3FE 200D 2764 200D 1F48B 200D 1F468 1F3FE ; minimally-qualified # 👩🏾❤💋👨🏾 E13.1 kiss: woman, man, medium-dark skin tone +1F469 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FF ; fully-qualified # 👩🏾❤️💋👨🏿 E13.1 kiss: woman, man, medium-dark skin tone, dark skin tone +1F469 1F3FE 200D 2764 200D 1F48B 200D 1F468 1F3FF ; minimally-qualified # 👩🏾❤💋👨🏿 E13.1 kiss: woman, man, medium-dark skin tone, dark skin tone +1F469 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FB ; fully-qualified # 👩🏿❤️💋👨🏻 E13.1 kiss: woman, man, dark skin tone, light skin tone +1F469 1F3FF 200D 2764 200D 1F48B 200D 1F468 1F3FB ; minimally-qualified # 👩🏿❤💋👨🏻 E13.1 kiss: woman, man, dark skin tone, light skin tone +1F469 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FC ; fully-qualified # 👩🏿❤️💋👨🏼 E13.1 kiss: woman, man, dark skin tone, medium-light skin tone +1F469 1F3FF 200D 2764 200D 1F48B 200D 1F468 1F3FC ; minimally-qualified # 👩🏿❤💋👨🏼 E13.1 kiss: woman, man, dark skin tone, medium-light skin tone +1F469 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FD ; fully-qualified # 👩🏿❤️💋👨🏽 E13.1 kiss: woman, man, dark skin tone, medium skin tone +1F469 1F3FF 200D 2764 200D 1F48B 200D 1F468 1F3FD ; minimally-qualified # 👩🏿❤💋👨🏽 E13.1 kiss: woman, man, dark skin tone, medium skin tone +1F469 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FE ; fully-qualified # 👩🏿❤️💋👨🏾 E13.1 kiss: woman, man, dark skin tone, medium-dark skin tone +1F469 1F3FF 200D 2764 200D 1F48B 200D 1F468 1F3FE ; minimally-qualified # 👩🏿❤💋👨🏾 E13.1 kiss: woman, man, dark skin tone, medium-dark skin tone +1F469 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FF ; fully-qualified # 👩🏿❤️💋👨🏿 E13.1 kiss: woman, man, dark skin tone +1F469 1F3FF 200D 2764 200D 1F48B 200D 1F468 1F3FF ; minimally-qualified # 👩🏿❤💋👨🏿 E13.1 kiss: woman, man, dark skin tone +1F468 200D 2764 FE0F 200D 1F48B 200D 1F468 ; fully-qualified # 👨❤️💋👨 E2.0 kiss: man, man +1F468 200D 2764 200D 1F48B 200D 1F468 ; minimally-qualified # 👨❤💋👨 E2.0 kiss: man, man +1F468 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FB ; fully-qualified # 👨🏻❤️💋👨🏻 E13.1 kiss: man, man, light skin tone +1F468 1F3FB 200D 2764 200D 1F48B 200D 1F468 1F3FB ; minimally-qualified # 👨🏻❤💋👨🏻 E13.1 kiss: man, man, light skin tone +1F468 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FC ; fully-qualified # 👨🏻❤️💋👨🏼 E13.1 kiss: man, man, light skin tone, medium-light skin tone +1F468 1F3FB 200D 2764 200D 1F48B 200D 1F468 1F3FC ; minimally-qualified # 👨🏻❤💋👨🏼 E13.1 kiss: man, man, light skin tone, medium-light skin tone +1F468 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FD ; fully-qualified # 👨🏻❤️💋👨🏽 E13.1 kiss: man, man, light skin tone, medium skin tone +1F468 1F3FB 200D 2764 200D 1F48B 200D 1F468 1F3FD ; minimally-qualified # 👨🏻❤💋👨🏽 E13.1 kiss: man, man, light skin tone, medium skin tone +1F468 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FE ; fully-qualified # 👨🏻❤️💋👨🏾 E13.1 kiss: man, man, light skin tone, medium-dark skin tone +1F468 1F3FB 200D 2764 200D 1F48B 200D 1F468 1F3FE ; minimally-qualified # 👨🏻❤💋👨🏾 E13.1 kiss: man, man, light skin tone, medium-dark skin tone +1F468 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FF ; fully-qualified # 👨🏻❤️💋👨🏿 E13.1 kiss: man, man, light skin tone, dark skin tone +1F468 1F3FB 200D 2764 200D 1F48B 200D 1F468 1F3FF ; minimally-qualified # 👨🏻❤💋👨🏿 E13.1 kiss: man, man, light skin tone, dark skin tone +1F468 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FB ; fully-qualified # 👨🏼❤️💋👨🏻 E13.1 kiss: man, man, medium-light skin tone, light skin tone +1F468 1F3FC 200D 2764 200D 1F48B 200D 1F468 1F3FB ; minimally-qualified # 👨🏼❤💋👨🏻 E13.1 kiss: man, man, medium-light skin tone, light skin tone +1F468 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FC ; fully-qualified # 👨🏼❤️💋👨🏼 E13.1 kiss: man, man, medium-light skin tone +1F468 1F3FC 200D 2764 200D 1F48B 200D 1F468 1F3FC ; minimally-qualified # 👨🏼❤💋👨🏼 E13.1 kiss: man, man, medium-light skin tone +1F468 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FD ; fully-qualified # 👨🏼❤️💋👨🏽 E13.1 kiss: man, man, medium-light skin tone, medium skin tone +1F468 1F3FC 200D 2764 200D 1F48B 200D 1F468 1F3FD ; minimally-qualified # 👨🏼❤💋👨🏽 E13.1 kiss: man, man, medium-light skin tone, medium skin tone +1F468 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FE ; fully-qualified # 👨🏼❤️💋👨🏾 E13.1 kiss: man, man, medium-light skin tone, medium-dark skin tone +1F468 1F3FC 200D 2764 200D 1F48B 200D 1F468 1F3FE ; minimally-qualified # 👨🏼❤💋👨🏾 E13.1 kiss: man, man, medium-light skin tone, medium-dark skin tone +1F468 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FF ; fully-qualified # 👨🏼❤️💋👨🏿 E13.1 kiss: man, man, medium-light skin tone, dark skin tone +1F468 1F3FC 200D 2764 200D 1F48B 200D 1F468 1F3FF ; minimally-qualified # 👨🏼❤💋👨🏿 E13.1 kiss: man, man, medium-light skin tone, dark skin tone +1F468 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FB ; fully-qualified # 👨🏽❤️💋👨🏻 E13.1 kiss: man, man, medium skin tone, light skin tone +1F468 1F3FD 200D 2764 200D 1F48B 200D 1F468 1F3FB ; minimally-qualified # 👨🏽❤💋👨🏻 E13.1 kiss: man, man, medium skin tone, light skin tone +1F468 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FC ; fully-qualified # 👨🏽❤️💋👨🏼 E13.1 kiss: man, man, medium skin tone, medium-light skin tone +1F468 1F3FD 200D 2764 200D 1F48B 200D 1F468 1F3FC ; minimally-qualified # 👨🏽❤💋👨🏼 E13.1 kiss: man, man, medium skin tone, medium-light skin tone +1F468 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FD ; fully-qualified # 👨🏽❤️💋👨🏽 E13.1 kiss: man, man, medium skin tone +1F468 1F3FD 200D 2764 200D 1F48B 200D 1F468 1F3FD ; minimally-qualified # 👨🏽❤💋👨🏽 E13.1 kiss: man, man, medium skin tone +1F468 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FE ; fully-qualified # 👨🏽❤️💋👨🏾 E13.1 kiss: man, man, medium skin tone, medium-dark skin tone +1F468 1F3FD 200D 2764 200D 1F48B 200D 1F468 1F3FE ; minimally-qualified # 👨🏽❤💋👨🏾 E13.1 kiss: man, man, medium skin tone, medium-dark skin tone +1F468 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FF ; fully-qualified # 👨🏽❤️💋👨🏿 E13.1 kiss: man, man, medium skin tone, dark skin tone +1F468 1F3FD 200D 2764 200D 1F48B 200D 1F468 1F3FF ; minimally-qualified # 👨🏽❤💋👨🏿 E13.1 kiss: man, man, medium skin tone, dark skin tone +1F468 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FB ; fully-qualified # 👨🏾❤️💋👨🏻 E13.1 kiss: man, man, medium-dark skin tone, light skin tone +1F468 1F3FE 200D 2764 200D 1F48B 200D 1F468 1F3FB ; minimally-qualified # 👨🏾❤💋👨🏻 E13.1 kiss: man, man, medium-dark skin tone, light skin tone +1F468 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FC ; fully-qualified # 👨🏾❤️💋👨🏼 E13.1 kiss: man, man, medium-dark skin tone, medium-light skin tone +1F468 1F3FE 200D 2764 200D 1F48B 200D 1F468 1F3FC ; minimally-qualified # 👨🏾❤💋👨🏼 E13.1 kiss: man, man, medium-dark skin tone, medium-light skin tone +1F468 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FD ; fully-qualified # 👨🏾❤️💋👨🏽 E13.1 kiss: man, man, medium-dark skin tone, medium skin tone +1F468 1F3FE 200D 2764 200D 1F48B 200D 1F468 1F3FD ; minimally-qualified # 👨🏾❤💋👨🏽 E13.1 kiss: man, man, medium-dark skin tone, medium skin tone +1F468 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FE ; fully-qualified # 👨🏾❤️💋👨🏾 E13.1 kiss: man, man, medium-dark skin tone +1F468 1F3FE 200D 2764 200D 1F48B 200D 1F468 1F3FE ; minimally-qualified # 👨🏾❤💋👨🏾 E13.1 kiss: man, man, medium-dark skin tone +1F468 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FF ; fully-qualified # 👨🏾❤️💋👨🏿 E13.1 kiss: man, man, medium-dark skin tone, dark skin tone +1F468 1F3FE 200D 2764 200D 1F48B 200D 1F468 1F3FF ; minimally-qualified # 👨🏾❤💋👨🏿 E13.1 kiss: man, man, medium-dark skin tone, dark skin tone +1F468 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FB ; fully-qualified # 👨🏿❤️💋👨🏻 E13.1 kiss: man, man, dark skin tone, light skin tone +1F468 1F3FF 200D 2764 200D 1F48B 200D 1F468 1F3FB ; minimally-qualified # 👨🏿❤💋👨🏻 E13.1 kiss: man, man, dark skin tone, light skin tone +1F468 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FC ; fully-qualified # 👨🏿❤️💋👨🏼 E13.1 kiss: man, man, dark skin tone, medium-light skin tone +1F468 1F3FF 200D 2764 200D 1F48B 200D 1F468 1F3FC ; minimally-qualified # 👨🏿❤💋👨🏼 E13.1 kiss: man, man, dark skin tone, medium-light skin tone +1F468 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FD ; fully-qualified # 👨🏿❤️💋👨🏽 E13.1 kiss: man, man, dark skin tone, medium skin tone +1F468 1F3FF 200D 2764 200D 1F48B 200D 1F468 1F3FD ; minimally-qualified # 👨🏿❤💋👨🏽 E13.1 kiss: man, man, dark skin tone, medium skin tone +1F468 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FE ; fully-qualified # 👨🏿❤️💋👨🏾 E13.1 kiss: man, man, dark skin tone, medium-dark skin tone +1F468 1F3FF 200D 2764 200D 1F48B 200D 1F468 1F3FE ; minimally-qualified # 👨🏿❤💋👨🏾 E13.1 kiss: man, man, dark skin tone, medium-dark skin tone +1F468 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F468 1F3FF ; fully-qualified # 👨🏿❤️💋👨🏿 E13.1 kiss: man, man, dark skin tone +1F468 1F3FF 200D 2764 200D 1F48B 200D 1F468 1F3FF ; minimally-qualified # 👨🏿❤💋👨🏿 E13.1 kiss: man, man, dark skin tone +1F469 200D 2764 FE0F 200D 1F48B 200D 1F469 ; fully-qualified # 👩❤️💋👩 E2.0 kiss: woman, woman +1F469 200D 2764 200D 1F48B 200D 1F469 ; minimally-qualified # 👩❤💋👩 E2.0 kiss: woman, woman +1F469 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FB ; fully-qualified # 👩🏻❤️💋👩🏻 E13.1 kiss: woman, woman, light skin tone +1F469 1F3FB 200D 2764 200D 1F48B 200D 1F469 1F3FB ; minimally-qualified # 👩🏻❤💋👩🏻 E13.1 kiss: woman, woman, light skin tone +1F469 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FC ; fully-qualified # 👩🏻❤️💋👩🏼 E13.1 kiss: woman, woman, light skin tone, medium-light skin tone +1F469 1F3FB 200D 2764 200D 1F48B 200D 1F469 1F3FC ; minimally-qualified # 👩🏻❤💋👩🏼 E13.1 kiss: woman, woman, light skin tone, medium-light skin tone +1F469 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FD ; fully-qualified # 👩🏻❤️💋👩🏽 E13.1 kiss: woman, woman, light skin tone, medium skin tone +1F469 1F3FB 200D 2764 200D 1F48B 200D 1F469 1F3FD ; minimally-qualified # 👩🏻❤💋👩🏽 E13.1 kiss: woman, woman, light skin tone, medium skin tone +1F469 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FE ; fully-qualified # 👩🏻❤️💋👩🏾 E13.1 kiss: woman, woman, light skin tone, medium-dark skin tone +1F469 1F3FB 200D 2764 200D 1F48B 200D 1F469 1F3FE ; minimally-qualified # 👩🏻❤💋👩🏾 E13.1 kiss: woman, woman, light skin tone, medium-dark skin tone +1F469 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FF ; fully-qualified # 👩🏻❤️💋👩🏿 E13.1 kiss: woman, woman, light skin tone, dark skin tone +1F469 1F3FB 200D 2764 200D 1F48B 200D 1F469 1F3FF ; minimally-qualified # 👩🏻❤💋👩🏿 E13.1 kiss: woman, woman, light skin tone, dark skin tone +1F469 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FB ; fully-qualified # 👩🏼❤️💋👩🏻 E13.1 kiss: woman, woman, medium-light skin tone, light skin tone +1F469 1F3FC 200D 2764 200D 1F48B 200D 1F469 1F3FB ; minimally-qualified # 👩🏼❤💋👩🏻 E13.1 kiss: woman, woman, medium-light skin tone, light skin tone +1F469 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FC ; fully-qualified # 👩🏼❤️💋👩🏼 E13.1 kiss: woman, woman, medium-light skin tone +1F469 1F3FC 200D 2764 200D 1F48B 200D 1F469 1F3FC ; minimally-qualified # 👩🏼❤💋👩🏼 E13.1 kiss: woman, woman, medium-light skin tone +1F469 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FD ; fully-qualified # 👩🏼❤️💋👩🏽 E13.1 kiss: woman, woman, medium-light skin tone, medium skin tone +1F469 1F3FC 200D 2764 200D 1F48B 200D 1F469 1F3FD ; minimally-qualified # 👩🏼❤💋👩🏽 E13.1 kiss: woman, woman, medium-light skin tone, medium skin tone +1F469 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FE ; fully-qualified # 👩🏼❤️💋👩🏾 E13.1 kiss: woman, woman, medium-light skin tone, medium-dark skin tone +1F469 1F3FC 200D 2764 200D 1F48B 200D 1F469 1F3FE ; minimally-qualified # 👩🏼❤💋👩🏾 E13.1 kiss: woman, woman, medium-light skin tone, medium-dark skin tone +1F469 1F3FC 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FF ; fully-qualified # 👩🏼❤️💋👩🏿 E13.1 kiss: woman, woman, medium-light skin tone, dark skin tone +1F469 1F3FC 200D 2764 200D 1F48B 200D 1F469 1F3FF ; minimally-qualified # 👩🏼❤💋👩🏿 E13.1 kiss: woman, woman, medium-light skin tone, dark skin tone +1F469 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FB ; fully-qualified # 👩🏽❤️💋👩🏻 E13.1 kiss: woman, woman, medium skin tone, light skin tone +1F469 1F3FD 200D 2764 200D 1F48B 200D 1F469 1F3FB ; minimally-qualified # 👩🏽❤💋👩🏻 E13.1 kiss: woman, woman, medium skin tone, light skin tone +1F469 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FC ; fully-qualified # 👩🏽❤️💋👩🏼 E13.1 kiss: woman, woman, medium skin tone, medium-light skin tone +1F469 1F3FD 200D 2764 200D 1F48B 200D 1F469 1F3FC ; minimally-qualified # 👩🏽❤💋👩🏼 E13.1 kiss: woman, woman, medium skin tone, medium-light skin tone +1F469 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FD ; fully-qualified # 👩🏽❤️💋👩🏽 E13.1 kiss: woman, woman, medium skin tone +1F469 1F3FD 200D 2764 200D 1F48B 200D 1F469 1F3FD ; minimally-qualified # 👩🏽❤💋👩🏽 E13.1 kiss: woman, woman, medium skin tone +1F469 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FE ; fully-qualified # 👩🏽❤️💋👩🏾 E13.1 kiss: woman, woman, medium skin tone, medium-dark skin tone +1F469 1F3FD 200D 2764 200D 1F48B 200D 1F469 1F3FE ; minimally-qualified # 👩🏽❤💋👩🏾 E13.1 kiss: woman, woman, medium skin tone, medium-dark skin tone +1F469 1F3FD 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FF ; fully-qualified # 👩🏽❤️💋👩🏿 E13.1 kiss: woman, woman, medium skin tone, dark skin tone +1F469 1F3FD 200D 2764 200D 1F48B 200D 1F469 1F3FF ; minimally-qualified # 👩🏽❤💋👩🏿 E13.1 kiss: woman, woman, medium skin tone, dark skin tone +1F469 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FB ; fully-qualified # 👩🏾❤️💋👩🏻 E13.1 kiss: woman, woman, medium-dark skin tone, light skin tone +1F469 1F3FE 200D 2764 200D 1F48B 200D 1F469 1F3FB ; minimally-qualified # 👩🏾❤💋👩🏻 E13.1 kiss: woman, woman, medium-dark skin tone, light skin tone +1F469 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FC ; fully-qualified # 👩🏾❤️💋👩🏼 E13.1 kiss: woman, woman, medium-dark skin tone, medium-light skin tone +1F469 1F3FE 200D 2764 200D 1F48B 200D 1F469 1F3FC ; minimally-qualified # 👩🏾❤💋👩🏼 E13.1 kiss: woman, woman, medium-dark skin tone, medium-light skin tone +1F469 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FD ; fully-qualified # 👩🏾❤️💋👩🏽 E13.1 kiss: woman, woman, medium-dark skin tone, medium skin tone +1F469 1F3FE 200D 2764 200D 1F48B 200D 1F469 1F3FD ; minimally-qualified # 👩🏾❤💋👩🏽 E13.1 kiss: woman, woman, medium-dark skin tone, medium skin tone +1F469 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FE ; fully-qualified # 👩🏾❤️💋👩🏾 E13.1 kiss: woman, woman, medium-dark skin tone +1F469 1F3FE 200D 2764 200D 1F48B 200D 1F469 1F3FE ; minimally-qualified # 👩🏾❤💋👩🏾 E13.1 kiss: woman, woman, medium-dark skin tone +1F469 1F3FE 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FF ; fully-qualified # 👩🏾❤️💋👩🏿 E13.1 kiss: woman, woman, medium-dark skin tone, dark skin tone +1F469 1F3FE 200D 2764 200D 1F48B 200D 1F469 1F3FF ; minimally-qualified # 👩🏾❤💋👩🏿 E13.1 kiss: woman, woman, medium-dark skin tone, dark skin tone +1F469 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FB ; fully-qualified # 👩🏿❤️💋👩🏻 E13.1 kiss: woman, woman, dark skin tone, light skin tone +1F469 1F3FF 200D 2764 200D 1F48B 200D 1F469 1F3FB ; minimally-qualified # 👩🏿❤💋👩🏻 E13.1 kiss: woman, woman, dark skin tone, light skin tone +1F469 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FC ; fully-qualified # 👩🏿❤️💋👩🏼 E13.1 kiss: woman, woman, dark skin tone, medium-light skin tone +1F469 1F3FF 200D 2764 200D 1F48B 200D 1F469 1F3FC ; minimally-qualified # 👩🏿❤💋👩🏼 E13.1 kiss: woman, woman, dark skin tone, medium-light skin tone +1F469 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FD ; fully-qualified # 👩🏿❤️💋👩🏽 E13.1 kiss: woman, woman, dark skin tone, medium skin tone +1F469 1F3FF 200D 2764 200D 1F48B 200D 1F469 1F3FD ; minimally-qualified # 👩🏿❤💋👩🏽 E13.1 kiss: woman, woman, dark skin tone, medium skin tone +1F469 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FE ; fully-qualified # 👩🏿❤️💋👩🏾 E13.1 kiss: woman, woman, dark skin tone, medium-dark skin tone +1F469 1F3FF 200D 2764 200D 1F48B 200D 1F469 1F3FE ; minimally-qualified # 👩🏿❤💋👩🏾 E13.1 kiss: woman, woman, dark skin tone, medium-dark skin tone +1F469 1F3FF 200D 2764 FE0F 200D 1F48B 200D 1F469 1F3FF ; fully-qualified # 👩🏿❤️💋👩🏿 E13.1 kiss: woman, woman, dark skin tone +1F469 1F3FF 200D 2764 200D 1F48B 200D 1F469 1F3FF ; minimally-qualified # 👩🏿❤💋👩🏿 E13.1 kiss: woman, woman, dark skin tone +1F491 ; fully-qualified # 💑 E0.6 couple with heart +1F491 1F3FB ; fully-qualified # 💑🏻 E13.1 couple with heart: light skin tone +1F491 1F3FC ; fully-qualified # 💑🏼 E13.1 couple with heart: medium-light skin tone +1F491 1F3FD ; fully-qualified # 💑🏽 E13.1 couple with heart: medium skin tone +1F491 1F3FE ; fully-qualified # 💑🏾 E13.1 couple with heart: medium-dark skin tone +1F491 1F3FF ; fully-qualified # 💑🏿 E13.1 couple with heart: dark skin tone +1F9D1 1F3FB 200D 2764 FE0F 200D 1F9D1 1F3FC ; fully-qualified # 🧑🏻❤️🧑🏼 E13.1 couple with heart: person, person, light skin tone, medium-light skin tone +1F9D1 1F3FB 200D 2764 200D 1F9D1 1F3FC ; minimally-qualified # 🧑🏻❤🧑🏼 E13.1 couple with heart: person, person, light skin tone, medium-light skin tone +1F9D1 1F3FB 200D 2764 FE0F 200D 1F9D1 1F3FD ; fully-qualified # 🧑🏻❤️🧑🏽 E13.1 couple with heart: person, person, light skin tone, medium skin tone +1F9D1 1F3FB 200D 2764 200D 1F9D1 1F3FD ; minimally-qualified # 🧑🏻❤🧑🏽 E13.1 couple with heart: person, person, light skin tone, medium skin tone +1F9D1 1F3FB 200D 2764 FE0F 200D 1F9D1 1F3FE ; fully-qualified # 🧑🏻❤️🧑🏾 E13.1 couple with heart: person, person, light skin tone, medium-dark skin tone +1F9D1 1F3FB 200D 2764 200D 1F9D1 1F3FE ; minimally-qualified # 🧑🏻❤🧑🏾 E13.1 couple with heart: person, person, light skin tone, medium-dark skin tone +1F9D1 1F3FB 200D 2764 FE0F 200D 1F9D1 1F3FF ; fully-qualified # 🧑🏻❤️🧑🏿 E13.1 couple with heart: person, person, light skin tone, dark skin tone +1F9D1 1F3FB 200D 2764 200D 1F9D1 1F3FF ; minimally-qualified # 🧑🏻❤🧑🏿 E13.1 couple with heart: person, person, light skin tone, dark skin tone +1F9D1 1F3FC 200D 2764 FE0F 200D 1F9D1 1F3FB ; fully-qualified # 🧑🏼❤️🧑🏻 E13.1 couple with heart: person, person, medium-light skin tone, light skin tone +1F9D1 1F3FC 200D 2764 200D 1F9D1 1F3FB ; minimally-qualified # 🧑🏼❤🧑🏻 E13.1 couple with heart: person, person, medium-light skin tone, light skin tone +1F9D1 1F3FC 200D 2764 FE0F 200D 1F9D1 1F3FD ; fully-qualified # 🧑🏼❤️🧑🏽 E13.1 couple with heart: person, person, medium-light skin tone, medium skin tone +1F9D1 1F3FC 200D 2764 200D 1F9D1 1F3FD ; minimally-qualified # 🧑🏼❤🧑🏽 E13.1 couple with heart: person, person, medium-light skin tone, medium skin tone +1F9D1 1F3FC 200D 2764 FE0F 200D 1F9D1 1F3FE ; fully-qualified # 🧑🏼❤️🧑🏾 E13.1 couple with heart: person, person, medium-light skin tone, medium-dark skin tone +1F9D1 1F3FC 200D 2764 200D 1F9D1 1F3FE ; minimally-qualified # 🧑🏼❤🧑🏾 E13.1 couple with heart: person, person, medium-light skin tone, medium-dark skin tone +1F9D1 1F3FC 200D 2764 FE0F 200D 1F9D1 1F3FF ; fully-qualified # 🧑🏼❤️🧑🏿 E13.1 couple with heart: person, person, medium-light skin tone, dark skin tone +1F9D1 1F3FC 200D 2764 200D 1F9D1 1F3FF ; minimally-qualified # 🧑🏼❤🧑🏿 E13.1 couple with heart: person, person, medium-light skin tone, dark skin tone +1F9D1 1F3FD 200D 2764 FE0F 200D 1F9D1 1F3FB ; fully-qualified # 🧑🏽❤️🧑🏻 E13.1 couple with heart: person, person, medium skin tone, light skin tone +1F9D1 1F3FD 200D 2764 200D 1F9D1 1F3FB ; minimally-qualified # 🧑🏽❤🧑🏻 E13.1 couple with heart: person, person, medium skin tone, light skin tone +1F9D1 1F3FD 200D 2764 FE0F 200D 1F9D1 1F3FC ; fully-qualified # 🧑🏽❤️🧑🏼 E13.1 couple with heart: person, person, medium skin tone, medium-light skin tone +1F9D1 1F3FD 200D 2764 200D 1F9D1 1F3FC ; minimally-qualified # 🧑🏽❤🧑🏼 E13.1 couple with heart: person, person, medium skin tone, medium-light skin tone +1F9D1 1F3FD 200D 2764 FE0F 200D 1F9D1 1F3FE ; fully-qualified # 🧑🏽❤️🧑🏾 E13.1 couple with heart: person, person, medium skin tone, medium-dark skin tone +1F9D1 1F3FD 200D 2764 200D 1F9D1 1F3FE ; minimally-qualified # 🧑🏽❤🧑🏾 E13.1 couple with heart: person, person, medium skin tone, medium-dark skin tone +1F9D1 1F3FD 200D 2764 FE0F 200D 1F9D1 1F3FF ; fully-qualified # 🧑🏽❤️🧑🏿 E13.1 couple with heart: person, person, medium skin tone, dark skin tone +1F9D1 1F3FD 200D 2764 200D 1F9D1 1F3FF ; minimally-qualified # 🧑🏽❤🧑🏿 E13.1 couple with heart: person, person, medium skin tone, dark skin tone +1F9D1 1F3FE 200D 2764 FE0F 200D 1F9D1 1F3FB ; fully-qualified # 🧑🏾❤️🧑🏻 E13.1 couple with heart: person, person, medium-dark skin tone, light skin tone +1F9D1 1F3FE 200D 2764 200D 1F9D1 1F3FB ; minimally-qualified # 🧑🏾❤🧑🏻 E13.1 couple with heart: person, person, medium-dark skin tone, light skin tone +1F9D1 1F3FE 200D 2764 FE0F 200D 1F9D1 1F3FC ; fully-qualified # 🧑🏾❤️🧑🏼 E13.1 couple with heart: person, person, medium-dark skin tone, medium-light skin tone +1F9D1 1F3FE 200D 2764 200D 1F9D1 1F3FC ; minimally-qualified # 🧑🏾❤🧑🏼 E13.1 couple with heart: person, person, medium-dark skin tone, medium-light skin tone +1F9D1 1F3FE 200D 2764 FE0F 200D 1F9D1 1F3FD ; fully-qualified # 🧑🏾❤️🧑🏽 E13.1 couple with heart: person, person, medium-dark skin tone, medium skin tone +1F9D1 1F3FE 200D 2764 200D 1F9D1 1F3FD ; minimally-qualified # 🧑🏾❤🧑🏽 E13.1 couple with heart: person, person, medium-dark skin tone, medium skin tone +1F9D1 1F3FE 200D 2764 FE0F 200D 1F9D1 1F3FF ; fully-qualified # 🧑🏾❤️🧑🏿 E13.1 couple with heart: person, person, medium-dark skin tone, dark skin tone +1F9D1 1F3FE 200D 2764 200D 1F9D1 1F3FF ; minimally-qualified # 🧑🏾❤🧑🏿 E13.1 couple with heart: person, person, medium-dark skin tone, dark skin tone +1F9D1 1F3FF 200D 2764 FE0F 200D 1F9D1 1F3FB ; fully-qualified # 🧑🏿❤️🧑🏻 E13.1 couple with heart: person, person, dark skin tone, light skin tone +1F9D1 1F3FF 200D 2764 200D 1F9D1 1F3FB ; minimally-qualified # 🧑🏿❤🧑🏻 E13.1 couple with heart: person, person, dark skin tone, light skin tone +1F9D1 1F3FF 200D 2764 FE0F 200D 1F9D1 1F3FC ; fully-qualified # 🧑🏿❤️🧑🏼 E13.1 couple with heart: person, person, dark skin tone, medium-light skin tone +1F9D1 1F3FF 200D 2764 200D 1F9D1 1F3FC ; minimally-qualified # 🧑🏿❤🧑🏼 E13.1 couple with heart: person, person, dark skin tone, medium-light skin tone +1F9D1 1F3FF 200D 2764 FE0F 200D 1F9D1 1F3FD ; fully-qualified # 🧑🏿❤️🧑🏽 E13.1 couple with heart: person, person, dark skin tone, medium skin tone +1F9D1 1F3FF 200D 2764 200D 1F9D1 1F3FD ; minimally-qualified # 🧑🏿❤🧑🏽 E13.1 couple with heart: person, person, dark skin tone, medium skin tone +1F9D1 1F3FF 200D 2764 FE0F 200D 1F9D1 1F3FE ; fully-qualified # 🧑🏿❤️🧑🏾 E13.1 couple with heart: person, person, dark skin tone, medium-dark skin tone +1F9D1 1F3FF 200D 2764 200D 1F9D1 1F3FE ; minimally-qualified # 🧑🏿❤🧑🏾 E13.1 couple with heart: person, person, dark skin tone, medium-dark skin tone +1F469 200D 2764 FE0F 200D 1F468 ; fully-qualified # 👩❤️👨 E2.0 couple with heart: woman, man +1F469 200D 2764 200D 1F468 ; minimally-qualified # 👩❤👨 E2.0 couple with heart: woman, man +1F469 1F3FB 200D 2764 FE0F 200D 1F468 1F3FB ; fully-qualified # 👩🏻❤️👨🏻 E13.1 couple with heart: woman, man, light skin tone +1F469 1F3FB 200D 2764 200D 1F468 1F3FB ; minimally-qualified # 👩🏻❤👨🏻 E13.1 couple with heart: woman, man, light skin tone +1F469 1F3FB 200D 2764 FE0F 200D 1F468 1F3FC ; fully-qualified # 👩🏻❤️👨🏼 E13.1 couple with heart: woman, man, light skin tone, medium-light skin tone +1F469 1F3FB 200D 2764 200D 1F468 1F3FC ; minimally-qualified # 👩🏻❤👨🏼 E13.1 couple with heart: woman, man, light skin tone, medium-light skin tone +1F469 1F3FB 200D 2764 FE0F 200D 1F468 1F3FD ; fully-qualified # 👩🏻❤️👨🏽 E13.1 couple with heart: woman, man, light skin tone, medium skin tone +1F469 1F3FB 200D 2764 200D 1F468 1F3FD ; minimally-qualified # 👩🏻❤👨🏽 E13.1 couple with heart: woman, man, light skin tone, medium skin tone +1F469 1F3FB 200D 2764 FE0F 200D 1F468 1F3FE ; fully-qualified # 👩🏻❤️👨🏾 E13.1 couple with heart: woman, man, light skin tone, medium-dark skin tone +1F469 1F3FB 200D 2764 200D 1F468 1F3FE ; minimally-qualified # 👩🏻❤👨🏾 E13.1 couple with heart: woman, man, light skin tone, medium-dark skin tone +1F469 1F3FB 200D 2764 FE0F 200D 1F468 1F3FF ; fully-qualified # 👩🏻❤️👨🏿 E13.1 couple with heart: woman, man, light skin tone, dark skin tone +1F469 1F3FB 200D 2764 200D 1F468 1F3FF ; minimally-qualified # 👩🏻❤👨🏿 E13.1 couple with heart: woman, man, light skin tone, dark skin tone +1F469 1F3FC 200D 2764 FE0F 200D 1F468 1F3FB ; fully-qualified # 👩🏼❤️👨🏻 E13.1 couple with heart: woman, man, medium-light skin tone, light skin tone +1F469 1F3FC 200D 2764 200D 1F468 1F3FB ; minimally-qualified # 👩🏼❤👨🏻 E13.1 couple with heart: woman, man, medium-light skin tone, light skin tone +1F469 1F3FC 200D 2764 FE0F 200D 1F468 1F3FC ; fully-qualified # 👩🏼❤️👨🏼 E13.1 couple with heart: woman, man, medium-light skin tone +1F469 1F3FC 200D 2764 200D 1F468 1F3FC ; minimally-qualified # 👩🏼❤👨🏼 E13.1 couple with heart: woman, man, medium-light skin tone +1F469 1F3FC 200D 2764 FE0F 200D 1F468 1F3FD ; fully-qualified # 👩🏼❤️👨🏽 E13.1 couple with heart: woman, man, medium-light skin tone, medium skin tone +1F469 1F3FC 200D 2764 200D 1F468 1F3FD ; minimally-qualified # 👩🏼❤👨🏽 E13.1 couple with heart: woman, man, medium-light skin tone, medium skin tone +1F469 1F3FC 200D 2764 FE0F 200D 1F468 1F3FE ; fully-qualified # 👩🏼❤️👨🏾 E13.1 couple with heart: woman, man, medium-light skin tone, medium-dark skin tone +1F469 1F3FC 200D 2764 200D 1F468 1F3FE ; minimally-qualified # 👩🏼❤👨🏾 E13.1 couple with heart: woman, man, medium-light skin tone, medium-dark skin tone +1F469 1F3FC 200D 2764 FE0F 200D 1F468 1F3FF ; fully-qualified # 👩🏼❤️👨🏿 E13.1 couple with heart: woman, man, medium-light skin tone, dark skin tone +1F469 1F3FC 200D 2764 200D 1F468 1F3FF ; minimally-qualified # 👩🏼❤👨🏿 E13.1 couple with heart: woman, man, medium-light skin tone, dark skin tone +1F469 1F3FD 200D 2764 FE0F 200D 1F468 1F3FB ; fully-qualified # 👩🏽❤️👨🏻 E13.1 couple with heart: woman, man, medium skin tone, light skin tone +1F469 1F3FD 200D 2764 200D 1F468 1F3FB ; minimally-qualified # 👩🏽❤👨🏻 E13.1 couple with heart: woman, man, medium skin tone, light skin tone +1F469 1F3FD 200D 2764 FE0F 200D 1F468 1F3FC ; fully-qualified # 👩🏽❤️👨🏼 E13.1 couple with heart: woman, man, medium skin tone, medium-light skin tone +1F469 1F3FD 200D 2764 200D 1F468 1F3FC ; minimally-qualified # 👩🏽❤👨🏼 E13.1 couple with heart: woman, man, medium skin tone, medium-light skin tone +1F469 1F3FD 200D 2764 FE0F 200D 1F468 1F3FD ; fully-qualified # 👩🏽❤️👨🏽 E13.1 couple with heart: woman, man, medium skin tone +1F469 1F3FD 200D 2764 200D 1F468 1F3FD ; minimally-qualified # 👩🏽❤👨🏽 E13.1 couple with heart: woman, man, medium skin tone +1F469 1F3FD 200D 2764 FE0F 200D 1F468 1F3FE ; fully-qualified # 👩🏽❤️👨🏾 E13.1 couple with heart: woman, man, medium skin tone, medium-dark skin tone +1F469 1F3FD 200D 2764 200D 1F468 1F3FE ; minimally-qualified # 👩🏽❤👨🏾 E13.1 couple with heart: woman, man, medium skin tone, medium-dark skin tone +1F469 1F3FD 200D 2764 FE0F 200D 1F468 1F3FF ; fully-qualified # 👩🏽❤️👨🏿 E13.1 couple with heart: woman, man, medium skin tone, dark skin tone +1F469 1F3FD 200D 2764 200D 1F468 1F3FF ; minimally-qualified # 👩🏽❤👨🏿 E13.1 couple with heart: woman, man, medium skin tone, dark skin tone +1F469 1F3FE 200D 2764 FE0F 200D 1F468 1F3FB ; fully-qualified # 👩🏾❤️👨🏻 E13.1 couple with heart: woman, man, medium-dark skin tone, light skin tone +1F469 1F3FE 200D 2764 200D 1F468 1F3FB ; minimally-qualified # 👩🏾❤👨🏻 E13.1 couple with heart: woman, man, medium-dark skin tone, light skin tone +1F469 1F3FE 200D 2764 FE0F 200D 1F468 1F3FC ; fully-qualified # 👩🏾❤️👨🏼 E13.1 couple with heart: woman, man, medium-dark skin tone, medium-light skin tone +1F469 1F3FE 200D 2764 200D 1F468 1F3FC ; minimally-qualified # 👩🏾❤👨🏼 E13.1 couple with heart: woman, man, medium-dark skin tone, medium-light skin tone +1F469 1F3FE 200D 2764 FE0F 200D 1F468 1F3FD ; fully-qualified # 👩🏾❤️👨🏽 E13.1 couple with heart: woman, man, medium-dark skin tone, medium skin tone +1F469 1F3FE 200D 2764 200D 1F468 1F3FD ; minimally-qualified # 👩🏾❤👨🏽 E13.1 couple with heart: woman, man, medium-dark skin tone, medium skin tone +1F469 1F3FE 200D 2764 FE0F 200D 1F468 1F3FE ; fully-qualified # 👩🏾❤️👨🏾 E13.1 couple with heart: woman, man, medium-dark skin tone +1F469 1F3FE 200D 2764 200D 1F468 1F3FE ; minimally-qualified # 👩🏾❤👨🏾 E13.1 couple with heart: woman, man, medium-dark skin tone +1F469 1F3FE 200D 2764 FE0F 200D 1F468 1F3FF ; fully-qualified # 👩🏾❤️👨🏿 E13.1 couple with heart: woman, man, medium-dark skin tone, dark skin tone +1F469 1F3FE 200D 2764 200D 1F468 1F3FF ; minimally-qualified # 👩🏾❤👨🏿 E13.1 couple with heart: woman, man, medium-dark skin tone, dark skin tone +1F469 1F3FF 200D 2764 FE0F 200D 1F468 1F3FB ; fully-qualified # 👩🏿❤️👨🏻 E13.1 couple with heart: woman, man, dark skin tone, light skin tone +1F469 1F3FF 200D 2764 200D 1F468 1F3FB ; minimally-qualified # 👩🏿❤👨🏻 E13.1 couple with heart: woman, man, dark skin tone, light skin tone +1F469 1F3FF 200D 2764 FE0F 200D 1F468 1F3FC ; fully-qualified # 👩🏿❤️👨🏼 E13.1 couple with heart: woman, man, dark skin tone, medium-light skin tone +1F469 1F3FF 200D 2764 200D 1F468 1F3FC ; minimally-qualified # 👩🏿❤👨🏼 E13.1 couple with heart: woman, man, dark skin tone, medium-light skin tone +1F469 1F3FF 200D 2764 FE0F 200D 1F468 1F3FD ; fully-qualified # 👩🏿❤️👨🏽 E13.1 couple with heart: woman, man, dark skin tone, medium skin tone +1F469 1F3FF 200D 2764 200D 1F468 1F3FD ; minimally-qualified # 👩🏿❤👨🏽 E13.1 couple with heart: woman, man, dark skin tone, medium skin tone +1F469 1F3FF 200D 2764 FE0F 200D 1F468 1F3FE ; fully-qualified # 👩🏿❤️👨🏾 E13.1 couple with heart: woman, man, dark skin tone, medium-dark skin tone +1F469 1F3FF 200D 2764 200D 1F468 1F3FE ; minimally-qualified # 👩🏿❤👨🏾 E13.1 couple with heart: woman, man, dark skin tone, medium-dark skin tone +1F469 1F3FF 200D 2764 FE0F 200D 1F468 1F3FF ; fully-qualified # 👩🏿❤️👨🏿 E13.1 couple with heart: woman, man, dark skin tone +1F469 1F3FF 200D 2764 200D 1F468 1F3FF ; minimally-qualified # 👩🏿❤👨🏿 E13.1 couple with heart: woman, man, dark skin tone +1F468 200D 2764 FE0F 200D 1F468 ; fully-qualified # 👨❤️👨 E2.0 couple with heart: man, man +1F468 200D 2764 200D 1F468 ; minimally-qualified # 👨❤👨 E2.0 couple with heart: man, man +1F468 1F3FB 200D 2764 FE0F 200D 1F468 1F3FB ; fully-qualified # 👨🏻❤️👨🏻 E13.1 couple with heart: man, man, light skin tone +1F468 1F3FB 200D 2764 200D 1F468 1F3FB ; minimally-qualified # 👨🏻❤👨🏻 E13.1 couple with heart: man, man, light skin tone +1F468 1F3FB 200D 2764 FE0F 200D 1F468 1F3FC ; fully-qualified # 👨🏻❤️👨🏼 E13.1 couple with heart: man, man, light skin tone, medium-light skin tone +1F468 1F3FB 200D 2764 200D 1F468 1F3FC ; minimally-qualified # 👨🏻❤👨🏼 E13.1 couple with heart: man, man, light skin tone, medium-light skin tone +1F468 1F3FB 200D 2764 FE0F 200D 1F468 1F3FD ; fully-qualified # 👨🏻❤️👨🏽 E13.1 couple with heart: man, man, light skin tone, medium skin tone +1F468 1F3FB 200D 2764 200D 1F468 1F3FD ; minimally-qualified # 👨🏻❤👨🏽 E13.1 couple with heart: man, man, light skin tone, medium skin tone +1F468 1F3FB 200D 2764 FE0F 200D 1F468 1F3FE ; fully-qualified # 👨🏻❤️👨🏾 E13.1 couple with heart: man, man, light skin tone, medium-dark skin tone +1F468 1F3FB 200D 2764 200D 1F468 1F3FE ; minimally-qualified # 👨🏻❤👨🏾 E13.1 couple with heart: man, man, light skin tone, medium-dark skin tone +1F468 1F3FB 200D 2764 FE0F 200D 1F468 1F3FF ; fully-qualified # 👨🏻❤️👨🏿 E13.1 couple with heart: man, man, light skin tone, dark skin tone +1F468 1F3FB 200D 2764 200D 1F468 1F3FF ; minimally-qualified # 👨🏻❤👨🏿 E13.1 couple with heart: man, man, light skin tone, dark skin tone +1F468 1F3FC 200D 2764 FE0F 200D 1F468 1F3FB ; fully-qualified # 👨🏼❤️👨🏻 E13.1 couple with heart: man, man, medium-light skin tone, light skin tone +1F468 1F3FC 200D 2764 200D 1F468 1F3FB ; minimally-qualified # 👨🏼❤👨🏻 E13.1 couple with heart: man, man, medium-light skin tone, light skin tone +1F468 1F3FC 200D 2764 FE0F 200D 1F468 1F3FC ; fully-qualified # 👨🏼❤️👨🏼 E13.1 couple with heart: man, man, medium-light skin tone +1F468 1F3FC 200D 2764 200D 1F468 1F3FC ; minimally-qualified # 👨🏼❤👨🏼 E13.1 couple with heart: man, man, medium-light skin tone +1F468 1F3FC 200D 2764 FE0F 200D 1F468 1F3FD ; fully-qualified # 👨🏼❤️👨🏽 E13.1 couple with heart: man, man, medium-light skin tone, medium skin tone +1F468 1F3FC 200D 2764 200D 1F468 1F3FD ; minimally-qualified # 👨🏼❤👨🏽 E13.1 couple with heart: man, man, medium-light skin tone, medium skin tone +1F468 1F3FC 200D 2764 FE0F 200D 1F468 1F3FE ; fully-qualified # 👨🏼❤️👨🏾 E13.1 couple with heart: man, man, medium-light skin tone, medium-dark skin tone +1F468 1F3FC 200D 2764 200D 1F468 1F3FE ; minimally-qualified # 👨🏼❤👨🏾 E13.1 couple with heart: man, man, medium-light skin tone, medium-dark skin tone +1F468 1F3FC 200D 2764 FE0F 200D 1F468 1F3FF ; fully-qualified # 👨🏼❤️👨🏿 E13.1 couple with heart: man, man, medium-light skin tone, dark skin tone +1F468 1F3FC 200D 2764 200D 1F468 1F3FF ; minimally-qualified # 👨🏼❤👨🏿 E13.1 couple with heart: man, man, medium-light skin tone, dark skin tone +1F468 1F3FD 200D 2764 FE0F 200D 1F468 1F3FB ; fully-qualified # 👨🏽❤️👨🏻 E13.1 couple with heart: man, man, medium skin tone, light skin tone +1F468 1F3FD 200D 2764 200D 1F468 1F3FB ; minimally-qualified # 👨🏽❤👨🏻 E13.1 couple with heart: man, man, medium skin tone, light skin tone +1F468 1F3FD 200D 2764 FE0F 200D 1F468 1F3FC ; fully-qualified # 👨🏽❤️👨🏼 E13.1 couple with heart: man, man, medium skin tone, medium-light skin tone +1F468 1F3FD 200D 2764 200D 1F468 1F3FC ; minimally-qualified # 👨🏽❤👨🏼 E13.1 couple with heart: man, man, medium skin tone, medium-light skin tone +1F468 1F3FD 200D 2764 FE0F 200D 1F468 1F3FD ; fully-qualified # 👨🏽❤️👨🏽 E13.1 couple with heart: man, man, medium skin tone +1F468 1F3FD 200D 2764 200D 1F468 1F3FD ; minimally-qualified # 👨🏽❤👨🏽 E13.1 couple with heart: man, man, medium skin tone +1F468 1F3FD 200D 2764 FE0F 200D 1F468 1F3FE ; fully-qualified # 👨🏽❤️👨🏾 E13.1 couple with heart: man, man, medium skin tone, medium-dark skin tone +1F468 1F3FD 200D 2764 200D 1F468 1F3FE ; minimally-qualified # 👨🏽❤👨🏾 E13.1 couple with heart: man, man, medium skin tone, medium-dark skin tone +1F468 1F3FD 200D 2764 FE0F 200D 1F468 1F3FF ; fully-qualified # 👨🏽❤️👨🏿 E13.1 couple with heart: man, man, medium skin tone, dark skin tone +1F468 1F3FD 200D 2764 200D 1F468 1F3FF ; minimally-qualified # 👨🏽❤👨🏿 E13.1 couple with heart: man, man, medium skin tone, dark skin tone +1F468 1F3FE 200D 2764 FE0F 200D 1F468 1F3FB ; fully-qualified # 👨🏾❤️👨🏻 E13.1 couple with heart: man, man, medium-dark skin tone, light skin tone +1F468 1F3FE 200D 2764 200D 1F468 1F3FB ; minimally-qualified # 👨🏾❤👨🏻 E13.1 couple with heart: man, man, medium-dark skin tone, light skin tone +1F468 1F3FE 200D 2764 FE0F 200D 1F468 1F3FC ; fully-qualified # 👨🏾❤️👨🏼 E13.1 couple with heart: man, man, medium-dark skin tone, medium-light skin tone +1F468 1F3FE 200D 2764 200D 1F468 1F3FC ; minimally-qualified # 👨🏾❤👨🏼 E13.1 couple with heart: man, man, medium-dark skin tone, medium-light skin tone +1F468 1F3FE 200D 2764 FE0F 200D 1F468 1F3FD ; fully-qualified # 👨🏾❤️👨🏽 E13.1 couple with heart: man, man, medium-dark skin tone, medium skin tone +1F468 1F3FE 200D 2764 200D 1F468 1F3FD ; minimally-qualified # 👨🏾❤👨🏽 E13.1 couple with heart: man, man, medium-dark skin tone, medium skin tone +1F468 1F3FE 200D 2764 FE0F 200D 1F468 1F3FE ; fully-qualified # 👨🏾❤️👨🏾 E13.1 couple with heart: man, man, medium-dark skin tone +1F468 1F3FE 200D 2764 200D 1F468 1F3FE ; minimally-qualified # 👨🏾❤👨🏾 E13.1 couple with heart: man, man, medium-dark skin tone +1F468 1F3FE 200D 2764 FE0F 200D 1F468 1F3FF ; fully-qualified # 👨🏾❤️👨🏿 E13.1 couple with heart: man, man, medium-dark skin tone, dark skin tone +1F468 1F3FE 200D 2764 200D 1F468 1F3FF ; minimally-qualified # 👨🏾❤👨🏿 E13.1 couple with heart: man, man, medium-dark skin tone, dark skin tone +1F468 1F3FF 200D 2764 FE0F 200D 1F468 1F3FB ; fully-qualified # 👨🏿❤️👨🏻 E13.1 couple with heart: man, man, dark skin tone, light skin tone +1F468 1F3FF 200D 2764 200D 1F468 1F3FB ; minimally-qualified # 👨🏿❤👨🏻 E13.1 couple with heart: man, man, dark skin tone, light skin tone +1F468 1F3FF 200D 2764 FE0F 200D 1F468 1F3FC ; fully-qualified # 👨🏿❤️👨🏼 E13.1 couple with heart: man, man, dark skin tone, medium-light skin tone +1F468 1F3FF 200D 2764 200D 1F468 1F3FC ; minimally-qualified # 👨🏿❤👨🏼 E13.1 couple with heart: man, man, dark skin tone, medium-light skin tone +1F468 1F3FF 200D 2764 FE0F 200D 1F468 1F3FD ; fully-qualified # 👨🏿❤️👨🏽 E13.1 couple with heart: man, man, dark skin tone, medium skin tone +1F468 1F3FF 200D 2764 200D 1F468 1F3FD ; minimally-qualified # 👨🏿❤👨🏽 E13.1 couple with heart: man, man, dark skin tone, medium skin tone +1F468 1F3FF 200D 2764 FE0F 200D 1F468 1F3FE ; fully-qualified # 👨🏿❤️👨🏾 E13.1 couple with heart: man, man, dark skin tone, medium-dark skin tone +1F468 1F3FF 200D 2764 200D 1F468 1F3FE ; minimally-qualified # 👨🏿❤👨🏾 E13.1 couple with heart: man, man, dark skin tone, medium-dark skin tone +1F468 1F3FF 200D 2764 FE0F 200D 1F468 1F3FF ; fully-qualified # 👨🏿❤️👨🏿 E13.1 couple with heart: man, man, dark skin tone +1F468 1F3FF 200D 2764 200D 1F468 1F3FF ; minimally-qualified # 👨🏿❤👨🏿 E13.1 couple with heart: man, man, dark skin tone +1F469 200D 2764 FE0F 200D 1F469 ; fully-qualified # 👩❤️👩 E2.0 couple with heart: woman, woman +1F469 200D 2764 200D 1F469 ; minimally-qualified # 👩❤👩 E2.0 couple with heart: woman, woman +1F469 1F3FB 200D 2764 FE0F 200D 1F469 1F3FB ; fully-qualified # 👩🏻❤️👩🏻 E13.1 couple with heart: woman, woman, light skin tone +1F469 1F3FB 200D 2764 200D 1F469 1F3FB ; minimally-qualified # 👩🏻❤👩🏻 E13.1 couple with heart: woman, woman, light skin tone +1F469 1F3FB 200D 2764 FE0F 200D 1F469 1F3FC ; fully-qualified # 👩🏻❤️👩🏼 E13.1 couple with heart: woman, woman, light skin tone, medium-light skin tone +1F469 1F3FB 200D 2764 200D 1F469 1F3FC ; minimally-qualified # 👩🏻❤👩🏼 E13.1 couple with heart: woman, woman, light skin tone, medium-light skin tone +1F469 1F3FB 200D 2764 FE0F 200D 1F469 1F3FD ; fully-qualified # 👩🏻❤️👩🏽 E13.1 couple with heart: woman, woman, light skin tone, medium skin tone +1F469 1F3FB 200D 2764 200D 1F469 1F3FD ; minimally-qualified # 👩🏻❤👩🏽 E13.1 couple with heart: woman, woman, light skin tone, medium skin tone +1F469 1F3FB 200D 2764 FE0F 200D 1F469 1F3FE ; fully-qualified # 👩🏻❤️👩🏾 E13.1 couple with heart: woman, woman, light skin tone, medium-dark skin tone +1F469 1F3FB 200D 2764 200D 1F469 1F3FE ; minimally-qualified # 👩🏻❤👩🏾 E13.1 couple with heart: woman, woman, light skin tone, medium-dark skin tone +1F469 1F3FB 200D 2764 FE0F 200D 1F469 1F3FF ; fully-qualified # 👩🏻❤️👩🏿 E13.1 couple with heart: woman, woman, light skin tone, dark skin tone +1F469 1F3FB 200D 2764 200D 1F469 1F3FF ; minimally-qualified # 👩🏻❤👩🏿 E13.1 couple with heart: woman, woman, light skin tone, dark skin tone +1F469 1F3FC 200D 2764 FE0F 200D 1F469 1F3FB ; fully-qualified # 👩🏼❤️👩🏻 E13.1 couple with heart: woman, woman, medium-light skin tone, light skin tone +1F469 1F3FC 200D 2764 200D 1F469 1F3FB ; minimally-qualified # 👩🏼❤👩🏻 E13.1 couple with heart: woman, woman, medium-light skin tone, light skin tone +1F469 1F3FC 200D 2764 FE0F 200D 1F469 1F3FC ; fully-qualified # 👩🏼❤️👩🏼 E13.1 couple with heart: woman, woman, medium-light skin tone +1F469 1F3FC 200D 2764 200D 1F469 1F3FC ; minimally-qualified # 👩🏼❤👩🏼 E13.1 couple with heart: woman, woman, medium-light skin tone +1F469 1F3FC 200D 2764 FE0F 200D 1F469 1F3FD ; fully-qualified # 👩🏼❤️👩🏽 E13.1 couple with heart: woman, woman, medium-light skin tone, medium skin tone +1F469 1F3FC 200D 2764 200D 1F469 1F3FD ; minimally-qualified # 👩🏼❤👩🏽 E13.1 couple with heart: woman, woman, medium-light skin tone, medium skin tone +1F469 1F3FC 200D 2764 FE0F 200D 1F469 1F3FE ; fully-qualified # 👩🏼❤️👩🏾 E13.1 couple with heart: woman, woman, medium-light skin tone, medium-dark skin tone +1F469 1F3FC 200D 2764 200D 1F469 1F3FE ; minimally-qualified # 👩🏼❤👩🏾 E13.1 couple with heart: woman, woman, medium-light skin tone, medium-dark skin tone +1F469 1F3FC 200D 2764 FE0F 200D 1F469 1F3FF ; fully-qualified # 👩🏼❤️👩🏿 E13.1 couple with heart: woman, woman, medium-light skin tone, dark skin tone +1F469 1F3FC 200D 2764 200D 1F469 1F3FF ; minimally-qualified # 👩🏼❤👩🏿 E13.1 couple with heart: woman, woman, medium-light skin tone, dark skin tone +1F469 1F3FD 200D 2764 FE0F 200D 1F469 1F3FB ; fully-qualified # 👩🏽❤️👩🏻 E13.1 couple with heart: woman, woman, medium skin tone, light skin tone +1F469 1F3FD 200D 2764 200D 1F469 1F3FB ; minimally-qualified # 👩🏽❤👩🏻 E13.1 couple with heart: woman, woman, medium skin tone, light skin tone +1F469 1F3FD 200D 2764 FE0F 200D 1F469 1F3FC ; fully-qualified # 👩🏽❤️👩🏼 E13.1 couple with heart: woman, woman, medium skin tone, medium-light skin tone +1F469 1F3FD 200D 2764 200D 1F469 1F3FC ; minimally-qualified # 👩🏽❤👩🏼 E13.1 couple with heart: woman, woman, medium skin tone, medium-light skin tone +1F469 1F3FD 200D 2764 FE0F 200D 1F469 1F3FD ; fully-qualified # 👩🏽❤️👩🏽 E13.1 couple with heart: woman, woman, medium skin tone +1F469 1F3FD 200D 2764 200D 1F469 1F3FD ; minimally-qualified # 👩🏽❤👩🏽 E13.1 couple with heart: woman, woman, medium skin tone +1F469 1F3FD 200D 2764 FE0F 200D 1F469 1F3FE ; fully-qualified # 👩🏽❤️👩🏾 E13.1 couple with heart: woman, woman, medium skin tone, medium-dark skin tone +1F469 1F3FD 200D 2764 200D 1F469 1F3FE ; minimally-qualified # 👩🏽❤👩🏾 E13.1 couple with heart: woman, woman, medium skin tone, medium-dark skin tone +1F469 1F3FD 200D 2764 FE0F 200D 1F469 1F3FF ; fully-qualified # 👩🏽❤️👩🏿 E13.1 couple with heart: woman, woman, medium skin tone, dark skin tone +1F469 1F3FD 200D 2764 200D 1F469 1F3FF ; minimally-qualified # 👩🏽❤👩🏿 E13.1 couple with heart: woman, woman, medium skin tone, dark skin tone +1F469 1F3FE 200D 2764 FE0F 200D 1F469 1F3FB ; fully-qualified # 👩🏾❤️👩🏻 E13.1 couple with heart: woman, woman, medium-dark skin tone, light skin tone +1F469 1F3FE 200D 2764 200D 1F469 1F3FB ; minimally-qualified # 👩🏾❤👩🏻 E13.1 couple with heart: woman, woman, medium-dark skin tone, light skin tone +1F469 1F3FE 200D 2764 FE0F 200D 1F469 1F3FC ; fully-qualified # 👩🏾❤️👩🏼 E13.1 couple with heart: woman, woman, medium-dark skin tone, medium-light skin tone +1F469 1F3FE 200D 2764 200D 1F469 1F3FC ; minimally-qualified # 👩🏾❤👩🏼 E13.1 couple with heart: woman, woman, medium-dark skin tone, medium-light skin tone +1F469 1F3FE 200D 2764 FE0F 200D 1F469 1F3FD ; fully-qualified # 👩🏾❤️👩🏽 E13.1 couple with heart: woman, woman, medium-dark skin tone, medium skin tone +1F469 1F3FE 200D 2764 200D 1F469 1F3FD ; minimally-qualified # 👩🏾❤👩🏽 E13.1 couple with heart: woman, woman, medium-dark skin tone, medium skin tone +1F469 1F3FE 200D 2764 FE0F 200D 1F469 1F3FE ; fully-qualified # 👩🏾❤️👩🏾 E13.1 couple with heart: woman, woman, medium-dark skin tone +1F469 1F3FE 200D 2764 200D 1F469 1F3FE ; minimally-qualified # 👩🏾❤👩🏾 E13.1 couple with heart: woman, woman, medium-dark skin tone +1F469 1F3FE 200D 2764 FE0F 200D 1F469 1F3FF ; fully-qualified # 👩🏾❤️👩🏿 E13.1 couple with heart: woman, woman, medium-dark skin tone, dark skin tone +1F469 1F3FE 200D 2764 200D 1F469 1F3FF ; minimally-qualified # 👩🏾❤👩🏿 E13.1 couple with heart: woman, woman, medium-dark skin tone, dark skin tone +1F469 1F3FF 200D 2764 FE0F 200D 1F469 1F3FB ; fully-qualified # 👩🏿❤️👩🏻 E13.1 couple with heart: woman, woman, dark skin tone, light skin tone +1F469 1F3FF 200D 2764 200D 1F469 1F3FB ; minimally-qualified # 👩🏿❤👩🏻 E13.1 couple with heart: woman, woman, dark skin tone, light skin tone +1F469 1F3FF 200D 2764 FE0F 200D 1F469 1F3FC ; fully-qualified # 👩🏿❤️👩🏼 E13.1 couple with heart: woman, woman, dark skin tone, medium-light skin tone +1F469 1F3FF 200D 2764 200D 1F469 1F3FC ; minimally-qualified # 👩🏿❤👩🏼 E13.1 couple with heart: woman, woman, dark skin tone, medium-light skin tone +1F469 1F3FF 200D 2764 FE0F 200D 1F469 1F3FD ; fully-qualified # 👩🏿❤️👩🏽 E13.1 couple with heart: woman, woman, dark skin tone, medium skin tone +1F469 1F3FF 200D 2764 200D 1F469 1F3FD ; minimally-qualified # 👩🏿❤👩🏽 E13.1 couple with heart: woman, woman, dark skin tone, medium skin tone +1F469 1F3FF 200D 2764 FE0F 200D 1F469 1F3FE ; fully-qualified # 👩🏿❤️👩🏾 E13.1 couple with heart: woman, woman, dark skin tone, medium-dark skin tone +1F469 1F3FF 200D 2764 200D 1F469 1F3FE ; minimally-qualified # 👩🏿❤👩🏾 E13.1 couple with heart: woman, woman, dark skin tone, medium-dark skin tone +1F469 1F3FF 200D 2764 FE0F 200D 1F469 1F3FF ; fully-qualified # 👩🏿❤️👩🏿 E13.1 couple with heart: woman, woman, dark skin tone +1F469 1F3FF 200D 2764 200D 1F469 1F3FF ; minimally-qualified # 👩🏿❤👩🏿 E13.1 couple with heart: woman, woman, dark skin tone +1F46A ; fully-qualified # 👪 E0.6 family +1F468 200D 1F469 200D 1F466 ; fully-qualified # 👨👩👦 E2.0 family: man, woman, boy +1F468 200D 1F469 200D 1F467 ; fully-qualified # 👨👩👧 E2.0 family: man, woman, girl +1F468 200D 1F469 200D 1F467 200D 1F466 ; fully-qualified # 👨👩👧👦 E2.0 family: man, woman, girl, boy +1F468 200D 1F469 200D 1F466 200D 1F466 ; fully-qualified # 👨👩👦👦 E2.0 family: man, woman, boy, boy +1F468 200D 1F469 200D 1F467 200D 1F467 ; fully-qualified # 👨👩👧👧 E2.0 family: man, woman, girl, girl +1F468 200D 1F468 200D 1F466 ; fully-qualified # 👨👨👦 E2.0 family: man, man, boy +1F468 200D 1F468 200D 1F467 ; fully-qualified # 👨👨👧 E2.0 family: man, man, girl +1F468 200D 1F468 200D 1F467 200D 1F466 ; fully-qualified # 👨👨👧👦 E2.0 family: man, man, girl, boy +1F468 200D 1F468 200D 1F466 200D 1F466 ; fully-qualified # 👨👨👦👦 E2.0 family: man, man, boy, boy +1F468 200D 1F468 200D 1F467 200D 1F467 ; fully-qualified # 👨👨👧👧 E2.0 family: man, man, girl, girl +1F469 200D 1F469 200D 1F466 ; fully-qualified # 👩👩👦 E2.0 family: woman, woman, boy +1F469 200D 1F469 200D 1F467 ; fully-qualified # 👩👩👧 E2.0 family: woman, woman, girl +1F469 200D 1F469 200D 1F467 200D 1F466 ; fully-qualified # 👩👩👧👦 E2.0 family: woman, woman, girl, boy +1F469 200D 1F469 200D 1F466 200D 1F466 ; fully-qualified # 👩👩👦👦 E2.0 family: woman, woman, boy, boy +1F469 200D 1F469 200D 1F467 200D 1F467 ; fully-qualified # 👩👩👧👧 E2.0 family: woman, woman, girl, girl +1F468 200D 1F466 ; fully-qualified # 👨👦 E4.0 family: man, boy +1F468 200D 1F466 200D 1F466 ; fully-qualified # 👨👦👦 E4.0 family: man, boy, boy +1F468 200D 1F467 ; fully-qualified # 👨👧 E4.0 family: man, girl +1F468 200D 1F467 200D 1F466 ; fully-qualified # 👨👧👦 E4.0 family: man, girl, boy +1F468 200D 1F467 200D 1F467 ; fully-qualified # 👨👧👧 E4.0 family: man, girl, girl +1F469 200D 1F466 ; fully-qualified # 👩👦 E4.0 family: woman, boy +1F469 200D 1F466 200D 1F466 ; fully-qualified # 👩👦👦 E4.0 family: woman, boy, boy +1F469 200D 1F467 ; fully-qualified # 👩👧 E4.0 family: woman, girl +1F469 200D 1F467 200D 1F466 ; fully-qualified # 👩👧👦 E4.0 family: woman, girl, boy +1F469 200D 1F467 200D 1F467 ; fully-qualified # 👩👧👧 E4.0 family: woman, girl, girl + +# subgroup: person-symbol +1F5E3 FE0F ; fully-qualified # 🗣️ E0.7 speaking head +1F5E3 ; unqualified # 🗣 E0.7 speaking head +1F464 ; fully-qualified # 👤 E0.6 bust in silhouette +1F465 ; fully-qualified # 👥 E1.0 busts in silhouette +1FAC2 ; fully-qualified # 🫂 E13.0 people hugging +1F463 ; fully-qualified # 👣 E0.6 footprints + +# People & Body subtotal: 2986 +# People & Body subtotal: 506 w/o modifiers + +# group: Component + +# subgroup: skin-tone +1F3FB ; component # 🏻 E1.0 light skin tone +1F3FC ; component # 🏼 E1.0 medium-light skin tone +1F3FD ; component # 🏽 E1.0 medium skin tone +1F3FE ; component # 🏾 E1.0 medium-dark skin tone +1F3FF ; component # 🏿 E1.0 dark skin tone + +# subgroup: hair-style +1F9B0 ; component # 🦰 E11.0 red hair +1F9B1 ; component # 🦱 E11.0 curly hair +1F9B3 ; component # 🦳 E11.0 white hair +1F9B2 ; component # 🦲 E11.0 bald + +# Component subtotal: 9 +# Component subtotal: 4 w/o modifiers + +# group: Animals & Nature + +# subgroup: animal-mammal +1F435 ; fully-qualified # 🐵 E0.6 monkey face +1F412 ; fully-qualified # 🐒 E0.6 monkey +1F98D ; fully-qualified # 🦍 E3.0 gorilla +1F9A7 ; fully-qualified # 🦧 E12.0 orangutan +1F436 ; fully-qualified # 🐶 E0.6 dog face +1F415 ; fully-qualified # 🐕 E0.7 dog +1F9AE ; fully-qualified # 🦮 E12.0 guide dog +1F415 200D 1F9BA ; fully-qualified # 🐕🦺 E12.0 service dog +1F429 ; fully-qualified # 🐩 E0.6 poodle +1F43A ; fully-qualified # 🐺 E0.6 wolf +1F98A ; fully-qualified # 🦊 E3.0 fox +1F99D ; fully-qualified # 🦝 E11.0 raccoon +1F431 ; fully-qualified # 🐱 E0.6 cat face +1F408 ; fully-qualified # 🐈 E0.7 cat +1F408 200D 2B1B ; fully-qualified # 🐈⬛ E13.0 black cat +1F981 ; fully-qualified # 🦁 E1.0 lion +1F42F ; fully-qualified # 🐯 E0.6 tiger face +1F405 ; fully-qualified # 🐅 E1.0 tiger +1F406 ; fully-qualified # 🐆 E1.0 leopard +1F434 ; fully-qualified # 🐴 E0.6 horse face +1F40E ; fully-qualified # 🐎 E0.6 horse +1F984 ; fully-qualified # 🦄 E1.0 unicorn +1F993 ; fully-qualified # 🦓 E5.0 zebra +1F98C ; fully-qualified # 🦌 E3.0 deer +1F9AC ; fully-qualified # 🦬 E13.0 bison +1F42E ; fully-qualified # 🐮 E0.6 cow face +1F402 ; fully-qualified # 🐂 E1.0 ox +1F403 ; fully-qualified # 🐃 E1.0 water buffalo +1F404 ; fully-qualified # 🐄 E1.0 cow +1F437 ; fully-qualified # 🐷 E0.6 pig face +1F416 ; fully-qualified # 🐖 E1.0 pig +1F417 ; fully-qualified # 🐗 E0.6 boar +1F43D ; fully-qualified # 🐽 E0.6 pig nose +1F40F ; fully-qualified # 🐏 E1.0 ram +1F411 ; fully-qualified # 🐑 E0.6 ewe +1F410 ; fully-qualified # 🐐 E1.0 goat +1F42A ; fully-qualified # 🐪 E1.0 camel +1F42B ; fully-qualified # 🐫 E0.6 two-hump camel +1F999 ; fully-qualified # 🦙 E11.0 llama +1F992 ; fully-qualified # 🦒 E5.0 giraffe +1F418 ; fully-qualified # 🐘 E0.6 elephant +1F9A3 ; fully-qualified # 🦣 E13.0 mammoth +1F98F ; fully-qualified # 🦏 E3.0 rhinoceros +1F99B ; fully-qualified # 🦛 E11.0 hippopotamus +1F42D ; fully-qualified # 🐭 E0.6 mouse face +1F401 ; fully-qualified # 🐁 E1.0 mouse +1F400 ; fully-qualified # 🐀 E1.0 rat +1F439 ; fully-qualified # 🐹 E0.6 hamster +1F430 ; fully-qualified # 🐰 E0.6 rabbit face +1F407 ; fully-qualified # 🐇 E1.0 rabbit +1F43F FE0F ; fully-qualified # 🐿️ E0.7 chipmunk +1F43F ; unqualified # 🐿 E0.7 chipmunk +1F9AB ; fully-qualified # 🦫 E13.0 beaver +1F994 ; fully-qualified # 🦔 E5.0 hedgehog +1F987 ; fully-qualified # 🦇 E3.0 bat +1F43B ; fully-qualified # 🐻 E0.6 bear +1F43B 200D 2744 FE0F ; fully-qualified # 🐻❄️ E13.0 polar bear +1F43B 200D 2744 ; minimally-qualified # 🐻❄ E13.0 polar bear +1F428 ; fully-qualified # 🐨 E0.6 koala +1F43C ; fully-qualified # 🐼 E0.6 panda +1F9A5 ; fully-qualified # 🦥 E12.0 sloth +1F9A6 ; fully-qualified # 🦦 E12.0 otter +1F9A8 ; fully-qualified # 🦨 E12.0 skunk +1F998 ; fully-qualified # 🦘 E11.0 kangaroo +1F9A1 ; fully-qualified # 🦡 E11.0 badger +1F43E ; fully-qualified # 🐾 E0.6 paw prints + +# subgroup: animal-bird +1F983 ; fully-qualified # 🦃 E1.0 turkey +1F414 ; fully-qualified # 🐔 E0.6 chicken +1F413 ; fully-qualified # 🐓 E1.0 rooster +1F423 ; fully-qualified # 🐣 E0.6 hatching chick +1F424 ; fully-qualified # 🐤 E0.6 baby chick +1F425 ; fully-qualified # 🐥 E0.6 front-facing baby chick +1F426 ; fully-qualified # 🐦 E0.6 bird +1F427 ; fully-qualified # 🐧 E0.6 penguin +1F54A FE0F ; fully-qualified # 🕊️ E0.7 dove +1F54A ; unqualified # 🕊 E0.7 dove +1F985 ; fully-qualified # 🦅 E3.0 eagle +1F986 ; fully-qualified # 🦆 E3.0 duck +1F9A2 ; fully-qualified # 🦢 E11.0 swan +1F989 ; fully-qualified # 🦉 E3.0 owl +1F9A4 ; fully-qualified # 🦤 E13.0 dodo +1FAB6 ; fully-qualified # 🪶 E13.0 feather +1F9A9 ; fully-qualified # 🦩 E12.0 flamingo +1F99A ; fully-qualified # 🦚 E11.0 peacock +1F99C ; fully-qualified # 🦜 E11.0 parrot + +# subgroup: animal-amphibian +1F438 ; fully-qualified # 🐸 E0.6 frog + +# subgroup: animal-reptile +1F40A ; fully-qualified # 🐊 E1.0 crocodile +1F422 ; fully-qualified # 🐢 E0.6 turtle +1F98E ; fully-qualified # 🦎 E3.0 lizard +1F40D ; fully-qualified # 🐍 E0.6 snake +1F432 ; fully-qualified # 🐲 E0.6 dragon face +1F409 ; fully-qualified # 🐉 E1.0 dragon +1F995 ; fully-qualified # 🦕 E5.0 sauropod +1F996 ; fully-qualified # 🦖 E5.0 T-Rex + +# subgroup: animal-marine +1F433 ; fully-qualified # 🐳 E0.6 spouting whale +1F40B ; fully-qualified # 🐋 E1.0 whale +1F42C ; fully-qualified # 🐬 E0.6 dolphin +1F9AD ; fully-qualified # 🦭 E13.0 seal +1F41F ; fully-qualified # 🐟 E0.6 fish +1F420 ; fully-qualified # 🐠 E0.6 tropical fish +1F421 ; fully-qualified # 🐡 E0.6 blowfish +1F988 ; fully-qualified # 🦈 E3.0 shark +1F419 ; fully-qualified # 🐙 E0.6 octopus +1F41A ; fully-qualified # 🐚 E0.6 spiral shell +1FAB8 ; fully-qualified # 🪸 E14.0 coral + +# subgroup: animal-bug +1F40C ; fully-qualified # 🐌 E0.6 snail +1F98B ; fully-qualified # 🦋 E3.0 butterfly +1F41B ; fully-qualified # 🐛 E0.6 bug +1F41C ; fully-qualified # 🐜 E0.6 ant +1F41D ; fully-qualified # 🐝 E0.6 honeybee +1FAB2 ; fully-qualified # 🪲 E13.0 beetle +1F41E ; fully-qualified # 🐞 E0.6 lady beetle +1F997 ; fully-qualified # 🦗 E5.0 cricket +1FAB3 ; fully-qualified # 🪳 E13.0 cockroach +1F577 FE0F ; fully-qualified # 🕷️ E0.7 spider +1F577 ; unqualified # 🕷 E0.7 spider +1F578 FE0F ; fully-qualified # 🕸️ E0.7 spider web +1F578 ; unqualified # 🕸 E0.7 spider web +1F982 ; fully-qualified # 🦂 E1.0 scorpion +1F99F ; fully-qualified # 🦟 E11.0 mosquito +1FAB0 ; fully-qualified # 🪰 E13.0 fly +1FAB1 ; fully-qualified # 🪱 E13.0 worm +1F9A0 ; fully-qualified # 🦠 E11.0 microbe + +# subgroup: plant-flower +1F490 ; fully-qualified # 💐 E0.6 bouquet +1F338 ; fully-qualified # 🌸 E0.6 cherry blossom +1F4AE ; fully-qualified # 💮 E0.6 white flower +1FAB7 ; fully-qualified # 🪷 E14.0 lotus +1F3F5 FE0F ; fully-qualified # 🏵️ E0.7 rosette +1F3F5 ; unqualified # 🏵 E0.7 rosette +1F339 ; fully-qualified # 🌹 E0.6 rose +1F940 ; fully-qualified # 🥀 E3.0 wilted flower +1F33A ; fully-qualified # 🌺 E0.6 hibiscus +1F33B ; fully-qualified # 🌻 E0.6 sunflower +1F33C ; fully-qualified # 🌼 E0.6 blossom +1F337 ; fully-qualified # 🌷 E0.6 tulip + +# subgroup: plant-other +1F331 ; fully-qualified # 🌱 E0.6 seedling +1FAB4 ; fully-qualified # 🪴 E13.0 potted plant +1F332 ; fully-qualified # 🌲 E1.0 evergreen tree +1F333 ; fully-qualified # 🌳 E1.0 deciduous tree +1F334 ; fully-qualified # 🌴 E0.6 palm tree +1F335 ; fully-qualified # 🌵 E0.6 cactus +1F33E ; fully-qualified # 🌾 E0.6 sheaf of rice +1F33F ; fully-qualified # 🌿 E0.6 herb +2618 FE0F ; fully-qualified # ☘️ E1.0 shamrock +2618 ; unqualified # ☘ E1.0 shamrock +1F340 ; fully-qualified # 🍀 E0.6 four leaf clover +1F341 ; fully-qualified # 🍁 E0.6 maple leaf +1F342 ; fully-qualified # 🍂 E0.6 fallen leaf +1F343 ; fully-qualified # 🍃 E0.6 leaf fluttering in wind +1FAB9 ; fully-qualified # 🪹 E14.0 empty nest +1FABA ; fully-qualified # 🪺 E14.0 nest with eggs + +# Animals & Nature subtotal: 151 +# Animals & Nature subtotal: 151 w/o modifiers + +# group: Food & Drink + +# subgroup: food-fruit +1F347 ; fully-qualified # 🍇 E0.6 grapes +1F348 ; fully-qualified # 🍈 E0.6 melon +1F349 ; fully-qualified # 🍉 E0.6 watermelon +1F34A ; fully-qualified # 🍊 E0.6 tangerine +1F34B ; fully-qualified # 🍋 E1.0 lemon +1F34C ; fully-qualified # 🍌 E0.6 banana +1F34D ; fully-qualified # 🍍 E0.6 pineapple +1F96D ; fully-qualified # 🥭 E11.0 mango +1F34E ; fully-qualified # 🍎 E0.6 red apple +1F34F ; fully-qualified # 🍏 E0.6 green apple +1F350 ; fully-qualified # 🍐 E1.0 pear +1F351 ; fully-qualified # 🍑 E0.6 peach +1F352 ; fully-qualified # 🍒 E0.6 cherries +1F353 ; fully-qualified # 🍓 E0.6 strawberry +1FAD0 ; fully-qualified # 🫐 E13.0 blueberries +1F95D ; fully-qualified # 🥝 E3.0 kiwi fruit +1F345 ; fully-qualified # 🍅 E0.6 tomato +1FAD2 ; fully-qualified # 🫒 E13.0 olive +1F965 ; fully-qualified # 🥥 E5.0 coconut + +# subgroup: food-vegetable +1F951 ; fully-qualified # 🥑 E3.0 avocado +1F346 ; fully-qualified # 🍆 E0.6 eggplant +1F954 ; fully-qualified # 🥔 E3.0 potato +1F955 ; fully-qualified # 🥕 E3.0 carrot +1F33D ; fully-qualified # 🌽 E0.6 ear of corn +1F336 FE0F ; fully-qualified # 🌶️ E0.7 hot pepper +1F336 ; unqualified # 🌶 E0.7 hot pepper +1FAD1 ; fully-qualified # 🫑 E13.0 bell pepper +1F952 ; fully-qualified # 🥒 E3.0 cucumber +1F96C ; fully-qualified # 🥬 E11.0 leafy green +1F966 ; fully-qualified # 🥦 E5.0 broccoli +1F9C4 ; fully-qualified # 🧄 E12.0 garlic +1F9C5 ; fully-qualified # 🧅 E12.0 onion +1F344 ; fully-qualified # 🍄 E0.6 mushroom +1F95C ; fully-qualified # 🥜 E3.0 peanuts +1FAD8 ; fully-qualified # 🫘 E14.0 beans +1F330 ; fully-qualified # 🌰 E0.6 chestnut + +# subgroup: food-prepared +1F35E ; fully-qualified # 🍞 E0.6 bread +1F950 ; fully-qualified # 🥐 E3.0 croissant +1F956 ; fully-qualified # 🥖 E3.0 baguette bread +1FAD3 ; fully-qualified # 🫓 E13.0 flatbread +1F968 ; fully-qualified # 🥨 E5.0 pretzel +1F96F ; fully-qualified # 🥯 E11.0 bagel +1F95E ; fully-qualified # 🥞 E3.0 pancakes +1F9C7 ; fully-qualified # 🧇 E12.0 waffle +1F9C0 ; fully-qualified # 🧀 E1.0 cheese wedge +1F356 ; fully-qualified # 🍖 E0.6 meat on bone +1F357 ; fully-qualified # 🍗 E0.6 poultry leg +1F969 ; fully-qualified # 🥩 E5.0 cut of meat +1F953 ; fully-qualified # 🥓 E3.0 bacon +1F354 ; fully-qualified # 🍔 E0.6 hamburger +1F35F ; fully-qualified # 🍟 E0.6 french fries +1F355 ; fully-qualified # 🍕 E0.6 pizza +1F32D ; fully-qualified # 🌭 E1.0 hot dog +1F96A ; fully-qualified # 🥪 E5.0 sandwich +1F32E ; fully-qualified # 🌮 E1.0 taco +1F32F ; fully-qualified # 🌯 E1.0 burrito +1FAD4 ; fully-qualified # 🫔 E13.0 tamale +1F959 ; fully-qualified # 🥙 E3.0 stuffed flatbread +1F9C6 ; fully-qualified # 🧆 E12.0 falafel +1F95A ; fully-qualified # 🥚 E3.0 egg +1F373 ; fully-qualified # 🍳 E0.6 cooking +1F958 ; fully-qualified # 🥘 E3.0 shallow pan of food +1F372 ; fully-qualified # 🍲 E0.6 pot of food +1FAD5 ; fully-qualified # 🫕 E13.0 fondue +1F963 ; fully-qualified # 🥣 E5.0 bowl with spoon +1F957 ; fully-qualified # 🥗 E3.0 green salad +1F37F ; fully-qualified # 🍿 E1.0 popcorn +1F9C8 ; fully-qualified # 🧈 E12.0 butter +1F9C2 ; fully-qualified # 🧂 E11.0 salt +1F96B ; fully-qualified # 🥫 E5.0 canned food + +# subgroup: food-asian +1F371 ; fully-qualified # 🍱 E0.6 bento box +1F358 ; fully-qualified # 🍘 E0.6 rice cracker +1F359 ; fully-qualified # 🍙 E0.6 rice ball +1F35A ; fully-qualified # 🍚 E0.6 cooked rice +1F35B ; fully-qualified # 🍛 E0.6 curry rice +1F35C ; fully-qualified # 🍜 E0.6 steaming bowl +1F35D ; fully-qualified # 🍝 E0.6 spaghetti +1F360 ; fully-qualified # 🍠 E0.6 roasted sweet potato +1F362 ; fully-qualified # 🍢 E0.6 oden +1F363 ; fully-qualified # 🍣 E0.6 sushi +1F364 ; fully-qualified # 🍤 E0.6 fried shrimp +1F365 ; fully-qualified # 🍥 E0.6 fish cake with swirl +1F96E ; fully-qualified # 🥮 E11.0 moon cake +1F361 ; fully-qualified # 🍡 E0.6 dango +1F95F ; fully-qualified # 🥟 E5.0 dumpling +1F960 ; fully-qualified # 🥠 E5.0 fortune cookie +1F961 ; fully-qualified # 🥡 E5.0 takeout box + +# subgroup: food-marine +1F980 ; fully-qualified # 🦀 E1.0 crab +1F99E ; fully-qualified # 🦞 E11.0 lobster +1F990 ; fully-qualified # 🦐 E3.0 shrimp +1F991 ; fully-qualified # 🦑 E3.0 squid +1F9AA ; fully-qualified # 🦪 E12.0 oyster + +# subgroup: food-sweet +1F366 ; fully-qualified # 🍦 E0.6 soft ice cream +1F367 ; fully-qualified # 🍧 E0.6 shaved ice +1F368 ; fully-qualified # 🍨 E0.6 ice cream +1F369 ; fully-qualified # 🍩 E0.6 doughnut +1F36A ; fully-qualified # 🍪 E0.6 cookie +1F382 ; fully-qualified # 🎂 E0.6 birthday cake +1F370 ; fully-qualified # 🍰 E0.6 shortcake +1F9C1 ; fully-qualified # 🧁 E11.0 cupcake +1F967 ; fully-qualified # 🥧 E5.0 pie +1F36B ; fully-qualified # 🍫 E0.6 chocolate bar +1F36C ; fully-qualified # 🍬 E0.6 candy +1F36D ; fully-qualified # 🍭 E0.6 lollipop +1F36E ; fully-qualified # 🍮 E0.6 custard +1F36F ; fully-qualified # 🍯 E0.6 honey pot + +# subgroup: drink +1F37C ; fully-qualified # 🍼 E1.0 baby bottle +1F95B ; fully-qualified # 🥛 E3.0 glass of milk +2615 ; fully-qualified # ☕ E0.6 hot beverage +1FAD6 ; fully-qualified # 🫖 E13.0 teapot +1F375 ; fully-qualified # 🍵 E0.6 teacup without handle +1F376 ; fully-qualified # 🍶 E0.6 sake +1F37E ; fully-qualified # 🍾 E1.0 bottle with popping cork +1F377 ; fully-qualified # 🍷 E0.6 wine glass +1F378 ; fully-qualified # 🍸 E0.6 cocktail glass +1F379 ; fully-qualified # 🍹 E0.6 tropical drink +1F37A ; fully-qualified # 🍺 E0.6 beer mug +1F37B ; fully-qualified # 🍻 E0.6 clinking beer mugs +1F942 ; fully-qualified # 🥂 E3.0 clinking glasses +1F943 ; fully-qualified # 🥃 E3.0 tumbler glass +1FAD7 ; fully-qualified # 🫗 E14.0 pouring liquid +1F964 ; fully-qualified # 🥤 E5.0 cup with straw +1F9CB ; fully-qualified # 🧋 E13.0 bubble tea +1F9C3 ; fully-qualified # 🧃 E12.0 beverage box +1F9C9 ; fully-qualified # 🧉 E12.0 mate +1F9CA ; fully-qualified # 🧊 E12.0 ice + +# subgroup: dishware +1F962 ; fully-qualified # 🥢 E5.0 chopsticks +1F37D FE0F ; fully-qualified # 🍽️ E0.7 fork and knife with plate +1F37D ; unqualified # 🍽 E0.7 fork and knife with plate +1F374 ; fully-qualified # 🍴 E0.6 fork and knife +1F944 ; fully-qualified # 🥄 E3.0 spoon +1F52A ; fully-qualified # 🔪 E0.6 kitchen knife +1FAD9 ; fully-qualified # 🫙 E14.0 jar +1F3FA ; fully-qualified # 🏺 E1.0 amphora + +# Food & Drink subtotal: 134 +# Food & Drink subtotal: 134 w/o modifiers + +# group: Travel & Places + +# subgroup: place-map +1F30D ; fully-qualified # 🌍 E0.7 globe showing Europe-Africa +1F30E ; fully-qualified # 🌎 E0.7 globe showing Americas +1F30F ; fully-qualified # 🌏 E0.6 globe showing Asia-Australia +1F310 ; fully-qualified # 🌐 E1.0 globe with meridians +1F5FA FE0F ; fully-qualified # 🗺️ E0.7 world map +1F5FA ; unqualified # 🗺 E0.7 world map +1F5FE ; fully-qualified # 🗾 E0.6 map of Japan +1F9ED ; fully-qualified # 🧭 E11.0 compass + +# subgroup: place-geographic +1F3D4 FE0F ; fully-qualified # 🏔️ E0.7 snow-capped mountain +1F3D4 ; unqualified # 🏔 E0.7 snow-capped mountain +26F0 FE0F ; fully-qualified # ⛰️ E0.7 mountain +26F0 ; unqualified # ⛰ E0.7 mountain +1F30B ; fully-qualified # 🌋 E0.6 volcano +1F5FB ; fully-qualified # 🗻 E0.6 mount fuji +1F3D5 FE0F ; fully-qualified # 🏕️ E0.7 camping +1F3D5 ; unqualified # 🏕 E0.7 camping +1F3D6 FE0F ; fully-qualified # 🏖️ E0.7 beach with umbrella +1F3D6 ; unqualified # 🏖 E0.7 beach with umbrella +1F3DC FE0F ; fully-qualified # 🏜️ E0.7 desert +1F3DC ; unqualified # 🏜 E0.7 desert +1F3DD FE0F ; fully-qualified # 🏝️ E0.7 desert island +1F3DD ; unqualified # 🏝 E0.7 desert island +1F3DE FE0F ; fully-qualified # 🏞️ E0.7 national park +1F3DE ; unqualified # 🏞 E0.7 national park + +# subgroup: place-building +1F3DF FE0F ; fully-qualified # 🏟️ E0.7 stadium +1F3DF ; unqualified # 🏟 E0.7 stadium +1F3DB FE0F ; fully-qualified # 🏛️ E0.7 classical building +1F3DB ; unqualified # 🏛 E0.7 classical building +1F3D7 FE0F ; fully-qualified # 🏗️ E0.7 building construction +1F3D7 ; unqualified # 🏗 E0.7 building construction +1F9F1 ; fully-qualified # 🧱 E11.0 brick +1FAA8 ; fully-qualified # 🪨 E13.0 rock +1FAB5 ; fully-qualified # 🪵 E13.0 wood +1F6D6 ; fully-qualified # 🛖 E13.0 hut +1F3D8 FE0F ; fully-qualified # 🏘️ E0.7 houses +1F3D8 ; unqualified # 🏘 E0.7 houses +1F3DA FE0F ; fully-qualified # 🏚️ E0.7 derelict house +1F3DA ; unqualified # 🏚 E0.7 derelict house +1F3E0 ; fully-qualified # 🏠 E0.6 house +1F3E1 ; fully-qualified # 🏡 E0.6 house with garden +1F3E2 ; fully-qualified # 🏢 E0.6 office building +1F3E3 ; fully-qualified # 🏣 E0.6 Japanese post office +1F3E4 ; fully-qualified # 🏤 E1.0 post office +1F3E5 ; fully-qualified # 🏥 E0.6 hospital +1F3E6 ; fully-qualified # 🏦 E0.6 bank +1F3E8 ; fully-qualified # 🏨 E0.6 hotel +1F3E9 ; fully-qualified # 🏩 E0.6 love hotel +1F3EA ; fully-qualified # 🏪 E0.6 convenience store +1F3EB ; fully-qualified # 🏫 E0.6 school +1F3EC ; fully-qualified # 🏬 E0.6 department store +1F3ED ; fully-qualified # 🏭 E0.6 factory +1F3EF ; fully-qualified # 🏯 E0.6 Japanese castle +1F3F0 ; fully-qualified # 🏰 E0.6 castle +1F492 ; fully-qualified # 💒 E0.6 wedding +1F5FC ; fully-qualified # 🗼 E0.6 Tokyo tower +1F5FD ; fully-qualified # 🗽 E0.6 Statue of Liberty + +# subgroup: place-religious +26EA ; fully-qualified # ⛪ E0.6 church +1F54C ; fully-qualified # 🕌 E1.0 mosque +1F6D5 ; fully-qualified # 🛕 E12.0 hindu temple +1F54D ; fully-qualified # 🕍 E1.0 synagogue +26E9 FE0F ; fully-qualified # ⛩️ E0.7 shinto shrine +26E9 ; unqualified # ⛩ E0.7 shinto shrine +1F54B ; fully-qualified # 🕋 E1.0 kaaba + +# subgroup: place-other +26F2 ; fully-qualified # ⛲ E0.6 fountain +26FA ; fully-qualified # ⛺ E0.6 tent +1F301 ; fully-qualified # 🌁 E0.6 foggy +1F303 ; fully-qualified # 🌃 E0.6 night with stars +1F3D9 FE0F ; fully-qualified # 🏙️ E0.7 cityscape +1F3D9 ; unqualified # 🏙 E0.7 cityscape +1F304 ; fully-qualified # 🌄 E0.6 sunrise over mountains +1F305 ; fully-qualified # 🌅 E0.6 sunrise +1F306 ; fully-qualified # 🌆 E0.6 cityscape at dusk +1F307 ; fully-qualified # 🌇 E0.6 sunset +1F309 ; fully-qualified # 🌉 E0.6 bridge at night +2668 FE0F ; fully-qualified # ♨️ E0.6 hot springs +2668 ; unqualified # ♨ E0.6 hot springs +1F3A0 ; fully-qualified # 🎠 E0.6 carousel horse +1F6DD ; fully-qualified # 🛝 E14.0 playground slide +1F3A1 ; fully-qualified # 🎡 E0.6 ferris wheel +1F3A2 ; fully-qualified # 🎢 E0.6 roller coaster +1F488 ; fully-qualified # 💈 E0.6 barber pole +1F3AA ; fully-qualified # 🎪 E0.6 circus tent + +# subgroup: transport-ground +1F682 ; fully-qualified # 🚂 E1.0 locomotive +1F683 ; fully-qualified # 🚃 E0.6 railway car +1F684 ; fully-qualified # 🚄 E0.6 high-speed train +1F685 ; fully-qualified # 🚅 E0.6 bullet train +1F686 ; fully-qualified # 🚆 E1.0 train +1F687 ; fully-qualified # 🚇 E0.6 metro +1F688 ; fully-qualified # 🚈 E1.0 light rail +1F689 ; fully-qualified # 🚉 E0.6 station +1F68A ; fully-qualified # 🚊 E1.0 tram +1F69D ; fully-qualified # 🚝 E1.0 monorail +1F69E ; fully-qualified # 🚞 E1.0 mountain railway +1F68B ; fully-qualified # 🚋 E1.0 tram car +1F68C ; fully-qualified # 🚌 E0.6 bus +1F68D ; fully-qualified # 🚍 E0.7 oncoming bus +1F68E ; fully-qualified # 🚎 E1.0 trolleybus +1F690 ; fully-qualified # 🚐 E1.0 minibus +1F691 ; fully-qualified # 🚑 E0.6 ambulance +1F692 ; fully-qualified # 🚒 E0.6 fire engine +1F693 ; fully-qualified # 🚓 E0.6 police car +1F694 ; fully-qualified # 🚔 E0.7 oncoming police car +1F695 ; fully-qualified # 🚕 E0.6 taxi +1F696 ; fully-qualified # 🚖 E1.0 oncoming taxi +1F697 ; fully-qualified # 🚗 E0.6 automobile +1F698 ; fully-qualified # 🚘 E0.7 oncoming automobile +1F699 ; fully-qualified # 🚙 E0.6 sport utility vehicle +1F6FB ; fully-qualified # 🛻 E13.0 pickup truck +1F69A ; fully-qualified # 🚚 E0.6 delivery truck +1F69B ; fully-qualified # 🚛 E1.0 articulated lorry +1F69C ; fully-qualified # 🚜 E1.0 tractor +1F3CE FE0F ; fully-qualified # 🏎️ E0.7 racing car +1F3CE ; unqualified # 🏎 E0.7 racing car +1F3CD FE0F ; fully-qualified # 🏍️ E0.7 motorcycle +1F3CD ; unqualified # 🏍 E0.7 motorcycle +1F6F5 ; fully-qualified # 🛵 E3.0 motor scooter +1F9BD ; fully-qualified # 🦽 E12.0 manual wheelchair +1F9BC ; fully-qualified # 🦼 E12.0 motorized wheelchair +1F6FA ; fully-qualified # 🛺 E12.0 auto rickshaw +1F6B2 ; fully-qualified # 🚲 E0.6 bicycle +1F6F4 ; fully-qualified # 🛴 E3.0 kick scooter +1F6F9 ; fully-qualified # 🛹 E11.0 skateboard +1F6FC ; fully-qualified # 🛼 E13.0 roller skate +1F68F ; fully-qualified # 🚏 E0.6 bus stop +1F6E3 FE0F ; fully-qualified # 🛣️ E0.7 motorway +1F6E3 ; unqualified # 🛣 E0.7 motorway +1F6E4 FE0F ; fully-qualified # 🛤️ E0.7 railway track +1F6E4 ; unqualified # 🛤 E0.7 railway track +1F6E2 FE0F ; fully-qualified # 🛢️ E0.7 oil drum +1F6E2 ; unqualified # 🛢 E0.7 oil drum +26FD ; fully-qualified # ⛽ E0.6 fuel pump +1F6DE ; fully-qualified # 🛞 E14.0 wheel +1F6A8 ; fully-qualified # 🚨 E0.6 police car light +1F6A5 ; fully-qualified # 🚥 E0.6 horizontal traffic light +1F6A6 ; fully-qualified # 🚦 E1.0 vertical traffic light +1F6D1 ; fully-qualified # 🛑 E3.0 stop sign +1F6A7 ; fully-qualified # 🚧 E0.6 construction + +# subgroup: transport-water +2693 ; fully-qualified # ⚓ E0.6 anchor +1F6DF ; fully-qualified # 🛟 E14.0 ring buoy +26F5 ; fully-qualified # ⛵ E0.6 sailboat +1F6F6 ; fully-qualified # 🛶 E3.0 canoe +1F6A4 ; fully-qualified # 🚤 E0.6 speedboat +1F6F3 FE0F ; fully-qualified # 🛳️ E0.7 passenger ship +1F6F3 ; unqualified # 🛳 E0.7 passenger ship +26F4 FE0F ; fully-qualified # ⛴️ E0.7 ferry +26F4 ; unqualified # ⛴ E0.7 ferry +1F6E5 FE0F ; fully-qualified # 🛥️ E0.7 motor boat +1F6E5 ; unqualified # 🛥 E0.7 motor boat +1F6A2 ; fully-qualified # 🚢 E0.6 ship + +# subgroup: transport-air +2708 FE0F ; fully-qualified # ✈️ E0.6 airplane +2708 ; unqualified # ✈ E0.6 airplane +1F6E9 FE0F ; fully-qualified # 🛩️ E0.7 small airplane +1F6E9 ; unqualified # 🛩 E0.7 small airplane +1F6EB ; fully-qualified # 🛫 E1.0 airplane departure +1F6EC ; fully-qualified # 🛬 E1.0 airplane arrival +1FA82 ; fully-qualified # 🪂 E12.0 parachute +1F4BA ; fully-qualified # 💺 E0.6 seat +1F681 ; fully-qualified # 🚁 E1.0 helicopter +1F69F ; fully-qualified # 🚟 E1.0 suspension railway +1F6A0 ; fully-qualified # 🚠 E1.0 mountain cableway +1F6A1 ; fully-qualified # 🚡 E1.0 aerial tramway +1F6F0 FE0F ; fully-qualified # 🛰️ E0.7 satellite +1F6F0 ; unqualified # 🛰 E0.7 satellite +1F680 ; fully-qualified # 🚀 E0.6 rocket +1F6F8 ; fully-qualified # 🛸 E5.0 flying saucer + +# subgroup: hotel +1F6CE FE0F ; fully-qualified # 🛎️ E0.7 bellhop bell +1F6CE ; unqualified # 🛎 E0.7 bellhop bell +1F9F3 ; fully-qualified # 🧳 E11.0 luggage + +# subgroup: time +231B ; fully-qualified # ⌛ E0.6 hourglass done +23F3 ; fully-qualified # ⏳ E0.6 hourglass not done +231A ; fully-qualified # ⌚ E0.6 watch +23F0 ; fully-qualified # ⏰ E0.6 alarm clock +23F1 FE0F ; fully-qualified # ⏱️ E1.0 stopwatch +23F1 ; unqualified # ⏱ E1.0 stopwatch +23F2 FE0F ; fully-qualified # ⏲️ E1.0 timer clock +23F2 ; unqualified # ⏲ E1.0 timer clock +1F570 FE0F ; fully-qualified # 🕰️ E0.7 mantelpiece clock +1F570 ; unqualified # 🕰 E0.7 mantelpiece clock +1F55B ; fully-qualified # 🕛 E0.6 twelve o’clock +1F567 ; fully-qualified # 🕧 E0.7 twelve-thirty +1F550 ; fully-qualified # 🕐 E0.6 one o’clock +1F55C ; fully-qualified # 🕜 E0.7 one-thirty +1F551 ; fully-qualified # 🕑 E0.6 two o’clock +1F55D ; fully-qualified # 🕝 E0.7 two-thirty +1F552 ; fully-qualified # 🕒 E0.6 three o’clock +1F55E ; fully-qualified # 🕞 E0.7 three-thirty +1F553 ; fully-qualified # 🕓 E0.6 four o’clock +1F55F ; fully-qualified # 🕟 E0.7 four-thirty +1F554 ; fully-qualified # 🕔 E0.6 five o’clock +1F560 ; fully-qualified # 🕠 E0.7 five-thirty +1F555 ; fully-qualified # 🕕 E0.6 six o’clock +1F561 ; fully-qualified # 🕡 E0.7 six-thirty +1F556 ; fully-qualified # 🕖 E0.6 seven o’clock +1F562 ; fully-qualified # 🕢 E0.7 seven-thirty +1F557 ; fully-qualified # 🕗 E0.6 eight o’clock +1F563 ; fully-qualified # 🕣 E0.7 eight-thirty +1F558 ; fully-qualified # 🕘 E0.6 nine o’clock +1F564 ; fully-qualified # 🕤 E0.7 nine-thirty +1F559 ; fully-qualified # 🕙 E0.6 ten o’clock +1F565 ; fully-qualified # 🕥 E0.7 ten-thirty +1F55A ; fully-qualified # 🕚 E0.6 eleven o’clock +1F566 ; fully-qualified # 🕦 E0.7 eleven-thirty + +# subgroup: sky & weather +1F311 ; fully-qualified # 🌑 E0.6 new moon +1F312 ; fully-qualified # 🌒 E1.0 waxing crescent moon +1F313 ; fully-qualified # 🌓 E0.6 first quarter moon +1F314 ; fully-qualified # 🌔 E0.6 waxing gibbous moon +1F315 ; fully-qualified # 🌕 E0.6 full moon +1F316 ; fully-qualified # 🌖 E1.0 waning gibbous moon +1F317 ; fully-qualified # 🌗 E1.0 last quarter moon +1F318 ; fully-qualified # 🌘 E1.0 waning crescent moon +1F319 ; fully-qualified # 🌙 E0.6 crescent moon +1F31A ; fully-qualified # 🌚 E1.0 new moon face +1F31B ; fully-qualified # 🌛 E0.6 first quarter moon face +1F31C ; fully-qualified # 🌜 E0.7 last quarter moon face +1F321 FE0F ; fully-qualified # 🌡️ E0.7 thermometer +1F321 ; unqualified # 🌡 E0.7 thermometer +2600 FE0F ; fully-qualified # ☀️ E0.6 sun +2600 ; unqualified # ☀ E0.6 sun +1F31D ; fully-qualified # 🌝 E1.0 full moon face +1F31E ; fully-qualified # 🌞 E1.0 sun with face +1FA90 ; fully-qualified # 🪐 E12.0 ringed planet +2B50 ; fully-qualified # ⭐ E0.6 star +1F31F ; fully-qualified # 🌟 E0.6 glowing star +1F320 ; fully-qualified # 🌠 E0.6 shooting star +1F30C ; fully-qualified # 🌌 E0.6 milky way +2601 FE0F ; fully-qualified # ☁️ E0.6 cloud +2601 ; unqualified # ☁ E0.6 cloud +26C5 ; fully-qualified # ⛅ E0.6 sun behind cloud +26C8 FE0F ; fully-qualified # ⛈️ E0.7 cloud with lightning and rain +26C8 ; unqualified # ⛈ E0.7 cloud with lightning and rain +1F324 FE0F ; fully-qualified # 🌤️ E0.7 sun behind small cloud +1F324 ; unqualified # 🌤 E0.7 sun behind small cloud +1F325 FE0F ; fully-qualified # 🌥️ E0.7 sun behind large cloud +1F325 ; unqualified # 🌥 E0.7 sun behind large cloud +1F326 FE0F ; fully-qualified # 🌦️ E0.7 sun behind rain cloud +1F326 ; unqualified # 🌦 E0.7 sun behind rain cloud +1F327 FE0F ; fully-qualified # 🌧️ E0.7 cloud with rain +1F327 ; unqualified # 🌧 E0.7 cloud with rain +1F328 FE0F ; fully-qualified # 🌨️ E0.7 cloud with snow +1F328 ; unqualified # 🌨 E0.7 cloud with snow +1F329 FE0F ; fully-qualified # 🌩️ E0.7 cloud with lightning +1F329 ; unqualified # 🌩 E0.7 cloud with lightning +1F32A FE0F ; fully-qualified # 🌪️ E0.7 tornado +1F32A ; unqualified # 🌪 E0.7 tornado +1F32B FE0F ; fully-qualified # 🌫️ E0.7 fog +1F32B ; unqualified # 🌫 E0.7 fog +1F32C FE0F ; fully-qualified # 🌬️ E0.7 wind face +1F32C ; unqualified # 🌬 E0.7 wind face +1F300 ; fully-qualified # 🌀 E0.6 cyclone +1F308 ; fully-qualified # 🌈 E0.6 rainbow +1F302 ; fully-qualified # 🌂 E0.6 closed umbrella +2602 FE0F ; fully-qualified # ☂️ E0.7 umbrella +2602 ; unqualified # ☂ E0.7 umbrella +2614 ; fully-qualified # ☔ E0.6 umbrella with rain drops +26F1 FE0F ; fully-qualified # ⛱️ E0.7 umbrella on ground +26F1 ; unqualified # ⛱ E0.7 umbrella on ground +26A1 ; fully-qualified # ⚡ E0.6 high voltage +2744 FE0F ; fully-qualified # ❄️ E0.6 snowflake +2744 ; unqualified # ❄ E0.6 snowflake +2603 FE0F ; fully-qualified # ☃️ E0.7 snowman +2603 ; unqualified # ☃ E0.7 snowman +26C4 ; fully-qualified # ⛄ E0.6 snowman without snow +2604 FE0F ; fully-qualified # ☄️ E1.0 comet +2604 ; unqualified # ☄ E1.0 comet +1F525 ; fully-qualified # 🔥 E0.6 fire +1F4A7 ; fully-qualified # 💧 E0.6 droplet +1F30A ; fully-qualified # 🌊 E0.6 water wave + +# Travel & Places subtotal: 267 +# Travel & Places subtotal: 267 w/o modifiers + +# group: Activities + +# subgroup: event +1F383 ; fully-qualified # 🎃 E0.6 jack-o-lantern +1F384 ; fully-qualified # 🎄 E0.6 Christmas tree +1F386 ; fully-qualified # 🎆 E0.6 fireworks +1F387 ; fully-qualified # 🎇 E0.6 sparkler +1F9E8 ; fully-qualified # 🧨 E11.0 firecracker +2728 ; fully-qualified # ✨ E0.6 sparkles +1F388 ; fully-qualified # 🎈 E0.6 balloon +1F389 ; fully-qualified # 🎉 E0.6 party popper +1F38A ; fully-qualified # 🎊 E0.6 confetti ball +1F38B ; fully-qualified # 🎋 E0.6 tanabata tree +1F38D ; fully-qualified # 🎍 E0.6 pine decoration +1F38E ; fully-qualified # 🎎 E0.6 Japanese dolls +1F38F ; fully-qualified # 🎏 E0.6 carp streamer +1F390 ; fully-qualified # 🎐 E0.6 wind chime +1F391 ; fully-qualified # 🎑 E0.6 moon viewing ceremony +1F9E7 ; fully-qualified # 🧧 E11.0 red envelope +1F380 ; fully-qualified # 🎀 E0.6 ribbon +1F381 ; fully-qualified # 🎁 E0.6 wrapped gift +1F397 FE0F ; fully-qualified # 🎗️ E0.7 reminder ribbon +1F397 ; unqualified # 🎗 E0.7 reminder ribbon +1F39F FE0F ; fully-qualified # 🎟️ E0.7 admission tickets +1F39F ; unqualified # 🎟 E0.7 admission tickets +1F3AB ; fully-qualified # 🎫 E0.6 ticket + +# subgroup: award-medal +1F396 FE0F ; fully-qualified # 🎖️ E0.7 military medal +1F396 ; unqualified # 🎖 E0.7 military medal +1F3C6 ; fully-qualified # 🏆 E0.6 trophy +1F3C5 ; fully-qualified # 🏅 E1.0 sports medal +1F947 ; fully-qualified # 🥇 E3.0 1st place medal +1F948 ; fully-qualified # 🥈 E3.0 2nd place medal +1F949 ; fully-qualified # 🥉 E3.0 3rd place medal + +# subgroup: sport +26BD ; fully-qualified # ⚽ E0.6 soccer ball +26BE ; fully-qualified # ⚾ E0.6 baseball +1F94E ; fully-qualified # 🥎 E11.0 softball +1F3C0 ; fully-qualified # 🏀 E0.6 basketball +1F3D0 ; fully-qualified # 🏐 E1.0 volleyball +1F3C8 ; fully-qualified # 🏈 E0.6 american football +1F3C9 ; fully-qualified # 🏉 E1.0 rugby football +1F3BE ; fully-qualified # 🎾 E0.6 tennis +1F94F ; fully-qualified # 🥏 E11.0 flying disc +1F3B3 ; fully-qualified # 🎳 E0.6 bowling +1F3CF ; fully-qualified # 🏏 E1.0 cricket game +1F3D1 ; fully-qualified # 🏑 E1.0 field hockey +1F3D2 ; fully-qualified # 🏒 E1.0 ice hockey +1F94D ; fully-qualified # 🥍 E11.0 lacrosse +1F3D3 ; fully-qualified # 🏓 E1.0 ping pong +1F3F8 ; fully-qualified # 🏸 E1.0 badminton +1F94A ; fully-qualified # 🥊 E3.0 boxing glove +1F94B ; fully-qualified # 🥋 E3.0 martial arts uniform +1F945 ; fully-qualified # 🥅 E3.0 goal net +26F3 ; fully-qualified # ⛳ E0.6 flag in hole +26F8 FE0F ; fully-qualified # ⛸️ E0.7 ice skate +26F8 ; unqualified # ⛸ E0.7 ice skate +1F3A3 ; fully-qualified # 🎣 E0.6 fishing pole +1F93F ; fully-qualified # 🤿 E12.0 diving mask +1F3BD ; fully-qualified # 🎽 E0.6 running shirt +1F3BF ; fully-qualified # 🎿 E0.6 skis +1F6F7 ; fully-qualified # 🛷 E5.0 sled +1F94C ; fully-qualified # 🥌 E5.0 curling stone + +# subgroup: game +1F3AF ; fully-qualified # 🎯 E0.6 bullseye +1FA80 ; fully-qualified # 🪀 E12.0 yo-yo +1FA81 ; fully-qualified # 🪁 E12.0 kite +1F3B1 ; fully-qualified # 🎱 E0.6 pool 8 ball +1F52E ; fully-qualified # 🔮 E0.6 crystal ball +1FA84 ; fully-qualified # 🪄 E13.0 magic wand +1F9FF ; fully-qualified # 🧿 E11.0 nazar amulet +1FAAC ; fully-qualified # 🪬 E14.0 hamsa +1F3AE ; fully-qualified # 🎮 E0.6 video game +1F579 FE0F ; fully-qualified # 🕹️ E0.7 joystick +1F579 ; unqualified # 🕹 E0.7 joystick +1F3B0 ; fully-qualified # 🎰 E0.6 slot machine +1F3B2 ; fully-qualified # 🎲 E0.6 game die +1F9E9 ; fully-qualified # 🧩 E11.0 puzzle piece +1F9F8 ; fully-qualified # 🧸 E11.0 teddy bear +1FA85 ; fully-qualified # 🪅 E13.0 piñata +1FAA9 ; fully-qualified # 🪩 E14.0 mirror ball +1FA86 ; fully-qualified # 🪆 E13.0 nesting dolls +2660 FE0F ; fully-qualified # ♠️ E0.6 spade suit +2660 ; unqualified # ♠ E0.6 spade suit +2665 FE0F ; fully-qualified # ♥️ E0.6 heart suit +2665 ; unqualified # ♥ E0.6 heart suit +2666 FE0F ; fully-qualified # ♦️ E0.6 diamond suit +2666 ; unqualified # ♦ E0.6 diamond suit +2663 FE0F ; fully-qualified # ♣️ E0.6 club suit +2663 ; unqualified # ♣ E0.6 club suit +265F FE0F ; fully-qualified # ♟️ E11.0 chess pawn +265F ; unqualified # ♟ E11.0 chess pawn +1F0CF ; fully-qualified # 🃏 E0.6 joker +1F004 ; fully-qualified # 🀄 E0.6 mahjong red dragon +1F3B4 ; fully-qualified # 🎴 E0.6 flower playing cards + +# subgroup: arts & crafts +1F3AD ; fully-qualified # 🎭 E0.6 performing arts +1F5BC FE0F ; fully-qualified # 🖼️ E0.7 framed picture +1F5BC ; unqualified # 🖼 E0.7 framed picture +1F3A8 ; fully-qualified # 🎨 E0.6 artist palette +1F9F5 ; fully-qualified # 🧵 E11.0 thread +1FAA1 ; fully-qualified # 🪡 E13.0 sewing needle +1F9F6 ; fully-qualified # 🧶 E11.0 yarn +1FAA2 ; fully-qualified # 🪢 E13.0 knot + +# Activities subtotal: 97 +# Activities subtotal: 97 w/o modifiers + +# group: Objects + +# subgroup: clothing +1F453 ; fully-qualified # 👓 E0.6 glasses +1F576 FE0F ; fully-qualified # 🕶️ E0.7 sunglasses +1F576 ; unqualified # 🕶 E0.7 sunglasses +1F97D ; fully-qualified # 🥽 E11.0 goggles +1F97C ; fully-qualified # 🥼 E11.0 lab coat +1F9BA ; fully-qualified # 🦺 E12.0 safety vest +1F454 ; fully-qualified # 👔 E0.6 necktie +1F455 ; fully-qualified # 👕 E0.6 t-shirt +1F456 ; fully-qualified # 👖 E0.6 jeans +1F9E3 ; fully-qualified # 🧣 E5.0 scarf +1F9E4 ; fully-qualified # 🧤 E5.0 gloves +1F9E5 ; fully-qualified # 🧥 E5.0 coat +1F9E6 ; fully-qualified # 🧦 E5.0 socks +1F457 ; fully-qualified # 👗 E0.6 dress +1F458 ; fully-qualified # 👘 E0.6 kimono +1F97B ; fully-qualified # 🥻 E12.0 sari +1FA71 ; fully-qualified # 🩱 E12.0 one-piece swimsuit +1FA72 ; fully-qualified # 🩲 E12.0 briefs +1FA73 ; fully-qualified # 🩳 E12.0 shorts +1F459 ; fully-qualified # 👙 E0.6 bikini +1F45A ; fully-qualified # 👚 E0.6 woman’s clothes +1F45B ; fully-qualified # 👛 E0.6 purse +1F45C ; fully-qualified # 👜 E0.6 handbag +1F45D ; fully-qualified # 👝 E0.6 clutch bag +1F6CD FE0F ; fully-qualified # 🛍️ E0.7 shopping bags +1F6CD ; unqualified # 🛍 E0.7 shopping bags +1F392 ; fully-qualified # 🎒 E0.6 backpack +1FA74 ; fully-qualified # 🩴 E13.0 thong sandal +1F45E ; fully-qualified # 👞 E0.6 man’s shoe +1F45F ; fully-qualified # 👟 E0.6 running shoe +1F97E ; fully-qualified # 🥾 E11.0 hiking boot +1F97F ; fully-qualified # 🥿 E11.0 flat shoe +1F460 ; fully-qualified # 👠 E0.6 high-heeled shoe +1F461 ; fully-qualified # 👡 E0.6 woman’s sandal +1FA70 ; fully-qualified # 🩰 E12.0 ballet shoes +1F462 ; fully-qualified # 👢 E0.6 woman’s boot +1F451 ; fully-qualified # 👑 E0.6 crown +1F452 ; fully-qualified # 👒 E0.6 woman’s hat +1F3A9 ; fully-qualified # 🎩 E0.6 top hat +1F393 ; fully-qualified # 🎓 E0.6 graduation cap +1F9E2 ; fully-qualified # 🧢 E5.0 billed cap +1FA96 ; fully-qualified # 🪖 E13.0 military helmet +26D1 FE0F ; fully-qualified # ⛑️ E0.7 rescue worker’s helmet +26D1 ; unqualified # ⛑ E0.7 rescue worker’s helmet +1F4FF ; fully-qualified # 📿 E1.0 prayer beads +1F484 ; fully-qualified # 💄 E0.6 lipstick +1F48D ; fully-qualified # 💍 E0.6 ring +1F48E ; fully-qualified # 💎 E0.6 gem stone + +# subgroup: sound +1F507 ; fully-qualified # 🔇 E1.0 muted speaker +1F508 ; fully-qualified # 🔈 E0.7 speaker low volume +1F509 ; fully-qualified # 🔉 E1.0 speaker medium volume +1F50A ; fully-qualified # 🔊 E0.6 speaker high volume +1F4E2 ; fully-qualified # 📢 E0.6 loudspeaker +1F4E3 ; fully-qualified # 📣 E0.6 megaphone +1F4EF ; fully-qualified # 📯 E1.0 postal horn +1F514 ; fully-qualified # 🔔 E0.6 bell +1F515 ; fully-qualified # 🔕 E1.0 bell with slash + +# subgroup: music +1F3BC ; fully-qualified # 🎼 E0.6 musical score +1F3B5 ; fully-qualified # 🎵 E0.6 musical note +1F3B6 ; fully-qualified # 🎶 E0.6 musical notes +1F399 FE0F ; fully-qualified # 🎙️ E0.7 studio microphone +1F399 ; unqualified # 🎙 E0.7 studio microphone +1F39A FE0F ; fully-qualified # 🎚️ E0.7 level slider +1F39A ; unqualified # 🎚 E0.7 level slider +1F39B FE0F ; fully-qualified # 🎛️ E0.7 control knobs +1F39B ; unqualified # 🎛 E0.7 control knobs +1F3A4 ; fully-qualified # 🎤 E0.6 microphone +1F3A7 ; fully-qualified # 🎧 E0.6 headphone +1F4FB ; fully-qualified # 📻 E0.6 radio + +# subgroup: musical-instrument +1F3B7 ; fully-qualified # 🎷 E0.6 saxophone +1FA97 ; fully-qualified # 🪗 E13.0 accordion +1F3B8 ; fully-qualified # 🎸 E0.6 guitar +1F3B9 ; fully-qualified # 🎹 E0.6 musical keyboard +1F3BA ; fully-qualified # 🎺 E0.6 trumpet +1F3BB ; fully-qualified # 🎻 E0.6 violin +1FA95 ; fully-qualified # 🪕 E12.0 banjo +1F941 ; fully-qualified # 🥁 E3.0 drum +1FA98 ; fully-qualified # 🪘 E13.0 long drum + +# subgroup: phone +1F4F1 ; fully-qualified # 📱 E0.6 mobile phone +1F4F2 ; fully-qualified # 📲 E0.6 mobile phone with arrow +260E FE0F ; fully-qualified # ☎️ E0.6 telephone +260E ; unqualified # ☎ E0.6 telephone +1F4DE ; fully-qualified # 📞 E0.6 telephone receiver +1F4DF ; fully-qualified # 📟 E0.6 pager +1F4E0 ; fully-qualified # 📠 E0.6 fax machine + +# subgroup: computer +1F50B ; fully-qualified # 🔋 E0.6 battery +1FAAB ; fully-qualified # 🪫 E14.0 low battery +1F50C ; fully-qualified # 🔌 E0.6 electric plug +1F4BB ; fully-qualified # 💻 E0.6 laptop +1F5A5 FE0F ; fully-qualified # 🖥️ E0.7 desktop computer +1F5A5 ; unqualified # 🖥 E0.7 desktop computer +1F5A8 FE0F ; fully-qualified # 🖨️ E0.7 printer +1F5A8 ; unqualified # 🖨 E0.7 printer +2328 FE0F ; fully-qualified # ⌨️ E1.0 keyboard +2328 ; unqualified # ⌨ E1.0 keyboard +1F5B1 FE0F ; fully-qualified # 🖱️ E0.7 computer mouse +1F5B1 ; unqualified # 🖱 E0.7 computer mouse +1F5B2 FE0F ; fully-qualified # 🖲️ E0.7 trackball +1F5B2 ; unqualified # 🖲 E0.7 trackball +1F4BD ; fully-qualified # 💽 E0.6 computer disk +1F4BE ; fully-qualified # 💾 E0.6 floppy disk +1F4BF ; fully-qualified # 💿 E0.6 optical disk +1F4C0 ; fully-qualified # 📀 E0.6 dvd +1F9EE ; fully-qualified # 🧮 E11.0 abacus + +# subgroup: light & video +1F3A5 ; fully-qualified # 🎥 E0.6 movie camera +1F39E FE0F ; fully-qualified # 🎞️ E0.7 film frames +1F39E ; unqualified # 🎞 E0.7 film frames +1F4FD FE0F ; fully-qualified # 📽️ E0.7 film projector +1F4FD ; unqualified # 📽 E0.7 film projector +1F3AC ; fully-qualified # 🎬 E0.6 clapper board +1F4FA ; fully-qualified # 📺 E0.6 television +1F4F7 ; fully-qualified # 📷 E0.6 camera +1F4F8 ; fully-qualified # 📸 E1.0 camera with flash +1F4F9 ; fully-qualified # 📹 E0.6 video camera +1F4FC ; fully-qualified # 📼 E0.6 videocassette +1F50D ; fully-qualified # 🔍 E0.6 magnifying glass tilted left +1F50E ; fully-qualified # 🔎 E0.6 magnifying glass tilted right +1F56F FE0F ; fully-qualified # 🕯️ E0.7 candle +1F56F ; unqualified # 🕯 E0.7 candle +1F4A1 ; fully-qualified # 💡 E0.6 light bulb +1F526 ; fully-qualified # 🔦 E0.6 flashlight +1F3EE ; fully-qualified # 🏮 E0.6 red paper lantern +1FA94 ; fully-qualified # 🪔 E12.0 diya lamp + +# subgroup: book-paper +1F4D4 ; fully-qualified # 📔 E0.6 notebook with decorative cover +1F4D5 ; fully-qualified # 📕 E0.6 closed book +1F4D6 ; fully-qualified # 📖 E0.6 open book +1F4D7 ; fully-qualified # 📗 E0.6 green book +1F4D8 ; fully-qualified # 📘 E0.6 blue book +1F4D9 ; fully-qualified # 📙 E0.6 orange book +1F4DA ; fully-qualified # 📚 E0.6 books +1F4D3 ; fully-qualified # 📓 E0.6 notebook +1F4D2 ; fully-qualified # 📒 E0.6 ledger +1F4C3 ; fully-qualified # 📃 E0.6 page with curl +1F4DC ; fully-qualified # 📜 E0.6 scroll +1F4C4 ; fully-qualified # 📄 E0.6 page facing up +1F4F0 ; fully-qualified # 📰 E0.6 newspaper +1F5DE FE0F ; fully-qualified # 🗞️ E0.7 rolled-up newspaper +1F5DE ; unqualified # 🗞 E0.7 rolled-up newspaper +1F4D1 ; fully-qualified # 📑 E0.6 bookmark tabs +1F516 ; fully-qualified # 🔖 E0.6 bookmark +1F3F7 FE0F ; fully-qualified # 🏷️ E0.7 label +1F3F7 ; unqualified # 🏷 E0.7 label + +# subgroup: money +1F4B0 ; fully-qualified # 💰 E0.6 money bag +1FA99 ; fully-qualified # 🪙 E13.0 coin +1F4B4 ; fully-qualified # 💴 E0.6 yen banknote +1F4B5 ; fully-qualified # 💵 E0.6 dollar banknote +1F4B6 ; fully-qualified # 💶 E1.0 euro banknote +1F4B7 ; fully-qualified # 💷 E1.0 pound banknote +1F4B8 ; fully-qualified # 💸 E0.6 money with wings +1F4B3 ; fully-qualified # 💳 E0.6 credit card +1F9FE ; fully-qualified # 🧾 E11.0 receipt +1F4B9 ; fully-qualified # 💹 E0.6 chart increasing with yen + +# subgroup: mail +2709 FE0F ; fully-qualified # ✉️ E0.6 envelope +2709 ; unqualified # ✉ E0.6 envelope +1F4E7 ; fully-qualified # 📧 E0.6 e-mail +1F4E8 ; fully-qualified # 📨 E0.6 incoming envelope +1F4E9 ; fully-qualified # 📩 E0.6 envelope with arrow +1F4E4 ; fully-qualified # 📤 E0.6 outbox tray +1F4E5 ; fully-qualified # 📥 E0.6 inbox tray +1F4E6 ; fully-qualified # 📦 E0.6 package +1F4EB ; fully-qualified # 📫 E0.6 closed mailbox with raised flag +1F4EA ; fully-qualified # 📪 E0.6 closed mailbox with lowered flag +1F4EC ; fully-qualified # 📬 E0.7 open mailbox with raised flag +1F4ED ; fully-qualified # 📭 E0.7 open mailbox with lowered flag +1F4EE ; fully-qualified # 📮 E0.6 postbox +1F5F3 FE0F ; fully-qualified # 🗳️ E0.7 ballot box with ballot +1F5F3 ; unqualified # 🗳 E0.7 ballot box with ballot + +# subgroup: writing +270F FE0F ; fully-qualified # ✏️ E0.6 pencil +270F ; unqualified # ✏ E0.6 pencil +2712 FE0F ; fully-qualified # ✒️ E0.6 black nib +2712 ; unqualified # ✒ E0.6 black nib +1F58B FE0F ; fully-qualified # 🖋️ E0.7 fountain pen +1F58B ; unqualified # 🖋 E0.7 fountain pen +1F58A FE0F ; fully-qualified # 🖊️ E0.7 pen +1F58A ; unqualified # 🖊 E0.7 pen +1F58C FE0F ; fully-qualified # 🖌️ E0.7 paintbrush +1F58C ; unqualified # 🖌 E0.7 paintbrush +1F58D FE0F ; fully-qualified # 🖍️ E0.7 crayon +1F58D ; unqualified # 🖍 E0.7 crayon +1F4DD ; fully-qualified # 📝 E0.6 memo + +# subgroup: office +1F4BC ; fully-qualified # 💼 E0.6 briefcase +1F4C1 ; fully-qualified # 📁 E0.6 file folder +1F4C2 ; fully-qualified # 📂 E0.6 open file folder +1F5C2 FE0F ; fully-qualified # 🗂️ E0.7 card index dividers +1F5C2 ; unqualified # 🗂 E0.7 card index dividers +1F4C5 ; fully-qualified # 📅 E0.6 calendar +1F4C6 ; fully-qualified # 📆 E0.6 tear-off calendar +1F5D2 FE0F ; fully-qualified # 🗒️ E0.7 spiral notepad +1F5D2 ; unqualified # 🗒 E0.7 spiral notepad +1F5D3 FE0F ; fully-qualified # 🗓️ E0.7 spiral calendar +1F5D3 ; unqualified # 🗓 E0.7 spiral calendar +1F4C7 ; fully-qualified # 📇 E0.6 card index +1F4C8 ; fully-qualified # 📈 E0.6 chart increasing +1F4C9 ; fully-qualified # 📉 E0.6 chart decreasing +1F4CA ; fully-qualified # 📊 E0.6 bar chart +1F4CB ; fully-qualified # 📋 E0.6 clipboard +1F4CC ; fully-qualified # 📌 E0.6 pushpin +1F4CD ; fully-qualified # 📍 E0.6 round pushpin +1F4CE ; fully-qualified # 📎 E0.6 paperclip +1F587 FE0F ; fully-qualified # 🖇️ E0.7 linked paperclips +1F587 ; unqualified # 🖇 E0.7 linked paperclips +1F4CF ; fully-qualified # 📏 E0.6 straight ruler +1F4D0 ; fully-qualified # 📐 E0.6 triangular ruler +2702 FE0F ; fully-qualified # ✂️ E0.6 scissors +2702 ; unqualified # ✂ E0.6 scissors +1F5C3 FE0F ; fully-qualified # 🗃️ E0.7 card file box +1F5C3 ; unqualified # 🗃 E0.7 card file box +1F5C4 FE0F ; fully-qualified # 🗄️ E0.7 file cabinet +1F5C4 ; unqualified # 🗄 E0.7 file cabinet +1F5D1 FE0F ; fully-qualified # 🗑️ E0.7 wastebasket +1F5D1 ; unqualified # 🗑 E0.7 wastebasket + +# subgroup: lock +1F512 ; fully-qualified # 🔒 E0.6 locked +1F513 ; fully-qualified # 🔓 E0.6 unlocked +1F50F ; fully-qualified # 🔏 E0.6 locked with pen +1F510 ; fully-qualified # 🔐 E0.6 locked with key +1F511 ; fully-qualified # 🔑 E0.6 key +1F5DD FE0F ; fully-qualified # 🗝️ E0.7 old key +1F5DD ; unqualified # 🗝 E0.7 old key + +# subgroup: tool +1F528 ; fully-qualified # 🔨 E0.6 hammer +1FA93 ; fully-qualified # 🪓 E12.0 axe +26CF FE0F ; fully-qualified # ⛏️ E0.7 pick +26CF ; unqualified # ⛏ E0.7 pick +2692 FE0F ; fully-qualified # ⚒️ E1.0 hammer and pick +2692 ; unqualified # ⚒ E1.0 hammer and pick +1F6E0 FE0F ; fully-qualified # 🛠️ E0.7 hammer and wrench +1F6E0 ; unqualified # 🛠 E0.7 hammer and wrench +1F5E1 FE0F ; fully-qualified # 🗡️ E0.7 dagger +1F5E1 ; unqualified # 🗡 E0.7 dagger +2694 FE0F ; fully-qualified # ⚔️ E1.0 crossed swords +2694 ; unqualified # ⚔ E1.0 crossed swords +1F52B ; fully-qualified # 🔫 E0.6 water pistol +1FA83 ; fully-qualified # 🪃 E13.0 boomerang +1F3F9 ; fully-qualified # 🏹 E1.0 bow and arrow +1F6E1 FE0F ; fully-qualified # 🛡️ E0.7 shield +1F6E1 ; unqualified # 🛡 E0.7 shield +1FA9A ; fully-qualified # 🪚 E13.0 carpentry saw +1F527 ; fully-qualified # 🔧 E0.6 wrench +1FA9B ; fully-qualified # 🪛 E13.0 screwdriver +1F529 ; fully-qualified # 🔩 E0.6 nut and bolt +2699 FE0F ; fully-qualified # ⚙️ E1.0 gear +2699 ; unqualified # ⚙ E1.0 gear +1F5DC FE0F ; fully-qualified # 🗜️ E0.7 clamp +1F5DC ; unqualified # 🗜 E0.7 clamp +2696 FE0F ; fully-qualified # ⚖️ E1.0 balance scale +2696 ; unqualified # ⚖ E1.0 balance scale +1F9AF ; fully-qualified # 🦯 E12.0 white cane +1F517 ; fully-qualified # 🔗 E0.6 link +26D3 FE0F ; fully-qualified # ⛓️ E0.7 chains +26D3 ; unqualified # ⛓ E0.7 chains +1FA9D ; fully-qualified # 🪝 E13.0 hook +1F9F0 ; fully-qualified # 🧰 E11.0 toolbox +1F9F2 ; fully-qualified # 🧲 E11.0 magnet +1FA9C ; fully-qualified # 🪜 E13.0 ladder + +# subgroup: science +2697 FE0F ; fully-qualified # ⚗️ E1.0 alembic +2697 ; unqualified # ⚗ E1.0 alembic +1F9EA ; fully-qualified # 🧪 E11.0 test tube +1F9EB ; fully-qualified # 🧫 E11.0 petri dish +1F9EC ; fully-qualified # 🧬 E11.0 dna +1F52C ; fully-qualified # 🔬 E1.0 microscope +1F52D ; fully-qualified # 🔭 E1.0 telescope +1F4E1 ; fully-qualified # 📡 E0.6 satellite antenna + +# subgroup: medical +1F489 ; fully-qualified # 💉 E0.6 syringe +1FA78 ; fully-qualified # 🩸 E12.0 drop of blood +1F48A ; fully-qualified # 💊 E0.6 pill +1FA79 ; fully-qualified # 🩹 E12.0 adhesive bandage +1FA7C ; fully-qualified # 🩼 E14.0 crutch +1FA7A ; fully-qualified # 🩺 E12.0 stethoscope +1FA7B ; fully-qualified # 🩻 E14.0 x-ray + +# subgroup: household +1F6AA ; fully-qualified # 🚪 E0.6 door +1F6D7 ; fully-qualified # 🛗 E13.0 elevator +1FA9E ; fully-qualified # 🪞 E13.0 mirror +1FA9F ; fully-qualified # 🪟 E13.0 window +1F6CF FE0F ; fully-qualified # 🛏️ E0.7 bed +1F6CF ; unqualified # 🛏 E0.7 bed +1F6CB FE0F ; fully-qualified # 🛋️ E0.7 couch and lamp +1F6CB ; unqualified # 🛋 E0.7 couch and lamp +1FA91 ; fully-qualified # 🪑 E12.0 chair +1F6BD ; fully-qualified # 🚽 E0.6 toilet +1FAA0 ; fully-qualified # 🪠 E13.0 plunger +1F6BF ; fully-qualified # 🚿 E1.0 shower +1F6C1 ; fully-qualified # 🛁 E1.0 bathtub +1FAA4 ; fully-qualified # 🪤 E13.0 mouse trap +1FA92 ; fully-qualified # 🪒 E12.0 razor +1F9F4 ; fully-qualified # 🧴 E11.0 lotion bottle +1F9F7 ; fully-qualified # 🧷 E11.0 safety pin +1F9F9 ; fully-qualified # 🧹 E11.0 broom +1F9FA ; fully-qualified # 🧺 E11.0 basket +1F9FB ; fully-qualified # 🧻 E11.0 roll of paper +1FAA3 ; fully-qualified # 🪣 E13.0 bucket +1F9FC ; fully-qualified # 🧼 E11.0 soap +1FAE7 ; fully-qualified # 🫧 E14.0 bubbles +1FAA5 ; fully-qualified # 🪥 E13.0 toothbrush +1F9FD ; fully-qualified # 🧽 E11.0 sponge +1F9EF ; fully-qualified # 🧯 E11.0 fire extinguisher +1F6D2 ; fully-qualified # 🛒 E3.0 shopping cart + +# subgroup: other-object +1F6AC ; fully-qualified # 🚬 E0.6 cigarette +26B0 FE0F ; fully-qualified # ⚰️ E1.0 coffin +26B0 ; unqualified # ⚰ E1.0 coffin +1FAA6 ; fully-qualified # 🪦 E13.0 headstone +26B1 FE0F ; fully-qualified # ⚱️ E1.0 funeral urn +26B1 ; unqualified # ⚱ E1.0 funeral urn +1F5FF ; fully-qualified # 🗿 E0.6 moai +1FAA7 ; fully-qualified # 🪧 E13.0 placard +1FAAA ; fully-qualified # 🪪 E14.0 identification card + +# Objects subtotal: 304 +# Objects subtotal: 304 w/o modifiers + +# group: Symbols + +# subgroup: transport-sign +1F3E7 ; fully-qualified # 🏧 E0.6 ATM sign +1F6AE ; fully-qualified # 🚮 E1.0 litter in bin sign +1F6B0 ; fully-qualified # 🚰 E1.0 potable water +267F ; fully-qualified # ♿ E0.6 wheelchair symbol +1F6B9 ; fully-qualified # 🚹 E0.6 men’s room +1F6BA ; fully-qualified # 🚺 E0.6 women’s room +1F6BB ; fully-qualified # 🚻 E0.6 restroom +1F6BC ; fully-qualified # 🚼 E0.6 baby symbol +1F6BE ; fully-qualified # 🚾 E0.6 water closet +1F6C2 ; fully-qualified # 🛂 E1.0 passport control +1F6C3 ; fully-qualified # 🛃 E1.0 customs +1F6C4 ; fully-qualified # 🛄 E1.0 baggage claim +1F6C5 ; fully-qualified # 🛅 E1.0 left luggage + +# subgroup: warning +26A0 FE0F ; fully-qualified # ⚠️ E0.6 warning +26A0 ; unqualified # ⚠ E0.6 warning +1F6B8 ; fully-qualified # 🚸 E1.0 children crossing +26D4 ; fully-qualified # ⛔ E0.6 no entry +1F6AB ; fully-qualified # 🚫 E0.6 prohibited +1F6B3 ; fully-qualified # 🚳 E1.0 no bicycles +1F6AD ; fully-qualified # 🚭 E0.6 no smoking +1F6AF ; fully-qualified # 🚯 E1.0 no littering +1F6B1 ; fully-qualified # 🚱 E1.0 non-potable water +1F6B7 ; fully-qualified # 🚷 E1.0 no pedestrians +1F4F5 ; fully-qualified # 📵 E1.0 no mobile phones +1F51E ; fully-qualified # 🔞 E0.6 no one under eighteen +2622 FE0F ; fully-qualified # ☢️ E1.0 radioactive +2622 ; unqualified # ☢ E1.0 radioactive +2623 FE0F ; fully-qualified # ☣️ E1.0 biohazard +2623 ; unqualified # ☣ E1.0 biohazard + +# subgroup: arrow +2B06 FE0F ; fully-qualified # ⬆️ E0.6 up arrow +2B06 ; unqualified # ⬆ E0.6 up arrow +2197 FE0F ; fully-qualified # ↗️ E0.6 up-right arrow +2197 ; unqualified # ↗ E0.6 up-right arrow +27A1 FE0F ; fully-qualified # ➡️ E0.6 right arrow +27A1 ; unqualified # ➡ E0.6 right arrow +2198 FE0F ; fully-qualified # ↘️ E0.6 down-right arrow +2198 ; unqualified # ↘ E0.6 down-right arrow +2B07 FE0F ; fully-qualified # ⬇️ E0.6 down arrow +2B07 ; unqualified # ⬇ E0.6 down arrow +2199 FE0F ; fully-qualified # ↙️ E0.6 down-left arrow +2199 ; unqualified # ↙ E0.6 down-left arrow +2B05 FE0F ; fully-qualified # ⬅️ E0.6 left arrow +2B05 ; unqualified # ⬅ E0.6 left arrow +2196 FE0F ; fully-qualified # ↖️ E0.6 up-left arrow +2196 ; unqualified # ↖ E0.6 up-left arrow +2195 FE0F ; fully-qualified # ↕️ E0.6 up-down arrow +2195 ; unqualified # ↕ E0.6 up-down arrow +2194 FE0F ; fully-qualified # ↔️ E0.6 left-right arrow +2194 ; unqualified # ↔ E0.6 left-right arrow +21A9 FE0F ; fully-qualified # ↩️ E0.6 right arrow curving left +21A9 ; unqualified # ↩ E0.6 right arrow curving left +21AA FE0F ; fully-qualified # ↪️ E0.6 left arrow curving right +21AA ; unqualified # ↪ E0.6 left arrow curving right +2934 FE0F ; fully-qualified # ⤴️ E0.6 right arrow curving up +2934 ; unqualified # ⤴ E0.6 right arrow curving up +2935 FE0F ; fully-qualified # ⤵️ E0.6 right arrow curving down +2935 ; unqualified # ⤵ E0.6 right arrow curving down +1F503 ; fully-qualified # 🔃 E0.6 clockwise vertical arrows +1F504 ; fully-qualified # 🔄 E1.0 counterclockwise arrows button +1F519 ; fully-qualified # 🔙 E0.6 BACK arrow +1F51A ; fully-qualified # 🔚 E0.6 END arrow +1F51B ; fully-qualified # 🔛 E0.6 ON! arrow +1F51C ; fully-qualified # 🔜 E0.6 SOON arrow +1F51D ; fully-qualified # 🔝 E0.6 TOP arrow + +# subgroup: religion +1F6D0 ; fully-qualified # 🛐 E1.0 place of worship +269B FE0F ; fully-qualified # ⚛️ E1.0 atom symbol +269B ; unqualified # ⚛ E1.0 atom symbol +1F549 FE0F ; fully-qualified # 🕉️ E0.7 om +1F549 ; unqualified # 🕉 E0.7 om +2721 FE0F ; fully-qualified # ✡️ E0.7 star of David +2721 ; unqualified # ✡ E0.7 star of David +2638 FE0F ; fully-qualified # ☸️ E0.7 wheel of dharma +2638 ; unqualified # ☸ E0.7 wheel of dharma +262F FE0F ; fully-qualified # ☯️ E0.7 yin yang +262F ; unqualified # ☯ E0.7 yin yang +271D FE0F ; fully-qualified # ✝️ E0.7 latin cross +271D ; unqualified # ✝ E0.7 latin cross +2626 FE0F ; fully-qualified # ☦️ E1.0 orthodox cross +2626 ; unqualified # ☦ E1.0 orthodox cross +262A FE0F ; fully-qualified # ☪️ E0.7 star and crescent +262A ; unqualified # ☪ E0.7 star and crescent +262E FE0F ; fully-qualified # ☮️ E1.0 peace symbol +262E ; unqualified # ☮ E1.0 peace symbol +1F54E ; fully-qualified # 🕎 E1.0 menorah +1F52F ; fully-qualified # 🔯 E0.6 dotted six-pointed star + +# subgroup: zodiac +2648 ; fully-qualified # ♈ E0.6 Aries +2649 ; fully-qualified # ♉ E0.6 Taurus +264A ; fully-qualified # ♊ E0.6 Gemini +264B ; fully-qualified # ♋ E0.6 Cancer +264C ; fully-qualified # ♌ E0.6 Leo +264D ; fully-qualified # ♍ E0.6 Virgo +264E ; fully-qualified # ♎ E0.6 Libra +264F ; fully-qualified # ♏ E0.6 Scorpio +2650 ; fully-qualified # ♐ E0.6 Sagittarius +2651 ; fully-qualified # ♑ E0.6 Capricorn +2652 ; fully-qualified # ♒ E0.6 Aquarius +2653 ; fully-qualified # ♓ E0.6 Pisces +26CE ; fully-qualified # ⛎ E0.6 Ophiuchus + +# subgroup: av-symbol +1F500 ; fully-qualified # 🔀 E1.0 shuffle tracks button +1F501 ; fully-qualified # 🔁 E1.0 repeat button +1F502 ; fully-qualified # 🔂 E1.0 repeat single button +25B6 FE0F ; fully-qualified # ▶️ E0.6 play button +25B6 ; unqualified # ▶ E0.6 play button +23E9 ; fully-qualified # ⏩ E0.6 fast-forward button +23ED FE0F ; fully-qualified # ⏭️ E0.7 next track button +23ED ; unqualified # ⏭ E0.7 next track button +23EF FE0F ; fully-qualified # ⏯️ E1.0 play or pause button +23EF ; unqualified # ⏯ E1.0 play or pause button +25C0 FE0F ; fully-qualified # ◀️ E0.6 reverse button +25C0 ; unqualified # ◀ E0.6 reverse button +23EA ; fully-qualified # ⏪ E0.6 fast reverse button +23EE FE0F ; fully-qualified # ⏮️ E0.7 last track button +23EE ; unqualified # ⏮ E0.7 last track button +1F53C ; fully-qualified # 🔼 E0.6 upwards button +23EB ; fully-qualified # ⏫ E0.6 fast up button +1F53D ; fully-qualified # 🔽 E0.6 downwards button +23EC ; fully-qualified # ⏬ E0.6 fast down button +23F8 FE0F ; fully-qualified # ⏸️ E0.7 pause button +23F8 ; unqualified # ⏸ E0.7 pause button +23F9 FE0F ; fully-qualified # ⏹️ E0.7 stop button +23F9 ; unqualified # ⏹ E0.7 stop button +23FA FE0F ; fully-qualified # ⏺️ E0.7 record button +23FA ; unqualified # ⏺ E0.7 record button +23CF FE0F ; fully-qualified # ⏏️ E1.0 eject button +23CF ; unqualified # ⏏ E1.0 eject button +1F3A6 ; fully-qualified # 🎦 E0.6 cinema +1F505 ; fully-qualified # 🔅 E1.0 dim button +1F506 ; fully-qualified # 🔆 E1.0 bright button +1F4F6 ; fully-qualified # 📶 E0.6 antenna bars +1F4F3 ; fully-qualified # 📳 E0.6 vibration mode +1F4F4 ; fully-qualified # 📴 E0.6 mobile phone off + +# subgroup: gender +2640 FE0F ; fully-qualified # ♀️ E4.0 female sign +2640 ; unqualified # ♀ E4.0 female sign +2642 FE0F ; fully-qualified # ♂️ E4.0 male sign +2642 ; unqualified # ♂ E4.0 male sign +26A7 FE0F ; fully-qualified # ⚧️ E13.0 transgender symbol +26A7 ; unqualified # ⚧ E13.0 transgender symbol + +# subgroup: math +2716 FE0F ; fully-qualified # ✖️ E0.6 multiply +2716 ; unqualified # ✖ E0.6 multiply +2795 ; fully-qualified # ➕ E0.6 plus +2796 ; fully-qualified # ➖ E0.6 minus +2797 ; fully-qualified # ➗ E0.6 divide +1F7F0 ; fully-qualified # 🟰 E14.0 heavy equals sign +267E FE0F ; fully-qualified # ♾️ E11.0 infinity +267E ; unqualified # ♾ E11.0 infinity + +# subgroup: punctuation +203C FE0F ; fully-qualified # ‼️ E0.6 double exclamation mark +203C ; unqualified # ‼ E0.6 double exclamation mark +2049 FE0F ; fully-qualified # ⁉️ E0.6 exclamation question mark +2049 ; unqualified # ⁉ E0.6 exclamation question mark +2753 ; fully-qualified # ❓ E0.6 red question mark +2754 ; fully-qualified # ❔ E0.6 white question mark +2755 ; fully-qualified # ❕ E0.6 white exclamation mark +2757 ; fully-qualified # ❗ E0.6 red exclamation mark +3030 FE0F ; fully-qualified # 〰️ E0.6 wavy dash +3030 ; unqualified # 〰 E0.6 wavy dash + +# subgroup: currency +1F4B1 ; fully-qualified # 💱 E0.6 currency exchange +1F4B2 ; fully-qualified # 💲 E0.6 heavy dollar sign + +# subgroup: other-symbol +2695 FE0F ; fully-qualified # ⚕️ E4.0 medical symbol +2695 ; unqualified # ⚕ E4.0 medical symbol +267B FE0F ; fully-qualified # ♻️ E0.6 recycling symbol +267B ; unqualified # ♻ E0.6 recycling symbol +269C FE0F ; fully-qualified # ⚜️ E1.0 fleur-de-lis +269C ; unqualified # ⚜ E1.0 fleur-de-lis +1F531 ; fully-qualified # 🔱 E0.6 trident emblem +1F4DB ; fully-qualified # 📛 E0.6 name badge +1F530 ; fully-qualified # 🔰 E0.6 Japanese symbol for beginner +2B55 ; fully-qualified # ⭕ E0.6 hollow red circle +2705 ; fully-qualified # ✅ E0.6 check mark button +2611 FE0F ; fully-qualified # ☑️ E0.6 check box with check +2611 ; unqualified # ☑ E0.6 check box with check +2714 FE0F ; fully-qualified # ✔️ E0.6 check mark +2714 ; unqualified # ✔ E0.6 check mark +274C ; fully-qualified # ❌ E0.6 cross mark +274E ; fully-qualified # ❎ E0.6 cross mark button +27B0 ; fully-qualified # ➰ E0.6 curly loop +27BF ; fully-qualified # ➿ E1.0 double curly loop +303D FE0F ; fully-qualified # 〽️ E0.6 part alternation mark +303D ; unqualified # 〽 E0.6 part alternation mark +2733 FE0F ; fully-qualified # ✳️ E0.6 eight-spoked asterisk +2733 ; unqualified # ✳ E0.6 eight-spoked asterisk +2734 FE0F ; fully-qualified # ✴️ E0.6 eight-pointed star +2734 ; unqualified # ✴ E0.6 eight-pointed star +2747 FE0F ; fully-qualified # ❇️ E0.6 sparkle +2747 ; unqualified # ❇ E0.6 sparkle +00A9 FE0F ; fully-qualified # ©️ E0.6 copyright +00A9 ; unqualified # © E0.6 copyright +00AE FE0F ; fully-qualified # ®️ E0.6 registered +00AE ; unqualified # ® E0.6 registered +2122 FE0F ; fully-qualified # ™️ E0.6 trade mark +2122 ; unqualified # ™ E0.6 trade mark + +# subgroup: keycap +0023 FE0F 20E3 ; fully-qualified # #️⃣ E0.6 keycap: # +0023 20E3 ; unqualified # #⃣ E0.6 keycap: # +002A FE0F 20E3 ; fully-qualified # *️⃣ E2.0 keycap: * +002A 20E3 ; unqualified # *⃣ E2.0 keycap: * +0030 FE0F 20E3 ; fully-qualified # 0️⃣ E0.6 keycap: 0 +0030 20E3 ; unqualified # 0⃣ E0.6 keycap: 0 +0031 FE0F 20E3 ; fully-qualified # 1️⃣ E0.6 keycap: 1 +0031 20E3 ; unqualified # 1⃣ E0.6 keycap: 1 +0032 FE0F 20E3 ; fully-qualified # 2️⃣ E0.6 keycap: 2 +0032 20E3 ; unqualified # 2⃣ E0.6 keycap: 2 +0033 FE0F 20E3 ; fully-qualified # 3️⃣ E0.6 keycap: 3 +0033 20E3 ; unqualified # 3⃣ E0.6 keycap: 3 +0034 FE0F 20E3 ; fully-qualified # 4️⃣ E0.6 keycap: 4 +0034 20E3 ; unqualified # 4⃣ E0.6 keycap: 4 +0035 FE0F 20E3 ; fully-qualified # 5️⃣ E0.6 keycap: 5 +0035 20E3 ; unqualified # 5⃣ E0.6 keycap: 5 +0036 FE0F 20E3 ; fully-qualified # 6️⃣ E0.6 keycap: 6 +0036 20E3 ; unqualified # 6⃣ E0.6 keycap: 6 +0037 FE0F 20E3 ; fully-qualified # 7️⃣ E0.6 keycap: 7 +0037 20E3 ; unqualified # 7⃣ E0.6 keycap: 7 +0038 FE0F 20E3 ; fully-qualified # 8️⃣ E0.6 keycap: 8 +0038 20E3 ; unqualified # 8⃣ E0.6 keycap: 8 +0039 FE0F 20E3 ; fully-qualified # 9️⃣ E0.6 keycap: 9 +0039 20E3 ; unqualified # 9⃣ E0.6 keycap: 9 +1F51F ; fully-qualified # 🔟 E0.6 keycap: 10 + +# subgroup: alphanum +1F520 ; fully-qualified # 🔠 E0.6 input latin uppercase +1F521 ; fully-qualified # 🔡 E0.6 input latin lowercase +1F522 ; fully-qualified # 🔢 E0.6 input numbers +1F523 ; fully-qualified # 🔣 E0.6 input symbols +1F524 ; fully-qualified # 🔤 E0.6 input latin letters +1F170 FE0F ; fully-qualified # 🅰️ E0.6 A button (blood type) +1F170 ; unqualified # 🅰 E0.6 A button (blood type) +1F18E ; fully-qualified # 🆎 E0.6 AB button (blood type) +1F171 FE0F ; fully-qualified # 🅱️ E0.6 B button (blood type) +1F171 ; unqualified # 🅱 E0.6 B button (blood type) +1F191 ; fully-qualified # 🆑 E0.6 CL button +1F192 ; fully-qualified # 🆒 E0.6 COOL button +1F193 ; fully-qualified # 🆓 E0.6 FREE button +2139 FE0F ; fully-qualified # ℹ️ E0.6 information +2139 ; unqualified # ℹ E0.6 information +1F194 ; fully-qualified # 🆔 E0.6 ID button +24C2 FE0F ; fully-qualified # Ⓜ️ E0.6 circled M +24C2 ; unqualified # Ⓜ E0.6 circled M +1F195 ; fully-qualified # 🆕 E0.6 NEW button +1F196 ; fully-qualified # 🆖 E0.6 NG button +1F17E FE0F ; fully-qualified # 🅾️ E0.6 O button (blood type) +1F17E ; unqualified # 🅾 E0.6 O button (blood type) +1F197 ; fully-qualified # 🆗 E0.6 OK button +1F17F FE0F ; fully-qualified # 🅿️ E0.6 P button +1F17F ; unqualified # 🅿 E0.6 P button +1F198 ; fully-qualified # 🆘 E0.6 SOS button +1F199 ; fully-qualified # 🆙 E0.6 UP! button +1F19A ; fully-qualified # 🆚 E0.6 VS button +1F201 ; fully-qualified # 🈁 E0.6 Japanese “here” button +1F202 FE0F ; fully-qualified # 🈂️ E0.6 Japanese “service charge” button +1F202 ; unqualified # 🈂 E0.6 Japanese “service charge” button +1F237 FE0F ; fully-qualified # 🈷️ E0.6 Japanese “monthly amount” button +1F237 ; unqualified # 🈷 E0.6 Japanese “monthly amount” button +1F236 ; fully-qualified # 🈶 E0.6 Japanese “not free of charge” button +1F22F ; fully-qualified # 🈯 E0.6 Japanese “reserved” button +1F250 ; fully-qualified # 🉐 E0.6 Japanese “bargain” button +1F239 ; fully-qualified # 🈹 E0.6 Japanese “discount” button +1F21A ; fully-qualified # 🈚 E0.6 Japanese “free of charge” button +1F232 ; fully-qualified # 🈲 E0.6 Japanese “prohibited” button +1F251 ; fully-qualified # 🉑 E0.6 Japanese “acceptable” button +1F238 ; fully-qualified # 🈸 E0.6 Japanese “application” button +1F234 ; fully-qualified # 🈴 E0.6 Japanese “passing grade” button +1F233 ; fully-qualified # 🈳 E0.6 Japanese “vacancy” button +3297 FE0F ; fully-qualified # ㊗️ E0.6 Japanese “congratulations” button +3297 ; unqualified # ㊗ E0.6 Japanese “congratulations” button +3299 FE0F ; fully-qualified # ㊙️ E0.6 Japanese “secret” button +3299 ; unqualified # ㊙ E0.6 Japanese “secret” button +1F23A ; fully-qualified # 🈺 E0.6 Japanese “open for business” button +1F235 ; fully-qualified # 🈵 E0.6 Japanese “no vacancy” button + +# subgroup: geometric +1F534 ; fully-qualified # 🔴 E0.6 red circle +1F7E0 ; fully-qualified # 🟠 E12.0 orange circle +1F7E1 ; fully-qualified # 🟡 E12.0 yellow circle +1F7E2 ; fully-qualified # 🟢 E12.0 green circle +1F535 ; fully-qualified # 🔵 E0.6 blue circle +1F7E3 ; fully-qualified # 🟣 E12.0 purple circle +1F7E4 ; fully-qualified # 🟤 E12.0 brown circle +26AB ; fully-qualified # ⚫ E0.6 black circle +26AA ; fully-qualified # ⚪ E0.6 white circle +1F7E5 ; fully-qualified # 🟥 E12.0 red square +1F7E7 ; fully-qualified # 🟧 E12.0 orange square +1F7E8 ; fully-qualified # 🟨 E12.0 yellow square +1F7E9 ; fully-qualified # 🟩 E12.0 green square +1F7E6 ; fully-qualified # 🟦 E12.0 blue square +1F7EA ; fully-qualified # 🟪 E12.0 purple square +1F7EB ; fully-qualified # 🟫 E12.0 brown square +2B1B ; fully-qualified # ⬛ E0.6 black large square +2B1C ; fully-qualified # ⬜ E0.6 white large square +25FC FE0F ; fully-qualified # ◼️ E0.6 black medium square +25FC ; unqualified # ◼ E0.6 black medium square +25FB FE0F ; fully-qualified # ◻️ E0.6 white medium square +25FB ; unqualified # ◻ E0.6 white medium square +25FE ; fully-qualified # ◾ E0.6 black medium-small square +25FD ; fully-qualified # ◽ E0.6 white medium-small square +25AA FE0F ; fully-qualified # ▪️ E0.6 black small square +25AA ; unqualified # ▪ E0.6 black small square +25AB FE0F ; fully-qualified # ▫️ E0.6 white small square +25AB ; unqualified # ▫ E0.6 white small square +1F536 ; fully-qualified # 🔶 E0.6 large orange diamond +1F537 ; fully-qualified # 🔷 E0.6 large blue diamond +1F538 ; fully-qualified # 🔸 E0.6 small orange diamond +1F539 ; fully-qualified # 🔹 E0.6 small blue diamond +1F53A ; fully-qualified # 🔺 E0.6 red triangle pointed up +1F53B ; fully-qualified # 🔻 E0.6 red triangle pointed down +1F4A0 ; fully-qualified # 💠 E0.6 diamond with a dot +1F518 ; fully-qualified # 🔘 E0.6 radio button +1F533 ; fully-qualified # 🔳 E0.6 white square button +1F532 ; fully-qualified # 🔲 E0.6 black square button + +# Symbols subtotal: 302 +# Symbols subtotal: 302 w/o modifiers + +# group: Flags + +# subgroup: flag +1F3C1 ; fully-qualified # 🏁 E0.6 chequered flag +1F6A9 ; fully-qualified # 🚩 E0.6 triangular flag +1F38C ; fully-qualified # 🎌 E0.6 crossed flags +1F3F4 ; fully-qualified # 🏴 E1.0 black flag +1F3F3 FE0F ; fully-qualified # 🏳️ E0.7 white flag +1F3F3 ; unqualified # 🏳 E0.7 white flag +1F3F3 FE0F 200D 1F308 ; fully-qualified # 🏳️🌈 E4.0 rainbow flag +1F3F3 200D 1F308 ; unqualified # 🏳🌈 E4.0 rainbow flag +1F3F3 FE0F 200D 26A7 FE0F ; fully-qualified # 🏳️⚧️ E13.0 transgender flag +1F3F3 200D 26A7 FE0F ; unqualified # 🏳⚧️ E13.0 transgender flag +1F3F3 FE0F 200D 26A7 ; unqualified # 🏳️⚧ E13.0 transgender flag +1F3F3 200D 26A7 ; unqualified # 🏳⚧ E13.0 transgender flag +1F3F4 200D 2620 FE0F ; fully-qualified # 🏴☠️ E11.0 pirate flag +1F3F4 200D 2620 ; minimally-qualified # 🏴☠ E11.0 pirate flag + +# subgroup: country-flag +1F1E6 1F1E8 ; fully-qualified # 🇦🇨 E2.0 flag: Ascension Island +1F1E6 1F1E9 ; fully-qualified # 🇦🇩 E2.0 flag: Andorra +1F1E6 1F1EA ; fully-qualified # 🇦🇪 E2.0 flag: United Arab Emirates +1F1E6 1F1EB ; fully-qualified # 🇦🇫 E2.0 flag: Afghanistan +1F1E6 1F1EC ; fully-qualified # 🇦🇬 E2.0 flag: Antigua & Barbuda +1F1E6 1F1EE ; fully-qualified # 🇦🇮 E2.0 flag: Anguilla +1F1E6 1F1F1 ; fully-qualified # 🇦🇱 E2.0 flag: Albania +1F1E6 1F1F2 ; fully-qualified # 🇦🇲 E2.0 flag: Armenia +1F1E6 1F1F4 ; fully-qualified # 🇦🇴 E2.0 flag: Angola +1F1E6 1F1F6 ; fully-qualified # 🇦🇶 E2.0 flag: Antarctica +1F1E6 1F1F7 ; fully-qualified # 🇦🇷 E2.0 flag: Argentina +1F1E6 1F1F8 ; fully-qualified # 🇦🇸 E2.0 flag: American Samoa +1F1E6 1F1F9 ; fully-qualified # 🇦🇹 E2.0 flag: Austria +1F1E6 1F1FA ; fully-qualified # 🇦🇺 E2.0 flag: Australia +1F1E6 1F1FC ; fully-qualified # 🇦🇼 E2.0 flag: Aruba +1F1E6 1F1FD ; fully-qualified # 🇦🇽 E2.0 flag: Åland Islands +1F1E6 1F1FF ; fully-qualified # 🇦🇿 E2.0 flag: Azerbaijan +1F1E7 1F1E6 ; fully-qualified # 🇧🇦 E2.0 flag: Bosnia & Herzegovina +1F1E7 1F1E7 ; fully-qualified # 🇧🇧 E2.0 flag: Barbados +1F1E7 1F1E9 ; fully-qualified # 🇧🇩 E2.0 flag: Bangladesh +1F1E7 1F1EA ; fully-qualified # 🇧🇪 E2.0 flag: Belgium +1F1E7 1F1EB ; fully-qualified # 🇧🇫 E2.0 flag: Burkina Faso +1F1E7 1F1EC ; fully-qualified # 🇧🇬 E2.0 flag: Bulgaria +1F1E7 1F1ED ; fully-qualified # 🇧🇭 E2.0 flag: Bahrain +1F1E7 1F1EE ; fully-qualified # 🇧🇮 E2.0 flag: Burundi +1F1E7 1F1EF ; fully-qualified # 🇧🇯 E2.0 flag: Benin +1F1E7 1F1F1 ; fully-qualified # 🇧🇱 E2.0 flag: St. Barthélemy +1F1E7 1F1F2 ; fully-qualified # 🇧🇲 E2.0 flag: Bermuda +1F1E7 1F1F3 ; fully-qualified # 🇧🇳 E2.0 flag: Brunei +1F1E7 1F1F4 ; fully-qualified # 🇧🇴 E2.0 flag: Bolivia +1F1E7 1F1F6 ; fully-qualified # 🇧🇶 E2.0 flag: Caribbean Netherlands +1F1E7 1F1F7 ; fully-qualified # 🇧🇷 E2.0 flag: Brazil +1F1E7 1F1F8 ; fully-qualified # 🇧🇸 E2.0 flag: Bahamas +1F1E7 1F1F9 ; fully-qualified # 🇧🇹 E2.0 flag: Bhutan +1F1E7 1F1FB ; fully-qualified # 🇧🇻 E2.0 flag: Bouvet Island +1F1E7 1F1FC ; fully-qualified # 🇧🇼 E2.0 flag: Botswana +1F1E7 1F1FE ; fully-qualified # 🇧🇾 E2.0 flag: Belarus +1F1E7 1F1FF ; fully-qualified # 🇧🇿 E2.0 flag: Belize +1F1E8 1F1E6 ; fully-qualified # 🇨🇦 E2.0 flag: Canada +1F1E8 1F1E8 ; fully-qualified # 🇨🇨 E2.0 flag: Cocos (Keeling) Islands +1F1E8 1F1E9 ; fully-qualified # 🇨🇩 E2.0 flag: Congo - Kinshasa +1F1E8 1F1EB ; fully-qualified # 🇨🇫 E2.0 flag: Central African Republic +1F1E8 1F1EC ; fully-qualified # 🇨🇬 E2.0 flag: Congo - Brazzaville +1F1E8 1F1ED ; fully-qualified # 🇨🇭 E2.0 flag: Switzerland +1F1E8 1F1EE ; fully-qualified # 🇨🇮 E2.0 flag: Côte d’Ivoire +1F1E8 1F1F0 ; fully-qualified # 🇨🇰 E2.0 flag: Cook Islands +1F1E8 1F1F1 ; fully-qualified # 🇨🇱 E2.0 flag: Chile +1F1E8 1F1F2 ; fully-qualified # 🇨🇲 E2.0 flag: Cameroon +1F1E8 1F1F3 ; fully-qualified # 🇨🇳 E0.6 flag: China +1F1E8 1F1F4 ; fully-qualified # 🇨🇴 E2.0 flag: Colombia +1F1E8 1F1F5 ; fully-qualified # 🇨🇵 E2.0 flag: Clipperton Island +1F1E8 1F1F7 ; fully-qualified # 🇨🇷 E2.0 flag: Costa Rica +1F1E8 1F1FA ; fully-qualified # 🇨🇺 E2.0 flag: Cuba +1F1E8 1F1FB ; fully-qualified # 🇨🇻 E2.0 flag: Cape Verde +1F1E8 1F1FC ; fully-qualified # 🇨🇼 E2.0 flag: Curaçao +1F1E8 1F1FD ; fully-qualified # 🇨🇽 E2.0 flag: Christmas Island +1F1E8 1F1FE ; fully-qualified # 🇨🇾 E2.0 flag: Cyprus +1F1E8 1F1FF ; fully-qualified # 🇨🇿 E2.0 flag: Czechia +1F1E9 1F1EA ; fully-qualified # 🇩🇪 E0.6 flag: Germany +1F1E9 1F1EC ; fully-qualified # 🇩🇬 E2.0 flag: Diego Garcia +1F1E9 1F1EF ; fully-qualified # 🇩🇯 E2.0 flag: Djibouti +1F1E9 1F1F0 ; fully-qualified # 🇩🇰 E2.0 flag: Denmark +1F1E9 1F1F2 ; fully-qualified # 🇩🇲 E2.0 flag: Dominica +1F1E9 1F1F4 ; fully-qualified # 🇩🇴 E2.0 flag: Dominican Republic +1F1E9 1F1FF ; fully-qualified # 🇩🇿 E2.0 flag: Algeria +1F1EA 1F1E6 ; fully-qualified # 🇪🇦 E2.0 flag: Ceuta & Melilla +1F1EA 1F1E8 ; fully-qualified # 🇪🇨 E2.0 flag: Ecuador +1F1EA 1F1EA ; fully-qualified # 🇪🇪 E2.0 flag: Estonia +1F1EA 1F1EC ; fully-qualified # 🇪🇬 E2.0 flag: Egypt +1F1EA 1F1ED ; fully-qualified # 🇪🇭 E2.0 flag: Western Sahara +1F1EA 1F1F7 ; fully-qualified # 🇪🇷 E2.0 flag: Eritrea +1F1EA 1F1F8 ; fully-qualified # 🇪🇸 E0.6 flag: Spain +1F1EA 1F1F9 ; fully-qualified # 🇪🇹 E2.0 flag: Ethiopia +1F1EA 1F1FA ; fully-qualified # 🇪🇺 E2.0 flag: European Union +1F1EB 1F1EE ; fully-qualified # 🇫🇮 E2.0 flag: Finland +1F1EB 1F1EF ; fully-qualified # 🇫🇯 E2.0 flag: Fiji +1F1EB 1F1F0 ; fully-qualified # 🇫🇰 E2.0 flag: Falkland Islands +1F1EB 1F1F2 ; fully-qualified # 🇫🇲 E2.0 flag: Micronesia +1F1EB 1F1F4 ; fully-qualified # 🇫🇴 E2.0 flag: Faroe Islands +1F1EB 1F1F7 ; fully-qualified # 🇫🇷 E0.6 flag: France +1F1EC 1F1E6 ; fully-qualified # 🇬🇦 E2.0 flag: Gabon +1F1EC 1F1E7 ; fully-qualified # 🇬🇧 E0.6 flag: United Kingdom +1F1EC 1F1E9 ; fully-qualified # 🇬🇩 E2.0 flag: Grenada +1F1EC 1F1EA ; fully-qualified # 🇬🇪 E2.0 flag: Georgia +1F1EC 1F1EB ; fully-qualified # 🇬🇫 E2.0 flag: French Guiana +1F1EC 1F1EC ; fully-qualified # 🇬🇬 E2.0 flag: Guernsey +1F1EC 1F1ED ; fully-qualified # 🇬🇭 E2.0 flag: Ghana +1F1EC 1F1EE ; fully-qualified # 🇬🇮 E2.0 flag: Gibraltar +1F1EC 1F1F1 ; fully-qualified # 🇬🇱 E2.0 flag: Greenland +1F1EC 1F1F2 ; fully-qualified # 🇬🇲 E2.0 flag: Gambia +1F1EC 1F1F3 ; fully-qualified # 🇬🇳 E2.0 flag: Guinea +1F1EC 1F1F5 ; fully-qualified # 🇬🇵 E2.0 flag: Guadeloupe +1F1EC 1F1F6 ; fully-qualified # 🇬🇶 E2.0 flag: Equatorial Guinea +1F1EC 1F1F7 ; fully-qualified # 🇬🇷 E2.0 flag: Greece +1F1EC 1F1F8 ; fully-qualified # 🇬🇸 E2.0 flag: South Georgia & South Sandwich Islands +1F1EC 1F1F9 ; fully-qualified # 🇬🇹 E2.0 flag: Guatemala +1F1EC 1F1FA ; fully-qualified # 🇬🇺 E2.0 flag: Guam +1F1EC 1F1FC ; fully-qualified # 🇬🇼 E2.0 flag: Guinea-Bissau +1F1EC 1F1FE ; fully-qualified # 🇬🇾 E2.0 flag: Guyana +1F1ED 1F1F0 ; fully-qualified # 🇭🇰 E2.0 flag: Hong Kong SAR China +1F1ED 1F1F2 ; fully-qualified # 🇭🇲 E2.0 flag: Heard & McDonald Islands +1F1ED 1F1F3 ; fully-qualified # 🇭🇳 E2.0 flag: Honduras +1F1ED 1F1F7 ; fully-qualified # 🇭🇷 E2.0 flag: Croatia +1F1ED 1F1F9 ; fully-qualified # 🇭🇹 E2.0 flag: Haiti +1F1ED 1F1FA ; fully-qualified # 🇭🇺 E2.0 flag: Hungary +1F1EE 1F1E8 ; fully-qualified # 🇮🇨 E2.0 flag: Canary Islands +1F1EE 1F1E9 ; fully-qualified # 🇮🇩 E2.0 flag: Indonesia +1F1EE 1F1EA ; fully-qualified # 🇮🇪 E2.0 flag: Ireland +1F1EE 1F1F1 ; fully-qualified # 🇮🇱 E2.0 flag: Israel +1F1EE 1F1F2 ; fully-qualified # 🇮🇲 E2.0 flag: Isle of Man +1F1EE 1F1F3 ; fully-qualified # 🇮🇳 E2.0 flag: India +1F1EE 1F1F4 ; fully-qualified # 🇮🇴 E2.0 flag: British Indian Ocean Territory +1F1EE 1F1F6 ; fully-qualified # 🇮🇶 E2.0 flag: Iraq +1F1EE 1F1F7 ; fully-qualified # 🇮🇷 E2.0 flag: Iran +1F1EE 1F1F8 ; fully-qualified # 🇮🇸 E2.0 flag: Iceland +1F1EE 1F1F9 ; fully-qualified # 🇮🇹 E0.6 flag: Italy +1F1EF 1F1EA ; fully-qualified # 🇯🇪 E2.0 flag: Jersey +1F1EF 1F1F2 ; fully-qualified # 🇯🇲 E2.0 flag: Jamaica +1F1EF 1F1F4 ; fully-qualified # 🇯🇴 E2.0 flag: Jordan +1F1EF 1F1F5 ; fully-qualified # 🇯🇵 E0.6 flag: Japan +1F1F0 1F1EA ; fully-qualified # 🇰🇪 E2.0 flag: Kenya +1F1F0 1F1EC ; fully-qualified # 🇰🇬 E2.0 flag: Kyrgyzstan +1F1F0 1F1ED ; fully-qualified # 🇰🇭 E2.0 flag: Cambodia +1F1F0 1F1EE ; fully-qualified # 🇰🇮 E2.0 flag: Kiribati +1F1F0 1F1F2 ; fully-qualified # 🇰🇲 E2.0 flag: Comoros +1F1F0 1F1F3 ; fully-qualified # 🇰🇳 E2.0 flag: St. Kitts & Nevis +1F1F0 1F1F5 ; fully-qualified # 🇰🇵 E2.0 flag: North Korea +1F1F0 1F1F7 ; fully-qualified # 🇰🇷 E0.6 flag: South Korea +1F1F0 1F1FC ; fully-qualified # 🇰🇼 E2.0 flag: Kuwait +1F1F0 1F1FE ; fully-qualified # 🇰🇾 E2.0 flag: Cayman Islands +1F1F0 1F1FF ; fully-qualified # 🇰🇿 E2.0 flag: Kazakhstan +1F1F1 1F1E6 ; fully-qualified # 🇱🇦 E2.0 flag: Laos +1F1F1 1F1E7 ; fully-qualified # 🇱🇧 E2.0 flag: Lebanon +1F1F1 1F1E8 ; fully-qualified # 🇱🇨 E2.0 flag: St. Lucia +1F1F1 1F1EE ; fully-qualified # 🇱🇮 E2.0 flag: Liechtenstein +1F1F1 1F1F0 ; fully-qualified # 🇱🇰 E2.0 flag: Sri Lanka +1F1F1 1F1F7 ; fully-qualified # 🇱🇷 E2.0 flag: Liberia +1F1F1 1F1F8 ; fully-qualified # 🇱🇸 E2.0 flag: Lesotho +1F1F1 1F1F9 ; fully-qualified # 🇱🇹 E2.0 flag: Lithuania +1F1F1 1F1FA ; fully-qualified # 🇱🇺 E2.0 flag: Luxembourg +1F1F1 1F1FB ; fully-qualified # 🇱🇻 E2.0 flag: Latvia +1F1F1 1F1FE ; fully-qualified # 🇱🇾 E2.0 flag: Libya +1F1F2 1F1E6 ; fully-qualified # 🇲🇦 E2.0 flag: Morocco +1F1F2 1F1E8 ; fully-qualified # 🇲🇨 E2.0 flag: Monaco +1F1F2 1F1E9 ; fully-qualified # 🇲🇩 E2.0 flag: Moldova +1F1F2 1F1EA ; fully-qualified # 🇲🇪 E2.0 flag: Montenegro +1F1F2 1F1EB ; fully-qualified # 🇲🇫 E2.0 flag: St. Martin +1F1F2 1F1EC ; fully-qualified # 🇲🇬 E2.0 flag: Madagascar +1F1F2 1F1ED ; fully-qualified # 🇲🇭 E2.0 flag: Marshall Islands +1F1F2 1F1F0 ; fully-qualified # 🇲🇰 E2.0 flag: North Macedonia +1F1F2 1F1F1 ; fully-qualified # 🇲🇱 E2.0 flag: Mali +1F1F2 1F1F2 ; fully-qualified # 🇲🇲 E2.0 flag: Myanmar (Burma) +1F1F2 1F1F3 ; fully-qualified # 🇲🇳 E2.0 flag: Mongolia +1F1F2 1F1F4 ; fully-qualified # 🇲🇴 E2.0 flag: Macao SAR China +1F1F2 1F1F5 ; fully-qualified # 🇲🇵 E2.0 flag: Northern Mariana Islands +1F1F2 1F1F6 ; fully-qualified # 🇲🇶 E2.0 flag: Martinique +1F1F2 1F1F7 ; fully-qualified # 🇲🇷 E2.0 flag: Mauritania +1F1F2 1F1F8 ; fully-qualified # 🇲🇸 E2.0 flag: Montserrat +1F1F2 1F1F9 ; fully-qualified # 🇲🇹 E2.0 flag: Malta +1F1F2 1F1FA ; fully-qualified # 🇲🇺 E2.0 flag: Mauritius +1F1F2 1F1FB ; fully-qualified # 🇲🇻 E2.0 flag: Maldives +1F1F2 1F1FC ; fully-qualified # 🇲🇼 E2.0 flag: Malawi +1F1F2 1F1FD ; fully-qualified # 🇲🇽 E2.0 flag: Mexico +1F1F2 1F1FE ; fully-qualified # 🇲🇾 E2.0 flag: Malaysia +1F1F2 1F1FF ; fully-qualified # 🇲🇿 E2.0 flag: Mozambique +1F1F3 1F1E6 ; fully-qualified # 🇳🇦 E2.0 flag: Namibia +1F1F3 1F1E8 ; fully-qualified # 🇳🇨 E2.0 flag: New Caledonia +1F1F3 1F1EA ; fully-qualified # 🇳🇪 E2.0 flag: Niger +1F1F3 1F1EB ; fully-qualified # 🇳🇫 E2.0 flag: Norfolk Island +1F1F3 1F1EC ; fully-qualified # 🇳🇬 E2.0 flag: Nigeria +1F1F3 1F1EE ; fully-qualified # 🇳🇮 E2.0 flag: Nicaragua +1F1F3 1F1F1 ; fully-qualified # 🇳🇱 E2.0 flag: Netherlands +1F1F3 1F1F4 ; fully-qualified # 🇳🇴 E2.0 flag: Norway +1F1F3 1F1F5 ; fully-qualified # 🇳🇵 E2.0 flag: Nepal +1F1F3 1F1F7 ; fully-qualified # 🇳🇷 E2.0 flag: Nauru +1F1F3 1F1FA ; fully-qualified # 🇳🇺 E2.0 flag: Niue +1F1F3 1F1FF ; fully-qualified # 🇳🇿 E2.0 flag: New Zealand +1F1F4 1F1F2 ; fully-qualified # 🇴🇲 E2.0 flag: Oman +1F1F5 1F1E6 ; fully-qualified # 🇵🇦 E2.0 flag: Panama +1F1F5 1F1EA ; fully-qualified # 🇵🇪 E2.0 flag: Peru +1F1F5 1F1EB ; fully-qualified # 🇵🇫 E2.0 flag: French Polynesia +1F1F5 1F1EC ; fully-qualified # 🇵🇬 E2.0 flag: Papua New Guinea +1F1F5 1F1ED ; fully-qualified # 🇵🇭 E2.0 flag: Philippines +1F1F5 1F1F0 ; fully-qualified # 🇵🇰 E2.0 flag: Pakistan +1F1F5 1F1F1 ; fully-qualified # 🇵🇱 E2.0 flag: Poland +1F1F5 1F1F2 ; fully-qualified # 🇵🇲 E2.0 flag: St. Pierre & Miquelon +1F1F5 1F1F3 ; fully-qualified # 🇵🇳 E2.0 flag: Pitcairn Islands +1F1F5 1F1F7 ; fully-qualified # 🇵🇷 E2.0 flag: Puerto Rico +1F1F5 1F1F8 ; fully-qualified # 🇵🇸 E2.0 flag: Palestinian Territories +1F1F5 1F1F9 ; fully-qualified # 🇵🇹 E2.0 flag: Portugal +1F1F5 1F1FC ; fully-qualified # 🇵🇼 E2.0 flag: Palau +1F1F5 1F1FE ; fully-qualified # 🇵🇾 E2.0 flag: Paraguay +1F1F6 1F1E6 ; fully-qualified # 🇶🇦 E2.0 flag: Qatar +1F1F7 1F1EA ; fully-qualified # 🇷🇪 E2.0 flag: Réunion +1F1F7 1F1F4 ; fully-qualified # 🇷🇴 E2.0 flag: Romania +1F1F7 1F1F8 ; fully-qualified # 🇷🇸 E2.0 flag: Serbia +1F1F7 1F1FA ; fully-qualified # 🇷🇺 E0.6 flag: Russia +1F1F7 1F1FC ; fully-qualified # 🇷🇼 E2.0 flag: Rwanda +1F1F8 1F1E6 ; fully-qualified # 🇸🇦 E2.0 flag: Saudi Arabia +1F1F8 1F1E7 ; fully-qualified # 🇸🇧 E2.0 flag: Solomon Islands +1F1F8 1F1E8 ; fully-qualified # 🇸🇨 E2.0 flag: Seychelles +1F1F8 1F1E9 ; fully-qualified # 🇸🇩 E2.0 flag: Sudan +1F1F8 1F1EA ; fully-qualified # 🇸🇪 E2.0 flag: Sweden +1F1F8 1F1EC ; fully-qualified # 🇸🇬 E2.0 flag: Singapore +1F1F8 1F1ED ; fully-qualified # 🇸🇭 E2.0 flag: St. Helena +1F1F8 1F1EE ; fully-qualified # 🇸🇮 E2.0 flag: Slovenia +1F1F8 1F1EF ; fully-qualified # 🇸🇯 E2.0 flag: Svalbard & Jan Mayen +1F1F8 1F1F0 ; fully-qualified # 🇸🇰 E2.0 flag: Slovakia +1F1F8 1F1F1 ; fully-qualified # 🇸🇱 E2.0 flag: Sierra Leone +1F1F8 1F1F2 ; fully-qualified # 🇸🇲 E2.0 flag: San Marino +1F1F8 1F1F3 ; fully-qualified # 🇸🇳 E2.0 flag: Senegal +1F1F8 1F1F4 ; fully-qualified # 🇸🇴 E2.0 flag: Somalia +1F1F8 1F1F7 ; fully-qualified # 🇸🇷 E2.0 flag: Suriname +1F1F8 1F1F8 ; fully-qualified # 🇸🇸 E2.0 flag: South Sudan +1F1F8 1F1F9 ; fully-qualified # 🇸🇹 E2.0 flag: São Tomé & Príncipe +1F1F8 1F1FB ; fully-qualified # 🇸🇻 E2.0 flag: El Salvador +1F1F8 1F1FD ; fully-qualified # 🇸🇽 E2.0 flag: Sint Maarten +1F1F8 1F1FE ; fully-qualified # 🇸🇾 E2.0 flag: Syria +1F1F8 1F1FF ; fully-qualified # 🇸🇿 E2.0 flag: Eswatini +1F1F9 1F1E6 ; fully-qualified # 🇹🇦 E2.0 flag: Tristan da Cunha +1F1F9 1F1E8 ; fully-qualified # 🇹🇨 E2.0 flag: Turks & Caicos Islands +1F1F9 1F1E9 ; fully-qualified # 🇹🇩 E2.0 flag: Chad +1F1F9 1F1EB ; fully-qualified # 🇹🇫 E2.0 flag: French Southern Territories +1F1F9 1F1EC ; fully-qualified # 🇹🇬 E2.0 flag: Togo +1F1F9 1F1ED ; fully-qualified # 🇹🇭 E2.0 flag: Thailand +1F1F9 1F1EF ; fully-qualified # 🇹🇯 E2.0 flag: Tajikistan +1F1F9 1F1F0 ; fully-qualified # 🇹🇰 E2.0 flag: Tokelau +1F1F9 1F1F1 ; fully-qualified # 🇹🇱 E2.0 flag: Timor-Leste +1F1F9 1F1F2 ; fully-qualified # 🇹🇲 E2.0 flag: Turkmenistan +1F1F9 1F1F3 ; fully-qualified # 🇹🇳 E2.0 flag: Tunisia +1F1F9 1F1F4 ; fully-qualified # 🇹🇴 E2.0 flag: Tonga +1F1F9 1F1F7 ; fully-qualified # 🇹🇷 E2.0 flag: Turkey +1F1F9 1F1F9 ; fully-qualified # 🇹🇹 E2.0 flag: Trinidad & Tobago +1F1F9 1F1FB ; fully-qualified # 🇹🇻 E2.0 flag: Tuvalu +1F1F9 1F1FC ; fully-qualified # 🇹🇼 E2.0 flag: Taiwan +1F1F9 1F1FF ; fully-qualified # 🇹🇿 E2.0 flag: Tanzania +1F1FA 1F1E6 ; fully-qualified # 🇺🇦 E2.0 flag: Ukraine +1F1FA 1F1EC ; fully-qualified # 🇺🇬 E2.0 flag: Uganda +1F1FA 1F1F2 ; fully-qualified # 🇺🇲 E2.0 flag: U.S. Outlying Islands +1F1FA 1F1F3 ; fully-qualified # 🇺🇳 E4.0 flag: United Nations +1F1FA 1F1F8 ; fully-qualified # 🇺🇸 E0.6 flag: United States +1F1FA 1F1FE ; fully-qualified # 🇺🇾 E2.0 flag: Uruguay +1F1FA 1F1FF ; fully-qualified # 🇺🇿 E2.0 flag: Uzbekistan +1F1FB 1F1E6 ; fully-qualified # 🇻🇦 E2.0 flag: Vatican City +1F1FB 1F1E8 ; fully-qualified # 🇻🇨 E2.0 flag: St. Vincent & Grenadines +1F1FB 1F1EA ; fully-qualified # 🇻🇪 E2.0 flag: Venezuela +1F1FB 1F1EC ; fully-qualified # 🇻🇬 E2.0 flag: British Virgin Islands +1F1FB 1F1EE ; fully-qualified # 🇻🇮 E2.0 flag: U.S. Virgin Islands +1F1FB 1F1F3 ; fully-qualified # 🇻🇳 E2.0 flag: Vietnam +1F1FB 1F1FA ; fully-qualified # 🇻🇺 E2.0 flag: Vanuatu +1F1FC 1F1EB ; fully-qualified # 🇼🇫 E2.0 flag: Wallis & Futuna +1F1FC 1F1F8 ; fully-qualified # 🇼🇸 E2.0 flag: Samoa +1F1FD 1F1F0 ; fully-qualified # 🇽🇰 E2.0 flag: Kosovo +1F1FE 1F1EA ; fully-qualified # 🇾🇪 E2.0 flag: Yemen +1F1FE 1F1F9 ; fully-qualified # 🇾🇹 E2.0 flag: Mayotte +1F1FF 1F1E6 ; fully-qualified # 🇿🇦 E2.0 flag: South Africa +1F1FF 1F1F2 ; fully-qualified # 🇿🇲 E2.0 flag: Zambia +1F1FF 1F1FC ; fully-qualified # 🇿🇼 E2.0 flag: Zimbabwe + +# subgroup: subdivision-flag +1F3F4 E0067 E0062 E0065 E006E E0067 E007F ; fully-qualified # 🏴 E5.0 flag: England +1F3F4 E0067 E0062 E0073 E0063 E0074 E007F ; fully-qualified # 🏴 E5.0 flag: Scotland +1F3F4 E0067 E0062 E0077 E006C E0073 E007F ; fully-qualified # 🏴 E5.0 flag: Wales + +# Flags subtotal: 275 +# Flags subtotal: 275 w/o modifiers + +# Status Counts +# fully-qualified : 3624 +# minimally-qualified : 817 +# unqualified : 252 +# component : 9 + +#EOF 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/admin/update_autogen b/admin/update_autogen index 11c4313ae37..99297a9c0dc 100755 --- a/admin/update_autogen +++ b/admin/update_autogen @@ -44,7 +44,7 @@ PD=${0%/*} [ "$PD" = "$0" ] && PD=. # if PATH includes PWD ## This should be the admin directory. -cd $PD +cd $PD || exit cd ../ [ -d admin ] || die "Could not locate admin directory" @@ -53,7 +53,7 @@ cd ../ usage () { cat 1>&2 <<EOF -Usage: ${PN} [-f] [-c] [-q] [-A dir] [-I] [-L] [-C] [-- make-flags] +Usage: ${PN} [-f] [-c] [-q] [-A dir] [-L] [-C] [-- make-flags] Update some auto-generated files in the Emacs tree. By default, only does the versioned loaddefs-like files in lisp/. This requires a build. Passes any non-option args to make (eg -- -j2). @@ -63,8 +63,6 @@ Options: commit them (caution). -q: be quiet; only give error messages, not status messages. -A: only update autotools files, copying into specified dir. --H: also update ChangeLog.${changelog_n} --I: also update info/dir. -L: also update ldefs-boot.el. -C: start from a clean state. Slower, but more correct. EOF @@ -81,14 +79,10 @@ clean= autogendir= # was "autogen" ldefs_flag=1 lboot_flag= -info_flag= -changelog_flag= ## Parameters. ldefs_in=lisp/loaddefs.el ldefs_out=lisp/ldefs-boot.el -changelog_n=$(sed -n 's/CHANGELOG_HISTORY_INDEX_MAX *= *//p' Makefile.in) -changelog_files="ChangeLog.$changelog_n" sources="configure.ac lib/Makefile.am" ## Files to copy into autogendir. ## Everything: @@ -108,10 +102,10 @@ done tempfile=/tmp/$PN.$$ -trap "rm -f $tempfile 2> /dev/null" EXIT +trap 'rm -f $tempfile 2> /dev/null' EXIT -while getopts ":hcfqA:HCIL" option ; do +while getopts ":hcfqA:CL" option ; do case $option in (h) usage ;; @@ -127,10 +121,6 @@ while getopts ":hcfqA:HCIL" option ; do (C) clean=1 ;; - (H) changelog_flag=1 ;; - - (I) info_flag=1 ;; - (L) lboot_flag=1 ;; (\?) die "Bad option -$OPTARG" ;; @@ -172,7 +162,7 @@ status () echo "Checking input file status..." ## The lisp portion could be more permissive, eg only care about .el files. -modified=$(status ${autogendir:+$sources} ${ldefs_flag:+lisp} ${info_flag:+doc}) || die +modified=$(status ${autogendir:+$sources} ${ldefs_flag:+lisp}) || die [ "$modified" ] && { echo "Locally modified: $modified" @@ -235,65 +225,8 @@ commit () } # function commit -## No longer used since info/dir is now generated at install time if needed, -## and is not in the repository any more. -info_dir () -{ - local basefile=build-aux/dir_top outfile=info/dir - - echo "Regenerating info/dir..." - - ## Header contains non-printing characters, so this is more - ## reliable than using echo. - rm -f $outfile - cp $basefile $outfile - - local topic file dircat dirent - - ## FIXME inefficient looping. - for topic in "Texinfo documentation system" "Emacs" "GNU Emacs Lisp" \ - "Emacs editing modes" "Emacs network features" "Emacs misc features" \ - "Emacs lisp libraries"; do - - cat - <<EOF >> $outfile - -$topic -EOF - ## Bit faster than doc/*/*.texi. - for file in doc/emacs/emacs.texi doc/lispintro/*.texi \ - doc/lispref/elisp.texi doc/misc/*.texi; do - - ## FIXME do not ignore w32 if OS is w32. - case $file in - *-xtra.texi|*efaq-w32.texi) continue ;; - esac - - dircat=$(sed -n -e 's/@value{emacsname}/Emacs/' -e 's/^@dircategory //p' $file) - - ## TODO warn about unknown topics (check-info in top-level - ## Makefile does this). - [ "$dircat" = "$topic" ] || continue - - sed -n -e 's/@value{emacsname}/Emacs/' \ - -e 's/@acronym{\([A-Z]*\)}/\1/' \ - -e '/^@direntry/,/^@end direntry/ s/^\([^@]\)/\1/p' \ - $file >> $outfile - - done - done - - local modified - - modified=$(status $outfile) || die - - commit "info/dir" $modified || die "commit error" -} # function info_dir - - [ "$autogendir" ] && { - oldpwd=$PWD - cp $genfiles $autogendir/ cd $autogendir || die "cd error for $autogendir" @@ -308,9 +241,6 @@ EOF } # $autogendir -[ "$info_flag" ] && info_dir - - [ "$ldefs_flag" ] || exit 0 @@ -385,14 +315,6 @@ modified=$(status $genfiles $ldefs_out $grammar_out) || die commit "loaddefs" $modified || die "commit error" -## Less important than the other stuff, so do it last. -[ ! "$changelog_flag" ] || { - make change-history-nocommit || die "make change-history error" - modified=$(status $changelog_files) || die - commit "ChangeLog" $modified || die "commit error" -} - - exit 0 ### update_autogen ends here diff --git a/build-aux/config.guess b/build-aux/config.guess index e81d3ae7c21..1105a749838 100755 --- a/build-aux/config.guess +++ b/build-aux/config.guess @@ -4,7 +4,7 @@ # shellcheck disable=SC2006,SC2268 # see below for rationale -timestamp='2021-06-03' +timestamp='2021-11-30' # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by @@ -437,7 +437,7 @@ case $UNAME_MACHINE:$UNAME_SYSTEM:$UNAME_RELEASE:$UNAME_VERSION in # This test works for both compilers. if test "$CC_FOR_BUILD" != no_compiler_found; then if (echo '#ifdef __amd64'; echo IS_64BIT_ARCH; echo '#endif') | \ - (CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | \ + (CCOPTS="" $CC_FOR_BUILD -m64 -E - 2>/dev/null) | \ grep IS_64BIT_ARCH >/dev/null then SUN_ARCH=x86_64 @@ -1522,6 +1522,9 @@ EOF i*86:rdos:*:*) GUESS=$UNAME_MACHINE-pc-rdos ;; + i*86:Fiwix:*:*) + GUESS=$UNAME_MACHINE-pc-fiwix + ;; *:AROS:*:*) GUESS=$UNAME_MACHINE-unknown-aros ;; diff --git a/build-aux/config.sub b/build-aux/config.sub index d74fb6deac9..38f3d037a78 100755 --- a/build-aux/config.sub +++ b/build-aux/config.sub @@ -4,7 +4,7 @@ # shellcheck disable=SC2006,SC2268 # see below for rationale -timestamp='2021-08-14' +timestamp='2021-10-27' # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by @@ -1304,7 +1304,7 @@ esac if test x$basic_os != x then -# First recognize some ad-hoc caes, or perhaps split kernel-os, or else just +# First recognize some ad-hoc cases, or perhaps split kernel-os, or else just # set os. case $basic_os in gnu/linux*) @@ -1748,7 +1748,8 @@ case $os in | skyos* | haiku* | rdos* | toppers* | drops* | es* \ | onefs* | tirtos* | phoenix* | fuchsia* | redox* | bme* \ | midnightbsd* | amdhsa* | unleashed* | emscripten* | wasi* \ - | nsk* | powerunix* | genode* | zvmoe* | qnx* | emx* | zephyr*) + | nsk* | powerunix* | genode* | zvmoe* | qnx* | emx* | zephyr* \ + | fiwix* ) ;; # This one is extra strict with allowed versions sco3.2v2 | sco3.2v[4-9]* | sco5v6*) diff --git a/configure.ac b/configure.ac index 357d2538e64..5b94fc8e1b7 100644 --- a/configure.ac +++ b/configure.ac @@ -23,7 +23,7 @@ dnl along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. AC_PREREQ(2.65) dnl Note this is parsed by (at least) make-dist and lisp/cedet/ede/emacs.el. -AC_INIT(GNU Emacs, 28.0.90, bug-gnu-emacs@gnu.org, , https://www.gnu.org/software/emacs/) +AC_INIT(GNU Emacs, 29.0.50, bug-gnu-emacs@gnu.org, , https://www.gnu.org/software/emacs/) dnl Set emacs_config_options to the options of 'configure', quoted for the shell, dnl and then quoted again for a C string. Separate options with spaces. @@ -448,6 +448,8 @@ OPTION_DEFAULT_ON([tiff],[don't compile with TIFF image support]) OPTION_DEFAULT_ON([gif],[don't compile with GIF image support]) OPTION_DEFAULT_ON([png],[don't compile with PNG image support]) OPTION_DEFAULT_ON([rsvg],[don't compile with SVG image support]) +OPTION_DEFAULT_ON([webp],[don't compile with WebP image support]) +OPTION_DEFAULT_ON([sqlite3],[don't compile with sqlite3 support]) OPTION_DEFAULT_ON([lcms2],[don't compile with Little CMS support]) OPTION_DEFAULT_ON([libsystemd],[don't compile with libsystemd support]) OPTION_DEFAULT_ON([cairo],[don't compile with Cairo drawing]) @@ -469,6 +471,7 @@ AC_ARG_WITH([ns],[AS_HELP_STRING([--with-ns], [use Nextstep (macOS Cocoa or GNUstep) windowing system. On by default on macOS.])],[],[with_ns=maybe]) OPTION_DEFAULT_OFF([w32], [use native MS Windows GUI in a Cygwin build]) +OPTION_DEFAULT_OFF([pgtk], [use pure GTK build without reliance on X libs (Wayland support) (requires cairo) - Experimental]) OPTION_DEFAULT_ON([gpm],[don't use -lgpm for mouse support on a GNU/Linux console]) OPTION_DEFAULT_ON([dbus],[don't compile with D-Bus support]) @@ -487,6 +490,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)])], @@ -510,6 +514,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) @@ -786,6 +796,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 @@ -907,7 +921,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 @@ -1183,8 +1199,8 @@ fi) dnl Automake replacements. AC_DEFUN([AM_CONDITIONAL], - [$2 && $1=1 || $1= - AC_SUBST([$1])]) + [$2 && $1_CONDITION=1 || $1_CONDITION= + AC_SUBST([$1_CONDITION])]) dnl Prefer silent make output. For verbose output, use dnl 'configure --disable-silent-rules' or 'make V=1' . @@ -1574,6 +1590,8 @@ case "$opsys" in ## Motif needs -lgen. unixware) LIBS_SYSTEM="-lsocket -lnsl -lelf -lgen" ;; + + haiku) LIBS_SYSTEM="-lnetwork" ;; esac AC_SUBST(LIBS_SYSTEM) @@ -1824,8 +1842,14 @@ AC_SUBST(AUTO_DEPEND) ## window-system-specific substs. window_system=none + +if test "${with_pgtk}" = "yes"; then + window_system=pgtk +fi + + AC_PATH_X -if test "$no_x" != yes; then +if test "$no_x" != yes && test "${with_pgtk}" != "yes"; then window_system=x11 fi @@ -2079,6 +2103,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= @@ -2200,6 +2240,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. @@ -2239,6 +2312,16 @@ dnl use the toolkit if we have gtk, or X11R5 or newer. w32 ) term_header=w32term.h ;; + pgtk ) + term_header=pgtkterm.h + with_gtk3=yes + USE_X_TOOLKIT=none + HAVE_PGTK=yes + AC_DEFINE([HAVE_PGTK], 1, [Define to 1 if you have pure Gtk+-3.]) + ;; + haiku ) + term_header=haikuterm.h + ;; esac if test "$window_system" = none && test "X$with_x" != "Xno"; then @@ -2570,7 +2653,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 "${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" @@ -2590,8 +2675,53 @@ if test "${HAVE_X11}" = "yes" || test "${HAVE_NS}" = "yes" || test "${opsys}" = fi fi +### Use -lwebp if available, unless '--with-webp=no' +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" \ + || test "${HAVE_BE_APP}" = "yes" || test "${HAVE_PGTK}" = "yes"; then + WEBP_REQUIRED=0.6.0 + WEBP_MODULE="libwebp >= $WEBP_REQUIRED" + + EMACS_CHECK_MODULES([WEBP], [$WEBP_MODULE]) + AC_SUBST(WEBP_CFLAGS) + AC_SUBST(WEBP_LIBS) + fi + if test $HAVE_WEBP = yes; then + AC_DEFINE(HAVE_WEBP, 1, [Define to 1 if using libwebp.]) + CFLAGS="$CFLAGS $WEBP_CFLAGS" + # Windows loads libwebp dynamically + if test "${opsys}" = "mingw32"; then + WEBP_LIBS= + fi + fi +fi + +### Use -lsqlite3 if available, unless '--with-sqlite3=no' +HAVE_SQLITE3=no +if test "${with_sqlite3}" != "no"; then + AC_CHECK_LIB(sqlite3, sqlite3_open_v2, HAVE_SQLITE3=yes, HAVE_SQLITE3=no) + if test "$HAVE_SQLITE3" = "yes"; then + SQLITE3_LIBS=-lsqlite3 + AC_SUBST(SQLITE3_LIBS) + LIBS="$SQLITE3_LIBS $LIBS" + AC_DEFINE(HAVE_SQLITE3, 1, [Define to 1 if you have the libsqlite3 library (-lsqlite).]) + # Windows loads libsqlite dynamically + if test "${opsys}" = "mingw32"; then + SQLITE3_LIBS= + fi + AC_CHECK_LIB(sqlite3, sqlite3_load_extension, + HAVE_SQLITE3_LOAD_EXTENSION=yes, HAVE_SQLITE3_LOAD_EXTENSION=no) + if test "$HAVE_SQLITE3_LOAD_EXTENSION" = "yes"; then + AC_DEFINE(HAVE_SQLITE3_LOAD_EXTENSION, 1, [Define to 1 if sqlite3 supports loading extensions.]) + fi + fi +fi + HAVE_IMAGEMAGICK=no -if test "${HAVE_X11}" = "yes" || test "${HAVE_NS}" = "yes" || 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 @@ -2674,6 +2804,9 @@ if test "${opsys}" != "mingw32"; then AC_DEFINE([GLIB_DISABLE_DEPRECATION_WARNINGS], [1], [Define to 1 to disable Glib deprecation warnings.]) fi + if test "$window_system" = pgtk; then + GLIB_GSETTINGS + fi else check_gtk2=yes gtk3_pkg_errors="$GTK_PKG_ERRORS " @@ -2815,6 +2948,15 @@ AC_SUBST(XWIDGETS_OBJ) CFLAGS=$OLD_CFLAGS LIBS=$OLD_LIBS +PGTK_OBJ= +PGTK_LIBS= +if test "$window_system" = "pgtk"; then + PGTK_OBJ="pgtkfns.o pgtkterm.o pgtkselect.o pgtkmenu.o pgtkim.o xsettings.o" + PGTK_LIBS="$GTK_LIBS" +fi +AC_SUBST(PGTK_OBJ) +AC_SUBST(PGTK_LIBS) + dnl D-Bus has been tested under GNU/Linux only. Must be adapted for dnl other platforms. HAVE_DBUS=no @@ -2844,7 +2986,7 @@ AC_SUBST(DBUS_OBJ) dnl GSettings has been tested under GNU/Linux only. HAVE_GSETTINGS=no -if test "${HAVE_X11}" = "yes" && test "${with_gsettings}" = "yes"; then +if test "${HAVE_X11}" = "yes" -o "${window_system}" = "pgtk" && test "${with_gsettings}" = "yes"; then EMACS_CHECK_MODULES([GSETTINGS], [gio-2.0 >= 2.26]) if test "$HAVE_GSETTINGS" = "yes"; then old_CFLAGS=$CFLAGS @@ -2878,7 +3020,7 @@ fi dnl GConf has been tested under GNU/Linux only. dnl The version is really arbitrary, it is about the same age as Gtk+ 2.6. HAVE_GCONF=no -if test "${HAVE_X11}" = "yes" && test "${with_gconf}" != "no"; then +if test "${HAVE_X11}" = "yes" -o "${window_system}" = "pgtk" && test "${with_gconf}" != "no"; then EMACS_CHECK_MODULES([GCONF], [gconf-2.0 >= 2.13]) if test "$HAVE_GCONF" = yes; then AC_DEFINE(HAVE_GCONF, 1, [Define to 1 if using GConf.]) @@ -3241,6 +3383,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 @@ -3331,6 +3476,39 @@ if test "${HAVE_X11}" = "yes"; then fi fi +if test "$window_system" = "pgtk"; then + CAIRO_REQUIRED=1.12.0 + CAIRO_MODULE="cairo >= $CAIRO_REQUIRED" + EMACS_CHECK_MODULES(CAIRO, $CAIRO_MODULE) + if test $HAVE_CAIRO = yes; then + AC_DEFINE(USE_CAIRO, 1, [Define to 1 if using cairo.]) + else + AC_MSG_ERROR([cairo required but not found.]) + fi + + CFLAGS="$CFLAGS $CAIRO_CFLAGS" + LIBS="$LIBS $CAIRO_LIBS" + AC_SUBST(CAIRO_CFLAGS) + AC_SUBST(CAIRO_LIBS) +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) ### End of font-backend (under any platform) section. @@ -3450,10 +3628,34 @@ if test "${HAVE_X11}" = "yes"; then fi fi else # "${HAVE_X11}" != "yes" - HAVE_XFT=no - HAVE_FREETYPE=no - HAVE_LIBOTF=no - HAVE_M17N_FLT=no + if test $window_system = pgtk; then + EMACS_CHECK_MODULES([FONTCONFIG], [fontconfig >= 2.2.0]) + EMACS_CHECK_MODULES([FREETYPE], [freetype2]) + if test "$HAVE_FONTCONFIG" != yes -o "$HAVE_FREETYPE" != yes; then + AC_MSG_ERROR(fontconfig and freetype is required.) + fi + HAVE_LIBOTF=no + AC_DEFINE(HAVE_FREETYPE, 1, + [Define to 1 if using the freetype and fontconfig libraries.]) + 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 + fi + fi + else + HAVE_XFT=no + HAVE_FREETYPE=no + HAVE_LIBOTF=no + HAVE_M17N_FLT=no + fi fi # "${HAVE_X11}" != "yes" HAVE_HARFBUZZ=no @@ -3465,6 +3667,7 @@ else harfbuzz_required_ver=0.9.42 fi if test "${HAVE_X11}" = "yes" && test "${HAVE_FREETYPE}" = "yes" \ + || test "$window_system" = "pgtk" \ || test "${HAVE_W32}" = "yes"; then if test "${with_harfbuzz}" != "no"; then EMACS_CHECK_MODULES([HARFBUZZ], [harfbuzz >= $harfbuzz_required_ver]) @@ -3479,6 +3682,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) @@ -3600,7 +3855,8 @@ AC_SUBST(LIBXPM) HAVE_JPEG=no LIBJPEG= if test "${HAVE_X11}" = "yes" || test "${HAVE_W32}" = "yes" \ - || test "${HAVE_NS}" = "yes"; then + || 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], @@ -3740,10 +3996,12 @@ AC_SUBST_FILE([module_env_snippet_25]) AC_SUBST_FILE([module_env_snippet_26]) AC_SUBST_FILE([module_env_snippet_27]) AC_SUBST_FILE([module_env_snippet_28]) +AC_SUBST_FILE([module_env_snippet_29]) module_env_snippet_25="$srcdir/src/module-env-25.h" module_env_snippet_26="$srcdir/src/module-env-26.h" module_env_snippet_27="$srcdir/src/module-env-27.h" module_env_snippet_28="$srcdir/src/module-env-28.h" +module_env_snippet_29="$srcdir/src/module-env-29.h" emacs_major_version="${PACKAGE_VERSION%%.*}" AC_SUBST(emacs_major_version) @@ -3916,7 +4174,8 @@ if test "${with_png}" != no; then if test "$opsys" = mingw32; then AC_CHECK_HEADER([png.h], [HAVE_PNG=yes]) elif test "${HAVE_X11}" = "yes" || test "${HAVE_W32}" = "yes" \ - || test "${HAVE_NS}" = "yes"; then + || 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 @@ -3991,7 +4250,8 @@ if test "${opsys}" = "mingw32"; then AC_DEFINE(HAVE_TIFF, 1, [Define to 1 if you have the tiff library (-ltiff).]) fi elif test "${HAVE_X11}" = "yes" || test "${HAVE_W32}" = "yes" \ - || test "${HAVE_NS}" = "yes"; then + || 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" @@ -4020,7 +4280,8 @@ if test "${opsys}" = "mingw32"; then AC_DEFINE(HAVE_GIF, 1, [Define to 1 if you have a gif (or ungif) library.]) fi elif test "${HAVE_X11}" = "yes" && test "${with_gif}" != "no" \ - || test "${HAVE_W32}" = "yes" || test "${HAVE_NS}" = "yes"; then + || 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. @@ -4213,6 +4474,33 @@ 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 + # Detect both faulty installations of libXi where gesture event + # types are defined but gesture event structures are not, and + # also where gesture event structures are empty. + AC_CHECK_MEMBERS([XIGesturePinchEvent.delta_unaccel_y], + [AC_DEFINE(HAVE_USABLE_XI_GESTURE_PINCH_EVENT, 1, + [Define to 1 if XInput headers define gesture structures correctly.])], + [], [[#include <X11/extensions/XInput2.h>]]) + fi +fi +AC_SUBST(XINPUT_CFLAGS) +AC_SUBST(XINPUT_LIBS) + ### Use Xdbe (-lXdbe) if available HAVE_XDBE=no if test "${HAVE_X11}" = "yes"; then @@ -4437,6 +4725,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]) @@ -4790,7 +5085,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 @@ -5045,7 +5340,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 @@ -5141,6 +5436,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 @@ -5225,6 +5528,7 @@ case $opsys in #if defined __i386__ || defined __sparc__ || defined __mc68000__ \ || defined __alpha__ || defined __mips__ || defined __s390__ \ || defined __arm__ || defined __powerpc__ || defined __amd64__ \ + || defined __x86_64__ \ || defined __ia64__ || defined __sh__ /* ok */ #else @@ -5362,8 +5666,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 <termios.h>]) + 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) @@ -5406,6 +5727,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 <fcntl.h> + #include <signal.h> + ]], + [[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 @@ -5456,6 +5793,7 @@ AC_SUBST(prefix) AC_SUBST(exec_prefix) AC_SUBST(bindir) AC_SUBST(datadir) +AC_SUBST(gsettingsschemadir) AC_SUBST(sharedstatedir) AC_SUBST(libexecdir) AC_SUBST(mandir) @@ -5518,6 +5856,17 @@ if test "${HAVE_X_WINDOWS}" = "yes" ; then FONT_OBJ="$FONT_OBJ ftfont.o" fi fi + +if test "${window_system}" = "pgtk"; then + FONT_OBJ="ftfont.o ftcrfont.o" +fi + +if test "${HAVE_BE_APP}" = "yes" ; then + if test "${HAVE_CAIRO}" = "yes"; then + FONT_OBJ="$FONT_OBJ ftfont.o ftcrfont.o" + fi +fi + if test "${HAVE_HARFBUZZ}" = "yes" ; then FONT_OBJ="$FONT_OBJ hbfont.o" fi @@ -5700,6 +6049,7 @@ CFLAGS=$pre_PKG_CONFIG_CFLAGS LIBS="$LIB_PTHREAD $pre_PKG_CONFIG_LIBS" gl_ASSERT_NO_GNULIB_POSIXCHECK gl_ASSERT_NO_GNULIB_TESTS +gl_EEMALLOC gl_INIT CFLAGS=$SAVE_CFLAGS LIBS=$SAVE_LIBS @@ -5905,11 +6255,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 PNG RSVG SECCOMP \ - SOUND THREADS TIFF \ - TOOLKIT_SCROLL_BARS UNEXEC X11 XAW3D XDBE XFT XIM XPM XWIDGETS X_TOOLKIT \ + M17N_FLT MODULES NATIVE_COMP NOTIFY NS OLDXMENU PDUMPER PGTK PNG RSVG SECCOMP \ + SOUND SQLITE3 THREADS TIFF TOOLKIT_SCROLL_BARS \ + UNEXEC WEBP X11 XAW3D XDBE XFT XIM XINPUT2 XPM XWIDGETS X_TOOLKIT \ ZLIB; do case $opt in @@ -5954,6 +6304,8 @@ AS_ECHO([" Does Emacs use -lXaw3d? ${HAVE_XAW3D Does Emacs use a gif library? ${HAVE_GIF} $LIBGIF Does Emacs use a png library? ${HAVE_PNG} $LIBPNG Does Emacs use -lrsvg-2? ${HAVE_RSVG} + Does Emacs use -lwebp? ${HAVE_WEBP} + Does Emacs use -lsqlite3? ${HAVE_SQLITE3} Does Emacs use cairo? ${HAVE_CAIRO} Does Emacs use -llcms2? ${HAVE_LCMS2} Does Emacs use imagemagick? ${HAVE_IMAGEMAGICK} @@ -5985,6 +6337,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 @@ -6061,6 +6414,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/abbrevs.texi b/doc/emacs/abbrevs.texi index c83da8aaec6..972416ff1cd 100644 --- a/doc/emacs/abbrevs.texi +++ b/doc/emacs/abbrevs.texi @@ -274,7 +274,7 @@ Edit a list of abbrevs; you can add, alter or remove definitions. @example @var{various other tables@dots{}} (lisp-mode-abbrev-table) -"dk" 0 "define-key" +"ks" 0 "keymap-set" (global-abbrev-table) "dfn" 0 "definition" @end example diff --git a/doc/emacs/cmdargs.texi b/doc/emacs/cmdargs.texi index 687a5caf712..b1e471f6d63 100644 --- a/doc/emacs/cmdargs.texi +++ b/doc/emacs/cmdargs.texi @@ -185,6 +185,11 @@ successfully. @item --version @opindex --version Print Emacs version, then exit successfully. + +@item --fingerprint +@opindex --fingerprint +Print the Emacs ``fingerprint'', which is used to uniquely identify +the compiled version of Emacs. @end table @node Initial Options @@ -751,6 +756,10 @@ On MS-Windows, if you set this variable, Emacs will load and initialize the network library at startup, instead of waiting until the first time it is required. +@item WAYLAND_DISPLAY +Pgtk Emacs (built with @option{--with-pgtk}) can run on Wayland natively. +@env{WAYLAND_DISPLAY} specifies the connection to the compositor. + @item emacs_dir On MS-Windows, @env{emacs_dir} is a special environment variable, which indicates the full path of the directory in which Emacs is installed. diff --git a/doc/emacs/custom.texi b/doc/emacs/custom.texi index a3d8a779b8b..c4c43f2713a 100644 --- a/doc/emacs/custom.texi +++ b/doc/emacs/custom.texi @@ -195,7 +195,7 @@ the customization buffer: The first line shows that the variable is named @code{kill-ring-max}, formatted as @samp{Kill Ring Max} for easier -viewing. Its value is @samp{60}. The button labeled @samp{[Hide]}, +viewing. Its value is @samp{120}. The button labeled @samp{[Hide]}, if activated, hides the variable's value and state; this is useful to avoid cluttering up the customization buffer with very long values (for this reason, variables that have very long values may start out @@ -1474,9 +1474,10 @@ as Dired buffers (@pxref{Dired}). Most of the variables reflect the situation on the local machine. Often, they must use a different value when you operate in buffers -with a remote default directory. Think about the shell to be applied -when calling @code{shell} -- it might be @file{/bin/bash} on your -local machine, and @file{/bin/ksh} on a remote machine. +with a remote default directory. Think about the behavior when +calling @code{shell} -- on your local machine, you might use +@file{/bin/bash} and rely on termcap, but on a remote machine, it may +be @file{/bin/ksh} and terminfo. This can be accomplished with @dfn{connection-local variables}. Directory and file local variables override connection-local @@ -1492,6 +1493,10 @@ variables/value pairs in a @dfn{profile}, using the criteria, identifying a remote machine: @example +(connection-local-set-profile-variables 'remote-terminfo + '((system-uses-terminfo . t) + (comint-terminfo-terminal . "dumb-emacs-ansi"))) + (connection-local-set-profile-variables 'remote-ksh '((shell-file-name . "/bin/ksh") (shell-command-switch . "-c"))) @@ -1501,11 +1506,13 @@ criteria, identifying a remote machine: (shell-command-switch . "-c"))) (connection-local-set-profiles - '(:application tramp :machine "remotemachine") 'remote-ksh) + '(:application tramp :machine "remotemachine") + 'remote-terminfo 'remote-ksh) @end example - This code declares two different profiles, @code{remote-ksh} and -@code{remote-bash}. The profile @code{remote-ksh} is applied to all + This code declares three different profiles, @code{remote-terminfo}, +@code{remote-ksh}, and @code{remote-bash}. The profiles +@code{remote-terminfo} and @code{remote-ksh} are applied to all buffers which have a remote default directory matching the regexp @code{"remotemachine"} as host name. Such a criteria can also discriminate for the properties @code{:protocol} (this is the Tramp @@ -1577,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. @@ -1727,8 +1734,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 @@ -1747,19 +1754,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 @@ -1768,11 +1775,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: @@ -1793,7 +1800,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 @@ -1801,8 +1808,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. @@ -1835,11 +1842,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 @@ -1852,69 +1859,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 "<f5>") 'flyspell-mode) -(global-set-key (kbd "C-<f5>") 'display-line-numbers-mode) -(global-set-key (kbd "C-<right>") 'forward-sentence) -(global-set-key (kbd "<mouse-2>") '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 "<f5>" 'flyspell-mode) +(keymap-global-set "C-<f5>" 'display-line-numbers-mode) +(keymap-global-set "C-<right>" 'forward-sentence) +(keymap-global-set "<mouse-2>" '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 @@ -1926,11 +1888,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 @@ -1952,7 +1914,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 @@ -2106,7 +2068,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 "<mouse-2>" 'split-window-below) @end example The symbols for drag events are similar, but have the prefix @@ -2189,7 +2151,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 "<mode-line> <mouse-1>" 'scroll-up-command) @end example Here is the complete list of these dummy prefix keys and their @@ -2580,13 +2542,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 @@ -2596,24 +2558,23 @@ 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 Redefine all keys which now run @code{next-line} in Fundamental mode so that they run @code{forward-line} instead. -@findex substitute-key-definition +@findex keymap-substitute @example -(substitute-key-definition 'next-line 'forward-line - global-map) +(keymap-substitute global-map 'next-line 'forward-line) @end example @item 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. @@ -2789,18 +2750,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/dired.texi b/doc/emacs/dired.texi index 9cdd4b805e6..48cf5630eea 100644 --- a/doc/emacs/dired.texi +++ b/doc/emacs/dired.texi @@ -742,6 +742,15 @@ never creates such missing directories; the value @code{always}, means Dired automatically creates them; the value @code{ask} means Dired asks you for confirmation before creating them. +@vindex dired-create-destination-dirs-on-trailing-dirsep +If the option @code{dired-create-destination-dirs-on-trailing-dirsep} +is non-@code{nil} in addition to @code{dired-create-destination-dirs}, +a trailing directory separator at the destination directory is treated +specially. In that case, when copying to @samp{test/} and no +directory @samp{test} exists already, it will be created and the +specified source files or directories are copied into the newly +created directory. + @vindex dired-copy-preserve-time If @code{dired-copy-preserve-time} is non-@code{nil}, then copying with this command preserves the modification time of the old file in @@ -784,6 +793,14 @@ which to move the files (this is like the shell command @command{mv}). The option @code{dired-create-destination-dirs} controls whether Dired should create non-existent directories in @var{new}. +The option @code{dired-create-destination-dirs-on-trailing-dirsep}, +when set in addition to @code{dired-create-destination-dirs}, controls +wether a trailing directory separator at the destination is treated +specially. In that case, when renaming a directory @samp{old} to +@samp{new/} and no directory @samp{new} exists already, it will be +created and @samp{old} is moved into the newly created directory. +Otherwise, @samp{old} is renamed to @samp{new}. + Dired automatically changes the visited file name of buffers associated with renamed files so that they refer to the new names. @@ -1509,14 +1526,12 @@ image-dired}. This prompts for a directory; specify one that has image files. This creates thumbnails for all the images in that directory, and displays them all in the thumbnail buffer. The thumbnails are generated in the background and are loaded as they -become available. This command asks for confirmation if the number of -image files exceeds @code{image-dired-show-all-from-dir-max-files}. +become available. With point in the thumbnail buffer, you can type @key{RET} -(@code{image-dired-display-thumbnail-original-image}) to display a -sized version of it in another window. This sizes the image to fit -the window. Use the arrow keys to move around in the buffer. For -easy browsing, use @key{SPC} +(@code{image-dired-display-thumbnail-original-image}) to display the +image in another window. Use the arrow keys to move around in the +thumbnail buffer. For easy browsing, use @key{SPC} (@code{image-dired-display-next-thumbnail-original}) to advance and display the next image. Typing @key{DEL} (@code{image-dired-display-previous-thumbnail-original}) backs up to @@ -1569,6 +1584,14 @@ rotation is lossless, and uses an external utility called @node Misc Dired Features @section Other Dired Features +@vindex dired-free-space + By default, Dired will display the available space on the disk in +the first line. This is the @code{first} value of the +@code{dired-free-space} variable. If you set this to +@code{separate} instead, Dired will display this on a separate line +(including the space the files in the current directory takes). If +you set this to @code{nil}, the free space isn't displayed at all. + @kindex + @r{(Dired)} @findex dired-create-directory The command @kbd{+} (@code{dired-create-directory}) reads a diff --git a/doc/emacs/display.texi b/doc/emacs/display.texi index 7ea754612ee..f0dc8b776f7 100644 --- a/doc/emacs/display.texi +++ b/doc/emacs/display.texi @@ -642,24 +642,41 @@ apply them to specific text when you want the effects they produce. @item default This face is used for ordinary text that doesn't specify any face. Its background color is used as the frame's background color. + @item bold This face uses a bold variant of the default font. + @item italic This face uses an italic variant of the default font. + @item bold-italic This face uses a bold italic variant of the default font. + @item underline This face underlines text. + @item fixed-pitch This face forces use of a fixed-width font. It's reasonable to customize this face to use a different fixed-width font, if you like, but you should not make it a variable-width font. + @item fixed-pitch-serif This face is like @code{fixed-pitch}, except the font has serifs and looks more like traditional typewriting. + @cindex @code{variable-pitch} face @item variable-pitch -This face forces use of a variable-width font. +This face forces use of a variable-width (i.e., proportional) font. +The font size picked for this face matches the font picked for the +default (usually fixed-width) font. + +@item variable-pitch-text +This is like the @code{variable-pitch} face (from which it inherits), +but is slightly larger. A proportional font of the same height as a +monospace font usually appears visually smaller, and can therefore be +harder to read. When displaying longer texts, this face can be a good +choice over the (slightly smaller) @code{variable-pitch} face. + @cindex @code{shadow} face @item shadow This face is used for making the text less noticeable than the surrounding @@ -716,46 +733,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 +798,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 @@ -866,6 +903,20 @@ prefix argument. @code{text-scale-mode} if the current font scaling is other than 1, and disable it otherwise. +@cindex pinch to scale +@findex text-scale-pinch + The command @code{text-scale-pinch} increases or decreases the text +scale based on the distance between fingers on a touchpad when a pinch +gesture is performed by placing two fingers on a touchpad and moving +them towards or apart from each other. This is only available on some +systems with supported hardware. + +@findex mouse-wheel-text-scale + The command @code{mouse-wheel-text-scale} also changes the text +scale. Normally, it is run when you press @key{Ctrl} while moving the +mouse wheel. The text scale is increased when the wheel is moved +downwards, and it is decreased when the wheel is moved upwards. + @node Font Lock @section Font Lock mode @cindex Font Lock mode @@ -1653,6 +1704,12 @@ characters more prominent on display. @xref{Glyphless Chars,, Glyphless Character Display, elisp, The Emacs Lisp Reference Manual}, for details. +@findex glyphless-display-mode + The @code{glyphless-display-mode} minor mode can be used to toggle +the display of glyphless characters in the current buffer. The +glyphless characters will be displayed as boxes with acronyms of their +names inside. + @cindex curly quotes, and terminal capabilities @cindex curved quotes, and terminal capabilities @cindex @code{homoglyph} face diff --git a/doc/emacs/emacs.texi b/doc/emacs/emacs.texi index 83847fb8f12..dff42c7b42c 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! @@ -344,14 +345,14 @@ Cut and Paste Operations on Graphical Displays Registers -* Position Registers:: Saving positions in registers. -* Text Registers:: Saving text in registers. -* Rectangle Registers:: Saving rectangles in registers. -* Configuration Registers:: Saving window configurations in registers. -* Number Registers:: Numbers in registers. -* File Registers:: File names in registers. -* Keyboard Macro Registers:: Keyboard macros in registers. -* Bookmarks:: Bookmarks are like registers, but persistent. +* Position Registers:: Saving positions in registers. +* Text Registers:: Saving text in registers. +* Rectangle Registers:: Saving rectangles in registers. +* Configuration Registers:: Saving window configurations in registers. +* Number Registers:: Numbers in registers. +* File and Buffer Registers:: File and buffer names in registers. +* Keyboard Macro Registers:: Keyboard macros in registers. +* Bookmarks:: Bookmarks are like registers, but persistent. Controlling the Display @@ -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/files.texi b/doc/emacs/files.texi index 65a57ccd31b..b7016b00575 100644 --- a/doc/emacs/files.texi +++ b/doc/emacs/files.texi @@ -1476,8 +1476,8 @@ characters that don't match. Then the command exits. If point in the two windows is followed by non-matching text when the command starts, @kbd{M-x compare-windows} tries heuristically to advance up to matching text in the two windows, and then exits. So if -you use @kbd{M-x compare-windows} repeatedly, each time it either -skips one matching range or finds the start of another. +you use @kbd{M-x compare-windows} repeatedly (@pxref{Repeating}), each +time it either skips one matching range or finds the start of another. @vindex compare-ignore-case @vindex compare-ignore-whitespace @@ -2205,11 +2205,11 @@ window, so this is only necessary if you customize the default behavior by using the options @code{image-auto-resize} and @code{image-auto-resize-on-window-resize}. -@findex image-transform-fit-both +@findex image-transform-fit-to-window @findex image-transform-set-scale @findex image-transform-reset To resize the image manually you can use the command -@code{image-transform-fit-both} bound to @kbd{s b} +@code{image-transform-fit-to-window} bound to @kbd{s w} that fits the image to both the window height and width. To scale the image specifying a scale factor, use the command @code{image-transform-set-scale} bound to @kbd{s s}. 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/help.texi b/doc/emacs/help.texi index 7d6c3085cb6..20a9d8be13b 100644 --- a/doc/emacs/help.texi +++ b/doc/emacs/help.texi @@ -461,15 +461,18 @@ Move point back to the previous hyperlink (@code{backward-button}). @item mouse-1 @itemx mouse-2 Follow a hyperlink that you click on. +@item n +@itemx p +Move forward and back between pages in the Help buffer. @item C-c C-c Show all documentation about the symbol at point (@code{help-follow-symbol}). @item C-c C-f @itemx r -Go forward to the next help topic (@code{help-go-forward}). +Go forward in history of help commands (@code{help-go-forward}). @item C-c C-b @itemx l -Go back to the previous help topic (@code{help-go-back}). +Go back in history of help commands (@code{help-go-back}). @item s View the source of the current help topic (if any) (@code{help-view-source}). @@ -498,6 +501,30 @@ C-b} or @kbd{l} (@code{help-go-back}). While retracing your steps, you can go forward by using @kbd{C-c C-f} or @kbd{r} (@code{help-go-forward}). +@kindex TAB @r{(Help mode)} +@findex forward-button +@kindex S-TAB @r{(Help mode)} +@findex backward-button + To move between hyperlinks in a help buffer, use @key{TAB} +(@code{forward-button}) to move forward to the next hyperlink and +@kbd{S-@key{TAB}} (@code{backward-button}) to move back to the +previous hyperlink. These commands act cyclically; for instance, +typing @key{TAB} at the last hyperlink moves back to the first +hyperlink. + +@kindex n @r{(Help mode)} +@kindex p @r{(Help mode)} +@findex help-goto-next-page +@findex help-goto-previous-page + Help buffers produced by some Help commands (like @kbd{C-h b}, which +shows a long list of key bindings) are divided into pages by the +@samp{^L} character. In such buffers, the @kbd{n} +(@code{help-goto-next-page}) command will take you to the next start +of page, and the @kbd{p} (@code{help-goto-previous-page}) command will +take you to the previous start of page. This way you can quickly +navigate between the different kinds of documentation in a help +buffer. + @cindex URL, viewing in help @cindex help, viewing web pages @cindex viewing web pages in help @@ -507,16 +534,6 @@ code definitions, and URLs (web pages). The first two are opened in Emacs, and the third using a web browser via the @code{browse-url} command (@pxref{Browse-URL}). -@kindex TAB @r{(Help mode)} -@findex forward-button -@kindex S-TAB @r{(Help mode)} -@findex backward-button - In a help buffer, @key{TAB} (@code{forward-button}) moves point -forward to the next hyperlink, while @kbd{S-@key{TAB}} -(@code{backward-button}) moves point back to the previous hyperlink. -These commands act cyclically; for instance, typing @key{TAB} at the -last hyperlink moves back to the first hyperlink. - To view all documentation about any symbol in the text, move point to the symbol and type @kbd{C-c C-c} (@code{help-follow-symbol}). This shows the documentation for all the meanings of the symbol---as a diff --git a/doc/emacs/killing.texi b/doc/emacs/killing.texi index 37243b6cd2f..3815c0fef66 100644 --- a/doc/emacs/killing.texi +++ b/doc/emacs/killing.texi @@ -353,7 +353,7 @@ other ways to move text around.) @vindex kill-ring-max The maximum number of entries in the kill ring is controlled by the -variable @code{kill-ring-max}. The default is 60. If you make a new +variable @code{kill-ring-max}. The default is 120. If you make a new kill when this limit has been reached, Emacs makes room by deleting the oldest entry in the kill ring. @@ -562,6 +562,14 @@ new yank to the clipboard. To prevent kill and yank commands from accessing the clipboard, change the variable @code{select-enable-clipboard} to @code{nil}. +@findex yank-media + Programs can put other things than plain text on the clipboard. For +instance, a web browser will usually let you choose ``Copy Image'' on +images, and this image will be put on the clipboard. On capable +platforms, Emacs can yank these objects with the @code{yank-media} +command---but only in modes that have support for it (@pxref{Yanking +Media,,, elisp, The Emacs Lisp Reference Manual}). + @cindex clipboard manager @vindex x-select-enable-clipboard-manager Many X desktop environments support a feature called the 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/m-x.texi b/doc/emacs/m-x.texi index 4e95e03aae8..1115a325412 100644 --- a/doc/emacs/m-x.texi +++ b/doc/emacs/m-x.texi @@ -45,10 +45,11 @@ from running the command by name. @cindex obsolete command When @kbd{M-x} completes on commands, it ignores the commands that -are declared @dfn{obsolete}; for these, you will have to type their -full name. (Obsolete commands are those for which newer, better -alternatives exist, and which are slated for removal in some future -Emacs release.) +were declared @dfn{obsolete} in any previous major version of Emacs; +for these, you will have to type their full name. Commands that were +marked obsolete in the current version of Emacs are listed. (Obsolete +commands are those for which newer, better alternatives exist, and +which are slated for removal in some future Emacs release.) @vindex read-extended-command-predicate In addition, @kbd{M-x} completion can exclude commands that are not diff --git a/doc/emacs/maintaining.texi b/doc/emacs/maintaining.texi index 05e5a5d5ec3..ebd72fa2a00 100644 --- a/doc/emacs/maintaining.texi +++ b/doc/emacs/maintaining.texi @@ -2139,7 +2139,10 @@ Find definition of identifier, and display it in a new frame Find definition of identifier at mouse click. @item M-, Go back to where you previously invoked @kbd{M-.} and friends -(@code{xref-pop-marker-stack}). +(@code{xref-go-back}). +@item C-M-, +Go forward to where you previously invoked @kbd{M-,} +(@code{xref-go-forward}). @item M-x xref-etags-mode Switch @code{xref} to use the @code{etags} backend. @end table @@ -2204,15 +2207,17 @@ selects the window showing the first candidate. The default value is buffer, but doesn't select any of them. @kindex M-, -@findex xref-pop-marker-stack -@vindex xref-marker-ring-length +@findex xref-go-back To go back to places @emph{from where} you've displayed the definition, -use @kbd{M-,} (@code{xref-pop-marker-stack}). It jumps back to the +use @kbd{M-,} (@code{xref-go-back}). It jumps back to the point of the last invocation of @kbd{M-.}. Thus you can find and examine the definition of something with @kbd{M-.} and then return to -where you were with @kbd{M-,}. @kbd{M-,} allows you to retrace your -steps to a depth determined by the variable -@code{xref-marker-ring-length}, which defaults to 16. +where you were with @kbd{M-,}. + +@kindex C-M-, +@findex xref-go-forward + Go forward to a place from where you previously went back using @kbd{M-,}. +This is useful if you find that you went back too far. @findex xref-etags-mode Some major modes install @code{xref} support facilities that might diff --git a/doc/emacs/misc.texi b/doc/emacs/misc.texi index 5123a716dcb..1f2c852fac1 100644 --- a/doc/emacs/misc.texi +++ b/doc/emacs/misc.texi @@ -1497,14 +1497,20 @@ directory stack if they are not already on it underlying shell, of course. @vindex comint-terminfo-terminal +@vindex system-uses-terminfo @vindex TERM@r{, environment variable, in sub-shell} Comint mode sets the @env{TERM} environment variable to a safe default value, but this value disables some useful features. For example, color is disabled in applications that use @env{TERM} to determine if color is supported. Therefore, Emacs provides an option -@code{comint-terminfo-terminal}, which you can set to a terminal that -is present in your system's terminfo database, in order to take -advantage of advanced features of that terminal. +@code{comint-terminfo-terminal} to let you choose a terminal with more +advanced features, as defined in your system's terminfo database. +Emacs will use this option as the value for @env{TERM} so long as +@code{system-uses-terminfo} is non-nil. + +Both @code{comint-terminfo-terminal} and @code{system-uses-terminfo} +can be declared as connection-local variables to adjust these options +to match what a remote system expects (@pxref{Connection Variables}). @node Terminal emulator @subsection Emacs Terminal Emulator @@ -1697,6 +1703,11 @@ options. @xref{Initial Options}. When Emacs is started this way, it calls @code{server-start} after initialization and does not open an initial frame. It then waits for edit requests from clients. +@item +Run the command @code{emacsclient} with the @samp{--alternate-editor=""} +command-line option. This starts an Emacs daemon only if no Emacs daemon +is already running. + @cindex systemd unit file @item If your operating system uses @command{systemd} to manage startup, @@ -1763,6 +1774,32 @@ you can give each daemon its own server name like this: emacs --daemon=foo @end example +@findex server-stop-automatically + The Emacs server can optionally be stopped automatically when +certain conditions are met. To do this, call the function +@code{server-stop-automatically} in your init file (@pxref{Init +File}), with one of the following arguments: + +@itemize +@item +With the argument @code{empty}, the server is stopped when it has no +clients, no unsaved file-visiting buffers and no running processes +anymore. + +@item +With the argument @code{delete-frame}, when the last client frame is +being closed, you are asked whether each unsaved file-visiting buffer +must be saved and each unfinished process can be stopped, and if so, +the server is stopped. + +@item +With the argument @code{kill-terminal}, when the last client frame is +being closed with @kbd{C-x C-c} (@code{save-buffers-kill-terminal}), +you are asked whether each unsaved file-visiting buffer must be saved +and each unfinished process can be stopped, and if so, the server is +stopped. +@end itemize + @findex server-eval-at If you have defined a server by a unique server name, it is possible to connect to the server from another Emacs instance and evaluate Lisp @@ -1986,6 +2023,11 @@ the new frame displays the @file{*scratch*} buffer by default. You can customize this behavior with the variable @code{initial-buffer-choice} (@pxref{Entering Emacs}). +@item -r +@itemx --reuse-frame +Create a new graphical client frame if none exists, otherwise use an +existing Emacs frame. + @item -F @var{alist} @itemx --frame-parameters=@var{alist} Set the parameters for a newly-created graphical frame @@ -2942,6 +2984,41 @@ one-key commands for scrolling the widget, changing its size, and reloading it. Type @w{@kbd{C-h b}} in that buffer to see the key bindings. +@findex xwidget-webkit-edit-mode +@cindex xwidget-webkit-edit-mode + By default, typing a self-inserting character inside an xwidget +webkit buffer will do nothing, or trigger some special action. To +make those characters and other common editing keys insert themselves +when pressed, you can enable @code{xwidget-webkit-edit-mode}, which +redefines them to be passed through to the WebKit xwidget. + +You can also enable @code{xwidget-webkit-edit-mode} by typing @kbd{e} +inside the xwidget webkit buffer. + +@findex xwidget-webkit-isearch-mode +@cindex searching in webkit buffers + @code{xwidget-webkit-isearch-mode} is a minor mode that behaves +similarly to incremental search (@pxref{Incremental Search}), but +operates on the contents of a WebKit widget instead of the current +buffer. It is bound to @kbd{C-s} and @kbd{C-r} inside xwidget-webkit +buffers. When it is invoked by @kbd{C-r}, the initial search will be +performed in reverse direction. + +Typing any self-inserting character will cause the character to be +inserted into the current search query. Typing @kbd{C-s} will cause +the WebKit widget to display the next search result, while typing +@kbd{C-r} will cause it to display the previous one. + +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/msdos-xtra.texi b/doc/emacs/msdos-xtra.texi index fce6ae46f81..114700f08d3 100644 --- a/doc/emacs/msdos-xtra.texi +++ b/doc/emacs/msdos-xtra.texi @@ -105,7 +105,7 @@ following line into your @file{_emacs} file: @smallexample ;; @r{Make the @key{ENTER} key from the numeric keypad act as @kbd{C-j}.} -(define-key function-key-map [kp-enter] [?\C-j]) +(keymap-set function-key-map "<kp-enter>" "C-j") @end smallexample @node MS-DOS Mouse diff --git a/doc/emacs/msdos.texi b/doc/emacs/msdos.texi index 0f8f429b3f8..20eaa0bcb6f 100644 --- a/doc/emacs/msdos.texi +++ b/doc/emacs/msdos.texi @@ -1181,6 +1181,14 @@ The default is @code{t}, which fits well with the Windows default click-to-focus policy. @end ifnottex + On Windows 10 (version 1809 and higher) and Windows 11, Emacs title +bars and scroll bars will follow the system's Light or Dark mode, +similar to other programs such as Explorer and Command Prompt. To +change the color mode, select @code{Personalization} from +@w{@code{Windows Settings}}, then +@w{@code{Colors->Choose your color}} (or @w{@code{Choose your default +app mode}}); then restart Emacs. + @ifnottex @include msdos-xtra.texi @end ifnottex diff --git a/doc/emacs/mule.texi b/doc/emacs/mule.texi index 81aabfb57d5..121d6967309 100644 --- a/doc/emacs/mule.texi +++ b/doc/emacs/mule.texi @@ -473,6 +473,10 @@ First, letters are mapped into symbols for particular sounds or tone marks; then, sequences of these that make up a whole syllable are mapped into one syllable sign. +@kindex C-f@r{, when using input methods} +@kindex C-b@r{, when using input methods} +@kindex C-n@r{, when using input methods} +@kindex C-p@r{, when using input methods} Chinese and Japanese require more complex methods. In Chinese input methods, first you enter the phonetic spelling of a Chinese word (in input method @code{chinese-py}, among others), or a sequence of @@ -498,6 +502,7 @@ alternatives in the row are also numbered; the number appears before the alternative. Typing a number selects the associated alternative of the current row and uses it as input. +@kindex TAB@r{, when using Chinese input methods} @key{TAB} in these Chinese input methods displays a buffer showing all the possible characters at once; then clicking @kbd{mouse-2} on one of them selects that alternative. The keys @kbd{C-f}, @kbd{C-b}, @@ -571,11 +576,37 @@ modes that make buffer text or parts of it read-only, such as @code{read-only-mode} and @code{image-mode}, even when an input method is active. +@kindex C-x 8 @key{RET} +@cindex insert character by name or code-point Another facility for typing characters not on your keyboard is by using @kbd{C-x 8 @key{RET}} (@code{insert-char}) to insert a single character based on its Unicode name or code-point; see @ref{Inserting Text}. +@cindex emoji input +@cindex inserting Emoji +@kindex C-x 8 e +@findex emoji-insert +@findex emoji-list +@findex emoji-search + There are specialized commands for inserting Emoji, and these can be +found on the @kbd{C-x 8 e} keymap. @kbd{C-x 8 e e} +(@code{emoji-insert}) will let you navigate through different Emoji +categories and then choose one. @kbd{C-x 8 e l} (@code{emoji-list}) +will pop up a new buffer and list all the Emoji; clicking (or using +@kbd{RET}) on an emoji character will insert it in the current buffer. +Finally, @kbd{C-x 8 e s} (@code{emoji-search}) will allow you to +search for Emoji based on their names. + +@findex emoji-describe + @code{describe-char} displays a lot of information about the +character/glyphs under point (including emojis). It's sometimes +useful to get a quick description of the name, and you can use the +@kbd{C-x 8 e d} (@code{emoji-describe}) command to do that. It's +meant primarily to help distinguish between different Emoji +variants (which can look very similar), but it will also tell you +the names of non-Emoji characters. + @node Select Input Method @section Selecting an Input Method @@ -1961,3 +1992,16 @@ or right of the current screen position, moving to the next or previous screen line as appropriate. Note that this might potentially move point many buffer positions away, depending on the surrounding bidirectional context. + +@cindex bidi formatting control characters + Bidirectional text sometimes uses special formatting characters to +affect the reordering of text for display. The @sc{lrm} and @sc{rlm} +characters, mentioned above, are two such characters, but there are +more of them. They are by default displayed as thin space glyphs on +GUI frames, and as simple spaces on text-mode frames. If you want to +be aware of these special control characters, so that their effect on +display does not come as a surprise, you can turn on the +@code{glyphless-display-mode} (@pxref{Text Display}). This minor mode +will cause these formatting characters to be displayed as acronyms +inside a small box, so that they stand out on display, and make their +effect easier to understand. diff --git a/doc/emacs/programs.texi b/doc/emacs/programs.texi index 51a48df2e27..85ed65a4954 100644 --- a/doc/emacs/programs.texi +++ b/doc/emacs/programs.texi @@ -868,6 +868,15 @@ highlighting also when point is in whitespace at the beginning of a line and there is a paren at the first or last non-whitespace position on the line, or when point is at the end of a line and there is a paren at the last non-whitespace position on the line. + +@item +@vindex show-paren-context-when-offscreen +@code{show-paren-context-when-offscreen}, when non-@code{nil}, shows +some context in the echo area when point is in a closing delimiter and +the opening delimiter is offscreen. The context is usually the line +that contains the opening delimiter, except if the opening delimiter +is on its own line, in which case the context includes the previous +nonblank line. @end itemize @cindex Electric Pair mode @@ -1818,7 +1827,7 @@ sure the keymap is loaded before we try to change it. @example (defun my-bind-clb () - (define-key c-mode-base-map "\C-m" + (keymap-set c-mode-base-map "RET" 'c-context-line-break)) (add-hook 'c-initialization-hook 'my-bind-clb) @end example diff --git a/doc/emacs/regs.texi b/doc/emacs/regs.texi index 59fa0ff0a1c..df1eec04c00 100644 --- a/doc/emacs/regs.texi +++ b/doc/emacs/regs.texi @@ -47,14 +47,14 @@ are similar in spirit to registers, so they are also documented in this chapter. @menu -* Position Registers:: Saving positions in registers. -* Text Registers:: Saving text in registers. -* Rectangle Registers:: Saving rectangles in registers. -* Configuration Registers:: Saving window configurations in registers. -* Number Registers:: Numbers in registers. -* File Registers:: File names in registers. -* Keyboard Macro Registers:: Keyboard macros in registers. -* Bookmarks:: Bookmarks are like registers, but persistent. +* Position Registers:: Saving positions in registers. +* Text Registers:: Saving text in registers. +* Rectangle Registers:: Saving rectangles in registers. +* Configuration Registers:: Saving window configurations in registers. +* Number Registers:: Numbers in registers. +* File and Buffer Registers:: File and buffer names in registers. +* Keyboard Macro Registers:: Keyboard macros in registers. +* Bookmarks:: Bookmarks are like registers, but persistent. @end menu @node Position Registers @@ -238,9 +238,10 @@ register contents into the buffer. @kbd{C-x r +} with no numeric argument increments the register value by 1; @kbd{C-x r n} with no numeric argument stores zero in the register. -@node File Registers -@section Keeping File Names in Registers +@node File and Buffer Registers +@section Keeping File and Buffer Names in Registers @cindex saving file name in a register +@cindex saving buffer name in a register If you visit certain file names frequently, you can visit them more conveniently if you put their names in registers. Here's the Lisp code @@ -265,6 +266,15 @@ puts the file name shown in register @samp{z}. @var{r}}. (This is the same command used to jump to a position or restore a frame configuration.) + Similarly, if there's certain buffers you visit frequently, you +can put their names in registers. For instance, if you visit the +@samp{*Messages*} buffer often, you can use the following snippet to +put that buffer into the @samp{m} register: + +@smallexample +(set-register ?m '(buffer . "*Messages*")) +@end smallexample + @node Keyboard Macro Registers @section Keyboard Macro Registers @cindex saving keyboard macro in a register diff --git a/doc/emacs/search.texi b/doc/emacs/search.texi index fbbb1f6e682..fae016531fa 100644 --- a/doc/emacs/search.texi +++ b/doc/emacs/search.texi @@ -1448,9 +1448,13 @@ letter @code{a} as well as all the other variants like @code{@'a}. @vindex char-fold-include @vindex char-fold-exclude +@vindex char-fold-override You can add new foldings using the customizable variable @code{char-fold-include}, or remove the existing ones using the -customizable variable @code{char-fold-exclude}. +customizable variable @code{char-fold-exclude}. You can also +customize @code{char-fold-override} to @code{t} to disable all the +character equivalences except those you add yourself using +@code{char-fold-include}. @node Replace @section Replacement Commands diff --git a/doc/emacs/text.texi b/doc/emacs/text.texi index d711636ecfc..90e7bdbf3ec 100644 --- a/doc/emacs/text.texi +++ b/doc/emacs/text.texi @@ -474,8 +474,8 @@ insert a curved quote even when Electric Quote is disabled or inactive, you can type @kbd{C-x 8 [} for @t{‘}, @kbd{C-x 8 ]} for @t{’}, @kbd{C-x 8 @{} for @t{“}, and @kbd{C-x 8 @}} for @t{”}. @xref{Inserting Text}. Note that the value of -@code{electric-quote-chars} does not affect these keybindings, they -are not keybindings of @code{electric-quote-mode} but bound in +@code{electric-quote-chars} does not affect these key bindings, they +are not key bindings of @code{electric-quote-mode} but bound in @code{global-map}. @node Filling @@ -996,6 +996,13 @@ specific file (@pxref{File Variables}). major mode's special commands. (The variable @code{outline-minor-mode-prefix} controls the prefix used.) +@vindex outline-minor-mode-use-buttons + If @code{outline-minor-mode-use-buttons} is non-@code{nil}, Outline +minor mode will use buttons (at the start of the header lines) in +addition to ellipsis to show that a section is hidden. Using +@kbd{RET} (or clicking on the button with a mouse) will toggle +displaying the section. + @vindex outline-minor-mode-cycle If the @code{outline-minor-mode-cycle} user option is non-@code{nil}, the @kbd{TAB} and @kbd{S-@key{TAB}} keys are enabled on the diff --git a/doc/emacs/windows.texi b/doc/emacs/windows.texi index 27c754133f7..8b833f412c7 100644 --- a/doc/emacs/windows.texi +++ b/doc/emacs/windows.texi @@ -605,7 +605,7 @@ selects the window immediately to the right of the currently selected one, and similarly for the left, up, and down counterparts. @code{windmove-default-keybindings} binds these commands to @kbd{S-right} etc.; doing so disables shift selection for those keys -(@pxref{Shift Selection}). In the same way as keybindings can be +(@pxref{Shift Selection}). In the same way as key bindings can be defined for commands that select windows directionally, you can use @code{windmove-display-default-keybindings} to define keybindings for commands that specify in what direction to display the window for the @@ -613,7 +613,7 @@ buffer that the next command is going to display. Also there is @code{windmove-delete-default-keybindings} to define keybindings for commands that delete windows directionally, and @code{windmove-swap-states-default-keybindings} that defines -keybindings for commands that swap the window contents of the selected +key bindings for commands that swap the window contents of the selected window with the window in the specified direction. The command @kbd{M-x compare-windows} lets you compare the text 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/lispintro/emacs-lisp-intro.texi b/doc/lispintro/emacs-lisp-intro.texi index bd5decff669..04269404e48 100644 --- a/doc/lispintro/emacs-lisp-intro.texi +++ b/doc/lispintro/emacs-lisp-intro.texi @@ -688,7 +688,7 @@ Your @file{.emacs} File * Text and Auto-fill:: Automatically wrap lines. * Mail Aliases:: Use abbreviations for email addresses. * Indent Tabs Mode:: Don't use tabs with @TeX{} -* Keybindings:: Create some personal keybindings. +* Key Bindings:: Create some personal key bindings. * Keymaps:: More about key binding. * Loading Files:: Load (i.e., evaluate) files automatically. * Autoload:: Make functions available. @@ -3358,7 +3358,7 @@ Both the examples just mentioned work identically to move point forward three sentences. (Since @code{multiply-by-seven} is not bound to a key, it could not be used as an example of key binding.) -(@xref{Keybindings, , Some Keybindings}, to learn how to bind a command +(@xref{Key Bindings, , Some Key Bindings}, to learn how to bind a command to a key.) A @dfn{prefix argument} is passed to an interactive function by typing the @@ -4896,8 +4896,6 @@ result of this, point is placed at the beginning of the buffer and mark is set at the end of the buffer. The whole buffer is, therefore, the region. -@c FIXME: the definition of append-to-buffer has been changed (in -@c 2010-03-30). @node append-to-buffer @section The Definition of @code{append-to-buffer} @findex append-to-buffer @@ -4932,8 +4930,9 @@ buffer to which the text will go, the window it comes from and goes to, and the region that will be copied. @need 1250 -Here is the complete text of the function: +Here is a possible implementation of the function: +@c GNU Emacs 22 @smallexample @group (defun append-to-buffer (buffer start end) @@ -5000,7 +4999,9 @@ name. (The function can handle either.) Since the @code{append-to-buffer} function will be used interactively, the function must have an @code{interactive} expression. (For a review of @code{interactive}, see @ref{Interactive, , Making a -Function Interactive}.) The expression reads as follows: +Function Interactive}.) + +The expression reads as follows: @smallexample @group @@ -5029,7 +5030,7 @@ for true. The first argument to @code{other-buffer}, the exception, is yet another function, @code{current-buffer}. That is not going to be -returned. The second argument is the symbol for true, @code{t}. that +returned. The second argument is the symbol for true, @code{t}. That tells @code{other-buffer} that it may show visible buffers (except in this case, it will not show the current buffer, which makes sense). @@ -5065,33 +5066,6 @@ point and mark. That argument worked fine.) @node append-to-buffer body @subsection The Body of @code{append-to-buffer} -@ignore -in GNU Emacs 22 in /usr/local/src/emacs/lisp/simple.el - -(defun append-to-buffer (buffer start end) - "Append to specified buffer the text of the region. -It is inserted into that buffer before its point. - -When calling from a program, give three arguments: -BUFFER (or buffer name), START and END. -START and END specify the portion of the current buffer to be copied." - (interactive - (list (read-buffer "Append to buffer: " (other-buffer (current-buffer) t)) - (region-beginning) (region-end))) - (let ((oldbuf (current-buffer))) - (save-excursion - (let* ((append-to (get-buffer-create buffer)) - (windows (get-buffer-window-list append-to t t)) - point) - (set-buffer append-to) - (setq point (point)) - (barf-if-buffer-read-only) - (insert-buffer-substring oldbuf start end) - (dolist (window windows) - (when (= (window-point window) point) - (set-window-point window (point)))))))) -@end ignore - The body of the @code{append-to-buffer} function begins with @code{let}. As we have seen before (@pxref{let, , @code{let}}), the purpose of a @@ -5110,7 +5084,7 @@ whole by showing a template for @code{append-to-buffer} with the "@var{documentation}@dots{}" (interactive @dots{}) (let ((@var{variable} @var{value})) - @var{body}@dots{}) + @var{body}@dots{})) @end group @end smallexample @@ -5230,19 +5204,39 @@ of filling in the slots of a template: @need 1200 @noindent +@anchor{let* introduced} +@findex let* In this function, the body of the @code{save-excursion} contains only one expression, the @code{let*} expression. You know about a -@code{let} function. The @code{let*} function is different. It has a -@samp{*} in its name. It enables Emacs to set each variable in its -varlist in sequence, one after another. +@code{let} function. The @code{let*} function is different. It +enables Emacs to set each variable in its varlist in sequence, one +after another; such that variables in the latter part of the varlist +can make use of the values to which Emacs set variables earlier in the +varlist. -Its critical feature is that variables later in the varlist can make -use of the values to which Emacs set variables earlier in the varlist. -@xref{fwd-para let, , The @code{let*} expression}. +Looking at the @code{let*} expression in @code{append-to-buffer}: -We will skip functions like @code{let*} and focus on two: the -@code{set-buffer} function and the @code{insert-buffer-substring} -function. +@smallexample +@group +(let* ((append-to (get-buffer-create buffer)) + (windows (get-buffer-window-list append-to t t)) + point) + BODY...) +@end group +@end smallexample + +@noindent +we see that @code{append-to} is bound to the value returned by the +@w{@code{(get-buffer-create buffer)}}. On the next line, +@code{append-to} is used as an argument to +@code{get-buffer-window-list}; this would not be possible with the +@code{let} expression. Note that @code{point} is automatically bound +to @code{nil}, the same way as it would be done in the @code{let} +statement. + +Now let's focus on the functions @code{set-buffer} and +@code{insert-buffer-substring} in the body of the @code{let*} +expression. @need 1250 In the old days, the @code{set-buffer} expression was simply @@ -5260,27 +5254,8 @@ but now it is @end smallexample @noindent -@code{append-to} is bound to @code{(get-buffer-create buffer)} earlier -on in the @code{let*} expression. That extra binding would not be -necessary except for that @code{append-to} is used later in the -varlist as an argument to @code{get-buffer-window-list}. - -@ignore -in GNU Emacs 22 - - (let ((oldbuf (current-buffer))) - (save-excursion - (let* ((append-to (get-buffer-create buffer)) - (windows (get-buffer-window-list append-to t t)) - point) - (set-buffer append-to) - (setq point (point)) - (barf-if-buffer-read-only) - (insert-buffer-substring oldbuf start end) - (dolist (window windows) - (when (= (window-point window) point) - (set-window-point window (point)))))))) -@end ignore +This is because @code{append-to} was bound to @code{(get-buffer-create +buffer)} earlier on in the @code{let*} expression. The @code{append-to-buffer} function definition inserts text from the buffer in which you are currently to a named buffer. It happens that @@ -5377,6 +5352,12 @@ an argument and insert the region into the current buffer. @item mark-whole-buffer Mark the whole buffer as a region. Normally bound to @kbd{C-x h}. +@item let* +Declare a list of variables and give them an initial value; then +evaluate the rest of the expressions in the body of @code{let*}. The +values of the variables can be used to bind ensuing variables in the +list. + @item set-buffer Switch the attention of Emacs to another buffer, but do not change the window being displayed. Used when the program rather than a human is @@ -8772,7 +8753,7 @@ keeps the kill ring from growing too long. It looks like this: The code checks whether the length of the kill ring is greater than the maximum permitted length. This is the value of -@code{kill-ring-max} (which is 60, by default). If the length of the +@code{kill-ring-max} (which is 120, by default). If the length of the kill ring is too long, then this code sets the last element of the kill ring to @code{nil}. It does this by using two functions, @code{nthcdr} and @code{setcdr}. @@ -12879,25 +12860,12 @@ familiar part of this function. @node fwd-para let @unnumberedsubsec The @code{let*} expression -The next line of the @code{forward-paragraph} function begins a -@code{let*} expression. This is different from @code{let}. The -symbol is @code{let*} not @code{let}. - @findex let* -The @code{let*} special form is like @code{let} except that Emacs sets -each variable in sequence, one after another, and variables in the -latter part of the varlist can make use of the values to which Emacs -set variables in the earlier part of the varlist. - -@ignore -( refappend save-excursion, , code save-excursion in code append-to-buffer .) -@end ignore - -(@ref{append save-excursion, , @code{save-excursion} in @code{append-to-buffer}}.) - -In the @code{let*} expression in this function, Emacs binds a total of -seven variables: @code{opoint}, @code{fill-prefix-regexp}, -@code{parstart}, @code{parsep}, @code{sp-parstart}, @code{start}, and +The next line of the @code{forward-paragraph} function begins a +@code{let*} expression (@pxref{let* introduced,,@code{let*} +introduced}), in which Emacs binds a total of seven variables: +@code{opoint}, @code{fill-prefix-regexp}, @code{parstart}, +@code{parsep}, @code{sp-parstart}, @code{start}, and @code{found-start}. The variable @code{parsep} appears twice, first, to remove instances @@ -13694,7 +13662,7 @@ syntax table determines which characters these are." @end ifinfo @need 1000 -If you wish, you can also install this keybinding by evaluating it: +If you wish, you can also install this key binding by evaluating it: @smallexample (global-set-key "\C-c=" '@value{COUNT-WORDS}) @@ -14646,7 +14614,7 @@ almost the same code as for the recursive version of @need 800 @noindent -Let's re-use @kbd{C-c =} as a convenient keybinding: +Let's re-use @kbd{C-c =} as a convenient key binding: @smallexample (global-set-key "\C-c=" 'count-words-defun) @@ -14654,7 +14622,7 @@ Let's re-use @kbd{C-c =} as a convenient keybinding: Now we can try out @code{count-words-defun}: install both @code{count-words-in-defun} and @code{count-words-defun}, and set the -keybinding. Then copy the following to an Emacs Lisp buffer (like, +key binding. Then copy the following to an Emacs Lisp buffer (like, for instance, @file{*scratch*}), place the cursor within the definition, and use the @kbd{C-c =} command. @@ -15996,7 +15964,7 @@ placing point somewhere in the buffer, typing @kbd{M-:}, typing the and then typing @key{RET}. This causes Emacs to evaluate the expression in the minibuffer, but to use as the value of point the position of point in the @file{*scratch*} buffer. (@kbd{M-:} is the -keybinding for @code{eval-expression}. Also, @code{nil} does not +key binding for @code{eval-expression}. Also, @code{nil} does not appear in the @file{*scratch*} buffer since the expression is evaluated in the minibuffer.) @@ -16563,7 +16531,7 @@ expressions in Emacs Lisp you can change or extend Emacs. * Text and Auto-fill:: Automatically wrap lines. * Mail Aliases:: Use abbreviations for email addresses. * Indent Tabs Mode:: Don't use tabs with @TeX{} -* Keybindings:: Create some personal keybindings. +* Key Bindings:: Create some personal key bindings. * Keymaps:: More about key binding. * Loading Files:: Load (i.e., evaluate) files automatically. * Autoload:: Make functions available. @@ -17107,10 +17075,10 @@ Files'' in @cite{The GNU Emacs Manual}. @end iftex @need 1700 -@node Keybindings -@section Some Keybindings +@node Key Bindings +@section Some Key Bindings -Now for some personal keybindings: +Now for some personal key bindings: @smallexample @group @@ -17132,10 +17100,10 @@ This also shows how to set a key globally, for all modes. @cindex Key setting globally @findex global-set-key The command is @code{global-set-key}. It is followed by the -keybinding. In a @file{.emacs} file, the keybinding is written as +key binding. In a @file{.emacs} file, the keybinding is written as shown: @code{\C-c} stands for Control-C, which means to press the control key and the @kbd{c} key at the same time. The @code{w} means -to press the @kbd{w} key. The keybinding is surrounded by double +to press the @kbd{w} key. The key binding is surrounded by double quotation marks. In documentation, you would write this as @w{@kbd{C-c w}}. (If you were binding a @key{META} key, such as @kbd{M-c}, rather than a @key{CTRL} key, you would write @@ -17149,26 +17117,26 @@ would first try to evaluate the symbol to determine its value. These three things, the double quotation marks, the backslash before the @samp{C}, and the single-quote are necessary parts of -keybinding that I tend to forget. Fortunately, I have come to +key binding that I tend to forget. Fortunately, I have come to remember that I should look at my existing @file{.emacs} file, and adapt what is there. -As for the keybinding itself: @kbd{C-c w}. This combines the prefix +As for the key binding itself: @kbd{C-c w}. This combines the prefix key, @kbd{C-c}, with a single character, in this case, @kbd{w}. This set of keys, @kbd{C-c} followed by a single character, is strictly reserved for individuals' own use. (I call these @dfn{own} keys, since these are for my own use.) You should always be able to create such a -keybinding for your own use without stomping on someone else's -keybinding. If you ever write an extension to Emacs, please avoid +key binding for your own use without stomping on someone else's +key binding. If you ever write an extension to Emacs, please avoid taking any of these keys for public use. Create a key like @kbd{C-c C-w} instead. Otherwise, we will run out of own keys. @need 1250 -Here is another keybinding, with a comment: +Here is another key binding, with a comment: @smallexample @group -;;; Keybinding for 'occur' +;;; Key binding for 'occur' ; I use occur a lot, so let's bind it to a key: (global-set-key "\C-co" 'occur) @end group @@ -17228,8 +17196,8 @@ but moves point into that window. @cindex Rebinding keys Emacs uses @dfn{keymaps} to record which keys call which commands. -When you use @code{global-set-key} to set the keybinding for a single -command in all parts of Emacs, you are specifying the keybinding in +When you use @code{global-set-key} to set the key binding for a single +command in all parts of Emacs, you are specifying the key binding in @code{current-global-map}. Specific modes, such as C mode or Text mode, have their own keymaps; @@ -17484,7 +17452,7 @@ Here is the definition: @end smallexample @need 1250 -Now for the keybinding. +Now for the key binding. Function keys as well as mouse button events and non-@sc{ascii} characters are written within square brackets, without quotation @@ -17789,7 +17757,7 @@ Some systems bind keys unpleasantly. Sometimes, for example, the @key{CTRL} key appears in an awkward spot rather than at the far left of the home row. -Usually, when people fix these sorts of keybindings, they do not +Usually, when people fix these sorts of key bindings, they do not change their @file{~/.emacs} file. Instead, they bind the proper keys on their consoles with the @code{loadkeys} or @code{install-keymap} commands in their boot script and then include @code{xmodmap} commands diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi index 2f3d6148f61..7b418166067 100644 --- a/doc/lispref/commands.texi +++ b/doc/lispref/commands.texi @@ -451,11 +451,11 @@ 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 -@code{define-key}. This works like @samp{k}, except that it +@code{keymap-set}. This works like @samp{k}, except that it suppresses, for the last input event in the key sequence, the conversions that are normally used (when necessary) to convert an undefined key into a defined one (@pxref{Key Sequence Input}), so this @@ -1187,7 +1187,9 @@ intended by Lisp code to be used as an event. * Button-Down Events:: A button was pushed and not yet released. * Repeat Events:: Double and triple click (or drag, or down). * Motion Events:: Just moving the mouse, not pushing a button. +* Touchscreen Events:: Tapping and moving fingers on a touchscreen. * Focus Events:: Moving the mouse between frames. +* Xwidget Events:: Events generated by xwidgets. * Misc Events:: Other events the system can generate. * Event Examples:: Examples of the lists for mouse events. * Classifying Events:: Finding the modifier keys in an event symbol. @@ -1326,12 +1328,9 @@ actually treated as the meta key, not this.) It is best to avoid mentioning specific bit numbers in your program. To test the modifier bits of a character, use the function @code{event-modifiers} (@pxref{Classifying Events}). When making key -bindings, you can use the read syntax for characters with modifier bits -(@samp{\C-}, @samp{\M-}, and so on). For making key bindings with -@code{define-key}, you can use lists such as @code{(control hyper ?x)} to -specify the characters (@pxref{Changing Key Bindings}). The function -@code{event-convert-list} converts such a list into an event type -(@pxref{Classifying Events}). +bindings with @code{keymap-set}, you specify these events using +strings like @samp{C-H-x} instead (for ``control hyper x'') +(@pxref{Changing Key Bindings}). @node Function Keys @subsection Function Keys @@ -1849,6 +1848,59 @@ small movements. Otherwise, motion events are not generated as long as the mouse cursor remains pointing to the same glyph in the text. @end defvar +@node Touchscreen Events +@subsection Touchscreen Events +@cindex touchscreen events +@cindex support for touchscreens + +Some window systems provide support for input devices that react to +the user's touching the screen and moving fingers while touching the +screen. These input devices are known as touchscreens, and Emacs +reports the events they generate as @dfn{touchscreen events}. + +Most individual events generated by a touchscreen only have meaning as +part of a larger sequence of other events: for instance, the simple +operation of tapping the touchscreen involves the user placing and +raising a finger on the touchscreen, and swiping the display to +scroll it involves placing a finger, moving it many times upwards or +downwards, and then raising the finger. + +@cindex touch point, in touchscreen events +While a simplistic model consisting of one finger is adequate for taps +and scrolling, more complicated gestures require support for keeping +track of multiple fingers, where the position of each finger is +represented by a @dfn{touch point}. For example, a ``pinch to zoom'' +gesture might consist of the user placing two fingers and moving them +individually in opposite directions, where the distance between the +positions of their individual points determine the amount by which to +zoom the display, and the center of an imaginary line between those +positions determines where to pan the display after zooming. + +The low-level touchscreen events described below can be used to +implement all the touch sequences described above. In those events, +each point is represented by a cons of an arbitrary number identifying +the point and a mouse position list (@pxref{Click Events}) specifying +the position of the finger when the event occurred. + +@table @code +@cindex @code{touchscreen-begin} event +@item (touchscreen-begin @var{point}) +This event is sent when @var{point} is created by the user pressing a +finger against the touchscreen. + +@cindex @code{touchscreen-update} event +@item (touchscreen-update @var{points}) +This event is sent when a point on the touchscreen has changed +position. @var{points} is a list of touch points containing the +up-to-date positions of each touch point currently on the touchscreen. + +@cindex @code{touchscreen-end} event +@item (touchscreen-end @var{point}) +This event is sent when @var{point} is no longer present on the +display, because another program took the grab, or because the user +raised the finger from the touchscreen. +@end table + @node Focus Events @subsection Focus Events @cindex focus event @@ -1885,6 +1937,100 @@ sequence---that is, after a prefix key---then Emacs reorders the events so that the focus event comes either before or after the multi-event key sequence, and not within it. +@node Xwidget Events +@subsection Xwidget events + +Xwidgets (@pxref{Xwidgets}) can send events to update Lisp programs on +their status. These events are dubbed @code{xwidget-events}, and +contain various data describing the nature of the change. + +@table @code +@cindex @code{xwidget-event} event +@item (xwidget-event @var{kind} @var{xwidget} @var{arg}) +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 +This xwidget event indicates that the @var{xwidget} has reached a +particular point of the page-loading process. When these events are +sent, @var{arg} will contain a string that futher describes the status +of the widget: + +@table @samp +@cindex @samp{load-started} in xwidgets +@item load-started +This means the widget has begun a page-loading operation. + +@cindex @samp{load-finished} in xwidgets +@item load-finished +This means the @var{xwidget} has finished processing whatever +page-loading operation that it was previously performing. + +@cindex @samp{load-redirected} in xwidgets +@item load-redirected +This means the @var{xwidget} has encountered and followed a redirect +during the page-loading operation. + +@cindex @samp{load-committed} in xwidgets +@item load-committed +This means the @var{xwidget} has committed to a given URL during the +page-loading operation, i.e.@: the URL is the final URL that will be +rendered by @var{xwidget} during the current page-loading operation. +@end table + +@cindex @code{download-callback} xwidget events +@item download-callback +This event indicates that a download of some kind has been completed. +@end table + +In the above events, there can be arguments after @var{arg}, which +itself indicates the URL from which the download file was retrieved: +the first argument after @var{arg} indicates the MIME type of the +download, as a string, while the second argument contains the full +file name of the downloaded file. + +@table @code +@cindex @code{download-started} xwidget events +@item download-started +This event indicates that a download has been started. In these +events, @var{arg} contains the URL of the file that is currently being +downloaded. + +@cindex @code{javascript-callback} xwidget events +@item javascript-callback +This event contains JavaScript callback data. These events are used +internally by @code{xwidget-webkit-execute-script}. +@end table + +@cindex @code{xwidget-display-event} event +@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, +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 +the buffer in which the xwidget will be displayed, using +@code{set-xwidget-buffer} (@pxref{Xwidgets}). +@end table + @node Misc Events @subsection Miscellaneous System Events @@ -1912,15 +2058,37 @@ This kind of event indicates that the user deiconified @var{frame} using the window manager. Its standard definition is @code{ignore}; since the frame has already been made visible, Emacs has no work to do. +@cindex @code{touch-end} event +@item (touch-end (@var{position})) +This kind of event indicates that the user's finger moved off the +mouse wheel or the touchpad. The @var{position} element is a mouse +position list (@pxref{Click Events}), specifying the position of the +mouse cursor when the finger moved off the mouse wheel. + @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 that the wheel was +moved in quick succession. @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 cons cell of the +form @w{@code{(@var{x} . @var{y})}}, where @var{x} and @var{y} are the +numbers of pixels by which to scroll in each axis, a.k.a.@: +@dfn{pixelwise deltas}. + +@cindex pixel-resolution wheel events +You can use these @var{x} and @var{y} pixelwise deltas 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 @@ -1929,6 +2097,38 @@ portable code, use the variables @code{mouse-wheel-up-event} and @code{mouse-wheel-down-event} defined in @file{mwheel.el} to determine what event types to expect for the mouse wheel. +@cindex @code{pinch} event +@item (pinch @var{position} @var{dx} @var{dy} @var{scale} @var{angle}) +This kind of event is generated by the user performing a ``pinch'' +gesture by placing two fingers on a touchpad and moving them towards +or away from each other. @var{position} is a mouse position list +(@pxref{Click Events}) that provides the position of the mouse pointer +when the event occurred, @var{dx} is the change in the horizontal +distance between the fingers since the last event in the same sequence, +@var{dy} is the vertical movement of the fingers since the last event +in the same sequence, @var{scale} is the ratio of the current distance +between the fingers to that distance at the start of the sequence, and +@var{angle} is the angular difference in degrees between the direction +of the line connecting the fingers in this event and the direction of +that line in the last event of the same sequence. + +As pinch events are only sent at the beginning or during a pinch +sequence, they do not report gestures where the user moves two fingers +on a touchpad in a rotating fashion without pinching the fingers. + +All arguments after @var{position} are floating point numbers. + +This event is usually sent as part of a sequence, which begins with +the user placing two fingers on the touchpad, and ends with the user +removing those fingers. @var{dx}, @var{dy}, and @var{angle} will be +@code{0.0} in the first event of a sequence; subsequent events will +report non-zero values for these members of the event structure. + +@var{dx} and @var{dy} are reported in imaginary relative units, in +which @code{1.0} is the width and height of the touchpad +respectively. They are usually interpreted as being relative to the +size of the object beneath the gesture: image, window, etc. + @cindex @code{drag-n-drop} event @item (drag-n-drop @var{position} @var{files}) This kind of event is generated when a group of files is @@ -1980,7 +2180,7 @@ example: (interactive) (message "Caught signal %S" last-input-event)) -(define-key special-event-map [sigusr1] 'sigusr-handler) +(keymap-set special-event-map "<sigusr1>" 'sigusr-handler) @end smallexample To test the signal handler, you can make Emacs send a signal to itself: @@ -2081,7 +2281,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 "<signal> <usr1>" 'usr1-handler) @end smallexample @node Classifying Events @@ -2186,21 +2386,6 @@ This function returns non-@code{nil} if @var{object} is a mouse movement event. @xref{Motion Events}. @end defun -@defun event-convert-list list -This function converts a list of modifier names and a basic event type -to an event type which specifies all of them. The basic event type -must be the last element of the list. For example, - -@example -(event-convert-list '(control ?a)) - @result{} 1 -(event-convert-list '(control meta ?a)) - @result{} -134217727 -(event-convert-list '(control super f1)) - @result{} C-s-f1 -@end example -@end defun - @node Accessing Mouse @subsection Accessing Mouse Events @cindex mouse events, data in @@ -2420,25 +2605,14 @@ characters in a string is a complex matter, for reasons of historical compatibility, and it is not always possible. We recommend that new programs avoid dealing with these complexities -by not storing keyboard events in strings. Here is how to do that: +by not storing keyboard events in strings containing control +characters or the like, but instead store them in the common Emacs +format as understood by @code{key-valid-p}. -@itemize @bullet -@item -Use vectors instead of strings for key sequences, when you plan to use -them for anything other than as arguments to @code{lookup-key} and -@code{define-key}. For example, you can use -@code{read-key-sequence-vector} instead of @code{read-key-sequence}, and -@code{this-command-keys-vector} instead of @code{this-command-keys}. - -@item -Use vectors to write key sequence constants containing meta characters, -even when passing them directly to @code{define-key}. - -@item -When you have to look at the contents of a key sequence that might be a -string, use @code{listify-key-sequence} (@pxref{Event Input Misc}) -first, to convert it to a list. -@end itemize + If you read a key sequence with @code{read-key-sequence-vector} (or +@code{read-key-sequence}), or access a key sequence with +@code{this-command-keys-vector} (or @code{this-command-keys}), you can +transform this to the recommended format by using @code{key-description}. The complexities stem from the modifier bits that keyboard input characters can include. Aside from the Meta modifier, none of these @@ -2630,10 +2804,14 @@ returns the key sequence as a vector, never as a string. @cindex upper case key sequence @cindex downcasing in @code{lookup-key} @cindex shift-translation +@vindex translate-upper-case-key-bindings If an input character is upper-case (or has the shift modifier) and has no key binding, but its lower-case equivalent has one, then -@code{read-key-sequence} converts the character to lower case. Note -that @code{lookup-key} does not perform case conversion in this way. +@code{read-key-sequence} converts the character to lower case. (This +behaviour can be disabled by setting the +@code{translate-upper-case-key-bindings} user option to @code{nil}.) +Note that @code{lookup-key} does not perform case conversion in this +way. @vindex this-command-keys-shift-translated When reading input results in such a @dfn{shift-translation}, Emacs @@ -2866,7 +3044,7 @@ causes it to evaluate @code{help-form} and display the result. It then continues to wait for a valid input character, or keyboard-quit. @end defun -@defun read-multiple-choice prompt choices &optional help-string +@defun read-multiple-choice prompt choices &optional help-string show-help Ask user a multiple choice question. @var{prompt} should be a string that will be displayed as the prompt. @@ -2881,6 +3059,10 @@ a string with a more detailed description of all choices. It will be displayed in a help buffer instead of the default auto-generated description when the user types @kbd{?}. +If optional argument @var{show-help} is non-@code{nil}, the help +buffer will be displayed immediately, before any user input. If it is +a string, use it as the name of the help buffer. + The return value is the matching value from @var{choices}. @lisp @@ -2951,7 +3133,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. @@ -2962,12 +3144,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" "<control-x>") +(key-translate "C-c" "<control-c>") +(key-translate "C-v" "<control-v>") +(keymap-global-set "<control-x>" 'kill-region) +(keymap-global-set "<control-c>" 'kill-ring-save) +(keymap-global-set "<control-v>" 'yank) @end example @noindent diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi index 30676f0fb11..06da1025186 100644 --- a/doc/lispref/control.texi +++ b/doc/lispref/control.texi @@ -1283,6 +1283,15 @@ bindings that can then be used inside @var{body}. The variable bindings are produced by destructuring binding of elements of @var{pattern} to the values of the corresponding elements of the evaluated @var{exp}. + +Here's a trivial example: + +@example +(pcase-let ((`(,major ,minor) + (split-string "image/png" "/"))) + minor) + @result{} "png" +@end example @end defmac @defmac pcase-let* bindings body@dots{} 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 b1fb9f8b956..449a58a3bb9 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -561,6 +561,26 @@ You can rewrite the previous example with this macro as follows: @end example @end defmac +@defmac with-delayed-message (timeout message) body@dots{} +Sometimes it's unclear whether an operation will take a long time to +execute or not, or it can be inconvenient to implement a progress +reporter. This macro can be used in those situations. + +@lisp +(with-delayed-message (2 (format "Gathering data for %s" entry)) + (setq data (gather-data entry))) +@end lisp + +In this example, if the body takes more than two seconds to execute, +the message will be displayed. If it takes a shorter time than that, +the message won't be displayed. In either case, the body is evaluated +as normally, and the return value of the final element in the body is +the return value of the macro. + +The @var{message} element is evaluated before @var{body}, and is +always evaluated, whether the message is displayed or not. +@end defmac + @node Logging Messages @subsection Logging Messages in @file{*Messages*} @cindex logging echo-area messages @@ -1334,6 +1354,11 @@ are not resized. By default, this mode uses @code{fit-window-to-buffer} (@pxref{Resizing Windows}) for resizing. You can specify a different function by customizing the options @code{temp-buffer-max-height} and @code{temp-buffer-max-width} below. + +The effect of this option can be overridden by providing a suitable +@code{window-height}, @code{window-width} or @code{window-size} action +alist entry for @code{display-buffer} (@pxref{Buffer Display Action +Alists}). @end defopt @defopt temp-buffer-max-height @@ -1983,7 +2008,8 @@ The return value is an approximation: it only considers the values returned by @code{char-width} for the constituent characters, always takes a tab character as taking @code{tab-width} columns, ignores display properties and fonts, etc. For these reasons, we recommend -using @code{window-text-pixel-size}, described below, instead. +using @code{window-text-pixel-size} or @code{string-pixel-width}, +described below, instead. @end defun @defun truncate-string-to-width string width &optional start-column padding ellipsis ellipsis-text-property @@ -2060,23 +2086,33 @@ displayed in a given window. This function is used by (@pxref{Resizing Windows}) to make a window exactly as large as the text it contains. -@defun window-text-pixel-size &optional window from to x-limit y-limit mode-lines +@defun window-text-pixel-size &optional window from to x-limit y-limit mode-lines ignore-line-at-end This function returns the size of the text of @var{window}'s buffer in pixels. @var{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 maximum pixel-height of all text lines. This function exists to allow Lisp programs to adjust the dimensions of -@var{window} to the buffer text it needs to display. +@var{window} to the buffer text it needs to display, and for other +similar situations. + +The return value can also optionally (see below) include the buffer +position of the first line whose dimensions were measured. The optional argument @var{from}, if non-@code{nil}, specifies the first text position to consider, and defaults to the minimum accessible position of the buffer. If @var{from} is @code{t}, it stands for the minimum accessible position that is not a newline -character. The optional argument @var{to}, if non-@code{nil}, -specifies the last text position to consider, and defaults to the -maximum accessible position of the buffer. If @var{to} is @code{t}, -it stands for the maximum accessible position that is not a newline -character. +character. If @var{from} is a cons, its @code{car} specifies a buffer +position, and its @code{cdr} specifies the vertical offset in pixels +from that position to the first screen line whose text is to be +measured. (The measurement will start from the visual beginning of +that screen line.) In that case, the return value will instead be a +list of the pixel-width, pixel-height, and the buffer position of the +first line that was measured. The optional argument @var{to}, if +non-@code{nil}, specifies the last text position to consider, and +defaults to the maximum accessible position of the buffer. If +@var{to} is @code{t}, it stands for the maximum accessible position +that is not a newline character. The optional argument @var{x-limit}, if non-@code{nil}, specifies the maximum X coordinate beyond which text should be ignored; it is @@ -2110,6 +2146,12 @@ line, if present, in the return value. If it is @code{t}, include the height of all of these lines, if present, in the return value. @end defun +The optional argument @var{ignore-line-at-end} controls whether or +not to count the height of text in @var{to}'s screen line as part of +the returned pixel-height. This is useful if your Lisp program is +only interested in the dimensions of text up to and excluding the +visual beginning of @var{to}'s screen line. + @code{window-text-pixel-size} treats the text displayed in a window as a whole and does not care about the size of individual lines. The following function does. @@ -2175,12 +2217,59 @@ 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). +@end defun + @defun line-pixel-height This function returns the height in pixels of the line at point in the selected window. The value includes the line spacing of the line (@pxref{Line Height}). @end defun +@cindex grapheme cluster +@defun string-glyph-split string +When character compositions are in effect, sequence of characters can +be composed for display to form @dfn{grapheme clusters}, for example +to display accented characters, or ligatures, or Emoji, or when +complex text shaping requires that for some scripts. When that +happens, characters no longer map in a simple way to display columns, +and display layout decisions with such strings, such as truncating too +wide strings, can be a complex job. This function helps in performing +suvh jobs: it splits up its argument @var{string} into a list of +substrings, where each substring produces a single grapheme cluster +that should be displayed as a unit. Lisp programs can then use this +list to construct visually-valid substrings of @var{string} which will +look correctly on display, or compute the width of any substring of +@var{string} by adding the width of its constituents in the returned +list, etc. + +For instance, if you want to display a string without the first glyph, +you can say: + +@example +(apply #'insert (cdr (string-glyph-split string)))) +@end example +@end defun + When a buffer is displayed with line numbers (@pxref{Display Custom,,, emacs, The GNU Emacs Manual}), it is sometimes useful to know the width taken for displaying the line numbers. The following function @@ -2372,8 +2461,10 @@ value @code{unspecified}. This special value means that the face doesn't specify that attribute directly. An @code{unspecified} attribute tells Emacs to refer instead to a parent face (see the description @code{:inherit} attribute below); or, failing that, to an -underlying face (@pxref{Displaying Faces}). The @code{default} face -must specify all attributes. +underlying face (@pxref{Displaying Faces}). (However, +@code{unspecified} is not a valid value in @code{defface}.) + + The @code{default} face must specify all attributes. Some of these attributes are meaningful only on certain kinds of displays. If your display cannot handle a certain attribute, the @@ -2709,8 +2800,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), @code{pgtk} (for GTK), 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}, @@ -4798,9 +4890,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 @@ -4808,6 +4898,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, @@ -5083,6 +5217,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}: @@ -5283,13 +5435,13 @@ to modify the set of known names for these dynamic libraries. Supported image formats (and the required support libraries) include PBM and XBM (which do not depend on support libraries and are always available), XPM (@code{libXpm}), GIF (@code{libgif} or -@code{libungif}), JPEG (@code{libjpeg}), TIFF -(@code{libtiff}), PNG (@code{libpng}), and SVG (@code{librsvg}). +@code{libungif}), JPEG (@code{libjpeg}), TIFF (@code{libtiff}), PNG +(@code{libpng}), SVG (@code{librsvg}), and WebP (@code{libwebp}). Each of these image formats is associated with an @dfn{image type symbol}. The symbols for the above formats are, respectively, -@code{pbm}, @code{xbm}, @code{xpm}, @code{gif}, -@code{jpeg}, @code{tiff}, @code{png}, and @code{svg}. +@code{pbm}, @code{xbm}, @code{xpm}, @code{gif}, @code{jpeg}, +@code{tiff}, @code{png}, @code{svg}, and @code{webp}. Furthermore, if you build Emacs with ImageMagick (@code{libMagickWand}) support, Emacs can display any image format @@ -6293,6 +6445,9 @@ Image type @code{png}. @item TIFF Image type @code{tiff}. Supports the @code{:index} property. @xref{Multi-Frame Images}. + +@item WebP +Image type @code{webp}. @end table @node Defining Images @@ -6444,7 +6599,7 @@ will compute a scaling factor based on the font pixel size. property yourself, but it is easier to use the functions in this section. -@defun insert-image image &optional string area slice +@defun insert-image image &optional string area slice inhibit-isearch This function inserts @var{image} in the current buffer at point. The value @var{image} should be an image descriptor; it could be a value returned by @code{create-image}, or the value of a symbol defined with @@ -6469,7 +6624,9 @@ image. Internally, this function inserts @var{string} in the buffer, and gives it a @code{display} property which specifies @var{image}. @xref{Display -Property}. +Property}. By default, doing interactive searches in the buffer will +consider @var{string} when searching. If @var{inhibit-isearch} is +non-@code{nil}, this is inhibited. @end defun @cindex slice, image @@ -6545,6 +6702,11 @@ cache, it can always be displayed, even if the value of @code{max-image-size} is subsequently changed (@pxref{Image Cache}). @end defvar +@defun image-at-point-p +This function returns @code{t} if point is on an image, and @code{nil} +otherwise. +@end defun + Images inserted with the insertion functions above also get a local keymap installed in the text properties (or overlays) that span the displayed image. This keymap defines the following commands: @@ -6716,7 +6878,10 @@ xwidget object, and then use that object as the display specifier in a @code{display} text or overlay property (@pxref{Display Property}). -@defun make-xwidget type title width height arguments &optional buffer + Embedded widgets can send events notifying Lisp code about changes +occurring within them. (@pxref{Xwidget Events}). + +@defun make-xwidget type title width height arguments &optional buffer related This creates and returns an xwidget object. If @var{buffer} is omitted or @code{nil}, it defaults to the current buffer. If @var{buffer} names a buffer that doesn't exist, it will be @@ -6729,7 +6894,17 @@ The WebKit component. @end table The @var{width} and @var{height} arguments specify the widget size in -pixels, and @var{title}, a string, specifies its title. +pixels, and @var{title}, a string, specifies its title. @var{related} +is used internally by the WebKit widget, and specifies another WebKit +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}). 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 @@ -6737,6 +6912,17 @@ This function returns @code{t} if @var{object} is an xwidget, @code{nil} otherwise. @end defun +@defun xwidget-live-p object +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 @@ -6747,7 +6933,12 @@ property list given by @var{plist}. @end defun @defun xwidget-buffer xwidget -This function returns the buffer of @var{xwidget}. +This function returns the buffer of @var{xwidget}. If @var{xwidget} +has been killed, it returns @code{nil}. +@end defun + +@defun set-xwidget-buffer xwidget buffer +This function sets the buffer of @var{xwidget} to @var{buffer}. @end defun @defun get-buffer-xwidgets buffer @@ -6810,6 +7001,130 @@ This function returns the current setting of @var{xwidget}s query-on-exit flag, either @code{t} or @code{nil}. @end defun +@defun xwidget-perform-lispy-event xwidget event frame +Send an input event @var{event} to @var{xwidget}. The precise action +performed is platform-specific. @xref{Input Events}. + +You can optionally pass the frame on which the event was generated via +@var{frame}. On X11, modifier keys in key events will not be +considered if @var{frame} is @code{nil}, and the selected frame is not +an X-Windows frame. + +On GTK, only keyboard and function key events are supported. Mouse, +motion, and click events are dispatched to the xwidget without going +through Lisp code, and as such shouldn't require this function to be +called. +@end defun + +@defun xwidget-webkit-search query xwidget &optional case-insensitive backwards wrap-around +Start an incremental search on the WebKit widget @var{xwidget} with +the string @var{query} as the query. @var{case-insensitive} denotes +whether or not the search is case-insensitive, @var{backwards} +determines if the search is performed backwards towards the start of +the document, and @var{wrap-around} determines whether or not the +search terminates at the end of the document. + +If the function is called while a search query is already present, +then the query specified here will replace the existing query. + +To stop a search query, use @code{xwidget-webkit-finish-search}. +@end defun + +@defun xwidget-webkit-next-result xwidget +Display the next search result in @var{xwidget}. This function will +signal an error if a search query has not been already started in +@var{xwidget} through @code{xwidget-webkit-search}. + +If @code{wrap-around} was non-nil when @code{xwidget-webkit-search} +was called, then the search will restart from the beginning of the +document when its end is reached. +@end defun + +@defun xwidget-webkit-previous-result xwidget +Display the previous search result in @var{xwidget}. This function +signals an error if a search query has not been already started in +@var{xwidget} through @code{xwidget-webkit-search}. + +If @code{wrap-around} was non-nil when @code{xwidget-webkit-search} +was called, then the search will restart from the end of the +document when its beginning is reached. +@end defun + +@defun xwidget-webkit-finish-search xwidget +Finish a search operation started with @code{xwidget-webkit-search} in +@var{xwidget}. If there is no query currently ongoing, this function +signals an error. +@end defun + +@defun xwidget-webkit-load-html xwidget text &optional base-uri +Load @var{text}, a string, into @var{xwidget}, which should be a +WebKit xwidget. Any HTML markup in @var{text} will be processed +by @var{xwidget} while rendering the text. + +Optional argument @var{base-uri}, which should be a string, specifies +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 @@ -7003,7 +7318,7 @@ This inserts a button with the label @var{label} at point, using text properties. @end defun -@defun button-buttonize string callback &optional data +@defun buttonize string callback &optional data Sometimes it's more convenient to make a string into a button without inserting it into a buffer immediately, for instance when creating data structures that may then, later, be inserted into a buffer. This @@ -7478,16 +7793,14 @@ The string is formatted #RRGGBB (hash followed by six hex digits)." (kill-buffer nil)) (setq colorcomp-mode-map - (let ((m (make-sparse-keymap))) - (suppress-keymap m) - (define-key m "i" 'colorcomp-R-less) - (define-key m "o" 'colorcomp-R-more) - (define-key m "k" 'colorcomp-G-less) - (define-key m "l" 'colorcomp-G-more) - (define-key m "," 'colorcomp-B-less) - (define-key m "." 'colorcomp-B-more) - (define-key m " " 'colorcomp-copy-as-kill-and-exit) - m)) + (define-keymap :suppress t + "i" 'colorcomp-R-less + "o" 'colorcomp-R-more + "k" 'colorcomp-G-less + "l" 'colorcomp-G-more + "," 'colorcomp-B-less + "." 'colorcomp-B-more + "SPC" 'colorcomp-copy-as-kill-and-exit)) @end smallexample Note that we never modify the data in each node, which is fixed when the @@ -7896,7 +8209,14 @@ there is no available font (on a graphical display), and characters which cannot be encoded by the terminal's coding system (on a text terminal). +@vindex glyphless-display-mode +The @code{glyphless-display-mode} minor mode can be used to toggle +displaying glyphless characters in a convenient manner in the current +buffer. If this mode is enabled, all the glyphless characters are +displayed as boxes that display acronyms of their character names. + @defvar glyphless-char-display +For more fine-grained (and global) control, this variable can be used. The value of this variable is a char-table which defines glyphless characters and how they are displayed. Each entry must be one of the following display methods: @@ -7976,6 +8296,16 @@ Characters of Unicode General Category [Cf], such as U+200E @sc{left-to-right mark}, but excluding characters that have graphic images, such as U+00AD @sc{soft hyphen}. +@item bidi-control +This is a subset of @code{format-control}, but only includes +characters that are related to bidirectional formatting control, like +U+2069 @sc{pop directional isolate} and U+202A @sc{left-to-right +embedding}. @xref{Bidirectional Display}. + +Characters of Unicode General Category [Cf], such as U+200E +@sc{left-to-right mark}, but excluding characters that have graphic +images, such as U+00AD @sc{soft hyphen}. + @item variation-selectors Unicode VS-1 through VS-16 (U+FE00 through U+FE0F), which are used to select between different glyphs for the same codepoints (typically @@ -8053,6 +8383,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 @@ -8099,6 +8431,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 6057691239f..2186203eb6d 100644 --- a/doc/lispref/elisp.texi +++ b/doc/lispref/elisp.texi @@ -365,6 +365,7 @@ Editing Types * Keymap Type:: What function a keystroke invokes. * Overlay Type:: How an overlay is represented. * Font Type:: Fonts for displaying text. +* Xwidget Type:: Embeddable widgets. Numbers @@ -525,6 +526,7 @@ Variables * Variables with Restricted Values:: Non-constant variables whose value can @emph{not} be an arbitrary Lisp object. * Generalized Variables:: Extending the concept of variables. +* Multisession Variables:: Variables that survive restarting Emacs. Scoping Rules for Variable Bindings @@ -546,6 +548,10 @@ Generalized Variables * Setting Generalized Variables:: The @code{setf} macro. * Adding Generalized Variables:: Defining new @code{setf} forms. +Multisession Variables + +* Multisession Variables:: Variables that survive restarting Emacs. + Functions * What Is a Function:: Lisp functions vs. primitives; terminology. @@ -839,6 +845,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. @@ -1123,6 +1130,7 @@ Frames * Dialog Boxes:: Displaying a box to ask yes or no. * Pointer Shape:: Specifying the shape of the mouse pointer. * Window System Selections::Transferring text to and from other X clients. +* Yanking Media:: Yanking things that aren't plain text. * Drag and Drop:: Internals of Drag-and-Drop implementation. * Color Names:: Getting the definitions of color names. * Text Terminal Colors:: Defining colors for text terminals. @@ -1221,6 +1229,7 @@ Text * Base 64:: Conversion to or from base 64 encoding. * Checksum/Hash:: Computing cryptographic hashes. * GnuTLS Cryptography:: Cryptographic algorithms imported from GnuTLS. +* Database:: Interacting with an SQL database. * Parsing HTML/XML:: Parsing HTML and XML. * Atomic Changes:: Installing several buffer changes atomically. * Change Hooks:: Supplying functions to be run when text is changed. diff --git a/doc/lispref/errors.texi b/doc/lispref/errors.texi index f848218e267..9dd052c5235 100644 --- a/doc/lispref/errors.texi +++ b/doc/lispref/errors.texi @@ -98,6 +98,10 @@ Lisp reader, not to file I/O@. @xref{Input Functions}. @item file-already-exists This is a subcategory of @code{file-error}. @xref{Writing to Files}. +@item permission-denied +This is a subcategory of @code{file-error}, which occurs when the OS +doesn't allow Emacs to access a file or a directory for some reason. + @item file-date-error This is a subcategory of @code{file-error}. It occurs when @code{copy-file} tries and fails to set the last-modification time of diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi index 1e05153f3c0..4b114ba111d 100644 --- a/doc/lispref/files.texi +++ b/doc/lispref/files.texi @@ -1314,6 +1314,20 @@ on the 19th, @file{aug-20} was written on the 20th, and the file @end example @end defun +@defun file-has-changed-p filename tag +This function returns non-@code{nil} if the time stamp of +@var{filename} has changed since the last call. When called for the +first time for some @var{filename}, it records the last modification +time and size of the file, and returns non-@code{nil} when +@var{filename} exists. Thereafter, when called for the same +@var{filename}, it compares the current time stamp and size with the +recorded ones, and returns non-@code{nil} only if either the time +stamp or the size (or both) are different. This is useful when a Lisp +program wants to re-read a file whenever it changes. With an optional +argument @var{tag}, which must be a symbol, the size and modification +time comparisons are limited to calls with the same tag. +@end defun + @defun file-attributes filename &optional id-format @anchor{Definition of file-attributes} This function returns a list of attributes of file @var{filename}. If @@ -2083,6 +2097,9 @@ directory. Therefore, Emacs considers a file name as having two main parts: the @dfn{directory name} part, and the @dfn{nondirectory} part (or @dfn{file name within the directory}). Either part may be empty. Concatenating these two parts reproduces the original file name. +@footnote{Emacs follows the GNU convention to use the term @emph{file name} +instead of the term @emph{pathname}. We use the term @emph{path} only for +search paths, which are lists of directory names.} On most systems, the directory part is everything up to and including the last slash (backslash is also allowed in input on MS-DOS or @@ -2227,6 +2244,19 @@ and @code{file-name-nondirectory}. For example, @end example @end defun +@defun file-name-split filename +This function splits a file name into its components, and can be +thought of as the inverse of @code{string-join} with the appropriate +directory separator. For example, + +@example +(file-name-split "/tmp/foo.txt") + @result{} ("" "tmp" "foo.txt") +(string-join (file-name-split "/tmp/foo.txt") "/") + @result{} "/tmp/foo.txt" +@end example +@end defun + @node Relative File Names @subsection Absolute and Relative File Names @cindex absolute file name @@ -3278,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}, @@ -3338,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 3aab9408422..3708ef94619 100644 --- a/doc/lispref/frames.texi +++ b/doc/lispref/frames.texi @@ -105,6 +105,7 @@ window of another Emacs frame. @xref{Child Frames}. * Dialog Boxes:: Displaying a box to ask yes or no. * Pointer Shape:: Specifying the shape of the mouse pointer. * Window System Selections:: Transferring text to and from other X clients. +* Yanking Media:: Yanking things that aren't plain text. * Drag and Drop:: Internals of Drag-and-Drop implementation. * Color Names:: Getting the definitions of color names. * Text Terminal Colors:: Defining colors for text terminals. @@ -170,7 +171,9 @@ usually not run for the initial frame, since Emacs reads the initial file only after creating that frame. However, if the initial frame is specified to use a separate minibuffer frame (@pxref{Minibuffers and Frames}), the functions will be run for both, the minibuffer-less and -the minibuffer frame. +the minibuffer frame. Alternatively, you can add functions to these +hooks in your ``early init file'' (@pxref{Init File}), in which case +they will be in effect for the initial frame as well. @defvar frame-inherited-parameters This variable specifies the list of frame parameters that a newly @@ -213,7 +216,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}, @code{haiku}, or @code{pgtk}). +@xref{Frames}. @item A list of terminal parameters. @xref{Terminal Parameters}. @@ -679,7 +683,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 @@ -1728,7 +1732,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 @@ -2190,7 +2196,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 @@ -2351,7 +2360,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} @@ -3140,8 +3152,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 @@ -3151,7 +3165,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 @@ -3246,12 +3261,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 @@ -3925,6 +3944,47 @@ For backward compatibility, there are obsolete aliases names of @code{gui-get-selection} and @code{gui-set-selection} before Emacs 25.1. +@node Yanking Media +@section Yanking Media + + If you choose, for instance, ``Copy Image'' in a web browser, that +image is put onto the clipboard, and Emacs can access it via +@code{gui-get-selection}. But in general, inserting image data into +an arbitrary buffer isn't very useful---you can't really do much with +it by default. + + So Emacs has a system to let modes register handlers for these +``complicated'' selections. + +@defun yank-media-handler types handler +@var{types} can be a @acronym{MIME} media type symbol, a regexp to +match these, or a list of these symbols and regexps. For instance: + +@example +(yank-media-handler 'text/html #'my-html-handler) +(yank-media-handler "image/.*" #'my-image-handler) +@end example + +A mode can register as many handlers as required. + + The @var{handler} function is called with two parameters: The +@acronym{MIME} media type symbol and the data (as a string). The +handler should then insert the object into the buffer, or save it, or +do whatever is appropriate for the mode. +@end defun + + The @code{yank-media} command will consult the registered handlers in +the current buffer, compare that with the available media types on the +clipboard, and then pass on the matching selection to the handler (if +any). If there's more than one matching selection, the user is +queried first. + + The @code{yank-media-types} command can be used to explore the +clipboard/primary selection. It lists all the media types that are +currently available, and can be handy when creating handlers---to see +what data is actually available. Some applications put a surprising +amount of different data types on the clipboard. + @node Drag and Drop @section Drag and Drop @cindex drag and drop diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi index c8f3b12080a..46a1e57ea58 100644 --- a/doc/lispref/functions.texi +++ b/doc/lispref/functions.texi @@ -969,14 +969,14 @@ side-effects only---the values it returns are ignored, not collected into a list. @code{mapc} always returns @var{sequence}. @end defun -@defun mapconcat function sequence separator +@defun mapconcat function sequence &optional separator @code{mapconcat} applies @var{function} to each element of @var{sequence}; the results, which must be sequences of characters (strings, vectors, or lists), are concatenated into a single string return value. Between each pair of result sequences, @code{mapconcat} inserts the characters from @var{separator}, which also must be a -string, or a vector or list of characters. @xref{Sequences Arrays -Vectors}. +string, or a vector or list of characters; a @code{nil} value is +treated as the empty string. @xref{Sequences Arrays Vectors}. The argument @var{function} must be a function that can take one argument and returns a sequence of characters: a string, a vector, or @@ -994,8 +994,7 @@ string. @group (mapconcat (lambda (x) (format "%c" (1+ x))) - "HAL-8000" - "") + "HAL-8000") @result{} "IBM.9111" @end group @end example diff --git a/doc/lispref/help.texi b/doc/lispref/help.texi index a48571838cc..e7b6406fd8c 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 @@ -644,7 +651,7 @@ follows: @smallexample @group -(define-key global-map (string help-char) 'help-command) +(keymap-set global-map (key-description (string help-char)) 'help-command) (fset 'help-command help-map) @end group @end smallexample diff --git a/doc/lispref/internals.texi b/doc/lispref/internals.texi index d3edd633171..7718712b9b8 100644 --- a/doc/lispref/internals.texi +++ b/doc/lispref/internals.texi @@ -218,6 +218,14 @@ the Emacs executable that dumped them. If you want to use this function in an Emacs that was already dumped, you must run Emacs with the @samp{-batch} option. + +@vindex after-pdump-load-hook +If you're including @samp{.el} files in the dumped Emacs and that +@samp{.el} file has code that is normally run at load time, that code +won't be run when Emacs starts after dumping. To help work around +that problem, you can put functions on the +@code{after-pdump-load-hook} hook. This hook is run when starting +Emacs. @end defun @defun dump-emacs to-file from-file diff --git a/doc/lispref/keymaps.texi b/doc/lispref/keymaps.texi index 4097c86f074..f19d55cd05e 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. @@ -94,8 +95,15 @@ Manual}. (kbd "<f1> SPC") @result{} [f1 32] (kbd "C-M-<down>") @result{} [C-M-down] @end example + +@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{key-valid-p} function. @end defun + @node Keymap Basics @section Keymap Basics @cindex key binding @@ -349,6 +357,103 @@ A full keymap is more efficient than a sparse keymap when it holds lots of bindings; for just a few, the sparse keymap is better. @end defun +@defun define-keymap &key options... &rest pairs... +You can create a keymap with the functions described above, and then +use @code{keymap-set} (@pxref{Changing Key Bindings}) to specify key +bindings in that map. When writing modes, however, you frequently +have to bind a 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 keymap and binds a +number of keys. Here's a very basic example: + +@lisp +(define-keymap + "n" #'forward-line + "f" #'previous-line + "C-c C-c" #'quit-window) +@end lisp + +This function creates a new sparse keymap, defines the 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{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 of this usage: + +@lisp +(define-keymap :full t + "g" #'eww-reload + :menu '("Eww" + ["Exit" quit-window t] + ["Reload" eww-reload t])) +@end lisp + +A number of keywords can be used before the key/definition pairs to +change features of the new keymap. If any of the feature keywords is +missing from the @code{define-keymap} call, the default value for that +feature is @code{nil}. Here's a list of the available feature +keywords: + +@table @code +@item :full +If non-@code{nil}, create a char-table keymap (as from +@code{make-keymap}) instead of a sparse keymap (as from +@code{make-sparse-keymap} (@pxref{Creating Keymaps}). A sparse keymap +is the default. + +@item :parent +If non-@code{nil}, the value should be a keymap to use as the parent +(@pxref{Inheritance and Keymaps}). + +@item :keymap +If non-@code{nil}, the value should be a keymap. Instead of creating +a new keymap, the specified keymap is modified instead. + +@item :suppress +If non-@code{nil}, the keymap will be suppressed with +@code{suppress-keymap} (@pxref{Changing Key Bindings}). By default, +digits and the minus sign are exempt from suppressing, but if the +value is @code{nodigits}, this suppresses digits and minus-sign like +it does with other characters. + +@item :name +If non-@code{nil}, the value should be a string to use as the menu for +the keymap if you use it as a menu with @code{x-popup-menu} +(@pxref{Pop-Up Menus}). + +@item :prefix +If non-@code{nil}, the value should be a symbol to be used as a prefix +command (@pxref{Prefix Keys}). If this is the case, this symbol is +returned by @code{define-keymap} instead of the map itself. +@end table + +@end defun + +@defmac defvar-keymap name &key options... &rest pairs... +By far, the most common thing to do with a keymap is to bind it to a +variable. This is what virtually all modes do---a mode called +@code{foo} almost always has a variable called @code{foo-mode-map}. + +This macro defines @var{name} as a variable, passes @var{options} +and @var{pairs} to @code{define-keymap}, and uses the result as the +default value for the variable. + +@var{options} is like the keywords in @code{define-keymap}, but +there's an additional @code{:doc} keyword that provides the doc +string for the defined variable. + +Here's an example: + +@lisp +(defvar-keymap eww-textarea-map + :parent text-mode-map + "RET" #'forward-line + "TAB" #'shr-next-link) +@end lisp +@end defmac + @defun copy-keymap keymap This function returns a copy of @var{keymap}. This is almost never needed. If you want a keymap that's like another yet with a few @@ -359,7 +464,7 @@ I.e., something like: @group (let ((map (make-sparse-keymap))) (set-keymap-parent map <theirmap>) - (define-key map ...) + (keymap-set map ...) ...) @end group @end example @@ -412,10 +517,10 @@ The effect is that this keymap inherits all the bindings of but can add to them or override them with @var{elements}. If you change the bindings in @var{parent-keymap} using -@code{define-key} or other key-binding functions, these changed +@code{keymap-set} or other key-binding functions, these changed bindings are visible in the inheriting keymap, unless shadowed by the bindings made by @var{elements}. The converse is not true: if you use -@code{define-key} to change bindings in the inheriting keymap, these +@code{keymap-set} to change bindings in the inheriting keymap, these changes are recorded in @var{elements}, but have no effect on @var{parent-keymap}. @@ -610,16 +715,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 @@ -682,7 +787,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. @@ -698,7 +803,7 @@ active keymaps, except for the global keymap. Secondly, the terminal-local variable @code{overriding-terminal-local-map} specifies a keymap that takes precedence over @emph{all} other keymaps (including @code{overriding-local-map}); this is normally used for -modal/transient keybindings (the function @code{set-transient-map} +modal/transient key bindings (the function @code{set-transient-map} provides a convenient interface for this). @xref{Controlling Active Maps}, for details. @@ -716,39 +821,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 @@ -821,7 +894,7 @@ out with. This function returns the current global keymap. This is the same as the value of @code{global-map} unless you change one or the other. The return value is a reference, not a copy; if you use -@code{define-key} or other functions on it you will alter global +@code{keymap-set} or other functions on it you will alter global bindings. @example @@ -857,7 +930,7 @@ keymap. @end defun @code{current-local-map} returns a reference to the local keymap, not -a copy of it; if you use @code{define-key} or other functions on it +a copy of it; if you use @code{keymap-set} or other functions on it you will alter local bindings. @defun current-minor-mode-maps @@ -1025,7 +1098,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: @@ -1113,22 +1186,18 @@ macro, a symbol that leads to one of them, or @code{nil}. Here are the functions and variables pertaining to key lookup. -@defun lookup-key keymap key &optional accept-defaults +@defun keymap-lookup keymap key &optional accept-defaults no-remap position This function returns the definition of @var{key} in @var{keymap}. All the other functions described in this chapter that look up keys use -@code{lookup-key}. Here are examples: +@code{keymap-lookup}. Here are examples: @example @group -(lookup-key (current-global-map) "\C-x\C-f") +(keymap-lookup (current-global-map) "C-x C-f") @result{} find-file @end group @group -(lookup-key (current-global-map) (kbd "C-x C-f")) - @result{} find-file -@end group -@group -(lookup-key (current-global-map) "\C-x\C-f12345") +(keymap-lookup (current-global-map) "C-x C-f 1 2 3 4 5") @result{} 2 @end group @end example @@ -1139,9 +1208,9 @@ 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} +If @var{accept-defaults} is non-@code{nil}, then @code{keymap-lookup} considers default bindings as well as bindings for the specific events -in @var{key}. Otherwise, @code{lookup-key} reports only bindings for +in @var{key}. Otherwise, @code{keymap-lookup} reports only bindings for the specific sequence @var{key}, ignoring default bindings except when you explicitly ask about them. (To do this, supply @code{t} as an element of @var{key}; see @ref{Format of Keymaps}.) @@ -1154,11 +1223,11 @@ the second example. @example @group -(lookup-key (current-global-map) "\M-f") +(keymap-lookup (current-global-map) "M-f") @result{} forward-word @end group @group -(lookup-key (current-global-map) "\ef") +(keymap-lookup (current-global-map) "ESC f") @result{} forward-word @end group @end example @@ -1169,6 +1238,20 @@ Unlike @code{read-key-sequence}, this function does not modify the specified events in ways that discard information (@pxref{Key Sequence Input}). In particular, it does not convert letters to lower case and it does not change drag events to clicks. + +Like the normal command loop, @code{keymap-lookup} will remap the +command resulting from looking up @var{key} by looking up the command +in the current keymaps. However, if the optional third argument +@var{no-remap} is non-@code{nil}, @code{keymap-lookup} returns the +command without remapping. + +If the optional argument @var{position} is non-@code{nil}, it +specifies a mouse position as returned by @code{event-start} and +@code{event-end}, and the lookup occurs in the keymaps associated with +that position, instead of in @var{keymap}. @var{position} can also be +a number or a marker, in which case it is interpreted as a buffer +position, and the function uses the keymap properties at that position +instead of at point. @end defun @deffn Command undefined @@ -1176,20 +1259,20 @@ 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. The argument @var{accept-defaults} controls checking for default bindings, -as in @code{lookup-key} (above). +as in @code{keymap-lookup} (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. The argument @var{accept-defaults} controls checking for default bindings, -as in @code{lookup-key} (above). +as in @code{keymap-lookup} (above). @end defun @defun minor-mode-key-binding key &optional accept-defaults @@ -1206,7 +1289,7 @@ modes are omitted, since they would be completely shadowed. Similarly, the list omits non-prefix bindings that follow prefix bindings. The argument @var{accept-defaults} controls checking for default -bindings, as in @code{lookup-key} (above). +bindings, as in @code{keymap-lookup} (above). @end defun @defopt meta-prefix-char @@ -1267,51 +1350,63 @@ 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 - In writing the key sequence to rebind, it is good to use the special -escape sequences for control and meta characters (@pxref{String Type}). -The syntax @samp{\C-} means that the following character is a control -character and @samp{\M-} means that the following character is a meta -character. Thus, the string @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}. You can also use this escape syntax in -vectors, as well as others that aren't allowed in strings; one example -is @samp{[?\C-\H-x home]}. @xref{Character Type}. - - The key definition and lookup functions accept an alternate syntax for -event types in a key sequence that is a vector: you can use a list -containing modifier names plus one base event (a character or function -key name). For example, @code{(control ?a)} is equivalent to -@code{?\C-a} and @code{(hyper control left)} is equivalent to -@code{C-H-left}. One advantage of such lists is that the precise -numeric codes for the modifier bits don't appear in compiled files. - 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. +or if @var{key} is not a valid key. + +@var{key} is a string representing a single key or a series of key +strokes. Key strokes are separated by a single 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: + +@table @kbd +@item f +The key @kbd{f}. + +@item S o m +A three key sequence of the keys @kbd{S}, @kbd{o} and @kbd{m}. -@defun define-key keymap key binding +@item C-c o +A two key sequence of the keys @kbd{c} with the control modifier and +then the key @kbd{o} + +@item H-<left> +The key named @kbd{left} with the hyper modifier. + +@item M-RET +The @kbd{return} key with a meta modifier. + +@item C-M-<space> +The @kbd{space} key with both the control and meta modifiers. +@end table + +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}. + +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 @var{binding} can be any Lisp object, but only certain types are meaningful. (For a list of meaningful types, see @ref{Key Lookup}.) -The value returned by @code{define-key} is @var{binding}. +The value returned by @code{keymap-set} is @var{binding}. -If @var{key} is @code{[t]}, this sets the default binding in +If @var{key} is @kbd{<t>}, 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. @@ -1319,7 +1414,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 @@ -1337,7 +1432,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 @@ -1347,7 +1442,7 @@ map @group ;; @r{Build sparse submap for @kbd{C-x} and bind @kbd{f} in that.} -(define-key map (kbd "C-x f") 'forward-word) +(keymap-set map "C-x f" 'forward-word) @result{} forward-word @end group @group @@ -1360,14 +1455,14 @@ map @group ;; @r{Bind @kbd{C-p} to the @code{ctl-x-map}.} -(define-key map (kbd "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 (kbd "C-p C-f") 'foo) +(keymap-set map "C-p C-f" 'foo) @result{} 'foo @end group @group @@ -1386,7 +1481,14 @@ changing an entry in @code{ctl-x-map}, and this has the effect of changing the bindings of both @kbd{C-p C-f} and @kbd{C-x C-f} in the default global map. - The function @code{substitute-key-definition} scans a keymap for +@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{keymap-set} on them all +can be tedious and error-prone. Instead you can use +@code{define-keymap}, which creates a keymap and binds a number of +keys. @xref{Creating Keymaps}, for details. + +The function @code{substitute-key-definition} scans a keymap for keys that have a certain binding and rebinds them with a different binding. Another feature which is cleaner and can often produce the same results is to remap one command into another (@pxref{Remapping @@ -1485,13 +1587,181 @@ 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 + +@defun event-convert-list list +This function converts a list of modifier names and a basic event type +to an event type which specifies all of them. The basic event type +must be the last element of the list. For example, + +@example +(event-convert-list '(control ?a)) + @result{} 1 +(event-convert-list '(control meta ?a)) + @result{} -134217727 +(event-convert-list '(control super f1)) + @result{} C-s-f1 +@end example +@end defun + @node Remapping Commands @section Remapping Commands @cindex remapping commands @@ -1510,7 +1780,7 @@ definition for a key binding). the following remapping: @smallexample -(define-key my-mode-map [remap kill-line] 'my-kill-line) +(keymap-set my-mode-map "<remap> <kill-line>" 'my-kill-line) @end smallexample @noindent @@ -1525,8 +1795,8 @@ In addition, remapping only works through a single level; in the following example, @smallexample -(define-key my-mode-map [remap kill-line] 'my-kill-line) -(define-key my-mode-map [remap my-kill-line] 'my-other-kill-line) +(keymap-set my-mode-map "<remap> <kill-line>" 'my-kill-line) +(keymap-set my-mode-map "<remap> <my-kill-line>" 'my-other-kill-line) @end smallexample @noindent @@ -1538,7 +1808,7 @@ remapped to @code{my-kill-line}; if an ordinary binding specifies To undo the remapping of a command, remap it to @code{nil}; e.g., @smallexample -(define-key my-mode-map [remap kill-line] nil) +(keymap-set my-mode-map "<remap> <kill-line>" nil) @end smallexample @defun command-remapping command &optional position keymaps @@ -1670,7 +1940,7 @@ to turn the character that follows into a Hyper character: symbol (cons symbol (cdr e))))) -(define-key local-function-key-map "\C-ch" 'hyperify) +(keymap-set local-function-key-map "C-c h" 'hyperify) @end group @end example @@ -1700,55 +1970,34 @@ problematic suffixes/prefixes are @kbd{@key{ESC}}, @kbd{M-O} (which is really @section Commands for Binding Keys This section describes some convenient interactive interfaces for -changing key bindings. They work by calling @code{define-key}. +changing key bindings. They work by calling @code{keymap-set}. - 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-1>" 'mouse-set-point) @end smallexample @noindent redefines the first (leftmost) mouse button, entered with the Meta key, to set point where you click. -@cindex non-@acronym{ASCII} text in keybindings +@cindex non-@acronym{ASCII} text in key bindings Be careful when using non-@acronym{ASCII} text characters in Lisp specifications of keys to bind. If these are read as multibyte text, as 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 @@ -1759,20 +2008,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. @@ -1783,50 +2032,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 @@ -2064,7 +2295,7 @@ the keymap. Since @code{define-key} puts new bindings at the front, you should define the menu items starting at the bottom of the menu and moving to the top, if you care about the order. When you add an item to an existing menu, you can specify its position in the menu using -@code{define-key-after} (@pxref{Modifying Menus}). +@code{keymap-set-after} (@pxref{Modifying Menus}). @menu * Simple Menu Items:: A simple kind of menu key binding. @@ -2227,6 +2458,12 @@ This property specifies that @var{string} is the string to display as the keyboard equivalent for this menu item. You can use the @samp{\\[...]} documentation construct in @var{string}. +This property can also be a function (which will be called with no +arguments). This function should return a string. This function will +be called every time the menu is computed, so using a function that +takes a lot of time to compute is not a good idea, and it should +expect to be called from any context. + @item :filter @var{filter-fn} This property provides a way to compute the menu item dynamically. The property value @var{filter-fn} should be a function of one argument; @@ -2675,9 +2912,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 "<tool-bar>" + `(menu-item ,(purecopy "tool bar") ignore + :filter tool-bar-make-keymap)) @end example @noindent @@ -2812,9 +3049,9 @@ To force recalculation of the tool bar, call When you insert a new item in an existing menu, you probably want to put it in a particular place among the menu's existing items. If you use @code{define-key} to add the item, it normally goes at the front of -the menu. To put it elsewhere in the menu, use @code{define-key-after}: +the menu. To put it elsewhere in the menu, use @code{keymap-set-after}: -@defun define-key-after map key binding &optional after +@defun keymap-set-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 @@ -2828,7 +3065,7 @@ inherited keymap. Here is an example: @example -(define-key-after my-menu [drink] +(keymap-set-after my-menu "<drink>" '("Drink" . drink-command) 'eat) @end example @@ -2840,7 +3077,7 @@ Here is how to insert an item called @samp{Work} in the @samp{Signals} menu of Shell mode, after the item @code{break}: @example -(define-key-after shell-mode-map [menu-bar signals work] +(keymap-set-after shell-mode-map "<menu-bar> <signals> <work>" '("Work" . work-command) 'break) @end example @end defun diff --git a/doc/lispref/loading.texi b/doc/lispref/loading.texi index 4d683da1ad3..070f763db87 100644 --- a/doc/lispref/loading.texi +++ b/doc/lispref/loading.texi @@ -291,29 +291,35 @@ a directory) or @code{nil} (which stands for the current working directory). @end defvar - When Emacs starts up, it sets up the value of @code{load-path} -in several steps. First, it initializes @code{load-path} using -default locations set when Emacs was compiled. Normally, this -is a directory something like + When Emacs starts up, it sets up the value of @code{load-path} in +several steps. First, it looks for the directory containing its own +Lisp files, using default locations set when Emacs was compiled. It +saves this directory in @code{lisp-directory}. Normally, this is a +directory where the @file{*.elc} files are installed, something like @example "/usr/local/share/emacs/@var{version}/lisp" @end example -(In this and the following examples, replace @file{/usr/local} with -the installation prefix appropriate for your Emacs.) -These directories contain the standard Lisp files that come with -Emacs. If Emacs cannot find them, it will not start correctly. +@noindent +where @var{version} is the Emacs version. (In this and the following +examples, replace @file{/usr/local} with the prefix appropriate for +your Emacs installation.) This directory and its subdirectories +contain the standard Lisp files that come with Emacs. If Emacs cannot +find its own Lisp files, it will not start correctly. If you run Emacs from the directory where it was built---that is, an -executable that has not been formally installed---Emacs instead -initializes @code{load-path} using the @file{lisp} -directory in the directory containing the sources from which it -was built. +executable that has not been installed yet---Emacs instead initializes +@code{lisp-directory} using the @file{lisp} subdirectory of the +directory containing the sources from which it was built. + +Emacs then initializes @code{load-path} with this @code{lisp-directory}. @c Though there should be no *.el files in builddir/lisp, so it's pointless. If you built Emacs in a separate directory from the -sources, it also adds the lisp directories from the build directory. -(In all cases, elements are represented as absolute file names.) +sources, it also adds the @file{lisp} subdirectory of the build directory. + +All of these directories are stored in the above two variables as +absolute file names. @cindex site-lisp directories Unless you start Emacs with the @option{--no-site-lisp} option, @@ -333,12 +339,12 @@ and @end example @noindent -The first one is for locally installed files for a specific Emacs -version; the second is for locally installed files meant for use -with all installed Emacs versions. (If Emacs is running uninstalled, -it also adds @file{site-lisp} directories from the source and build -directories, if they exist. Normally these directories do not contain -@file{site-lisp} directories.) +The first one is for locally installed files for the current Emacs +@var{version}; the second is for locally installed files meant for use +with any installed Emacs version. (If Emacs is running uninstalled, +it also adds @file{site-lisp} subdirectories from the source and build +directories, if they exist. However, normally the source and build +directories do not contain @file{site-lisp} subdirectories.) @cindex @env{EMACSLOADPATH} environment variable If the environment variable @env{EMACSLOADPATH} is set, it modifies @@ -360,9 +366,10 @@ export EMACSLOADPATH=/home/foo/.emacs.d/lisp: @end example An empty element in the value of the environment variable, whether -trailing (as in the above example), leading, or embedded, is replaced -by the default value of @code{load-path} as determined by the standard -initialization procedure. If there are no such empty elements, then +trailing (as in the above example, note the trailing @samp{:}), +leading, or embedded, is replaced by the default value of +@code{load-path} as determined by the standard initialization +procedure. If there are no such empty elements, then @env{EMACSLOADPATH} specifies the entire @code{load-path}. You must include either an empty element, or the explicit path to the directory containing the standard Lisp files, else Emacs will not function. @@ -391,11 +398,23 @@ add one or more directories to @code{load-path}. For example: (push "~/.emacs.d/lisp" load-path) @end example +@noindent +@xref{List Variables, push}, for the description of @code{push}. + Dumping Emacs uses a special value of @code{load-path}. If you use a @file{site-load.el} or @file{site-init.el} file to customize the dumped Emacs (@pxref{Building Emacs}), any changes to @code{load-path} that these files make will be lost after dumping. +@defvar lisp-directory +This variable holds a string naming the directory which holds +Emacs's own @file{*.el} and @file{*.elc} files. This is usually the +place where those files are located in the Emacs installation tree, +unless Emacs is run from its build directory in which case it points +to the @file{lisp} subdirectory in the source directory from which +Emacs was built. +@end defvar + @deffn Command locate-library library &optional nosuffix path interactive-call This command finds the precise file name for library @var{library}. It searches for the library in the same way @code{load} does, and the @@ -482,7 +501,7 @@ automatically. However, if this does make a difference, you can force a particular Lisp file to be interpreted as unibyte by writing @samp{coding: raw-text} in a local variables section. With that designator, the file will unconditionally be interpreted as -unibyte. This can matter when making keybindings to +unibyte. This can matter when making key bindings to non-@acronym{ASCII} characters written as @code{?v@var{literal}}. @node Autoload @@ -552,7 +571,7 @@ An autoloaded keymap loads automatically during key lookup when a prefix key's binding is the symbol @var{function}. Autoloading does not occur for other kinds of access to the keymap. In particular, it does not happen when a Lisp program gets the keymap from the value of a variable -and calls @code{define-key}; not even if the variable name is the same +and calls @code{keymap-set}; not even if the variable name is the same symbol @var{function}. @cindex function cell in autoload @@ -1156,7 +1175,7 @@ You don't need to give a directory or extension in the file name @var{library}. Normally, you just give a bare file name, like this: @example -(with-eval-after-load "js" (define-key js-mode-map "\C-c\C-c" 'js-eval)) +(with-eval-after-load "js" (keymap-set js-mode-map "C-c C-c" 'js-eval)) @end example To restrict which files can trigger the evaluation, include a diff --git a/doc/lispref/modes.texi b/doc/lispref/modes.texi index 5df3a74e780..69c022e5253 100644 --- a/doc/lispref/modes.texi +++ b/doc/lispref/modes.texi @@ -269,6 +269,18 @@ normal-mode}), but tries to force it not to choose any modes in @var{avoided-modes}, if that argument is non-@code{nil}. @end defun +@defun clean-mode +Changing the major mode clears out most local variables, but it +doesn't remove all artefacts in the buffer (like text properties and +overlays). It's rare to change a buffer from one major mode to +another (except from @code{fundamental-mode} to everything else), so +this is usually not a concern. It can sometimes be convenient (mostly +when debugging a problem in a buffer) to do a ``full reset'' of the +buffer, and that's what the @code{clean-mode} major mode offers. It +will kill all local variables (even the permanently local ones), and +also removes all overlays and text properties. +@end defun + The easiest way to write a major mode is to use the macro @code{define-derived-mode}, which sets up the new mode as a variant of an existing major mode. @xref{Derived Modes}. We recommend using @@ -904,10 +916,8 @@ which in turn may have been changed in a mode hook. Here is a hypothetical example: @example -(defvar hypertext-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [down-mouse-3] 'do-hyper-link) - map)) +(defvar-keymap hypertext-mode-map + "<down-mouse-3>" #'do-hyper-link) (define-derived-mode hypertext-mode text-mode "Hypertext" @@ -1138,10 +1148,11 @@ re-sorting entries. Comparison is done with @code{equal}. @item @var{contents} is a vector with the same number of elements as @code{tabulated-list-format}. Each vector element is either a string, -which is inserted into the buffer as-is, or a list @code{(@var{label} -. @var{properties})}, which means to insert a text button by calling -@code{insert-text-button} with @var{label} and @var{properties} as -arguments (@pxref{Making Buttons}). +which is inserted into the buffer as-is; an image descriptor, which is +used to insert an image (@pxref{Image Descriptors}); or a list +@w{@code{(@var{label} . @var{properties})}}, which means to insert a +text button by calling @code{insert-text-button} with @var{label} and +@var{properties} as arguments (@pxref{Making Buttons}). There should be no newlines in any of these strings. @end itemize @@ -1331,11 +1342,9 @@ the conventions listed above: ;; @r{Create the keymap for this mode.} @group -(defvar text-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\e\t" 'ispell-complete-word) - @dots{} - map) +(defvar-keymap text-mode-map + "C-M-i" #'ispell-complete-word + @dots{}) "Keymap for `text-mode'. Many other modes, such as `mail-mode', `outline-mode' and `indented-text-mode', inherit all the commands defined in this map.") @@ -1408,13 +1417,11 @@ common. The following code sets up the common commands: @smallexample @group -(defvar lisp-mode-shared-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map prog-mode-map) - (define-key map "\e\C-q" 'indent-sexp) - (define-key map "\177" 'backward-delete-char-untabify) - map) - "Keymap for commands shared by all sorts of Lisp modes.") +(defvar-keymap lisp-mode-shared-map + :parent prog-mode-map + :doc "Keymap for commands shared by all sorts of Lisp modes." + "C-M-q" #'indent-sexp + "DEL" #'backward-delete-char-untabify) @end group @end smallexample @@ -1423,16 +1430,12 @@ And here is the code to set up the keymap for Lisp mode: @smallexample @group -(defvar lisp-mode-map - (let ((map (make-sparse-keymap)) - (menu-map (make-sparse-keymap "Lisp"))) - (set-keymap-parent map lisp-mode-shared-map) - (define-key map "\e\C-x" 'lisp-eval-defun) - (define-key map "\C-c\C-z" 'run-lisp) - @dots{} - map) - "Keymap for ordinary Lisp mode. -All commands in `lisp-mode-shared-map' are inherited by this map.") +(defvar-keymap lisp-mode-map + :doc "Keymap for ordinary Lisp mode. +All commands in `lisp-mode-shared-map' are inherited by this map." + :parent lisp-mode-shared-map + "C-M-x" #'lisp-eval-defun + "C-c C-z" #'run-lisp) @end group @end smallexample diff --git a/doc/lispref/objects.texi b/doc/lispref/objects.texi index 0551bb5673f..bbd3973f61b 100644 --- a/doc/lispref/objects.texi +++ b/doc/lispref/objects.texi @@ -1535,6 +1535,7 @@ editing. * Keymap Type:: What function a keystroke invokes. * Overlay Type:: How an overlay is represented. * Font Type:: Fonts for displaying text. +* Xwidget Type:: Embeddable widgets. @end menu @node Buffer Type @@ -1860,6 +1861,20 @@ syntax looks like @samp{#<font-object>}, @samp{#<font-spec>}, and @samp{#<font-entity>} respectively. @xref{Low-Level Font}, for a description of these Lisp objects. +@node Xwidget Type +@subsection Xwidget Type +@cindex xwidget type +@cindex xwidget-view type + + An @dfn{xwidget} is a special display element, such as a web +browser, that can be embedded inside a buffer. Each window that +displays an xwidget will also have an @dfn{xwidget view}, which on +X-Windows corresponds to a single X window used to display the widget. + +Neither of these objects are readable; their print syntaxes look like +@samp{#<xwidget>} and @samp{#<xwidget-view>}, respectively. +@xref{Xwidgets}, for a more detailed description of xwidgets. + @node Circular Objects @section Read Syntax for Circular Objects @cindex circular structure, read syntax diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi index db986178dd8..de76ab4884a 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. @@ -1349,7 +1352,7 @@ may change as higher-resolution clocks become available. @cindex time value Function arguments, e.g., the @var{time} argument to -@code{current-time-string}, accept a more-general @dfn{time value} +@code{format-time-string}, accept a more-general @dfn{time value} format, which can be a Lisp timestamp, @code{nil} for the current time, a single floating-point number for seconds, or a list @code{(@var{high} @var{low} @var{micro})} or @code{(@var{high} @@ -1504,10 +1507,7 @@ The optional @var{form} argument specifies the timestamp form to be returned. If @var{form} is the symbol @code{integer}, this function returns an integer count of seconds. If @var{form} is a positive integer, it specifies a clock frequency and this function returns an -integer-pair timestamp @code{(@var{ticks} -. @var{form})}.@footnote{Currently a positive integer @var{form} -should be at least 65536 if the returned value is intended to be given -to standard functions expecting Lisp timestamps.} If @var{form} is +integer-pair timestamp @code{(@var{ticks} . @var{form})}. If @var{form} is @code{t}, this function treats it as a positive integer suitable for representing the timestamp; for example, it is treated as 1000000000 if @var{time} is nil and the platform timestamp has nanosecond @@ -1721,7 +1721,8 @@ This function parses the time-string @var{string} and returns the corresponding Lisp timestamp. The argument @var{string} should represent a date-time, and should be in one of the forms recognized by @code{parse-time-string} (see below). This function assumes Universal -Time if @var{string} lacks explicit time zone information. +Time if @var{string} lacks explicit time zone information, +and assumes earliest values if @var{string} lacks month, day, or time. The operating system limits the range of time and zone values. @end defun @@ -2180,7 +2181,13 @@ In most cases, @var{repeat} has no effect on when @emph{first} call takes place---@var{time} alone specifies that. There is one exception: if @var{time} is @code{t}, then the timer runs whenever the time is a multiple of @var{repeat} seconds after the epoch. This is useful for -functions like @code{display-time}. +functions like @code{display-time}. For instance, the following will +make @var{function} run at every ``whole'' minute (e.g., +@samp{11:03:00}, @samp{11:04:00}, etc): + +@example +(run-at-time t 60 @var{function}) +@end example If Emacs didn't get any CPU time when the timer would have run (for example if the system was busy running another process or if the @@ -3231,6 +3238,14 @@ Removes an existing file watch specified by its @var{descriptor}. @code{file-notify-add-watch}. @end defun +@deffn Command file-notify-rm-all-watches +Removes all existing file notification watches from Emacs. + +Use this command with caution, because it could have unexpected side +effects on packages relying on file watches. It is intended mainly +for debugging purposes, or when Emacs has been stalled. +@end deffn + @defun file-notify-valid-p descriptor Checks a watch specified by its @var{descriptor} for validity. @var{descriptor} should be an object returned by diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index 8a9cb2a8f88..ac5d4d16277 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -966,6 +966,15 @@ use the function @code{process-tty-name} (@pxref{Process Information}). @end defvar +@defvar process-error-pause-time +If a process sentinel/filter function has an error, Emacs will (by +default) pause Emacs for @code{process-error-pause-time} seconds after +displaying this error, so that users will see the error in question. +However, this can lead to situations where Emacs becomes unresponsive +(if there's a lot of these errors happening), so this can be disabled +by setting @code{process-error-pause-time} to 0. +@end defvar + @node Deleting Processes @section Deleting Processes @cindex deleting processes diff --git a/doc/lispref/searching.texi b/doc/lispref/searching.texi index ce79765b733..63b02a32929 100644 --- a/doc/lispref/searching.texi +++ b/doc/lispref/searching.texi @@ -2045,7 +2045,7 @@ feature for matching regular expressions from end to beginning. It's not worth the trouble of implementing that. @end deffn -@defun string-match regexp string &optional start +@defun string-match regexp string &optional start inhibit-modify This function returns the index of the start of the first match for the regular expression @var{regexp} in @var{string}, or @code{nil} if there is no match. If @var{start} is non-@code{nil}, the search starts @@ -2070,8 +2070,10 @@ For example, The index of the first character of the string is 0, the index of the second character is 1, and so on. -If this function finds a match, the index of the first character beyond -the match is available as @code{(match-end 0)}. @xref{Match Data}. +By default, if this function finds a match, the index of the first +character beyond the match is available as @code{(match-end 0)}. +@xref{Match Data}. If @var{inhibit-modify} is non-@code{nil}, the +match data isn't modified. @example @group @@ -2092,16 +2094,18 @@ This predicate function does what @code{string-match} does, but it avoids modifying the match data. @end defun -@defun looking-at regexp +@defun looking-at regexp &optional inhibit-modify This function determines whether the text in the current buffer directly following point matches the regular expression @var{regexp}. ``Directly following'' means precisely that: the search is ``anchored'' and it can succeed only starting with the first character following point. The result is @code{t} if so, @code{nil} otherwise. -This function does not move point, but it does update the match data. -@xref{Match Data}. If you need to test for a match without modifying -the match data, use @code{looking-at-p}, described below. +This function does not move point, but it does update the match data +(if @var{inhibit-modify} is @code{nil} or missing, which is the +default). @xref{Match Data}. As a convenience, instead of using the +@var{inhibit-modify} argument, you can use @code{looking-at-p}, +described below. In this example, point is located directly before the @samp{T}. If it were anywhere else, the result would be @code{nil}. @@ -2208,13 +2212,13 @@ backtracking specified by the POSIX standard for regular expression matching. @end deffn -@defun posix-looking-at regexp +@defun posix-looking-at regexp &optional inhibit-modify This is like @code{looking-at} except that it performs the full backtracking specified by the POSIX standard for regular expression matching. @end defun -@defun posix-string-match regexp string &optional start +@defun posix-string-match regexp string &optional start inhibit-modify This is like @code{string-match} except that it performs the full backtracking specified by the POSIX standard for regular expression matching. @@ -2850,7 +2854,7 @@ Display some help, then ask again. @defvar multi-query-replace-map This variable holds a keymap that extends @code{query-replace-map} by -providing additional keybindings that are useful in multi-buffer +providing additional key bindings that are useful in multi-buffer replacements. The additional bindings are: @table @code diff --git a/doc/lispref/strings.texi b/doc/lispref/strings.texi index 7212677d832..0914f204113 100644 --- a/doc/lispref/strings.texi +++ b/doc/lispref/strings.texi @@ -430,8 +430,8 @@ middle of a character representation. This function measures the string length in characters or bytes, and thus is generally inappropriate if you need to shorten strings for display purposes; use @code{truncate-string-to-width} or -@code{window-text-pixel-size} instead (@pxref{Size of Displayed -Text}). +@code{window-text-pixel-size} or @code{string-glyph-split} instead +(@pxref{Size of Displayed Text}). @end defun @defun string-lines string &optional omit-nulls diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi index f66cdfdbd19..9771d8a7ed9 100644 --- a/doc/lispref/text.texi +++ b/doc/lispref/text.texi @@ -60,6 +60,7 @@ the character after point. * Base 64:: Conversion to or from base 64 encoding. * Checksum/Hash:: Computing cryptographic hashes. * GnuTLS Cryptography:: Cryptographic algorithms imported from GnuTLS. +* Database:: Interacting with an SQL database. * Parsing HTML/XML:: Parsing HTML and XML. * Parsing JSON:: Parsing and generating JSON values. * JSONRPC:: JSON Remote Procedure Call protocol @@ -599,6 +600,19 @@ This command indents to the left margin if that is not zero. The value returned is @code{nil}. @end deffn +@deffn Command ensure-empty-lines &optional number-of-empty-lines +This command can be used to ensure that you have a specific number of +empty lines before point. (An ``empty line'' is here defined as a +line with no characters on it---a line with space characters isn't an +empty line.) It defaults to ensuring that there's a single empty line +before point. + +If point isn't at the beginning of a line, a newline character is +inserted first. If there's more empty lines before point than +specified, the number of empty lines is reduced. Otherwise it's +increased to the specified number. +@end deffn + @defvar overwrite-mode This variable controls whether overwrite mode is in effect. The value should be @code{overwrite-mode-textual}, @code{overwrite-mode-binary}, @@ -1329,7 +1343,7 @@ that @kbd{C-y} should yank. @defopt kill-ring-max The value of this variable is the maximum length to which the kill ring can grow, before elements are thrown away at the end. The default -value for @code{kill-ring-max} is 60. +value for @code{kill-ring-max} is 120. @end defopt @node Undo @@ -1493,6 +1507,11 @@ continuing to undo. This function does not bind @code{undo-in-progress}. @end defun +@defmac with-undo-amalgamate body@dots{} +This macro removes all the undo boundaries inserted during the +execution of @var{body} so that it can be undone as a single step. +@end defmac + Some commands leave the region active after execution in such a way that it interferes with selective undo of that command. To make @code{undo} ignore the active region when invoked immediately after such a command, @@ -1633,6 +1652,47 @@ The variable @code{paragraph-separate} controls how to distinguish paragraphs. @xref{Standard Regexps}. @end deffn +@defun pixel-fill-region start end pixel-width +Most Emacs buffers use monospaced text, so all the filling functions +(like @code{fill-region}) work based on the number of characters and +@code{char-width}. However, Emacs can render other types of things, +like text that contains images and using proportional fonts, and the +@code{pixel-fill-region} exists to handle that. It fills the region +of text between @var{start} and @var{end} at pixel granularity, so +text using variable-pitch fonts or several different fonts looks +filled regardless of different character sizes. The argument +@var{pixel-width} specifies the maximum pixel width a line is allowed +to have after filling; it is the pixel-resolution equivalent of the +@code{fill-column} in @code{fill-region}. For instance, this Lisp +snippet will insert text using a proportional font, and then fill this +to be no wider than 300 pixels: + +@lisp +(insert (propertize + "This is a sentence that's ends here." + 'face 'variable-pitch)) +(pixel-fill-region (point) (point-max) 300) +@end lisp + +If @var{start} isn't at the start of a line, the horizontal position +of @var{start}, converted to pixel units, will be used as the +indentation prefix on subsequent lines. + +@findex pixel-fill-width +The @code{pixel-fill-width} helper function can be used to compute the +pixel width to use. If given no arguments, it'll return a value +slightly less than the width of the current window. The first +optional value, @var{columns}, specifies the number of columns using +the standard, monospaced fonts, e.g. @code{fill-column}. The second +optional value is the window to use. You'd typically use it like +this: + +@lisp +(pixel-fill-region + start end (pixel-fill-width fill-column)) +@end lisp +@end defun + @deffn Command fill-individual-paragraphs start end &optional justify citation-regexp This command fills each paragraph in the region according to its individual fill prefix. Thus, if the lines of a paragraph were indented @@ -3602,6 +3662,11 @@ edited even in read-only buffers. @xref{Read Only Buffers}. A non-@code{nil} @code{invisible} property can make a character invisible on the screen. @xref{Invisible Text}, for details. +@kindex inhibit-isearch @r{(text property)} +@item inhibit-isearch +A non-@code{nil} @code{inhibit-isearch} property will make isearch +skip the text. + @item intangible @kindex intangible @r{(text property)} If a group of consecutive characters have equal and non-@code{nil} @@ -3627,9 +3692,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 @@ -3936,6 +4012,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 @@ -4168,7 +4246,7 @@ position. The action code is always @code{t}. For example, here is how Info mode handles @key{mouse-1}: @smallexample -(define-key Info-mode-map [follow-link] 'mouse-face) +(keymap-set Info-mode-map "<follow-link>" 'mouse-face) @end smallexample @item a function @@ -4181,9 +4259,9 @@ For example, here is how pcvs enables @kbd{mouse-1} to follow links on file names only: @smallexample -(define-key map [follow-link] - (lambda (pos) - (eq (get-char-property pos 'face) 'cvs-filename-face))) +(keymap-set map "<follow-link>" + (lambda (pos) + (eq (get-char-property pos 'face) 'cvs-filename-face))) @end smallexample @item anything else @@ -4715,9 +4793,8 @@ converting to and from this code. This function converts the region from @var{beg} to @var{end} into base 64 code. It returns the length of the encoded text. An error is signaled if a character in the region is multibyte, i.e., in a -multibyte buffer the region must contain only characters from the -charsets @code{ascii}, @code{eight-bit-control} and -@code{eight-bit-graphic}. +multibyte buffer the region must contain only ASCII characters or raw +bytes. Normally, this function inserts newline characters into the encoded text, to avoid overlong lines. However, if the optional argument @@ -5058,6 +5135,177 @@ On success, it returns a list of a binary string (the output) and the IV used. @end defun +@node Database +@section Database +@cindex database access, SQLite + + Emacs can be compiled with built-in support for accessing SQLite +databases. This section describes the facilities available for +accessing SQLite databases from Lisp programs. + +@defun sqlite-available-p +The function returns non-@code{nil} if built-in SQLite support is +available in this Emacs session. +@end defun + +When SQLite support is available, the following functions can be used. + +@cindex database object +@defun sqlite-open &optional file +This function opens @var{file} as an SQLite database file. If +@var{file} doesn't exist, a new database will be created and stored in +that file. If @var{file} is omitted or @code{nil}, a new in-memory +database is created instead. + +The return value is a @dfn{database object} that can be used as the +argument to most of the subsequent functions described below. +@end defun + +@defun sqlitep object +This predicate returns non-@code{nil} if @var{object} is an SQLite +database object. The database object returned by the +@code{sqlite-open} function satisfies this predicate. +@end defun + +@defun sqlite-close db +Close the database @var{db}. It's usually not necessary to call this +function explicitly---the database will automatically be closed if +Emacs shuts down or the database object is garbage collected. +@end defun + +@defun sqlite-execute db statement &optional values +Execute the @acronym{SQL} @var{statement}. For instance: + +@lisp +(sqlite-execute db "insert into foo values ('bar', 2)") +@end lisp + +If the optional @var{values} parameter is present, it should be either +a list or a vector of values to bind while executing the statement. +For instance: + +@lisp +(sqlite-execute db "insert into foo values (?, ?)" '("bar" 2)) +@end lisp + +This has exactly the same effect as the previous example, but is more +efficient and safer (because it doesn't involve any string parsing or +interpolation). + +@code{sqlite-execute} returns the number of affected rows. For +instance, an @samp{insert} statement will return @samp{1}, whereas an +@samp{update} statement may return zero or a higher number. +@end defun + +@defun sqlite-select db query &optional values result-type +Select some data from @var{db} and return them. For instance: + +@lisp +(sqlite-select db "select * from foo where key = 2") + @result{} (("bar" 2)) +@end lisp + +As with the @code{sqlite-execute}, you can optionally pass in a list +or a vector of values that will be bound before executing the select: + +@lisp +(sqlite-select db "select * from foo where key = ?" [2]) + @result{} (("bar" 2)) +@end lisp + +This is usually more efficient and safer than the method used by the +previous example. + +By default, this function returns a list of matching rows, where each +row is a list of column values. If @var{return-type} is @code{full}, +the names of the columns (as a list of strings) will be returned as +the first element in the return value. + +@cindex statement object +If @var{return-type} is @code{set}, this function will return a +@dfn{statement object} instead. This object can be examined by using +the @code{sqlite-next}, @code{sqlite-columns} and @code{sqlite-more-p} +functions. If the result set is small, it's often more convenient to +just return the data directly, but if the result set is large (or if +you won't be using all the data from the set), using the @code{set} +method will allocate a lot less memory, and is therefore more +memory-efficient. +@end defun + +@defun sqlite-next statement +This function returns the next row in the result set @var{statement}, +typically an object returned by @code{sqlite-select}. + +@lisp +(sqlite-next stmt) + @result{} ("bar" 2) +@end lisp +@end defun + +@defun sqlite-columns statement +This function returns the column names of the result set +@var{statement}, typically an object returned by @code{sqlite-select}. + +@lisp +(sqlite-columns stmt) + @result{} ("name" "issue") +@end lisp +@end defun + +@defun sqlite-more-p statement +This predicate says whether there is more data to be fetched from the +result set @var{statement}, typically an object returned by +@code{sqlite-select}. +@end defun + +@defun sqlite-finalize statement +If @var{statement} is not going to be used any more, calling this +function will free the resources used by @var{statement}. This is +usually not necessary---when the @var{statement} object is +garbage-collected, Emacs will automatically free its resources. +@end defun + +@defun sqlite-transaction db +Start a transaction in @var{db}. When in a transaction, other readers +of the database won't access the results until the transaction has +been committed by @code{sqlite-commit}. +@end defun + +@defun sqlite-commit db +End a transaction in @var{db} and write the data out to its file. +@end defun + +@defun sqlite-rollback db +End a transaction in @var{db} and discard any changes that have been +made by the transaction. +@end defun + +@defmac with-sqlite-transaction db body@dots{} +Like @code{progn} (@pxref{Sequencing}), but executes @var{body} with a +transaction held, and commits the transaction at the end. +@end defmac + +@defun sqlite-pragma db pragma +Execute @var{pragma} in @var{db}. A @dfn{pragma} is usually a command +that affects the database overall, instead of any particular table. +For instance, to make SQLite automatically garbage collect data that's +no longer needed, you can say: + +@lisp +(sqlite-pragma db "auto_vacuum = FULL") +@end lisp + +This function returns non-@code{nil} on success and @code{nil} if the +pragma failed. Many pragmas can only be issued when the database is +brand new and empty. +@end defun + +@defun sqlite-load-extension db module +Load the named extension @var{module} into the database @var{db}. +Extensions are usually shared-library files; on GNU and Unix systems, +they have the @file{.so} file-name extension. +@end defun + @node Parsing HTML/XML @section Parsing HTML and XML @cindex parsing html diff --git a/doc/lispref/tips.texi b/doc/lispref/tips.texi index fa764f18b5c..cbfcbd8d14f 100644 --- a/doc/lispref/tips.texi +++ b/doc/lispref/tips.texi @@ -252,6 +252,13 @@ themselves; Lisp programmers find this disconcerting. Please put a copyright notice and copying permission notice on the file if you distribute copies. @xref{Library Headers}. +@item +For variables holding (or functions returning) a file or directory name, +avoid using @code{path} in its name, preferring @code{file}, +@code{file-name}, or @code{directory} instead, since Emacs follows the +GNU convention to use the term @emph{path} only for search paths, +which are lists of directory names. + @end itemize @node Key Binding Conventions diff --git a/doc/lispref/two-volume.make b/doc/lispref/two-volume.make index cf612b12573..c791e2522f2 100644 --- a/doc/lispref/two-volume.make +++ b/doc/lispref/two-volume.make @@ -35,7 +35,7 @@ vol1.pdf: elisp1med-fns-ready elisp1med-aux-ready elisp1med-toc-ready $(tex1) # vol2.pdf: elisp2med-fns-ready elisp2med-aux-ready elisp2med-toc-ready - @echo "Final TeX run for volume 2..." + $(info Final TeX run for volume 2...) cp elisp2med-toc-ready elisp2-toc-ready.toc cp elisp2med-fns-ready vol2.fns cp elisp2med-aux-ready vol2.aux @@ -123,7 +123,7 @@ elisp1med-init: elisp1-fns-ready elisp1-aux-ready elisp1init-toc-ready $(texinfo mv vol1.toc elisp1med-toc # elisp2med-init: elisp2-fns-ready elisp2-aux-ready elisp2init-toc-ready $(texinfodir)/texinfo.tex - @echo "Final TeX run for volume 2..." + $(info Final TeX run for volume 2...) cp elisp2init-toc-ready elisp2-toc-ready.toc cp elisp2-fns-ready vol2.fns cp elisp2-aux-ready vol2.aux @@ -211,7 +211,7 @@ elisp1-init: elisp.texi touch $@ # elisp2-init: elisp.texi - @echo "Initial TeX run for volume 2..." + $(info Initial TeX run for volume 2...) rm -f vol2.aux vol2.toc $(tex2) texindex vol2.?? diff --git a/doc/lispref/variables.texi b/doc/lispref/variables.texi index a1d1919b4bf..98a9487aea9 100644 --- a/doc/lispref/variables.texi +++ b/doc/lispref/variables.texi @@ -44,6 +44,7 @@ representing the variable. * Variables with Restricted Values:: Non-constant variables whose value can @emph{not} be an arbitrary Lisp object. * Generalized Variables:: Extending the concept of variables. +* Multisession Variables:: Variables that survive restarting Emacs. @end menu @node Global Variables @@ -363,7 +364,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"}). @@ -686,7 +687,7 @@ entire computation of the value into the @code{defvar}, like this: @example (defvar my-mode-map (let ((map (make-sparse-keymap))) - (define-key map "\C-c\C-a" 'my-command) + (keymap-set map "C-c C-a" 'my-command) @dots{} map) @var{docstring}) @@ -702,25 +703,6 @@ important if the user has run hooks to alter part of the contents (such as, to rebind keys). Third, evaluating the @code{defvar} form with @kbd{C-M-x} will reinitialize the map completely. - Putting so much code in the @code{defvar} form has one disadvantage: -it puts the documentation string far away from the line which names the -variable. Here's a safe way to avoid that: - -@example -(defvar my-mode-map nil - @var{docstring}) -(unless my-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-c\C-a" 'my-command) - @dots{} - (setq my-mode-map map))) -@end example - -@noindent -This has all the same advantages as putting the initialization inside -the @code{defvar}, except that you must type @kbd{C-M-x} twice, once on -each form, if you do want to reinitialize the variable. - @node Accessing Variables @section Accessing Variable Values @@ -1695,12 +1677,14 @@ buffer-local variables interactively. @end deffn @cindex local variables, killed by major mode -@defun kill-all-local-variables +@defun kill-all-local-variables &optional kill-permanent This function eliminates all the buffer-local variable bindings of the -current buffer except for variables marked as permanent and local -hook functions that have a non-@code{nil} @code{permanent-local-hook} -property (@pxref{Setting Hooks}). As a result, the buffer will see -the default values of most variables. +current buffer. As a result, the buffer will see the default values +of most variables. By default, for variables marked as permanent and +local hook functions that have a non-@code{nil} +@code{permanent-local-hook} property (@pxref{Setting Hooks}) won't be +killed, but if the optional @var{kill-permanent} argument is +non-@code{nil}, even these variables will be killed. This function also resets certain other information pertaining to the buffer: it sets the local keymap to @code{nil}, the syntax table to the @@ -2769,3 +2753,157 @@ form that has not already had an appropriate expansion defined. In Common Lisp, this is not an error since the function @code{(setf @var{func})} might be defined later. @end quotation + +@node Multisession Variables +@section Multisession Variables + +@cindex multisession variable + When you set a variable to a value and then close Emacs and restart +it, that value won't be automatically restored. Users usually set +normal variables in their startup files, or use Customize +(@pxref{Customization}) to set user options permanently, and various +packages have various files wher they store the data (e.g., Gnus +stores this in @file{.newsrc.eld} and the URL library stores cookies +in @file{~/.emacs.d/url/cookies}). + +For things in between these two extremes (i.e., configuration which +goes in the startup file, and massive application state that goes into +separate files), Emacs provides a facility to replicate data between +sessions called @dfn{multisession variables}. (This facility may not +be available on all systems.) To give you an idea of how these are +meant to be used, here's a small example: + +@lisp +@group +(define-multisession-variable foo-var 0) +(defun my-adder (num) + (interactive "nAdd number: ") + (setf (multisession-value foo) + (+ (multisession-value foo) num)) + (message "The new number is: %s" (multisession-value foo))) +@end group +@end lisp + +@noindent +This defines the variable @code{foo-var} and binds it to a special +multisession object which is initialized with the value @samp{0} (if +the variable doesn't already exist from a previous session). The +@code{my-adder} command queries the user for a number, adds this to +the old (possibly saved value), and then saves the new value. + +This facility isn't meant to be used for huge data structures, but +should be performant for most values. + +@defmac define-multisession-variable name initial-value &optional doc &rest args +This macro defines @var{name} as a multisession variable, and gives it +the @var{initial-value} if this variable hasn't been assigned a value +earlier. @var{doc} is the doc string, and several keyword arguments can +be used in @var{args}: + +@table @code +@item :package @var{package-symbol} +This keyword says that a multisession variable belongs to the package +specified by @var{package-symbol}. The combination of +@var{package-symbol} and @var{name} has to be unique. If +@var{package-symbol} isn't given, this will default to the first +``segment'' of the @var{name} symbol's name, which is the part of its +name up to and excluding the first @samp{-}. For instance, if +@var{name} is @code{foo-var} and @var{package-symbol} isn't given, +@var{package-symbol} will default to @code{foo}. + +@cindex synchronized multisession variables +@item :synchronized @var{bool} +Multisession variables can be @dfn{synchronized} if @var{bool} is +non-@code{nil}. This means that if there're two concurrent Emacs +instances running, and the other Emacs changes the multisession +variable @code{foo-var}, the current Emacs instance will retrieve that +modified data when accessing the value. If @var{synchronized} is +@code{nil} or missing, this won't happen, and the values in all +Emacs sessions using the variable will be independent of each other. + +@item :storage @var{storage} +Use the specified @var{storage} method. This can be either +@code{sqlite} (in Emacs compiled with SQLite support) or @code{files}. +If not given, this defaults to the value of the +@code{multisession-storage} variable, described below. +@end table +@end defmac + +@defun multisession-value variable +This function returns the current value of @var{variable}. If this +variable hasn't been accessed before in this Emacs session, or if it's +changed externally, it will be read in from external storage. If not, +the current value in this session is returned as is. It is an error +to call this function for a @var{variable} that is not a multisession +variable. + +Values retrieved via @code{multisession-value} may or may not be +@code{eq} to each other, but they will always be @code{equal}. + +This is a generalized variable (@pxref{Generalized Variables}), so the +way to update such a variable is to say, for instance: + +@lisp +(setf (multisession-value foo-bar) 'zot) +@end lisp + +Only Emacs Lisp values that have a readable print syntax +(@pxref{Printed Representation}) can be saved this way. + +If the multisession variable is synchronized, setting it may update +the value first. For instance: + +@lisp +(cl-incf (multisession-value foo-bar)) +@end lisp + +This first checks whether the value has changed in a different +Emacs instance, retrieves that value, and then adds 1 to that value and +stores it. But note that this is done without locking, so if many +instances are updating the value at the same time, it's unpredictable +which instance ``wins''. +@end defun + +@defun multisession-delete object +This function deletes @var{object} and its value from its persistent +storage. +@end defun + +@c FIXME: this lacks the documentation of the form of the arguments. +@defun make-multisession +You can also make persistent values that aren't tied to a specific +variable, but are tied to an explicit package and key. + +@example +(setq foo (make-multisession :package "mail" + :key "friends")) +(setf (multisession-value foo) 'everybody) +@end example + +This supports the same keywords as +@code{define-multisession-variable}, but also supports a +@code{:initial-value} keyword, which specifies the default value. +@end defun + +@defopt multisession-storage +This variable controls how the multisession variables are stored. It +value defaults to @code{files}, which means that the values are stored +in a one-file-per-variable structure inside the directory specified by +@code{multisession-directory}. If this value is @code{sqlite} +instead, the values are stored in an SQLite database; this is only +available if Emacs was built with SQLite support. +@end defopt + +@defopt multisession-directory +The multisession variables are stored under this directory, which +defaults to @file{multisession/} subdirectory of the +@code{user-emacs-directory}, which is typically +@file{~/.emacs.d/multisession/}. +@end defopt + +@findex multisession-edit-mode +@deffn Command list-multisession-values +This command pops up a buffer listing all the multisession variables, +and enters a special mode @code{multisession-edit-mode} which allows +you to delete them and edit their values. +@end deffn diff --git a/doc/lispref/windows.texi b/doc/lispref/windows.texi index d988a0ff118..c3894bc3954 100644 --- a/doc/lispref/windows.texi +++ b/doc/lispref/windows.texi @@ -3038,6 +3038,11 @@ desired total height with respect to the total height of its frame's root window. @item +A cons cell whose @sc{car} is @code{body-lines} and whose @sc{cdr} is an +integer that specifies the height of the chosen window's body in frame +lines. + +@item If the value specifies a function, that function is called with one argument---the chosen window. The function is supposed to adjust the height of the window; its return value is ignored. Suitable functions @@ -3071,16 +3076,47 @@ desired total width with respect to the total width of the frame's root window. @item +A cons cell whose @sc{car} is @code{body-columns} and whose @sc{cdr} is +an integer that specifies the width of the chosen window's body in frame +columns. + +@item If the value specifies a function, that function is called with one argument---the chosen window. The function is supposed to adjust the width of the window; its return value is ignored. @end itemize -By convention, the width of the chosen window is adjusted only if the -window is part of a horizontal combination (@pxref{Windows and -Frames}) to avoid changing the width of other, unrelated windows. -Also, this entry should be processed under only certain conditions -which are specified right below this list. +@vindex window-size@r{, a buffer display action alist entry} +@item window-size +This entry is a combination of the two preceding ones and can be used to +adjust the chosen window's height @emph{and} width. Since windows can +be resized in one direction only without affecting other windows, +@code{window-size} is effective only to set up the size of a window +appearing alone on a frame. The value can be one of the following: + +@itemize @bullet +@item +@code{nil} means to leave the size of the chosen window alone. + +@item +A cons cell of two integers specifies the desired total width and height +of the chosen window in lines and columns. It's effect is to adjust the +size of the frame accordingly. + +@item +A cons cell whose @sc{car} equals @code{body-chars} and whose @sc{cdr} +is a cons cell of two integers---the desired body width and height of +the chosen window in frame columns and lines. It's effect is to adjust +the size of the frame accordingly. + +@item +If the value specifies a function, that function is called with one +argument---the chosen window. The function is supposed to adjust the +size of the window's frame; its return value is ignored. +@end itemize + +This entry should be processed under only certain conditions which are +specified right below this list. @vindex dedicated@r{, a buffer display action alist entry} @item dedicated @@ -3181,6 +3217,14 @@ the window was created earlier by @code{display-buffer} to show the buffer and never was used to show another buffer until it was reused by the current invocation of @code{display-buffer}. +If no @code{window-height}, @code{window-width} or @code{window-size} +entry was specified, the window may still be resized automatically when +the buffer is temporary and @code{temp-buffer-resize-mode} has been +enabled, @ref{Temporary Displays}. In that case, the @sc{cdr} of a +@code{window-height}, @code{window-width} or @code{window-size} entry +can be used to inhibit or override the default behavior of +@code{temp-buffer-resize-mode} for specific buffers or invocations of +@code{display-buffer}. @node Choosing Window Options @subsection Additional Options for Displaying Buffers diff --git a/doc/man/emacsclient.1 b/doc/man/emacsclient.1 index ba64efa282c..e5d1bbe09ae 100644 --- a/doc/man/emacsclient.1 +++ b/doc/man/emacsclient.1 @@ -1,5 +1,5 @@ .\" See section COPYING for conditions for redistribution. -.TH EMACSCLIENT 1 "2020-10-18" "GNU Emacs" "GNU" +.TH EMACSCLIENT 1 "2021-11-05" "GNU Emacs" "GNU" .\" NAME should be all caps, SECTION should be 1-8, maybe w/ subsection .\" other params are allowed: see man(7), man(1) .SH NAME @@ -69,6 +69,9 @@ start Emacs in daemon mode, and try to connect to it. .B -c, \-\-create-frame Create a new frame instead of trying to use the current Emacs frame. .TP +.B -r \-\-reuse-frame +Reuse an existing frame if one exists, otherwise create a new frame. +.TP .B \-F, \-\-frame-parameters=ALIST Set the parameters of a newly-created frame. .TP diff --git a/doc/misc/Makefile.in b/doc/misc/Makefile.in index 7982c0dc5ae..791cfa89f54 100644 --- a/doc/misc/Makefile.in +++ b/doc/misc/Makefile.in @@ -130,12 +130,12 @@ info: $(INFO_TARGETS) ## Used by top-level Makefile. ## Base file names of output info files. +INFO_BASES = $(patsubst %.info,%,$(notdir $(INFO_INSTALL))) echo-info: - @echo "$(INFO_INSTALL) " | \ - sed -e 's|[^ ]*/||g' -e 's/\.info//g' -e "s/ */.info /g" + @: $(info $(addsuffix .info,$(INFO_BASES))) echo-sources: - @echo ${SOURCES} + @: $(info $(SOURCES)) dvi: $(DVI_TARGETS) @@ -185,7 +185,8 @@ $(foreach ifile,$(filter-out info.info,$(INFO_TARGETS)),$(eval $(call info_templ ## Extra dependencies. -need_emacsver = calc cl dired-x efaq efaq-w32 erc ido reftex woman +## FIXME Updating this list manually is unreliable. +need_emacsver = calc cl dired-x efaq efaq-w32 erc forms ido newsticker reftex remember woman need_emacsver_prefix = $(addprefix ${buildinfodir}/,${need_emacsver}) $(need_emacsver_prefix:=.info) $(need_emacsver:=.dvi) $(need_emacsver:=.pdf) $(need_emacsver:=.html) : ${emacsdir}/emacsver.texi diff --git a/doc/misc/auth.texi b/doc/misc/auth.texi index 034004d1df4..b6823ea7791 100644 --- a/doc/misc/auth.texi +++ b/doc/misc/auth.texi @@ -305,7 +305,8 @@ The @dfn{Secret Service API} is a standard from to securely store passwords and other confidential information. This API is implemented by system daemons such as the GNOME Keyring and the KDE Wallet (these are GNOME and KDE packages respectively and should -be available on most modern GNU/Linux systems). +be available on most modern GNU/Linux systems). It has been tested +also with KeePassXC. The auth-source library uses the @file{secrets.el} library to connect through the Secret Service API@. You can also use that library in @@ -360,15 +361,19 @@ Collections can be created and deleted by the functions Usually, this is not done from within Emacs. Do not delete standard collections such as @code{"login"}. -The special collection @code{"session"} exists for the lifetime of the -corresponding client session (in our case, Emacs's lifetime). It is -created automatically when Emacs uses the Secret Service interface and -it is deleted when Emacs is killed. Therefore, it can be used to -store and retrieve secret items temporarily. The @code{"session"} -collection is better than a persistent collection when the secret -items should not live longer than Emacs. The session collection can -be specified either by the string @code{"session"}, or by @code{nil}, -whenever a collection parameter is needed in the following functions. +With GNOME Keyring, there exists a special collection called +@code{"session"}, which has the lifetime of the user being logged in. +Its data are not stored on disk and go away when the user logs out. +Therefore, it can be used to store and retrieve secret items +temporarily. The @code{"session"} collection is better than a +persistent collection when the secret items should not live +permanently. The @code{"session"} collection can be addressed either +by the string @code{"session"}, or by @code{nil}, whenever a +collection parameter is needed. + +However, other Secret Service provider don't create this temporary +@code{"session"} collection. You shall check first that this +collection exists, before you use it. @defun secrets-list-items collection Returns all the item labels of @var{collection} as a list. @@ -382,7 +387,7 @@ pairs set for the created item. The keys are keyword symbols, starting with a colon. Example: @example -;;; The session is "session", the label is "my item" +;;; The collection is "session", the label is "my item" ;;; and the secret (password) is "geheim". (secrets-create-item "session" "my item" "geheim" :method "sudo" :user "joe" :host "remote-host") diff --git a/doc/misc/cc-mode.texi b/doc/misc/cc-mode.texi index 98ded68e713..a388846fbfe 100644 --- a/doc/misc/cc-mode.texi +++ b/doc/misc/cc-mode.texi @@ -283,6 +283,7 @@ Font Locking * Font Locking Preliminaries:: * Faces:: * Doc Comments:: +* Wrong Comment Style:: * Misc Font Locking:: * AWK Mode Font Locking:: diff --git a/doc/misc/cl.texi b/doc/misc/cl.texi index 0ec02495d5e..55b112cb24a 100644 --- a/doc/misc/cl.texi +++ b/doc/misc/cl.texi @@ -1245,6 +1245,12 @@ blocks for other macros like @code{cl-incf}, and @code{cl-pushnew}. The @code{cl-letf} and @code{cl-letf*} macros are used in the processing of symbol macros; @pxref{Macro Bindings}. +@defmac with-memoization @var{place} @var{code}@dots{} +This macro provides a simple way to do memoization. @var{code} is +evaluated and then stashed in @var{place}. If @var{place}'s value is +non-@code{nil}, return that value instead of evaluating @var{code}. +@end defmac + @node Variable Bindings @section Variable Bindings @@ -5028,7 +5034,7 @@ The above @code{incf} example could be written using @ignore (defmacro concatf (place &rest args) (gv-letplace (getter setter) place - (macroexp-let2 nil v (mapconcat 'identity args "") + (macroexp-let2 nil v (mapconcat 'identity args) (funcall setter `(concat ,getter ,v))))) @end ignore @end defmac diff --git a/doc/misc/ede.texi b/doc/misc/ede.texi index 5e9c3d7eef6..1ed8ff24607 100644 --- a/doc/misc/ede.texi +++ b/doc/misc/ede.texi @@ -99,7 +99,7 @@ learn and adopt GNU ways of doing things. @chapter @ede{} Project Concepts @ede{} is a generic interface for managing projects. It specifies a -single set of menus and keybindings, while supporting multiple ways to +single set of menus and key bindings, while supporting multiple ways to express a project via a build system. In the subsequent chapters, we will describe the different project @@ -144,7 +144,7 @@ init file: Activating @ede{} adds a menu named @samp{Development} to the menu bar. This menu provides several menu items for high-level @ede{} -commands. These menu items, and their corresponding keybindings, are +commands. These menu items, and their corresponding key bindings, are independent of the type of project you are actually working on. @node Quick Start @@ -271,7 +271,7 @@ Projects. You can create targets either from a buffer, or from a @code{dired} directory buffer. Note: If for some reason a directory list buffer, or file does not have the -@samp{Project} menu item, or if @ede{} keybindings don't work, just +@samp{Project} menu item, or if @ede{} key bindings don't work, just use @kbd{M-x revert-buffer @key{RET}} to force a refresh. Sometimes creating a new project doesn't restart buffers correctly. @@ -958,7 +958,7 @@ The example for Makefiles looks like this: ((buildfile :initform "Makefile")) "Generic Project for makefiles.") -(defmethod ede-generic-setup-configuration ((proj ede-generic-makefile-project) config) +(cl-defmethod ede-generic-setup-configuration ((proj ede-generic-makefile-project) config) "Set up a configuration for Make." (oset config build-command "make -k") (oset config debug-command "gdb ")) @@ -1059,7 +1059,7 @@ examples. @menu * Development Overview:: * Detecting a Project:: -* User interface methods:: Methods associated with keybindings +* User interface methods:: Methods associated with key bindings * Base project methods:: The most basic methods on @ede{} objects. * Sourcecode objects:: Defining new sourcecode classes. * Compiler and Linker objects:: Defining new compilers and linkers. diff --git a/doc/misc/efaq-w32.texi b/doc/misc/efaq-w32.texi index a5b5251d6ea..1a4c43f022b 100644 --- a/doc/misc/efaq-w32.texi +++ b/doc/misc/efaq-w32.texi @@ -687,9 +687,9 @@ question also. @node CUA @subsection Standard Windows key bindings @findex cua-mode -@cindex CUA keybindings +@cindex CUA key bindings @cindex shift key, selecting with -@cindex standard Windows keybindings +@cindex standard Windows key bindings @cindex paste with C-v @cindex cut with C-x @cindex copy with C-c @@ -697,7 +697,7 @@ question also. @cindex C-x to cut @cindex C-v to paste -The keybindings of Emacs predate modern GUIs, and the keys that were +The key bindings of Emacs predate modern GUIs, and the keys that were chosen by later GUIs for cut and copy were given important functions as extended keymaps in Emacs. CUA mode attempts to let both bindings co-exist by defining C-x and C-c as @code{kill-region} and diff --git a/doc/misc/efaq.texi b/doc/misc/efaq.texi index 24bee6ad04f..28f0cb972d0 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}). diff --git a/doc/misc/eieio.texi b/doc/misc/eieio.texi index 63b42827311..c8d488d6edb 100644 --- a/doc/misc/eieio.texi +++ b/doc/misc/eieio.texi @@ -700,18 +700,18 @@ slot values, and use the previously mentioned set/ref routines. @defun slot-value object slot @anchor{slot-value} This function retrieves the value of @var{slot} from @var{object}. +It can also be used on objects defined by @code{cl-defstruct}. This is a generalized variable that can be used with @code{setf} to -modify the value stored in @var{slot}. @xref{Generalized -Variables,,,elisp,GNU Emacs Lisp Reference Manual}. +modify the value stored in @var{slot}. +@xref{Generalized Variables,,,elisp,GNU Emacs Lisp Reference Manual}. @end defun @defun set-slot-value object slot value @anchor{set-slot-value} This function sets the value of @var{slot} from @var{object}. -This is not a CLOS function, but is the obsolete setter for -@code{slot-value} used by the @code{setf} macro. It is therefore +This is not a CLOS function. It is therefore recommended to use @w{@code{(setf (slot-value @var{object} @var{slot}) @var{value})}} instead. @end defun @@ -856,11 +856,12 @@ You can also create a generic method with @code{cl-defmethod} (@pxref{Methods}). When a method is created and there is no generic method in place with that name, then a new generic will be created, and the new method will use it. -@end defmac -In CLOS, a generic call also be used to provide an argument list and -dispatch precedence for all the arguments. In @eieio{}, dispatching -only occurs for the first argument, so the @var{arglist} is not used. +In CLOS, a generic method can also be used to provide an argument list +and dispatch precedence for all the arguments. In @eieio{}, +dispatching only occurs for the first argument, so the @var{arglist} +is not used. +@end defmac @node Methods @section Methods 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/erc.texi b/doc/misc/erc.texi index 73e24a4b364..e7286d2ebe3 100644 --- a/doc/misc/erc.texi +++ b/doc/misc/erc.texi @@ -2,13 +2,15 @@ @c %**start of header @setfilename ../../info/erc.info @settitle ERC Manual +@set ERCVER 5.4.1 +@set ERCDIST as distributed with Emacs @value{EMACSVER} @include docstyle.texi @syncodeindex fn cp @include emacsver.texi @c %**end of header @copying -This manual is for ERC as distributed with Emacs @value{EMACSVER}. +This manual is for ERC @value{ERCVER} @value{ERCDIST}. Copyright @copyright{} 2005--2021 Free Software Foundation, Inc. @@ -88,7 +90,28 @@ Advanced Usage ERC is a powerful, modular, and extensible IRC client for Emacs. It is distributed with Emacs since version 22.1. -It comes with the following capabilities enabled by default. +IRC is short for Internet Relay Chat. When using IRC, you can +communicate with other users on the same IRC network. There are many +different networks---if you search for ``IRC networks'' in your +favorite search engine, you will find up-to-date lists of IRC networks +catering to various interests and topics. + +To use IRC, you need an IRC client such as ERC. Using the client, you +connect to an IRC server. Once you've done that, you will have access +to all available channels on that server's network. A channel is +basically a chat room, and what you type in a channel will be shown to +all other users in that channel. You can be in several channels at +the same time---ERC will show each channel in its own buffer. + +IRC channel names always begin with a @samp{#} character. For +example, the Emacs channel on Libera.Chat is @samp{#emacs}, and the +ERC channel is @samp{#erc}. Do not confuse them with the hashtags +used on many social media platforms. + +You can also send private messages to other IRC users on the same +network, even if they are not in the same channels as you. + +ERC comes with the following capabilities enabled by default. @itemize @bullet @item Flood control @@ -112,7 +135,11 @@ It comes with the following capabilities enabled by default. @cindex settings The command @kbd{M-x erc} will start ERC and prompt for the server to -connect to. +connect to. If you're unsure of which server or network to connect +to, we suggest starting with ``irc.libera.chat''. There you will find +the @samp{#emacs} channels where you can chat with other Emacs users, +and if you're having trouble with ERC, you can join the @samp{#erc} +channel and ask for help there. If you want to place ERC settings in their own file, you can place them in @file{~/.emacs.d/.ercrc.el}, creating it if necessary. diff --git a/doc/misc/ert.texi b/doc/misc/ert.texi index 5153829e2da..71c423ad9c6 100644 --- a/doc/misc/ert.texi +++ b/doc/misc/ert.texi @@ -109,6 +109,7 @@ Appendix @end menu @end ifnottex + @node Introduction @chapter Introduction @cindex introduction to ERT @@ -123,7 +124,7 @@ commands to run them to verify whether the definitions that are currently loaded in Emacs pass the tests. Some Lisp files have comments like the following (adapted from the -package @code{pp.el}): +package @file{pp.el}): @lisp ;; (pp-to-string '(quote quote)) ; expected: "'quote" @@ -358,6 +359,7 @@ Prompt for a test and then show its documentation. @end table + @node Running Tests in Batch Mode @section Running Tests in Batch Mode @cindex running tests in batch mode @@ -375,7 +377,7 @@ emacs -batch -l ert -l my-tests.el -f ert-run-tests-batch-and-exit @end example This command will start up Emacs in batch mode, load ERT, load -@code{my-tests.el}, and run all tests defined in it. It will exit +@file{my-tests.el}, and run all tests defined in it. It will exit with a zero exit status if all tests passed, or nonzero if any tests failed or if anything else went wrong. It will also print progress messages and error diagnostics to standard output. @@ -390,12 +392,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 \ @@ -414,10 +441,21 @@ emacs -batch -l ert -l my-tests.el \ -eval '(ert-run-tests-batch-and-exit "to-match")' @end example +@vindex EMACS_TEST_VERBOSE@r{, environment variable} By default, ERT test failure summaries are quite brief in batch mode---only the names of the failed tests are listed. If the -EMACS_TEST_VERBOSE environment variable is set, the failure summaries -will also include the data from the failing test. +@env{EMACS_TEST_VERBOSE} environment variable is set, the failure +summaries will also include the data from the failing test. + +@vindex EMACS_TEST_JUNIT_REPORT@r{, environment variable} +ERT can produce JUnit test reports in batch mode. If the environment +variable @env{EMACS_TEST_JUNIT_REPORT} is set, ERT will produce for +every test package @file{my-tests.el} a corresponding JUnit test +report @file{my-tests.xml}. The function +@code{ert-summarize-tests-batch-and-exit} collects all these package +test reports into a new JUnit test report, with the respective name of +that environment variable. + @node Test Selectors @section Test Selectors @@ -486,8 +524,10 @@ to find where a test was defined if the test was loaded from a file. * Expected Failures:: Tests for known bugs. * Tests and Their Environment:: Don't depend on customizations; no side effects. * Useful Techniques:: Some examples. +* erts files:: Files containing many buffer tests. @end menu + @node The @code{should} Macro @section The @code{should} Macro @@ -768,6 +808,121 @@ for testing. Usually, this makes the interfaces easier to use as well. +@node erts files +@section erts files + +@findex ert-test-erts-file +Many relevant Emacs tests depend on comparing the contents of a buffer +before and after executing a particular function. These tests can be +written the normal way---making a temporary buffer, inserting the +``before'' text, running the function, and then comparing with the +expected ``after'' text. However, this often leads to test code +that's pretty difficult to read and write, especially when the text in +question is multi-line. + +So ert provides a function called @code{ert-test-erts-file} that takes +two parameters: The name of a specially-formatted @dfn{erts} file, and +(optionally) a function that performs the transform. + +@findex erts-mode +These erts files can be edited with the @code{erts-mode} major mode. + +An erts file is divided into sections by the (@samp{=-=}) separator. + +Here's an example file containing two tests: + +@example +Name: flet + +=-= +(cl-flet ((bla (x) +(* x x))) +(bla 42)) +=-= +(cl-flet ((bla (x) + (* x x))) + (bla 42)) +=-=-= + +Name: defun + +=-= +(defun x () + (print (quote ( thingy great + stuff)))) +=-=-= +@end example + +A test starts with a line containing just @samp{=-=} and ends with a +line containing just @samp{=-=-=}. The test may be preceded by +freeform text (for instance, comments), and also name/value pairs (see +below for a list of them). + +If there is a line with @samp{=-=} inside the test, that designates +the start of the ``after'' text. Otherwise, the ``before'' and +``after'' texts are assumed to be identical, which you typically see +when writing indentation tests. + +@code{ert-test-erts-file} puts the ``before'' section into a temporary +buffer, calls the transform function, and then compares with the +``after'' section. + +Here's an example usage: + +@lisp +(ert-test-erts-file "elisp.erts" + (lambda () + (emacs-lisp-mode) + (indent-region (point-min) (point-max)))) +@end lisp + +A list of the name/value specifications that can appear before a test +follows. The general syntax is @samp{Name: Value}, but continuation +lines can be used (along the same lines as in mail---subsequent lines +that start with a space are part of the value). + +@example +Name: foo +Code: (indent-region + (point-min) (point-max)) +@end example + +@table @samp +@item Name +All tests should have a name. This name will appear in ERT output if +the test fails, and helps to identify the failing test. + +@item Code +This is the code that will be run to do the transform. This can also +be passed in via the @code{ert-test-erts-file} call, but @samp{Code} +overrides that. It's used not only in the following test, but in all +subsequent tests in the file (until overridden by another @samp{Code} +specification). + +@item No-Before-Newline +@itemx No-After-Newline +These specifications say whether the ``before'' or ``after'' portions +have a newline at the end. (This would otherwise be impossible to +specify.) + +@item Point-Char +Sometimes it's useful to be able to put point at a specific place +before executing the transform function. @samp{Point-Char: |} will +make @code{ert-test-erts-file} place point where @samp{|} is in the +``before'' form (and remove that character), and will check that it's +where the @samp{|} character is in the ``after'' form (and issue a +test failure if that isn't the case). (This is used in all subsequent +tests, unless overridden by a new @samp{Point-Char} spec.) + +@item Skip +If this is present and value is a form that evaluates to a +non-@code{nil} value, the test will be skipped. +@end table + +If you need to use the literal line single line @samp{=-=} in a test +section, you can quote it with a @samp{\} character. + + @node How to Debug Tests @chapter How to Debug Tests @@ -969,6 +1124,7 @@ For information on mocks, stubs, fixtures, or test suites, see below. * Fixtures and Test Suites:: How ERT differs from tools for other languages. @end menu + @node Mocks and Stubs @section Other Tools for Emacs Lisp @cindex mocks and stubs @@ -1043,11 +1199,13 @@ e.g., to run quick tests during interactive development and slow tests less often. This can be achieved with the @code{:tag} argument to @code{ert-deftest} and @code{tag} test selectors. + @node Index @unnumbered Index @printindex cp + @node GNU Free Documentation License @appendix GNU Free Documentation License @include doclicense.texi diff --git a/doc/misc/eshell.texi b/doc/misc/eshell.texi index c01ceb5fb93..a87dd4308c5 100644 --- a/doc/misc/eshell.texi +++ b/doc/misc/eshell.texi @@ -271,8 +271,30 @@ Some of the built-in commands have different behavior from their external counterparts, and some have no external counterpart. Most of these will print a usage message when given the @code{--help} option. +In some cases, a built-in command's behavior can be configured via +user settings, some of which are mentioned below. For example, +certain commands have two user settings to allow them to overwrite +files without warning and to ensure that they always prompt before +overwriting files. If both settings are non-@code{nil}, the commands +always prompt. If both settings are @code{nil} (the default), the +commands signal an error. + +Several commands observe the value of +@code{eshell-default-target-is-dot}. If non-@code{nil}, then the +default target for the commands @command{cp}, @command{mv}, and +@command{ln} is the current directory. + +A few commands are wrappers for more niche Emacs features, and can be +loaded as part of the eshell-xtra module. @xref{Extension modules}. + @table @code +@item . +@cmindex . +Source an Eshell file in the current environment. This is not to be +confused with the command @command{source}, which sources a file in a +subshell environment. + @item addpath @cmindex addpath Adds a given path or set of paths to the PATH environment variable, or, @@ -282,26 +304,137 @@ with no arguments, prints the current paths in this variable. @cmindex alias Define an alias (@pxref{Aliases}). This adds it to the aliases file. +@item basename +@cmindex basename +Return a file name without its directory. + +@item cat +@cmindex cat +Concatenate file contents into standard output. If in a pipeline, or +if the file is not a regular file, directory, or symlink, then this +command reverts to the system's definition of @command{cat}. + +@item cd +@cmindex cd +This command changes the current working directory. Usually, it is +invoked as @kbd{cd @var{dir}} where @file{@var{dir}} is the new +working directory. But @command{cd} knows about a few special +arguments: + +@itemize @minus{} +@item +When it receives no argument at all, it changes to the home directory. + +@item +Giving the command @kbd{cd -} changes back to the previous working +directory (this is the same as @kbd{cd $-}). + +@item +The command @kbd{cd =} shows the directory stack. Each line is +numbered. + +@item +With @kbd{cd =foo}, Eshell searches the directory stack for a directory +matching the regular expression @samp{foo}, and changes to that +directory. + +@item +With @kbd{cd -42}, you can access the directory stack slots by number. + +@item +If @code{eshell-cd-shows-directory} is non-@code{nil}, @command{cd} +will report the directory it changes to. If +@code{eshell-list-files-after-cd} is non-@code{nil}, then @command{ls} +is called with any remaining arguments after changing directories. +@end itemize + @item clear @cmindex clear -Scrolls the contents of the eshell window out of sight, leaving a blank window. -If provided with an optional non-nil argument, the scrollback contents are -cleared instead. +Scrolls the contents of the Eshell window out of sight, leaving a +blank window. If provided with an optional non-@code{nil} argument, +the scrollback contents are cleared instead. + +@item clear-scrollback +@cmindex clear-scrollback +Clear the scrollback contents of the Eshell window. Unlike the +command @command{clear}, this command deletes content in the Eshell +buffer. + +@item cp +@cmindex cp +Copy a file to a new location or copy multiple files to the same +directory. + +If @code{eshell-cp-overwrite-files} is non-@code{nil}, then +@command{cp} will overwrite files without warning. If +@code{eshell-cp-interactive-query} is non-@code{nil}, then +@command{cp} will ask before overwriting anything. @item date @cmindex date -Similar to, but slightly different from, the GNU Coreutils +Print the current local time as a human-readable string. This command +is similar to, but slightly different from, the GNU Coreutils @command{date} command. @item define @cmindex define -Define a varalias. +Define a variable alias. @xref{Variable Aliases, , , elisp, The Emacs Lisp Reference Manual}. @item diff @cmindex diff -Use Emacs's internal @code{diff} (not to be confused with -@code{ediff}). @xref{Comparing Files, , , emacs, The GNU Emacs Manual}. +Compare files using Emacs's internal @code{diff} (not to be confused +with @code{ediff}). @xref{Comparing Files, , , emacs, The GNU Emacs +Manual}. + +If @code{eshell-plain-diff-behavior} is non-@code{nil}, then this +command does not use Emacs's internal @code{diff}. This is the same +as using @samp{alias diff '*diff $*'}. + +@item dirname +@cmindex dirname +Return the directory component of a file name. + +@item dirs +@cmindex dirs +Prints the directory stack. Directories can be added or removed from +the stack using the commands @command{pushd} and @command{popd}, +respectively. + +@item du +@cmindex du +Summarize disk usage for each file. + +@item echo +@cmindex echo +Echoes its input. If @code{eshell-plain-echo-behavior} is +non-@code{nil}, @command{echo} will try to behave more like a plain +shell's @command{echo}. + +@item env +@cmindex env +Prints the current environment variables. Unlike in Bash, this +command does not yet support running commands with a modified +environment. + +@item exit +@cmindex exit +Exit Eshell and save the history. By default, this command kills the +Eshell buffer, but if @code{eshell-kill-on-exit} is @code{nil}, then +the buffer is merely buried instead. + +@item export +@cmindex export +Set environment variables using input like Bash's @command{export}, as +in @samp{export @var{var1}=@var{val1} @var{var2}=@var{val2} @dots{}}. + +@item expr +@cmindex expr +An implementation of @command{expr} using the Calc package. +@xref{Top,,, calc, The GNU Emacs Calculator}. + +This command can be loaded as part of the eshell-xtra module, which is +disabled by default. @item grep @cmindex grep @@ -313,13 +446,36 @@ Use Emacs's internal @code{diff} (not to be confused with @cmindex fgrep @itemx glimpse @cmindex glimpse -The @command{grep} commands are compatible with GNU @command{grep}, but -use Emacs's internal @code{grep} instead. +The @command{grep} commands are compatible with GNU @command{grep}, +but use Emacs's internal @code{grep} instead. +@xref{Grep Searching, , , emacs, The GNU Emacs Manual}. + +If @code{eshell-plain-grep-behavior} is non-@code{nil}, then these +commands do not use Emacs's internal @code{grep}. This is the same as +using @samp{alias grep '*grep $*'}, though this setting applies to all +of the built-in commands for which you would need to create a separate +alias. + +@item history +@cmindex history +Prints Eshell's input history. With a numeric argument @var{N}, this +command prints the @var{N} most recent items in the history. @item info @cmindex info -Same as the external @command{info} command, but uses Emacs's internal -Info reader. +Browse the available Info documentation. This command is the same as +the external @command{info} command, but uses Emacs's internal Info +reader. +@xref{Misc Help, , , emacs, The GNU Emacs Manual}. + +@item intersection +@cmindex intersection +A wrapper around the function @code{cl-intersection} (@pxref{Lists as +Sets,,, cl, GNU Emacs Common Lisp Emulation}). This command +can be used for comparing lists of strings. + +This command can be loaded as part of the eshell-xtra module, which is +disabled by default. @item jobs @cmindex jobs @@ -337,46 +493,152 @@ Eshell version of @code{list}. Allows you to create a list using Eshell syntax, rather than Elisp syntax. For example, @samp{listify foo bar} and @code{("foo" "bar")} both evaluate to @code{("foo" "bar")}. +@item ln +@cmindex ln +Create links to files. + +If @code{eshell-ln-overwrite-files} is non-@code{nil}, @command{ln} +will overwrite files without warning. If +@code{eshell-ln-interactive-query} is non-@code{nil}, then +@command{ln} will ask before overwriting files. + @item locate @cmindex locate Alias to Emacs's @code{locate} function, which simply runs the external @command{locate} command and parses the results. @xref{Dired and Find, , , emacs, The GNU Emacs Manual}. +If @code{eshell-plain-locate-behavior} is non-@code{nil}, then Emacs's +internal @code{locate} is not used. This is the same as using +@samp{alias locate '*locate $*'}. + +@item ls +@cmindex ls +Lists the contents of directories. + +If @code{eshell-ls-use-colors} is non-@code{nil}, the contents of a +directory is color-coded according to file type and status. These +colors and the regexps used to identify their corresponding files can +be customized via @w{@kbd{M-x customize-group @key{RET} eshell-ls @key{RET}}}. + +The user option @code{eshell-ls-date-format} determines how the date +is displayed when using the @option{-l} option. The date is produced +using the function @code{format-time-string} (@pxref{Time Parsing,,, +elisp, GNU Emacs Lisp Reference Manual}). + +The user option @code{eshell-ls-initial-args} contains a list of +arguments to include with any call to @command{ls}. For example, you +can include the option @option{-h} to always use a more human-readable +format. + +The user option @code{eshell-ls-default-blocksize} determines the +default blocksize used when displaying file sizes with the option +@option{-s}. + @item make @cmindex make Run @command{make} through @code{compile} when run asynchronously (e.g., @samp{make &}). @xref{Compilation, , , emacs, The GNU Emacs Manual}. Otherwise call the external @command{make} command. +@item man +@cmindex man +Display Man pages using the Emacs @code{man} command. +@xref{Man Page, , , emacs, The GNU Emacs Manual}. + +@item mismatch +@cmindex mismatch +A wrapper around the function @code{cl-mismatch} (@pxref{Searching +Sequences,,, cl, GNU Emacs Common Lisp Emulation}). This command can +be used for comparing lists of strings. + +This command can be loaded as part of the eshell-xtra module, which is +disabled by default. + +@item mkdir +@cmindex mkdir +Make new directories. + +@item mv +@cmindex mv +Move or rename files. + +If @code{eshell-mv-overwrite-files} is non-@code{nil}, @command{mv} +will overwrite files without warning. If +@code{eshell-mv-interactive-query} is non-@code{nil}, @command{mv} +will prompt before overwriting anything. + @item occur @cmindex occur Alias to Emacs's @code{occur}. @xref{Other Repeating Search, , , emacs, The GNU Emacs Manual}. +@item popd +@cmindex popd +Pop a directory from the directory stack and switch to a another place +in the stack. + @item printnl @cmindex printnl Print the arguments separated by newlines. -@item cd -@cmindex cd -This command changes the current working directory. Usually, it is -invoked as @samp{cd foo} where @file{foo} is the new working directory. -But @command{cd} knows about a few special arguments: - -When it receives no argument at all, it changes to the home directory. - -Giving the command @samp{cd -} changes back to the previous working -directory (this is the same as @samp{cd $-}). - -The command @samp{cd =} shows the directory stack. Each line is -numbered. - -With @samp{cd =foo}, Eshell searches the directory stack for a directory -matching the regular expression @samp{foo} and changes to that -directory. - -With @samp{cd -42}, you can access the directory stack by number. +@item pushd +@cmindex pushd +Push the current directory onto the directory stack, then change to +another directory. + +If @code{eshell-pushd-dunique} is non-@code{nil}, then only unique +directories will be added to the stack. If +@code{eshell-pushd-dextract} is non-@code{nil}, then @samp{pushd ++@var{n}} will pop the @var{n}th directory to the top of the stack. + +@item pwd +@cmindex pwd +Prints the current working directory. + +@item rm +@cmindex rm +Removes files, buffers, processes, or Emacs Lisp symbols, depending on +the argument. + +If @code{eshell-rm-interactive-query} is non-@code{nil}, @command{rm} +will prompt before removing anything. If +@code{eshell-rm-removes-directories} is non-@code{nil}, then +@command{rm} can also remove directories. Otherwise, @command{rmdir} +is required. + +@item rmdir +@cmindex rmdir +Removes directories if they are empty. + +@item set-difference +@cmindex set-difference +A wrapper around the function @code{cl-set-difference} (@pxref{Lists as +Sets,,, cl, GNU Emacs Common Lisp Emulation}). This command +can be used for comparing lists of strings. + +This command can be loaded as part of the eshell-xtra module, which is +disabled by default. + +@item set-exclusive-or +@cmindex set-exclusive-or +A wrapper around the function @code{cl-set-exclusive-or} (@pxref{Lists +as Sets,,, cl, GNU Emacs Common Lisp Emulation}). This command can be +used for comparing lists of strings. + +This command can be loaded as part of the eshell-xtra module, which is +disabled by default. + +@item setq +@cmindex setq +Set variable values, using the function @code{setq} like a command. +@xref{Setting Variables,,, elisp, GNU Emacs Lisp Reference Manual}. + +@item source +@cmindex source +Source an Eshell file in a subshell environment. This is not to be +confused with the command @command{.}, which sources a file in the +current environment. @item su @cmindex su @@ -386,6 +648,50 @@ Uses TRAMP's @command{su} or @command{sudo} method @pxref{Inline methods, , , tr to run a command via @command{su} or @command{sudo}. These commands are in the eshell-tramp module, which is disabled by default. + +@item substitute +@cmindex substitute +A wrapper around the function @code{cl-substitute} (@pxref{Sequence +Functions,,, cl, GNU Emacs Common Lisp Emulation}). This command can +be used for comparing lists of strings. + +This command can be loaded as part of the eshell-xtra module, which is +disabled by default. + +@item time +@cmindex time +Show the time elapsed during a command's execution. + +@item umask +@cmindex umask +Set or view the default file permissions for newly created files and +directories. + +@item union +@cmindex union +A wrapper around the function @code{cl-union} (@pxref{Lists as Sets,,, +cl, GNU Emacs Common Lisp Emulation}). This command can be used for +comparing lists of strings. + +This command can be loaded as part of the eshell-xtra module, which is +disabled by default. + +@item unset +@cmindex unset +Unset an environment variable. + +@item wait +@cmindex wait +Wait until a process has successfully completed. + +@item which +@cmindex which +Identify a command and its location. + +@item whoami +@cmindex whoami +Print the current user. This Eshell version of @command{whoami} +supports Tramp. @end table @subsection Built-in variables diff --git a/doc/misc/eww.texi b/doc/misc/eww.texi index ca752ec11b1..e41aa8d886d 100644 --- a/doc/misc/eww.texi +++ b/doc/misc/eww.texi @@ -305,6 +305,7 @@ state the directionality. @vindex shr-max-image-proportion @vindex shr-blocked-images +@vindex shr-allowed-images @cindex Image Display Loading random images from the web can be problematic due to their size or content. By customizing @code{shr-max-image-proportion} you @@ -312,7 +313,9 @@ can set the maximal image proportion in relation to the window they are displayed in. E.g., 0.7 means an image is allowed to take up 70% of the width and height. If Emacs supports image scaling (ImageMagick support required) then larger images are scaled down. You can block -specific images completely by customizing @code{shr-blocked-images}. +specific images completely by customizing @code{shr-blocked-images}, +or, if you want to only allow some specific images, customize +@code{shr-allowed-images}. @vindex shr-inhibit-images You can control image display by customizing @@ -380,6 +383,32 @@ thus allowing for the use of the usual substitutions, such as @code{\[eww-reload]} for the current key binding of the @code{eww-reload} command. +@vindex eww-auto-rename-buffer + If the @code{eww-auto-rename-buffer} user option is non-@code{nil}, +EWW buffers will be renamed after rendering a document. If this is +@code{title}, rename based on the title of the document. If this is +@code{url}, rename based on the @acronym{URL} of the document. This +can also be a user-defined function, which is called with no +parameters in the EWW buffer, and should return a string. + +@cindex utm +@vindex eww-url-transformers + EWW runs the URLs through @code{eww-url-transformers} before using +them. This user option is a list of functions, where each function is +called with the URL as the parameter, and should return the (possibly) +transformed URL. By default, this variable contains +@code{eww-remove-tracking}, which removes the common @samp{utm_} +trackers from links. + +@cindex video +@vindex shr-use-xwidgets-for-media + If Emacs has been built with xwidget support, EWW can use that to +display @samp{<video>} elements. However, this support is still +experimental, and on some systems doesn't work (and even worse) may +crash your Emacs, so this feature is off by default. If you wish to +switch it on, set @code{shr-use-xwidgets-for-media} to a +non-@code{nil} value. + @node Command Line @chapter Command Line Usage 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 6c892bc80a9..98b296c376b 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 @@ -4499,7 +4499,7 @@ command or better use it as a prefix key. For example: (gnus-group-jump-to-group "nndraft:drafts"))) @end lisp -On keys reserved for users in Emacs and on keybindings in general +On keys reserved for users in Emacs and on key bindings in general @xref{Keymaps, Keymaps, , emacs, The Emacs Editor}. @item ^ @@ -9843,6 +9843,13 @@ Gravatarify the @code{From} header (@code{gnus-treat-from-gravatar}). Gravatarify all mail headers (i.e., @code{Cc}, @code{To}) (@code{gnus-treat-from-gravatar}). +@item W D e +@kindex W D e @r{(Summary)} +@findex gnus-article-emojize-symbols +Some symbols have both a non-emoji presentation and an emoji +presentation. This command will make Gnus choose the emoji presentation +(@code{gnus-article-emojize-symbols}). + @item W D D @kindex W D D @r{(Summary)} @findex gnus-article-remove-images @@ -12185,6 +12192,7 @@ controlling variable is a predicate list, as described above. @vindex gnus-treat-capitalize-sentences @vindex gnus-treat-overstrike @vindex gnus-treat-strip-cr +@vindex gnus-treat-emojize-symbols @vindex gnus-treat-strip-headers-in-body @vindex gnus-treat-strip-leading-blank-lines @vindex gnus-treat-strip-multiple-blank-lines @@ -12237,6 +12245,7 @@ possible but those listed are probably sufficient for most people. @item gnus-treat-capitalize-sentences (t, integer) @item gnus-treat-overstrike (t, integer) @item gnus-treat-strip-cr (t, integer) +@item gnus-treat-emojize-symbols (t, integer) @item gnus-treat-strip-headers-in-body (t, integer) @item gnus-treat-strip-leading-blank-lines (t, first, integer) @item gnus-treat-strip-multiple-blank-lines (t, integer) @@ -13468,7 +13477,7 @@ Also @pxref{Formatting Variables}. @subsection Server Commands @cindex server commands -The following keybinding are available in the server buffer. Be aware +The following key bindings are available in the server buffer. Be aware that some of the commands will only work on servers that you've added through this interface (with @kbd{a}), not with servers you've defined in your init files. @@ -15438,10 +15447,6 @@ If non-@code{nil}, ask for confirmation before deleting old incoming files. This variable only applies when @code{mail-source-delete-incoming} is a positive number. -@item mail-source-ignore-errors -@vindex mail-source-ignore-errors -If non-@code{nil}, ignore errors when reading mail from a mail source. - @item mail-source-directory @vindex mail-source-directory Directory where incoming mail source files (if any) will be stored. The @@ -18043,7 +18048,7 @@ find all messages that have been received recently from certain groups: (list (cons 'query (format-time-string "SENTSINCE %d-%b-%Y" - (time-subtract (current-time) + (time-subtract nil (days-to-time (car args))))) (cons 'criteria ""))) (group-spec (cadr args))) @@ -28881,7 +28886,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/idlwave.texi b/doc/misc/idlwave.texi index 3cd53c71daf..0e35f20a774 100644 --- a/doc/misc/idlwave.texi +++ b/doc/misc/idlwave.texi @@ -2670,7 +2670,7 @@ As a special case, any error message in the output will be displayed @node Debugging IDL Programs @section Debugging IDL Programs @cindex Debugging -@cindex Keybindings for debugging +@cindex Key bindings for debugging @cindex Toolbar Programs can be compiled, run, and debugged directly from the source diff --git a/doc/misc/ido.texi b/doc/misc/ido.texi index 1c960940a0b..d71ebad4bce 100644 --- a/doc/misc/ido.texi +++ b/doc/misc/ido.texi @@ -476,13 +476,13 @@ M-x customize-variable @key{RET} ido-xxxxx @key{RET} @end example @vindex ido-setup-hook -To modify the keybindings, use the @code{ido-setup-hook}. For example: +To modify the key bindings, use the @code{ido-setup-hook}. For example: @example (add-hook 'ido-setup-hook 'ido-my-keys) (defun ido-my-keys () - "Add my keybindings for Ido." + "Add my key bindings for Ido." (define-key ido-completion-map " " 'ido-next-match)) @end example diff --git a/doc/misc/mairix-el.texi b/doc/misc/mairix-el.texi index d0ec552145e..e57b5ed5422 100644 --- a/doc/misc/mairix-el.texi +++ b/doc/misc/mairix-el.texi @@ -60,6 +60,8 @@ database. * Using:: List of interactive functions * Extending:: Support your favorite mail reader! * GNU Free Documentation License:: The license for this documentation. +* Function Index: Function Index. +* Variable Index: Variable Index. @end menu @node About @@ -339,4 +341,14 @@ And that's it! @appendix GNU Free Documentation License @include doclicense.texi +@node Function Index +@unnumbered Function Index + +@printindex fn + +@node Variable Index +@unnumbered Variable Index + +@printindex vr + @bye diff --git a/doc/misc/message.texi b/doc/misc/message.texi index 4136ad859f7..b628fd1b0f7 100644 --- a/doc/misc/message.texi +++ b/doc/misc/message.texi @@ -2553,6 +2553,22 @@ if @code{nil} let the mailer mail back a message to report errors. When non-@code{nil}, Gnus will ask for confirmation when sending a message. +@item message-server-alist +@vindex message-server-alist +An alist describing the rules for generating the +@code{X-Message-SMTP-Method} header to insert before sending out a new +message, if the message doesn't yet have such a header. Each element +of the alist should be of the form +@w{@code{(@var{cond} . @var{method})}}. If @var{cond} is a string, it +will be compared with the @code{From} header, and if they compare +equal, the corresponding @var{method} will be inserted as a string +into the message headers as the SMTP Method. If @var{cond} is a +function, it will be called in the message buffer without any +arguments, and the corresponding @var{method} will be inserted into +the message headers as the SMTP Method if the function returns a +non-@code{nil} value; if @var{method} is nil, the value returned by +the function @code{cond} is used instead. + @end table 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 9674a12e695..c75e8087c39 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 2.0.0 +#+macro: release-date 2021-12-24 +#+macro: development-version 2.1.0-dev #+macro: file @@texinfo:@file{@@$1@@texinfo:}@@ #+macro: space @@texinfo:@: @@ #+macro: kbd @@texinfo:@kbd{@@$1@@texinfo:}@@ @@ -82,9 +82,22 @@ themes strive to achieve as close to full face coverage as possible ([[#h:a9c8f29d-7f72-4b54-b74b-ddefe15d6a19][Face coverage]]). Furthermore, the themes are designed to empower users with red-green -color deficiency (deuteranopia). This is achieved through customization -options which have the effect of replacing all relevant instances of -green with a variant of blue ([[#h:bf1c82f2-46c7-4eb2-ad00-dd11fdd8b53f][Customization Options]]). +color deficiency (deuteranopia). This is achieved in three ways: + +1. The conformance with the highest legibility standard means that text + is always readable no matter the perception of its hue. + +2. Most contexts use colors on the blue-cyan-magenta-purple side of the + spectrum. Put differently, green and/or red are seldom used, thus + minimizing the potential for confusion. + + [[#h:0b26cb47-9733-4cb1-87d9-50850cb0386e][Why are colors mostly variants of blue, magenta, cyan?]]. + +3. In contexts where a red/green color-coding is unavoidable, we provide + a universal toggle to customize the themes so that a red/blue scheme + is used instead. + + [[#h:3ed03a48-20d8-4ce7-b214-0eb7e4c79abe][Option for red-green color deficiency or deuteranopia]]. Starting with version 0.12.0 and onwards, the themes are built into GNU Emacs. @@ -95,7 +108,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 +121,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 +281,7 @@ could look like: (define-key global-map (kbd "<f5>") #'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 @@ -279,15 +292,16 @@ With those granted, bear in mind a couple of technical points on 2. The functions will run the ~modus-themes-after-load-theme-hook~ as their final step. This can be employed for bespoke configurations - ([[#h:f4651d55-8c07-46aa-b52b-bed1e53463bb][Advanced customization]]). Experienced users may not 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]]). + ([[#h:f4651d55-8c07-46aa-b52b-bed1e53463bb][Advanced customization]]). Experienced users may not 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 +323,25 @@ package configurations in their setup. We use this as an example: :bind ("<f5>" . 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 "<f5>") #'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 +358,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 +385,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 +405,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,10 +414,12 @@ 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-success-deuteranopia t + modus-themes-intense-markup t + modus-themes-deuteranopia t modus-themes-tabs-accented t + modus-themes-variable-pitch-ui nil modus-themes-inhibit-reload t ; only applies to `customize-set-variable' and related modus-themes-fringes nil ; {nil,'subtle,'intense} @@ -391,13 +427,13 @@ 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 ;; that can combine any of `3d' OR `moody', `borderless', - ;; `accented', `padded'. - modus-themes-mode-line '(padded accented borderless) + ;; `accented', and a natural number for extra padding + modus-themes-mode-line '(4 accented borderless) ;; Options for `modus-themes-syntax' are either nil (the default), ;; or a list of properties that may include any of those symbols: @@ -434,32 +470,22 @@ this manual. ;; `no-extend', `bg-only', `accented' modus-themes-region '(bg-only no-extend) - ;; Options for `modus-themes-diffs': nil, 'desaturated, - ;; 'bg-only, 'deuteranopia, 'fg-only-deuteranopia - modus-themes-diffs 'fg-only-deuteranopia + ;; Options for `modus-themes-diffs': nil, 'desaturated, 'bg-only + modus-themes-diffs 'desaturated modus-themes-org-blocks 'gray-background ; {nil,'gray-background,'tinted-background} modus-themes-org-agenda ; this is an alist: read the manual or its doc string - '((header-block . (variable-pitch scale-title)) - (header-date . (grayscale workaholic bold-today)) - (event . (accented scale-small)) + '((header-block . (variable-pitch 1.3)) + (header-date . (grayscale workaholic bold-today 1.1)) + (event . (accented varied)) (scheduled . uniform) - (habit . traffic-light-deuteranopia)) + (habit . traffic-light)) modus-themes-headings ; this is an alist: read the manual or its doc string - '((1 . (overline background)) - (2 . (rainbow overline)) - (t . (no-bold))) - - modus-themes-variable-pitch-ui nil - modus-themes-variable-pitch-headings t - modus-themes-scale-headings t - modus-themes-scale-1 1.1 - modus-themes-scale-2 1.15 - modus-themes-scale-3 1.21 - modus-themes-scale-4 1.27 - modus-themes-scale-title 1.33) + '((1 . (overline background variable-pitch 1.3)) + (2 . (rainbow overline 1.1)) + (t . (semibold)))) #+end_src ** Option for inhibiting theme reload @@ -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,35 +512,43 @@ currently active Modus theme. Enable this behaviour by setting this variable to ~nil~. -** Option for color-coding success state +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 red-green color deficiency or deuteranopia :properties: -:alt_title: Success' color-code -:description: Toggle blue color for success or done states +:alt_title: Deuteranopia style +:description: Toggle red/blue color-coding instead of red/green :custom_id: h:3ed03a48-20d8-4ce7-b214-0eb7e4c79abe :end: -#+vindex: modus-themes-success-deuteranopia +#+vindex: modus-themes-deuteranopia + +Brief: When non-nil use red/blue color-coding instead of red/green, +where appropriate. -Symbol: ~modus-themes-success-deuteranopia~ +Symbol: ~modus-themes-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. +This is to account for red-green color deficiency, also know as +deuteranopia and variants. It applies to all contexts where there can +be a color-coded distinction between failure or success, a to-do or done +state, a mark for deletion versus a mark for selection (e.g. in Dired), +current and lazily highlighted search matches, removed lines in diffs as +opposed to added ones, and so on. -With a non-nil value (~t~), use variants of blue instead of green. This -is meant to empower users with red-green color deficiency. +Note that this does not change all colors throughout the active theme, +but only applies to cases that have color-coding significance. For +example, regular code syntax highlighting is not affected. There is no +such need because of the themes' overarching commitment to the highest +legibility standard, which ensures that text is readable regardless of +hue, as well as the predominance of colors on the +blue-cyan-magenta-purple side of the spectrum. -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. - -[[#h:ea7ac54f-5827-49bd-b09f-62424b3b6427][Option for diff buffer looks]]. +[[#h:0b26cb47-9733-4cb1-87d9-50850cb0386e][Why are colors mostly variants of blue, magenta, cyan?]]. ** Option for more bold constructs :properties: @@ -521,7 +558,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 +588,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 +616,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 +672,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 + +Brief: Toggle the use of monospaced fonts for spacing-sensitive +constructs (affects font families). -Symbol: ~modus-themes-no-mixed-fonts~ +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 +715,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 +788,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 +847,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: @@ -804,42 +859,44 @@ effect, color, and border visibility: - ~moody~ + ~accented~ + ~borderless~ -+ ~padded~ ++ A natural number > 1 for extra padding The default (a nil value or an empty list) is a two-dimensional -rectangle with a border around it. The active and the inactive -mode lines use different shades of grayscale values for the -background, foreground, border. - -The ~3d~ property applies a three-dimensional effect to the -active mode line. The inactive mode lines remain two-dimensional -and are toned down a bit, relative to the default style. - -The ~moody~ property optimizes the mode line for use with the -library of the same name (hereinafter referred to as 'Moody'). -In practice, it removes the box effect and replaces it with -underline and overline properties. It also tones down the -inactive mode lines. Despite its intended purpose, this option -can also be used without the Moody library (please consult the -themes' manual on this point for more details). If both ~3d~ and -~moody~ properties are set, the latter takes precedence. - -The ~borderless~ property removes the color of the borders. It -does not actually remove the borders, but only makes their color -the same as the background, effectively creating some padding. - -The ~accented~ property ensures that the active mode line uses a -colored background instead of the standard shade of gray. - -The ~padded~ property increases the apparent height of the mode line. -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. +rectangle with a border around it. The active and the inactive mode +lines use different shades of grayscale values for the background, +foreground, border. + +The ~3d~ property applies a three-dimensional effect to the active mode +line. The inactive mode lines remain two-dimensional and are toned down +a bit, relative to the default style. + +The ~moody~ property optimizes the mode line for use with the library of +the same name (hereinafter referred to as 'Moody'). In practice, it +removes the box effect and replaces it with underline and overline +properties. It also tones down the inactive mode lines. Despite its +intended purpose, this option can also be used without the Moody library +(please consult the themes' manual on this point for more details). If +both ~3d~ and ~moody~ properties are set, the latter takes precedence. + +The ~borderless~ property removes the color of the borders. It does not +actually remove the borders, but only makes their color the same as the +background, effectively creating some padding. + +The ~accented~ property ensures that the active mode line uses a colored +background instead of the standard shade of gray. + +A positive integer (natural number or natnum) applies a padding effect +of NATNUM pixels at the boundaries of the mode lines. The default value +is 1 and does not need to be specified explicitly. The padding has no +effect when the ~moody~ property is also used, because Moody already +applies its own tweaks. To ensure that the underline is placed at the +bottom of the mode line, set ~x-underline-at-descent-line~ to non-nil +(this is not needed when the ~borderless~ property is also set). For +users on Emacs 29, the ~x-use-underline-position-properties~ variable must +also be set to nil. -Combinations of any of those properties are expressed as a list, -like in these examples: +Combinations of any of those properties are expressed as a list, like in +these examples: #+begin_src emacs-lisp (accented) @@ -874,8 +931,12 @@ high, because it has the adverse effect of always overriding the default colors (which have been carefully designed to be highly accessible). 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. +a box style, it is strongly 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 accented background in tab interfaces :properties: @@ -885,7 +946,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 +969,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: @@ -921,7 +986,7 @@ foreground colors for their interaction model, and (ii) those that combine background and foreground values for some of their metaphors. The former category encompasses Icomplete, Ido, Selectrum, Vertico, as well as pattern matching styles like Orderless and Flx. The latter -covers Helm, Ivy, and Sallet. +covers Helm and Ivy. A value of ~nil~ (the default) will simply respect the metaphors of each completion framework. @@ -951,7 +1016,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 +1048,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 +1074,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 +1085,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 +1103,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 +1131,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 :properties: :alt_title: Line highlighting @@ -1064,7 +1143,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 +1197,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 +1220,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 :properties: :alt_title: Matching parentheses @@ -1145,7 +1252,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 +1302,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: @@ -1233,23 +1345,24 @@ In user configuration files the form may look like this: ** Option for diff buffer looks :properties: :alt_title: Diffs -:description: Choose among intense, desaturated, or text-only diffs +:description: Choose among intense, desaturated, or background-only diffs :custom_id: h:ea7ac54f-5827-49bd-b09f-62424b3b6427 :end: #+vindex: modus-themes-diffs -Symbol: ~modus-themes-diffs~ +Brief: Set the overall style of diffs. + +Symbol: ~modus-themes-diffs~ (=choice= type) Possible values: 1. ~nil~ (default) 2. ~desaturated~ 3. ~bg-only~ -4. ~deuteranopia~ -5. ~fg-only-deuteranopia~ The default (~nil~) uses fairly intense color combinations for diffs, by -applying prominently colored backgrounds, with appropriate foregrounds. +applying prominently colored backgrounds, with appropriately tinted +foregrounds. Option ~desaturated~ follows the same principles as with the default (~nil~), though it tones down all relevant colors. @@ -1257,24 +1370,22 @@ Option ~desaturated~ follows the same principles as with the default Option ~bg-only~ applies a background but does not override the text's foreground. This makes it suitable for a non-nil value passed to ~diff-font-lock-syntax~ (note: Magit does not support syntax highlighting -in diffs---last checked on 2021-04-21). - -Option ~deuteranopia~ is like the default (~nil~) in terms of using -prominently colored backgrounds, except that it also accounts for -red-green color defficiency by replacing all instances of green with -colors on the blue side of the spectrum. Other stylistic changes are -made in the interest of optimizing for such a use-case. - -Option ~fg-only-deuteranopia~ removes all colored backgrounds, except from -word-wise or refined changes. Instead, it only uses color-coded -foreground values to differentiate between added, removed, and changed -lines. If a background is necessary to denote context, a subtle -grayscale value is applied. The color used for added lines is a variant -of blue to account for red-green color defficiency but also because -green text alone is hard to discern in the diff's context (hard for our -accessibility purposes). The ~fg-only~ option that existed in older -versions of the themes is now an alias of ~fg-only-deuteranopia~, in the -interest of backward compatibility. +in diffs---last checked on 2021-12-02). + +When the user option ~modus-themes-deuteranopia~ is non-nil, all diffs +will use a red/blue color-coding system instead of the standard +red/green. Other stylistic changes are made in the interest of +optimizing for such a use-case. + +[[#h:3ed03a48-20d8-4ce7-b214-0eb7e4c79abe][Option for red-green color deficiency or deuteranopia]]. + +In versions before =2.0.0= there was an option for foreground-only diffs. +This is no longer supported at the theme level because there are cases +where the perceived contrast and overall contextuality were not good +enough although the applied colors were technically above the 7:1 +contrast threshold. + +[[#h:e2aed9eb-5e1e-45ec-bbd7-bc4faeab3236][Diffs with only the foreground]]. ** Option for org-mode block styles :properties: @@ -1284,7 +1395,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 +1438,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 @@ -1333,9 +1449,9 @@ all possible combinations: #+begin_src emacs-lisp (setq modus-themes-org-agenda - '((header-block . (variable-pitch scale-title)) - (header-date . (grayscale workaholic bold-today)) - (event . (accented scale-small)) + '((header-block . (variable-pitch 1.5)) + (header-date . (grayscale workaholic bold-today 1.2)) + (event . (accented italic varied)) (scheduled . uniform) (habit . traffic-light))) #+end_src @@ -1348,20 +1464,31 @@ come in the form of a list that can include either or both of those properties: - ~variable-pitch~ to use a proportionately spaced typeface; -- ~scale-title~ to increase the size to the number assigned to - ~modus-themes-scale-title~ ([[#h:6868baa1-beba-45ed-baa5-5fd68322ccb3][Control the scale of headings]]) or ~no-scale~ - to make the font use the same height as the rest of the buffer. +- A number as a floating point (e.g. 1.5) to set the height of the text + to that many times the default font height. A float of 1.0 or the + symbol ~no-scale~ have the same effect of making the font to the same + height as the rest of the buffer. When neither a number nor ~no-scale~ + are present, the default is a small increase in height (a value of + 1.15). +- 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. -In case both ~scale-title~ and ~no-scale~ are in the list, the latter takes -precedence. +[[#h:2793a224-2109-4f61-a106-721c57c01375][Configure bold and italic faces]]. + +In case both a number and ~no-scale~ are in the list, the latter takes +precedence. If two numbers are specified, the first one is applied. Example usage: #+begin_src emacs-lisp (header-block . nil) -(header-block . (scale-title)) +(header-block . (1.5)) (header-block . (no-scale)) -(header-block . (variable-pitch scale-title)) +(header-block . (variable-pitch 1.5)) +(header-block . (variable-pitch 1.5 semibold)) #+end_src A ~header-date~ key covers date headings. Dates use only a foreground @@ -1376,12 +1503,12 @@ the following properties: terms of color; - ~bold-today~ to apply a bold typographic weight to the current date; -- ~bold-all~ to render all date headings in a bold weight. -- ~scale-heading~ increases the height of the date headings to the value - of ~modus-themes-scale-1~ (which is the first step in the scale for - regular headings). +- ~bold-all~ to render all date headings in a bold weight; - ~underline-today~ applies an underline to the current date while - removing the background it has by default. + removing the background it has by default; +- A number as a floating point (e.g. 1.2) to set the height of the text + to that many times the default font height. The default is the same + as the base font height (the equivalent of 1.0). For example: @@ -1394,28 +1521,35 @@ 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: - -- ~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. +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: + +- ~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 @@ -1460,9 +1594,12 @@ passed as a symbol. Those are: being too late. The difference between ready and clear states is attenuated by painting both of them using shades of green. This option thus highlights the alert and overdue states. -- ~traffic-light-deuteranopia~ is like the ~traffic-light~ except its three - colors are red, yellow, and blue to be suitable for users with - red-green color deficiency (deuteranopia). +- When ~modus-themes-deuteranopia~ is non-nil the habit graph uses a + three-color style like the aforementioned ~traffic-light~ variant, + except that shades of blue are applied instead of green. This is + suitable for users with red-green color deficiency (deuteranopia). + +[[#h:3ed03a48-20d8-4ce7-b214-0eb7e4c79abe][Option for red-green color deficiency or deuteranopia]]. For example: @@ -1475,17 +1612,17 @@ For example: Putting it all together, the alist can look like this: #+begin_src emacs-lisp -'((header-block . (scale-title variable-pitch)) +'((header-block . (1.5 variable-pitch)) (header-date . (grayscale workaholic bold-today)) - (event . (accented scale-small)) + (event . (accented varied)) (scheduled . uniform) (habit . traffic-light)) ;; Or else: (setq modus-themes-org-agenda - '((header-block . (scale-title variable-pitch)) + '((header-block . (1.5 variable-pitch)) (header-date . (grayscale workaholic bold-today)) - (event . (accented scale-small)) + (event . (accented varied)) (scheduled . uniform) (habit . traffic-light))) #+end_src @@ -1498,7 +1635,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 @@ -1508,8 +1648,9 @@ a presentation of all available properties: #+begin_src emacs-lisp (setq modus-themes-headings - '((1 . (background overline)) - (2 . (overline rainbow)) + '((1 . (background overline variable-pitch 1.5)) + (2 . (overline rainbow 1.3)) + (3 . (overline 1.1)) (t . (monochrome)))) #+end_src @@ -1518,8 +1659,22 @@ 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~ (deprecated alias of a ~regular~ weight) ++ A floating point as a height multiple of the default By default (a ~nil~ value for this variable), all headings have a bold typographic weight and use a desaturated text color. @@ -1531,20 +1686,34 @@ 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 the heading the same as the base color, +which is that of the ~default~ face's foreground. When ~background~ is also +set, ~monochrome~ changes its color to gray. If both ~monochrome~ and +~rainbow~ are set, the former takes precedence. -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. +A ~variable-pitch~ property changes the font family of the heading to that +of the ~variable-pitch~ face (normally a proportionately spaced typeface). + +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]]. + +A number, expressed as a floating point (e.g. 1.5), adjusts the height +of the heading to that many times the base font size. The default +height is the same as 1.0, though it need not be explicitly stated. 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 1.3) #+end_src The order in which the properties are set is not significant. @@ -1553,9 +1722,9 @@ In user configuration files the form may look like this: #+begin_src emacs-lisp (setq modus-themes-headings - '((1 . (background overline rainbow)) - (2 . (background overline)) - (t . (overline no-bold)))) + '((1 . (background overline rainbow 1.5)) + (2 . (background overline 1.3)) + (t . (overline semibold)))) #+end_src When defining the styles per heading level, it is possible to pass a @@ -1570,7 +1739,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 @@ -1579,100 +1748,6 @@ For Org users, the extent of the heading depends on the variable ~background~ properties. Depending on the version of Org, there may be others, such as ~org-fontify-done-headline~. -[[#h:075eb022-37a6-41a4-a040-cc189f6bfa1f][Option for scaled headings]]. - -[[#h:97caca76-fa13-456c-aef1-a2aa165ea274][Option for variable-pitch font in headings]]. - -** Option for scaled headings -:properties: -:alt_title: Scaled headings -:description: Toggle scaling of headings -:custom_id: h:075eb022-37a6-41a4-a040-cc189f6bfa1f -:end: -#+vindex: modus-themes-scale-headings - -Symbol: ~modus-themes-scale-headings~ - -Possible values: - -1. ~nil~ (default) -2. ~t~ - -The default is to use the same size for headings and paragraph text. - -With a non-nil value (~t~) make headings larger in height relative to the -main text. This is noticeable in modes like Org, Markdown, and Info. - -*** Control the scale of headings -:properties: -:alt_title: Scaled heading sizes -:description: Specify rate of increase for scaled headings -:custom_id: h:6868baa1-beba-45ed-baa5-5fd68322ccb3 -:end: - -In addition to the toggle for enabling scaled headings, users can also -specify a number of their own. - -+ If it is a floating point, say, =1.5=, it is interpreted as a multiple - of the base font size. This is the recommended method, because it - will always adapt to changes in the base font size, such as while - using the ~text-scale-adjust~ command. - -+ If it is an integer, it is read as an absolute font height that is - 1/10 of the typographic point size. Thus a value of =18pt= must be - expressed as =180=. Setting an absolute value is discouraged, as it - will break the layout in cases where the base font size must change, - such as with the ~text-scale-adjust~ command ([[#h:defcf4fc-8fa8-4c29-b12e-7119582cc929][Font configurations]]). - While we discourage using absolute values, we still provide for this - option for users who do not need to perform text-scaling operations or - who are content with whatever discrepancies in height. - -Below are the variables in their default values, using the floating -point paradigm. The numbers are very conservative, but one is free to -change them to their liking, such as =1.2=, =1.4=, =1.6=, =1.8=, =2.0=---or use a -resource for finding a consistent scale: - -#+begin_src emacs-lisp -(setq modus-themes-scale-1 1.05 - modus-themes-scale-2 1.1 - modus-themes-scale-3 1.15 - modus-themes-scale-4 1.2 - modus-themes-scale-title 1.3 - modus-themes-scale-small 0.9) -#+end_src - -As for the application of that scale, the variables that range from -~modus-themes-scale-1~ up to ~modus-themes-scale-4~ apply to regular -headings within the context of the given major mode. The former is the -smallest, while the latter is the largest. "Regular headings" are those -that have a standard syntax for their scale, such as Org mode's eight -levels of asterisks or Markdown's six columns. - -Whereas ~modus-themes-scale-title~ is applied to special headings that do -not conform with the aforementioned syntax, yet which are expected to be -larger than the largest value on that implied scale or at least have -some unique purpose in the buffer. Put concretely, Org's =#+title= meta -datum is not part of the eight levels of headings in an Org file, yet is -supposed to signify the primary header. Similarly, the Org Agenda's -structure headings are not part of a recognisable scale and so they also -get ~modus-themes-scale-title~ ([[#h:68f481bc-5904-4725-a3e6-d7ecfa7c3dbc][Option for Org agenda constructs]]). - -Similarly ~modus-themes-scale-small~ is not applied to regular headings, -but reserved for special contexts where the user is presented with an -option to use a smaller font height than the base size. It is only -implemented for the Org agenda. - -Users who wish to maintain scaled headings for the normal syntax while -preventing special headings from standing out, can assign a value of =1.0= -to ~modus-themes-scale-title~ to make it the same as body text (or -whatever value would render it indistinguishable from the desired point -of reference). - -Note that in earlier versions of Org, scaling would only increase the -size of the heading, but not of keywords that were added to it, like -"TODO". The issue has been fixed upstream: -<https://protesilaos.com/codelog/2020-09-24-org-headings-adapt/>. - ** Option for variable-pitch font in UI elements :properties: :alt_title: UI typeface @@ -1681,7 +1756,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: @@ -1700,29 +1778,6 @@ is done by assigning the ~variable-pitch~ face to the relevant items. [[#h:defcf4fc-8fa8-4c29-b12e-7119582cc929][Font configurations for Org and others]]. -** Option for variable-pitch font in headings -:properties: -:alt_title: Headings' typeface -:description: Toggle the use of variable-pitch in headings -:custom_id: h:97caca76-fa13-456c-aef1-a2aa165ea274 -:end: -#+vindex: modus-themes-variable-pitch-headings - -Symbol: ~modus-themes-variable-pitch-headings~ - -Possible values: - -1. ~nil~ (default) -2. ~t~ - -The default is to use the main font family, which typically is -monospaced. - -With a non-nil value (~t~) apply a proportionately spaced typeface, else -"variable-pitch", to headings (such as in Org mode). - -[[#h:defcf4fc-8fa8-4c29-b12e-7119582cc929][Font configurations for Org and others]]. - * Advanced customization :properties: :custom_id: h:f4651d55-8c07-46aa-b52b-bed1e53463bb @@ -2460,17 +2515,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. - -[[#h:115e6c23-ee35-4a16-8cef-e2fcbb08e28b][Option for no font mixing]]. +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~. -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 +2545,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 +2565,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]]. @@ -2545,7 +2607,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 +2635,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 +2668,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 :properties: :custom_id: h:89f0678d-c5c3-4a57-a526-668b2bb2d7ad @@ -2897,6 +2962,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 +: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 :properties: :custom_id: h:86f6906b-f090-46cc-9816-1fe8aeb38776 @@ -2946,6 +3106,61 @@ user. Hence our hesitation to recommend it as part of the standard setup of the Modus themes (it is generally a good idea to understand what the implications are of advising a function). +** Diffs with only the foreground +:properties: +:custom_id: h:e2aed9eb-5e1e-45ec-bbd7-bc4faeab3236 +:end: +#+cindex: Foreground-only diffs + +Buffers that show differences between versions of a file or buffer, such +as in ~diff-mode~ and ~ediff~ always use color-coded background and +foreground combinations. + +[[#h:ea7ac54f-5827-49bd-b09f-62424b3b6427][Option for diff buffer looks]]. + +User may, however, prefer a style that removes the color-coded +backgrounds from regular changes while keeping them for word-wise (aka +"refined") changes---backgrounds for word-wise diffs are helpful in +context. To make this happen, one can use the ~modus-themes-with-colors~ +macro ([[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Face specs at scale using the themes' palette]]): + +#+begin_src emacs-lisp +(defun my-modus-themes-custom-faces () + (modus-themes-with-colors + (custom-set-faces + `(modus-themes-diff-added ((,class :background unspecified :foreground ,green))) ; OR ,blue for deuteranopia + `(modus-themes-diff-changed ((,class :background unspecified :foreground ,yellow))) + `(modus-themes-diff-removed ((,class :background unspecified :foreground ,red))) + + `(modus-themes-diff-refine-added ((,class :background ,bg-diff-added :foreground ,fg-diff-added))) + ;; `(modus-themes-diff-refine-added ((,class :background ,bg-diff-added-deuteran :foreground ,fg-diff-added-deuteran))) + `(modus-themes-diff-refine-changed ((,class :background ,bg-diff-changed :foreground ,fg-diff-changed))) + `(modus-themes-diff-refine-removed ((,class :background ,bg-diff-removed :foreground ,fg-diff-removed))) + + `(modus-themes-diff-focus-added ((,class :background ,bg-dim :foreground ,green))) ; OR ,blue for deuteranopia + `(modus-themes-diff-focus-changed ((,class :background ,bg-dim :foreground ,yellow))) + `(modus-themes-diff-focus-removed ((,class :background ,bg-dim :foreground ,red))) + + `(modus-themes-diff-heading ((,class :background ,bg-alt :foreground ,fg-main))) + + `(diff-indicator-added ((,class :foreground ,green))) ; OR ,blue for deuteranopia + `(diff-indicator-changed ((,class :foreground ,yellow))) + `(diff-indicator-removed ((,class :foreground ,red))) + + `(magit-diff-added ((,class :background unspecified :foreground ,green-faint))) + `(magit-diff-changed ((,class :background unspecified :foreground ,yellow-faint))) + `(magit-diff-removed ((,class :background unspecified :foreground ,red-faint))) + `(magit-diff-context-highlight ((,class :background ,bg-dim :foreground ,fg-dim)))))) + +;; This is so that the changes persist when switching between +;; `modus-operandi' and `modus-vivendi'. +(add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-custom-faces) +#+end_src + +This used to be an optional style of ~modus-themes-diffs~, but has been +removed since version =2.0.0= to ensure that the accessibility standard +and aesthetic quality of the themes is not compromised. + * Face coverage :properties: :custom_id: h:a9c8f29d-7f72-4b54-b74b-ddefe15d6a19 @@ -2969,14 +3184,12 @@ affected face groups. The items with an appended asterisk =*= tend to have lots of extensions, so the "full support" may not be 100% true… + ace-window -+ ag + alert + all-the-icons + annotate + ansi-color + anzu + apropos -+ apt-sources-list + artbollocks-mode + auctex and TeX + auto-dim-other-buffers @@ -2989,7 +3202,6 @@ have lots of extensions, so the "full support" may not be 100% true… + boon + bookmark + breakpoint (provided by the built-in {{{file(gdb-mi.el)}}} library) -+ buffer-expose + calendar and diary + calfw + centaur-tabs @@ -3007,7 +3219,6 @@ have lots of extensions, so the "full support" may not be 100% true… + corfu + counsel* + counsel-css -+ counsel-org-capture-string + cov + cperl-mode + css-mode @@ -3019,7 +3230,6 @@ have lots of extensions, so the "full support" may not be 100% true… + dashboard (emacs-dashboard) + deadgrep + debbugs -+ define-word + deft + dictionary + diff-hl @@ -3032,15 +3242,12 @@ have lots of extensions, so the "full support" may not be 100% true… + dired-git-info + dired-narrow + dired-subtree -+ diredc + diredfl + diredp (dired+) -+ disk-usage + display-fill-column-indicator-mode + doom-modeline + dynamic-ruler + easy-jekyll -+ easy-kill + ebdb + ediff + eglot @@ -3076,7 +3283,6 @@ have lots of extensions, so the "full support" may not be 100% true… + flycheck-posframe + flymake + flyspell -+ flyspell-correct + flx + freeze-it + frog-menu @@ -3088,10 +3294,8 @@ have lots of extensions, so the "full support" may not be 100% true… + geiser + git-commit + git-gutter (and variants) -+ git-lens + git-rebase + git-timemachine -+ git-walktree + gnus + gotest + golden-ratio-scroll-screen @@ -3100,27 +3304,22 @@ have lots of extensions, so the "full support" may not be 100% true… + helm-switch-shell + helm-xref + helpful -+ highlight-blocks -+ highlight-defined -+ highlight-escape-sequences (~hes-mode~) + highlight-indentation + highlight-numbers + highlight-parentheses ([[#h:24bab397-dcb2-421d-aa6e-ec5bd622b913][Note on highlight-parentheses.el]]) -+ highlight-symbol -+ highlight-tail + highlight-thing + hl-defined + hl-fill-column + hl-line-mode + hl-todo + hydra -+ hyperlist + ibuffer + icomplete + icomplete-vertical + ido-mode + iedit + iflipb ++ image-dired + imenu-list + indium + info @@ -3128,7 +3327,6 @@ have lots of extensions, so the "full support" may not be 100% true… + interaction-log + ioccur + isearch, occur, etc. -+ isl (isearch-light) + ivy* + ivy-posframe + jira (org-jira) @@ -3152,7 +3350,6 @@ have lots of extensions, so the "full support" may not be 100% true… + markup-faces (~adoc-mode~) + mentor + messages -+ minibuffer-line + minimap + mmm-mode + mode-line @@ -3160,14 +3357,12 @@ have lots of extensions, so the "full support" may not be 100% true… + moody + mpdel + mu4e -+ mu4e-conversation + multiple-cursors ++ nano-modeline + neotree -+ no-emoji + notmuch + num3-mode + nxml-mode -+ objed + orderless + org* + org-journal @@ -3187,14 +3382,11 @@ have lots of extensions, so the "full support" may not be 100% true… + pandoc-mode + paradox + paren-face -+ parrot + pass + pdf-tools + persp-mode + perspective + phi-grep -+ phi-search -+ pkgbuild-mode + pomidor + popup + powerline @@ -3206,7 +3398,6 @@ have lots of extensions, so the "full support" may not be 100% true… + quick-peek + racket-mode + rainbow-blocks -+ rainbow-identifiers + rainbow-delimiters + rcirc + recursion-indicator @@ -3215,7 +3406,6 @@ have lots of extensions, so the "full support" may not be 100% true… + ripgrep + rmail + ruler-mode -+ sallet + selectrum + selectrum-prescient + semantic @@ -3233,13 +3423,10 @@ have lots of extensions, so the "full support" may not be 100% true… + solaire + spaceline + speedbar -+ spell-fu -+ spray + stripes + suggest + switch-window + swiper -+ swoop + sx + symbol-overlay + syslog-mode @@ -3261,12 +3448,11 @@ have lots of extensions, so the "full support" may not be 100% true… + undo-tree + vc (vc-dir.el, vc-hooks.el) + vc-annotate (the output of {{{kbd(C-x v g)}}}) -+ vdiff + vertico ++ vertico-quick + vimish-fold + visible-mark + visual-regexp -+ volatile-highlights + vterm + wcheck-mode + web-mode @@ -3298,23 +3484,38 @@ These do not require any extra styles because they are configured to inherit from some basic faces or their dependencies which are directly supported by the themes. ++ ag ++ apt-sources-list ++ buffer-expose + bufler + counsel-notmuch ++ counsel-org-capture-string ++ define-word ++ disk-usage ++ easy-kill + edit-indirect + evil-owl ++ flyspell-correct + fortran-mode ++ git-walktree + goggles ++ highlight-defined ++ highlight-escape-sequences (~hes-mode~) + i3wm-config-mode ++ minibuffer-line ++ no-emoji ++ parrot + perl-mode + php-mode + rjsx-mode + side-hustle ++ spell-fu + swift-mode + tab-bar-echo-area + tide ++ vdiff + vertico-indexed + vertico-mouse -+ vertico-quick * Notes on individual packages :properties: @@ -3775,11 +3976,11 @@ examples with the 4, 8, 16 colors): :custom_id: h:4da1d515-3e05-47ef-9e45-8251fc7e986a :end: -The ~god-mode~ library does not provide faces that could be configured -by the Modus themes. Users who would like to get some visual feedback -on the status of {{{kbd(M-x god-mode)}}} are instead encouraged by upstream -to set up their own configurations, such as by changing the ~mode-line~ -face ([[#h:f4651d55-8c07-46aa-b52b-bed1e53463bb][Advanced customization]]). This is an adaptation of the approach +The ~god-mode~ library does not provide faces that could be configured by +the Modus themes. Users who would like to get some visual feedback on +the status of {{{kbd(M-x god-mode)}}} are instead encouraged by upstream to +set up their own configurations, such as by changing the ~mode-line~ face +([[#h:f4651d55-8c07-46aa-b52b-bed1e53463bb][Advanced customization]]). This is an adaptation of the approach followed in the upstream README: #+begin_src emacs-lisp @@ -3992,7 +4193,7 @@ you've customized any faces. :properties: :custom_id: h:b3384767-30d3-4484-ba7f-081729f03a47 :end: -#+cindex: Frequently Asked Questions (FAQ) +#+cindex: Frequently Asked Questions In this section we provide answers related to some aspects of the Modus themes' design and application. @@ -4219,7 +4420,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,7 +4524,8 @@ 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, + L.{{{space()}}} Contovounesios, Björn Lindström, Carlo Zancanaro, Christian + Tietze, Daniel Mendler, Eli Zaretskii, Fritz Grabo, Illia Ostapyshyn, Kévin Le Gouguec, Kostadin Ninev, Madhavan Krishnan, Markus Beppler, Matthew Stevenson, Mauro Aranda, Nicolas De Jaeghere, Philip Kaludercic, Rudolf Adamkovič, Stephen Gildea, Shreyas Ragavan, Stefan @@ -4336,19 +4538,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 +4561,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 +4592,9 @@ of this sort): And here are the canonical sources of this project's documentation: -+ Manual :: <https://protesilaos.com/modus-themes> -+ Change Log :: <https://protesilaos.com/modus-themes-changelog> -+ Screenshots :: <https://protesilaos.com/modus-themes-pictures> ++ Manual :: <https://protesilaos.com/emacs/modus-themes> ++ Change Log :: <https://protesilaos.com/emacs/modus-themes-changelog> ++ Screenshots :: <https://protesilaos.com/emacs/modus-themes-pictures> * GNU Free Documentation License :properties: diff --git a/doc/misc/octave-mode.texi b/doc/misc/octave-mode.texi index e3306060159..d6b669a292e 100644 --- a/doc/misc/octave-mode.texi +++ b/doc/misc/octave-mode.texi @@ -240,7 +240,7 @@ entering Octave commands at the prompt. The buffer is in Inferior Octave mode, which is derived from the standard Comint mode, a major mode for interacting with an inferior interpreter. See the documentation for @code{comint-mode} for more details, and use -@kbd{C-h b} to find out about available special keybindings. +@kbd{C-h b} to find out about available special key bindings. You can also communicate with an inferior Octave process from within files with Octave code (i.e., buffers in Octave mode), using the 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 603bf42e0cc..f03f614275c 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/remember.texi b/doc/misc/remember.texi index 91e67a8798b..1ba80eedfcd 100644 --- a/doc/misc/remember.texi +++ b/doc/misc/remember.texi @@ -313,7 +313,7 @@ Save (if it is modified) and bury the current buffer. @node Keystrokes @chapter Keystroke Reference -@file{remember.el} defines the following keybindings by default: +@file{remember.el} defines the following key bindings by default: @table @kbd diff --git a/doc/misc/sem-user.texi b/doc/misc/sem-user.texi index 70a19484e8a..22df24c98c6 100644 --- a/doc/misc/sem-user.texi +++ b/doc/misc/sem-user.texi @@ -145,7 +145,7 @@ this means moving to the parent of the current tag. @item C-c , @key{SPC} Display a list of possible completions for the symbol at point (@code{semantic-complete-analyze-inline}). This also activates a -special set of keybindings for choosing a completion: @key{RET} +special set of key bindings for choosing a completion: @key{RET} accepts the current completion, @kbd{M-n} and @kbd{M-p} cycle through possible completions, @key{TAB} completes as far as possible and then cycles, and @kbd{C-g} or any other key aborts the completion. @@ -655,7 +655,7 @@ usual summary if the text at point has one of these faces. Semantic Idle Completions mode is a minor mode for performing @dfn{code completions} during idle time. The completions are -displayed inline, with keybindings that allow you to cycle through +displayed inline, with key bindings that allow you to cycle through different alternatives. Semantic Idle Completions mode performs completion based on the @@ -681,7 +681,7 @@ besselj [1 of 6 matches] @end example @noindent -While the completion is being displayed, the following keybindings +While the completion is being displayed, the following key bindings take effect: @table @kbd @@ -785,7 +785,7 @@ Most of the other commands documented in this section call This command is bound to @kbd{C-c , @key{SPC}} when Semantic mode is enabled (@pxref{Semantic mode user commands}). It displays a list of possible completions for the symbol at point, and activates a special -set of keybindings for choosing a completion. +set of key bindings for choosing a completion. You can type @key{RET} to accept the current completion, @kbd{M-n} and @kbd{M-p} to cycle through the possible completions, @key{TAB} to @@ -1122,7 +1122,7 @@ that @code{grep} is much slower than the others. The commands to display symbol references are @kbd{C-c , g} (@code{semantic-symref-symbol} and @kbd{C-c , G} -(@code{semantic-symref}). These keybindings are available whenever +(@code{semantic-symref}). These key bindings are available whenever Semantic mode is enabled (@pxref{Semantic mode user commands}). @deffn Command semantic-symref-symbol sym diff --git a/doc/misc/speedbar.texi b/doc/misc/speedbar.texi index 70d4b054166..1d1c65c7786 100644 --- a/doc/misc/speedbar.texi +++ b/doc/misc/speedbar.texi @@ -1218,4 +1218,3 @@ Two good values are @code{nil} and @code{statictag}. @bye @c LocalWords: speedbar's xref slowbar kbd subsubsection -@c LocalWords: keybindings diff --git a/doc/misc/srecode.texi b/doc/misc/srecode.texi index 1f7473c151a..8e55ac2971c 100644 --- a/doc/misc/srecode.texi +++ b/doc/misc/srecode.texi @@ -293,14 +293,14 @@ If the variable @code{srecode-takeover-INS-key} is set, then the key The most important key is bound to @code{srecode-insert} which is @kbd{C-c / /}, or @kbd{@key{INSERT} @key{INSERT}}. @ref{Quick Start}. -Major keybindings are: +Major key bindings are: @table @kbd @item C-c / / Insert a template whose name is typed into the minibuffer. @item C-c / <lower case letter> Reserved for direct binding of simple templates to keys using a -keybinding command in the template file. +key binding command in the template file. @item C-c / <upper case letter> Reserved for template applications (Such as comment or get/set inserter.) @item C-c / E @@ -1070,9 +1070,9 @@ Here is an example of wrapping a semantic tag in a compound value: "Wrap up a collection of semantic tag information. This class will be used to derive dictionary values.") -(defmethod srecode-compound-toString((cp srecode-semantic-tag) - function - dictionary) +(cl-defmethod srecode-compound-toString ((cp srecode-semantic-tag) + function + dictionary) "Convert the compound dictionary value CP to a string. If FUNCTION is non-nil, then FUNCTION is somehow applied to an aspect of the compound value." diff --git a/doc/misc/texinfo.tex b/doc/misc/texinfo.tex index e48383defc4..6e194298948 100644 --- a/doc/misc/texinfo.tex +++ b/doc/misc/texinfo.tex @@ -3,7 +3,7 @@ % Load plain if necessary, i.e., if running under initex. \expandafter\ifx\csname fmtname\endcsname\relax\input plain\fi % -\def\texinfoversion{2021-04-25.21} +\def\texinfoversion{2021-11-01.16} % % Copyright 1985, 1986, 1988, 1990-2021 Free Software Foundation, Inc. % @@ -3614,6 +3614,9 @@ $$% \def\quotedblbase{{\ecfont \char"12}} \def\quotesinglbase{{\ecfont \char"0D}} % +\def\L{{\ecfont \char"8A}} % L with stroke +\def\l{{\ecfont \char"AA}} % l with stroke +% % This positioning is not perfect (see the ogonek LaTeX package), but % we have the precomposed glyphs for the most common cases. We put the % tests to use those glyphs in the single \ogonek macro so we have fewer @@ -7592,6 +7595,7 @@ might help (with 'rm \jobname.?? \jobname.??s')% % \def\printdefunline#1#2{% \begingroup + \plainfrenchspacing % call \deffnheader: #1#2 \endheader % common ending: @@ -9402,7 +9406,7 @@ might help (with 'rm \jobname.?? \jobname.??s')% \fi\fi % \ifimagevmode - \nobreak\medskip + \medskip % Usually we'll have text after the image which will insert % \parskip glue, so insert it here too to equalize the space % above and below. @@ -11599,11 +11603,9 @@ directory should work if nowhere else does.} @setregularquotes @c Local variables: -@c eval: (add-hook 'before-save-hook 'time-stamp) +@c eval: (add-hook 'before-save-hook 'time-stamp nil t) +@c time-stamp-pattern: "texinfoversion{%Y-%02m-%02d.%02H}" @c page-delimiter: "^\\\\message\\|emacs-page" -@c time-stamp-start: "def\\\\texinfoversion{" -@c time-stamp-format: "%:y-%02m-%02d.%02H" -@c time-stamp-end: "}" @c End: @c vim:sw=2: diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index 27ad912523b..86f4d1c38eb 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -2238,8 +2238,7 @@ preserves the path value, which can be used to update shell supports the login argument @samp{-l}. @end defopt -Starting with @w{Emacs 26}, @code{tramp-remote-path} can be set per -host via connection-local +@code{tramp-remote-path} can also be set per host via connection-local @ifinfo variables, @xref{Connection Variables, , , emacs}. @end ifinfo @@ -3389,9 +3388,9 @@ 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 -the local host and @value{tramp} accesses it by changing the +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}. @value{tramp} starts a remote process when a command is executed in a @@ -3411,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 @@ -3533,9 +3532,8 @@ ensures the correct name of the remote shell program. When @code{explicit-shell-file-name} is equal to @code{nil}, calling @code{shell} interactively will prompt for a shell name. -Starting with @w{Emacs 26}, you could use connection-local variables -for setting different values of @code{explicit-shell-file-name} for -different remote hosts. +You could use connection-local variables for setting different values +of @code{explicit-shell-file-name} for different remote hosts. @ifinfo @xref{Connection Variables, , , emacs}. @end ifinfo @@ -4061,6 +4059,11 @@ CPIO archives @cindex @file{cpio} file archive suffix @cindex file archive suffix @file{cpio} +@item @samp{.crate} --- +Cargo (Rust) packages +@cindex @file{crate} file archive suffix +@cindex file archive suffix @file{crate} + @item @samp{.deb} --- Debian packages @cindex @file{deb} file archive suffix @@ -4347,8 +4350,8 @@ Where is the latest @value{tramp}? @item Which systems does it work on? -The package works successfully on @w{Emacs 25}, @w{Emacs 26}, @w{Emacs -27}, and @w{Emacs 28}. +The package works successfully on @w{Emacs 26}, @w{Emacs 27}, @w{Emacs +28}, and @w{Emacs 29}. While Unix and Unix-like systems are the primary remote targets, @value{tramp} has equal success connecting to other platforms, such as @@ -5225,6 +5228,28 @@ time being you can suppress this error by the following code in your @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}? There are packages that call @value{tramp} without the user ever diff --git a/doc/misc/trampver.texi b/doc/misc/trampver.texi index e9fbacc7920..89c478035c0 100644 --- a/doc/misc/trampver.texi +++ b/doc/misc/trampver.texi @@ -8,10 +8,10 @@ @c In the Tramp GIT, the version numbers are auto-frobbed from @c tramp.el, and the bug report address is auto-frobbed from @c configure.ac. -@set trampver 2.5.2.28.1 +@set trampver 2.6.0-pre @set trampurl https://www.gnu.org/software/tramp/ @set tramp-bug-report-address tramp-devel@@gnu.org -@set emacsver 25.1 +@set emacsver 26.1 @c Other flags from configuration. @set instprefix /usr/local diff --git a/doc/misc/vhdl-mode.texi b/doc/misc/vhdl-mode.texi index fef98a74636..baa27179f88 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 @@ -928,7 +928,7 @@ If you want to customize indentation, here you go: (setq tab-width 8 ;; this will make sure spaces are used instead of tabs indent-tabs-mode nil) - ;; keybindings for VHDL are put in vhdl-mode-map + ;; key bindings for VHDL are put in vhdl-mode-map (define-key vhdl-mode-map "\C-m" 'newline-and-indent) ) diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS index f533c58aa41..31ea3de620d 100644 --- a/etc/ERC-NEWS +++ b/etc/ERC-NEWS @@ -12,6 +12,14 @@ extensible IRC (Internet Relay Chat) client distributed with GNU Emacs since Emacs version 22.1. +* Changes in ERC 5.4.1 + +** No user-visible changes since ERC 5.4, but a few tweaks in some ERC +file headers and the ERC manual in order to successfully build ERC for +GNU ELPA. (See below for the news item of ERC now being distributed +on GNU ELPA in addition to its continued inclusion in GNU Emacs core.) + + * Changes in ERC 5.4 ** Starting with Emacs 28.1 and ERC 5.4, ERC NEWS are added here again. 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 @@ -1,15 +1,15 @@ GNU Emacs NEWS -- history of user-visible changes. -Copyright (C) 2019-2021 Free Software Foundation, Inc. +Copyright (C) 2021 Free Software Foundation, Inc. See the end of the file for license conditions. Please send Emacs bug reports to 'bug-gnu-emacs@gnu.org'. If possible, use 'M-x report-emacs-bug'. -This file is about changes in Emacs version 28. +This file is about changes in Emacs version 29. See file HISTORY for a list of GNU Emacs versions and release dates. -See files NEWS.27, NEWS.26, ..., NEWS.18, and NEWS.1-17 for changes +See files NEWS.28, NEWS.27, ..., NEWS.18, and NEWS.1-17 for changes in older Emacs versions. You can narrow news to a specific version by calling 'view-emacs-news' @@ -22,4570 +22,1245 @@ When you add a new item, use the appropriate mark if you are sure it applies, and please also update docstrings as needed. -* Installation Changes in Emacs 28.1 - -** Emacs now optionally supports native compilation of Lisp files. -To enable this, configure Emacs with the '--with-native-compilation' option. -This requires the libgccjit library to be installed and functional, -and also requires GCC and Binutils to be available when Lisp code is -natively compiled. See the Info node "(elisp) Native Compilation" for -more details. - -If you build Emacs with native compilation, but without zlib, be sure -to configure with the '--without-compress-install' option, so that the -installed *.el files are not compressed; otherwise, you will not be -able to use JIT native compilation of the installed *.el files. - -Note that JIT native compilation is done in a fresh session of Emacs -that is run in a subprocess, so it can legitimately report some -warnings and errors that aren't uncovered by byte-compilation. We -recommend examining any such warnings before you decide they are -false. - -** The Cairo graphics library is now used by default if present. -'--with-cairo' is now the default, if the appropriate development files -are found by 'configure'. Note that building with Cairo means using -Pango instead of libXFT for font support. Since Pango 1.44 has -removed support for bitmapped fonts, this may require you to adjust -your font settings. - -Note also that 'FontBackend' settings in ".Xdefaults" or -".Xresources", or 'font-backend' frame parameter settings in your init -files, may need to be adjusted, as 'xft' is no longer a valid backend -when using Cairo. Use 'ftcrhb' if your Emacs was built with HarfBuzz -text shaping support, and 'ftcr' otherwise. You can determine this by -checking 'system-configuration-features'. The 'ftcr' backend will -still be available when HarfBuzz is supported, but will not be used by -default. We strongly recommend building with HarfBuzz support. 'x' is -still a valid backend. - ---- -** 'configure' now warns about building with libXft support. -libXft is unmaintained, and causes a number of problems with modern -fonts including but not limited to crashes; support for it may be -removed in a future version of Emacs. Please consider using -Cairo + HarfBuzz instead. - ---- -** 'configure' now warns about not using HarfBuzz if using Cairo. -We want to encourage people to use the most modern font features -available, and this is the Cairo graphics library + HarfBuzz for font -shaping, so 'configure' now recommends that combination. - ---- -** Building without double buffering support. -'configure --with-xdbe=no' can now be used to disable double buffering -at build time. - ---- -** The configure option '--without-makeinfo' has been removed. -This was only ever relevant when building from a repository checkout. -This now requires makeinfo, which is part of the texinfo package. - ---- -** New configure option '--disable-year2038'. -This causes Emacs to use only 32-bit time_t on platforms that have -both 32- and 64-bit time_t. This may help when linking Emacs with a -library with an ABI requiring traditional 32-bit time_t. This option -currently affects only 32-bit ARM and x86 running GNU/Linux with glibc -2.34 and later. Emacs now defaults to 64-bit time_t on these -platforms. - ---- -** Support for building with '-fcheck-pointer-bounds' has been removed. -GCC has withdrawn the '-fcheck-pointer-bounds' option and support for -its implementation has been removed from the Linux kernel. - ---- -** The ftx font backend driver has been removed. -It was declared obsolete in Emacs 27.1. - ---- -** Emacs no longer supports old OpenBSD systems. -OpenBSD 5.3 and older releases are no longer supported, as they lack -proper pty support that Emacs needs. - - -* Startup Changes in Emacs 28.1 - ---- -** In GTK builds, Emacs now supports startup notification. -This means that Emacs won't steal keyboard focus upon startup -(when started via the Desktop) if the user is typing into another -application. - ---- -** Errors in 'kill-emacs-hook' no longer prevent Emacs from shutting down. -If a function in that hook signals an error in an interactive Emacs, -the user will be prompted on whether to continue. If the user doesn't -answer within five seconds, Emacs will continue shutting down anyway. - -** Emacs now supports loading a Secure Computing filter. -This is supported only on capable GNU/Linux systems. To activate, -invoke Emacs with the '--seccomp=FILE' command-line option. FILE must -name a binary file containing an array of 'struct sock_filter' -structures. Emacs will then install that list of Secure Computing -filters into its own process early during the startup process. You -can use this functionality to put an Emacs process in a sandbox to -avoid security issues when executing untrusted code. See the manual -page for 'seccomp' system call, for details about Secure Computing -filters. - -** Emacs can support 24-bit color TTY without terminfo database. -If your text-mode terminal supports 24-bit true color, but your system -lacks the terminfo database, you can instruct Emacs to support 24-bit -true color by setting 'COLORTERM=truecolor' in the environment. This is -useful on systems such as FreeBSD which ships only with "etc/termcap". - ---- -** File names given on the command line are now be pushed onto history. -The file names will be pushed onto 'file-name-history', like the names -of files visited via 'C-x C-f' and other commands. - - -* Changes in Emacs 28.1 - ---- -** Emacs now supports Unicode Standard version 14.0. - -+++ -** Improved support for Emoji. -On capable systems, Emacs now correctly displays Emoji and Emoji -sequences by default, provided that a suitable font is available to -Emacs. With a few exceptions, all of the Emoji sequences specified by -Unicode 14.0 are automatically composed and displayed as a single -colorful glyph. This is achieved by changes in the Emacs font -configuration, and by additional character-composition rules for the -Emoji codepoints that follow from the Unicode-defined sequences. - -If your system lacks a suitable font, we recommend to install "Noto -Color Emoji"; Emacs will use it automatically if it's installed. If -you prefer to use another font for Emoji, customize your fontset like -this: - - (set-fontset-font t 'emoji - '("My New Emoji Font" . "iso10646-1") nil 'prepend) - -The Emoji characters are now assigned to a special script, 'emoji', so -as to make it easier to customize fontsets for Emoji display, as in -the above example. (Previously, the Emoji characters were assigned to -the 'symbol' script, together with other symbol and punctuation -characters.) - -+++ -** 'glyphless-char-display-control' now applies to Variation Selectors. -VS-1 through VS-16 are now displayed as 'thin-space' by default when -not composed with previous characters (typically, as part of Emoji -sequences). - -+++ -** New command 'execute-extended-command-for-buffer'. -This new command, bound to 'M-S-x', works like -'execute-extended-command', but limits the set of commands to the -commands that have been determined to be particularly useful with the -current mode. +* Installation Changes in Emacs 29.1 +++ -** New user option 'read-extended-command-predicate'. -This user option controls how 'M-x' performs completion of commands when -you type 'TAB'. By default, any command that matches what you have -typed is considered a completion candidate, but you can customize this -option to exclude commands that are not applicable to the current -buffer's major and minor modes, and respect the command's completion -predicate (if any). +** Emacs can be built with built-in support for accessing SQLite databases. +This uses the popular sqlite3 library, and can be disabled by using +the '--without-sqlite3' option to the 'configure' script. -+++ -** Completion on 'M-x' shows key bindings for commands. -When 'suggest-key-bindings' is non-nil (as it is by default), the -completion list popped up by 'M-x' shows the key bindings for all the -commands shown in the list of candidate completions that have a key -binding. - -+++ -** New user option 'completions-detailed'. -When non-nil, some commands like 'describe-symbol' show more detailed -completions with more information in completion prefix and suffix. -The default is nil. - ---- -** 'C-s' in 'M-x' now once again searches over completions. -In Emacs 23, typing 'M-x' ('read-extended-command') and then 'C-s' (to -do an interactive search) would search over possible completions. -This was lost in Emacs 24, but is now back again. - -+++ -** User option 'completions-format' supports a new value 'one-column'. - -+++ -** New system for displaying documentation for groups of functions. -This can either be used by saying 'M-x shortdoc-display-group' and -choosing a group, or clicking a button in the "*Help*" buffers when -looking at the doc string of a function that belongs to one of these -groups. +** 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. +++ -** New minor mode 'context-menu-mode' for context menus popped by 'mouse-3'. -When this mode is enabled, clicking 'down-mouse-3' (usually, the -right mouse button) anywhere in the buffer pops up a menu whose -contents depends on surrounding context near the mouse click. -You can change the order of the default sub-menus in the context menu -by customizing the user option 'context-menu-functions'. You can also -invoke the context menu by pressing 'S-<F10>' or, on macOS, by -clicking 'C-down-mouse-1'. - -+++ -** A new keymap for buffer actions has been added. -The 'C-x x' keymap now holds keystrokes for various buffer-oriented -commands. The new keystrokes are 'C-x x g' ('revert-buffer-quick'), -'C-x x r' ('rename-buffer'), 'C-x x u' ('rename-uniquely'), 'C-x x n' -('clone-buffer'), 'C-x x i' ('insert-buffer'), 'C-x x t' -('toggle-truncate-lines') and 'C-x x f' ('font-lock-update'). - -+++ -** Modifiers now go outside angle brackets in pretty-printed key bindings. -For example, 'RET' with Control and Meta modifiers is now shown as -'C-M-<return>' instead of '<C-M-return>'. Either variant can be used -as input; functions such as 'kbd' and 'read-kbd-macro' accept both -styles as equivalent (they have done so for a long time). +*** 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'. --- -** 'eval-expression' no longer signals an error on incomplete expressions. -Previously, typing 'M-: ( RET' would result in Emacs saying "End of -file during parsing" and dropping out of the minibuffer. The user -would have to type 'M-: M-p' to edit and redo the expression. Now -Emacs will echo the message and allow the user to continue editing. +*** 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. -+++ -** 'eval-last-sexp' now handles 'defvar'/'defcustom'/'defface' specially. -This command would previously not redefine values defined by these -forms, but this command has now been changed to work more like -'eval-defun', and reset the values as specified. +** Emacs now installs the ".pdmp" file using a unique fingerprint in the name. +The file is typically installed using a file name akin to +"...dir/libexec/emacs/29.1/x86_64-pc-linux-gnu/emacs-<fingerprint>.pdmp". +If a constant file name is required, the file can be renamed to +"emacs.pdmp", and Emacs will find it during startup anyway. ---- -** New user option 'use-short-answers'. -When non-nil, the function 'y-or-n-p' is used instead of -'yes-or-no-p'. This eliminates the need to define an alias that maps -one to another in the init file. The same user option also controls -whether the function 'read-answer' accepts short answers. - -+++ -** New user option 'kill-buffer-delete-auto-save-files'. -If non-nil, killing a buffer that has an auto-save file will prompt -the user for whether that auto-save file should be deleted. (Note -that 'delete-auto-save-files', if non-nil, was previously documented -to result in deletion of auto-save files when killing a buffer without -unsaved changes, but this has apparently not worked for several -decades, so the documented semantics of this variable has been changed -to match the behavior.) +** 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. -+++ -** New user option 'next-error-message-highlight'. -In addition to a fringe arrow, 'next-error' error may now optionally -highlight the current error message in the 'next-error' buffer. -This user option can be also customized to keep highlighting on all -visited errors, so you can have an overview what errors were already visited. +The named feature 'xinput2' can be used to test for the presence of +XInput 2 support from Lisp programs. ---- -** New choice 'next-error-quit-window' for 'next-error-found-function'. -When 'next-error-found-function' is customized to 'next-error-quit-window', -then typing the numeric prefix argument 0 before the command 'next-error' -will quit the source window after visiting the next occurrence. - -+++ -** New user option 'file-preserve-symlinks-on-save'. -This controls what Emacs does when saving buffers that visit files via -symbolic links, and 'file-precious-flag' is non-nil. - -+++ -** New user option 'copy-directory-create-symlink'. -If non-nil, will make 'copy-directory' (when used on a symbolic -link) copy the link instead of following the link. The default is -nil, so the default behavior is unchanged. - -+++ -** New user option 'ignored-local-variable-values'. -This is the opposite of 'safe-local-variable-values' -- it's an alist -of variable-value pairs that are to be ignored when reading a -local-variables section of a file. - ---- -** Specific warnings can now be disabled from the warning buffer. -When a warning is displayed to the user, the resulting buffer now has -buttons which allow making permanent changes to the treatment of that -warning. Automatic showing of the warning can be disabled (although -it is still logged to the "*Messages*" buffer), or the warning can be -disabled entirely. - -+++ -** ".dir-locals.el" now supports setting 'auto-mode-alist'. -The new 'auto-mode-alist' specification in ".dir-locals.el" files can -now be used to override the global 'auto-mode-alist' in the current -directory tree. - ---- -** User option 'uniquify-buffer-name-style' can now be a function. -This user option can be one of the predefined styles or a function to -personalize the uniquified buffer name. - ---- -** 'remove-hook' is now an interactive command. - ---- -** 'expand-file-name' now checks for null bytes in filenames. -The function will now check for null bytes in both NAME and -DEFAULT-DIRECTORY arguments, as well as in the 'default-directory' -buffer-local variable, when its value is used. If null bytes are -found, 'expand-file-name' will signal an error. -This means that practically all file-related operations will now check -file names for null bytes, thus avoiding subtle bugs with silently -using only the part of file name up to the first null byte. +** Emacs now supports being built with pure GTK. +To use this option, make sure the GTK 3 and Cairo development files +are installed, and configure Emacs with the option '--with-pgtk'. +Unlike the default X and GTK build, the resulting Emacs binary will +work on any underlying window system supported by GDK, such as +Wayland and Broadway. --- -** Frames +** The docstrings of preloaded files are not in 'etc/DOC' any more. +Instead, they're fetched as needed from the corresponding '.elc' file, +as was already the case for all the non-preloaded files. -+++ -*** The key prefix 'C-x 5 5' displays next command buffer in a new frame. -It's bound to the command 'other-frame-prefix' that requests the buffer -of the next command to be displayed in a new frame. - -+++ -*** New command 'clone-frame' (bound to 'C-x 5 c'). -This is like 'C-x 5 2', but uses the window configuration and frame -parameters of the current frame instead of 'default-frame-alist'. -When called interactively with a prefix arg, the window configuration -is not cloned. - ---- -*** Default values of 'frame-title-format' and 'icon-title-format' have changed. -These variables are used to display the title bar of visible frames -and the title bar of an iconified frame. They now show the name of -the current buffer and the text "GNU Emacs" instead of the value of -'invocation-name'. To get the old behavior back, add the following to -your init file: - - (setq frame-title-format '(multiple-frames "%b" - ("" invocation-name "@" system-name))) - -+++ -*** New frame parameter 'drag-with-tab-line'. -This parameter, similar to 'drag-with-header-line', allows moving frames -by dragging the tab lines of their topmost windows with the mouse. - -+++ -*** New optional behavior of 'delete-other-frames'. -When invoked with a prefix argument, 'delete-other-frames' now -iconifies frames, rather than deleting them. - ---- -*** Commands 'set-frame-width' and 'set-frame-height' now prompt for values. -These commands now prompt for the value via the minibuffer, instead of -requiring the user to specify the value via the prefix argument. - -** Windows - -+++ -*** The key prefix 'C-x 4 1' displays next command buffer in the same window. -It's bound to the command 'same-window-prefix' that requests the buffer -of the next command to be displayed in the same window. - -+++ -*** The key prefix 'C-x 4 4' displays next command buffer in a new window. -It's bound to the command 'other-window-prefix' that requests the buffer -of the next command to be displayed in a new window. - -+++ -*** New command 'recenter-other-window', bound to 'S-M-C-l'. -Like 'recenter-top-bottom', but acting on the other window. - -+++ -*** New user option 'delete-window-choose-selected'. -This allows specifying how Emacs chooses which window will be the -frame's selected window after the currently selected window is -deleted. - -+++ -*** New argument NO-OTHER for some window functions. -'get-lru-window', 'get-mru-window' and 'get-largest-window' now accept a -new optional argument NO-OTHER which, if non-nil, avoids returning a -window whose 'no-other-window' parameter is non-nil. - -+++ -*** New 'display-buffer' function 'display-buffer-use-least-recent-window'. -This is like 'display-buffer-use-some-window', but won't reuse the -current window, and when called repeatedly will try not to reuse a -previously selected window. - -+++ -*** New function 'window-bump-use-time'. -This updates the use time of a window. - -** Minibuffer - -+++ -*** Minibuffer scrolling is now conservative by default. -This is controlled by the new variable 'scroll-minibuffer-conservatively'. -It is t by default; setting it to nil will cause scrolling in the -minibuffer obey the value of 'scroll-conservatively'. - -+++ -*** Improved handling of minibuffers on switching frames. -By default, when you switch to another frame, an active minibuffer now -moves to the newly selected frame. Nevertheless, the effect of what -you type in the minibuffer happens in the frame where the minibuffer -was first activated. An alternative behavior is available by -customizing 'minibuffer-follows-selected-frame' to nil. Here, the -minibuffer stays in the frame where you first opened it, and you must -switch back to this frame to continue or abort its command. The old -behavior, which mixed these two, can be approximated by customizing -'minibuffer-follows-selected-frame' to a value which is neither nil -nor t. - -+++ -*** New user option 'read-minibuffer-restore-windows'. -When customized to nil, it uses 'minibuffer-restore-windows' in -'minibuffer-exit-hook' to remove only the window showing the -"*Completions*" buffer, but keeps all other windows created -while the minibuffer was active. - ---- -*** New variable 'redisplay-adhoc-scroll-in-resize-mini-windows'. -Customizing it to nil will disable the ad-hoc auto-scrolling of -minibuffer text shown in mini-windows when resizing those windows. -The default heuristics of that scrolling can be counter productive in -some corner cases, though the cure might be worse than the disease. -This said, the effect should be negligible in the vast majority of -cases anyway. - -** Mode Line - -+++ -*** New user option 'mode-line-compact'. -If non-nil, repeating spaces are compressed into a single space. If -'long', this is only done when the mode line is longer than the -current window width (in columns). - -+++ -*** New user options to control format of line/column numbers in the mode line. -'mode-line-position-line-format' is the line number format (when -'line-number-mode' is on), 'mode-line-position-column-format' is -the column number format (when 'column-number-mode' is on), and -'mode-line-position-column-line-format' is the combined format (when -both modes are on). - -** Tab Bars and Tab Lines - -+++ -*** The prefix key 'C-x t t' can be used to display a buffer in a new tab. -Typing 'C-x t t' before a command will cause the buffer shown by that -command to be displayed in a new tab. 'C-x t t' is bound to the -command 'other-tab-prefix'. - -+++ -*** New command 'C-x t C-r' to open file read-only in the other tab. - -+++ -*** The tab bar now supports more mouse commands. -Clicking 'mouse-2' closes the tab, 'mouse-3' displays the context menu -with items that operate on the clicked tab. Dragging the tab with -'mouse-1' moves it to another position on the tab bar. Mouse wheel -scrolling switches to the previous/next tab, and holding the Shift key -during scrolling moves the tab to the left/right. - -+++ -*** Frame-specific appearance of the tab bar when 'tab-bar-show' is a number. -When 'tab-bar-show' is a number, the tab bar on different frames can -be shown or hidden independently, as determined by the number of tabs -on each frame compared to the numerical value of 'tab-bar-show'. - -+++ -*** New command 'toggle-frame-tab-bar'. -It can be used to enable/disable the tab bar on the currently selected -frame regardless of the values of 'tab-bar-mode' and 'tab-bar-show'. -This allows enabling/disabling the tab bar independently on different -frames. + +* Startup Changes in Emacs 29.1 +++ -*** New user option 'tab-bar-format' defines a list of tab bar items. -When it contains 'tab-bar-format-global' (possibly appended after -'tab-bar-format-align-right'), then after enabling 'display-time-mode' -(or any other mode that uses 'global-mode-string') it displays time -aligned to the right on the tab bar instead of on the mode line. -When 'tab-bar-format-tabs' is replaced with 'tab-bar-format-tabs-groups', -the tab bar displays tab groups. +** Emacs now has a '--fingerprint' option. +This will output a string identifying the current Emacs build. +++ -*** New optional key binding for 'tab-last'. -If you customize the user option 'tab-bar-select-tab-modifiers' to -allow selecting tabs using their index numbers, the '<MODIFIER>-9' key -is bound to 'tab-last', and switches to the last tab. Here <MODIFIER> -is any of the modifiers in the list that is the value of -'tab-bar-select-tab-modifiers'. You can also use positive indices, -which count from the last tab: 1 is the last tab, 2 the one before -that, etc. - ---- -*** New command 'tab-duplicate' bound to 'C-x t n'. - ---- -*** 'C-x t N' creates a new tab at the specified absolute position. -The position is provided as prefix arg, and specifies an index that -starts at 1. Negative values count from the end of the tab bar. - ---- -*** 'C-x t M' moves the current tab to the specified absolute position. -The position is provided as prefix arg, whose interpretation is as in -'C-x t N'. +** New hook 'after-pdump-load-hook'. +This is run at the end of the Emacs startup process, and it meant to +be used to reinitialize structures that would normally be done at load +time. ---- -*** 'C-x t G' assigns a tab to a named group of tabs. -'tab-close-group' closes all tabs that belong to the selected group. -The user option 'tab-bar-new-tab-group' defines the default group of -new tabs. After customizing 'tab-bar-tab-post-change-group-functions' -to 'tab-bar-move-tab-to-group', changing the group of a tab will also -move it closer to other tabs in the same group. - ---- -*** New user option 'tab-bar-tab-name-format-function'. + +* Incompatible changes in Emacs 29.1 --- -*** New user option 'tab-line-tab-name-format-function'. +** Support for old EIEIO functions is not autoloaded any more. +You need an explicit (require 'eieio-compat) to use 'defmethod' +and 'defgeneric' (which have been made obsolete in Emacs-25 with +'cl-defmethod' and 'cl-defgeneric'). +Similarly you might need to (require 'eieio-compat) before loading +files that were compiled with an old EIEIO (Emacs<25). --- -*** The tabs in the tab line can now be scrolled using horizontal scroll. -If your mouse or trackpad supports it, you can now scroll tabs when -the mouse pointer is in the tab line by scrolling left or right. +** 'C-x 8 .' has been moved to 'C-x 8 . .'. +This is to open up the 'C-x 8 .' map to bind further characters there. ---- -*** New tab-line faces and user options. -The face 'tab-line-tab-special' is used for tabs whose buffers are -special, i.e. buffers that don't visit a file. The face -'tab-line-tab-modified' is used to display modified, file-backed -buffers. The face 'tab-line-tab-inactive-alternate' is used to -display inactive tabs with an alternating background color, making -them easier to distinguish, especially if the face 'tab-line-tab' is -configured to not display with a box; this alternate face is only -applied when the user option 'tab-line-tab-face-functions' is so -configured. That option may also be used to customize tab-line faces -in other ways. - -** Mouse wheel + +* Changes in Emacs 29.1 ---- -*** Mouse wheel scrolling now defaults to one line at a time. +** New command 'sqlite-mode-open-file' for examining an sqlite3 file. +This uses the new 'sqlite-mode' which allows listing the tables in a +DB file, and examining and modifying the columns and the contents of +those tables. --- -*** Mouse wheel scrolling now works on more parts of frame's display. -When using 'mouse-wheel-mode', the mouse wheel will now scroll also when -the mouse cursor is on the scroll bars, fringes, margins, header line, -and mode line. ('mouse-wheel-mode' is enabled by default on most graphical -displays.) +** 'write-file' will now copy some file mode bits. +If the current buffer is visiting a file that is executable, the +'C-x C-w' command will now make the new file executable, too. +++ -*** Mouse wheel scrolling with Shift modifier now scrolls horizontally. -This works in text buffers and over images. Typing a numeric prefix arg -(e.g. 'M-5') before starting horizontal scrolling changes its step value. -The value is saved in the user option 'mouse-wheel-scroll-amount-horizontal'. - -** Customize - ---- -*** Customize buffers can now be reverted with 'C-x x g'. - ---- -*** Most customize commands now hide obsolete user options. -Obsolete user options are no longer shown in the listings produced by -the commands 'customize', 'customize-group', 'customize-apropos' and -'customize-changed'. - -To customize obsolete user options, use 'customize-option' or -'customize-saved'. - ---- -*** New SVG icons for checkboxes and arrows. -They will be used automatically instead of the old icons. If Emacs is -built without SVG support, the old icons will be used instead. - -** Help - ---- -*** The order of things displayed in the "*Help*" buffer has been changed. -The indented "administrative" block (containing the "probably -introduced" and "other relevant functions" (and similar things) has -been moved to after the doc string. +** New user option 'process-error-pause-time'. +This determines how long to pause Emacs after a process +filter/sentinel error has been handled. +++ -*** New command 'describe-command' shows help for a command. -This can be used instead of 'describe-function' for interactive -commands and is globally bound to 'C-h x'. +** New face 'variable-pitch-text'. +This face is like 'variable-pitch' (from which it inherits), but is +slightly larger, which should help with the visual size differences +between the default, non-proportional font and proportional fonts when +mixed. +++ -*** New command 'describe-keymap' describes keybindings in a keymap. - ---- -*** New command 'apropos-function'. -This works like 'C-u M-x apropos-command' but is more discoverable. - ---- -*** New keybinding 'C-h R' prompts for an Info manual and displays it. - ---- -*** Keybindings in 'help-mode' use the new 'help-key-binding' face. -This face is added by 'substitute-command-keys' to any "\[command]" -substitution. The return value of that function should consequently -be assumed to be a propertized string. To prevent the function from -adding the 'help-key-binding' face, call 'substitute-command-keys' -with the new optional argument NO-FACE non-nil. - -Note that the new face will also be used in tooltips. When using the -GTK toolkit, this is only true if 'x-gtk-use-system-tooltips' is t. +** 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'). +++ -*** New user option 'help-enable-symbol-autoload'. -If non-nil, displaying help for an autoloaded function whose -'autoload' form provides no documentation string will try to load the -file it's from. This will give more extensive help for such -functions. - ---- -*** The 'help-for-help' ('C-h C-h') screen has been redesigned. +** 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 convenience commands with short keys in the Help buffer. -New command 'help-view-source' ('s') will view the source file (if -any) of the current help topic. New command 'help-goto-info' ('i') -will look up the current symbol (if any) in Info. New command -'help-customize' ('c') will customize the user option or the face -(if any) whose doc string is being shown in the Help buffer. +** New X resource: "borderThickness". +This controls the thickness of the external borders of the menu bars +and pop-up menus. --- -*** New user option 'describe-bindings-outline'. -It enables outlines in the output buffer of 'describe-bindings' that -can provide a better overview in a long list of available bindings. +** 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. -+++ -*** New commands to describe buttons and widgets. -'widget-describe' (on a widget) will pop up a help buffer and give a -description of the properties. Likewise 'button-describe' does the -same for a button. +** Terminal Emacs --- -*** Improved "find definition" feature of "*Help*" buffers. -Now clicking on the link to find the definition of functions generated -by 'cl-defstruct', or variables generated by 'define-derived-mode', -for example, will go to the exact place where they are defined. +*** Emacs will now use 24-bit colors on terminals that support "Tc" capability. +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 commands 'apropos-next-symbol' and 'apropos-previous-symbol'. -These new navigation commands are bound to 'n' and 'p' in -'apropos-mode'. - ---- -*** The command 'view-lossage' can now be invoked from the menu bar. -The menu bar "Help" menu now has a "Show Recent Inputs" item under the -"Describe" sub-menu. +** ERT +++ -*** New command 'lossage-size'. -It allows users to change the maximum number of keystrokes and -commands recorded for the purpose of 'view-lossage'. - ---- -*** Closing the "*Help*" buffer from the toolbar now buries the buffer. -In previous Emacs versions, the "*Help*" buffer was killed instead when -clicking the "X" icon in the tool bar. +*** 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. --- -*** 'g' ('revert-buffer') in 'help-mode' no longer requires confirmation. - -** File Locks +*** 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. +++ -*** New user option 'lock-file-name-transforms'. -This option allows controlling where lock files are written. It uses -the same syntax as 'auto-save-file-name-transforms'. +*** ERT can generate JUnit test reports. +When environment variable 'EMACS_TEST_JUNIT_REPORT' is set, ERT +generates a JUnit test report under this file name. This is useful +for Emacs integration into CI/CD test environments. -+++ -*** New user option 'remote-file-name-inhibit-locks'. -When non-nil, this option suppresses lock files for remote files. -Default is nil. - -+++ -*** New minor mode 'lock-file-mode'. -This command, called interactively, toggles the local value of -'create-lockfiles' in the current buffer. - -** Emacs Server +*** Unbound test symbols now signal an 'ert-test-unbound' error. +This affects the 'ert-select-tests' function and its callers. -+++ -*** New user option 'server-client-instructions'. -When emacsclient connects, Emacs will (by default) output a message -about how to exit the client frame. If 'server-client-instructions' -is set to nil, this message is inhibited. - -+++ -*** New command 'server-edit-abort'. -This command (not bound to any key by default) can be used to abort -an edit instead of marking it as "Done" (which the 'C-x #' command -does). The 'emacsclient' program exits with an abnormal status as -result of this command. +** Emoji +++ -*** New desktop integration for connecting to the server. -If your operating system’s desktop environment is -freedesktop.org-compatible (which is true of most GNU/Linux and other -recent Unix-like desktops), you may use the new "Emacs (Client)" -desktop menu entry to open files in an existing Emacs instance rather -than starting a new one. The daemon starts if it is not already -running. - -** Miscellaneous +*** Emacs now has several new methods for inserting Emojis. +The Emoji commands are under the new 'C-x 8 e' prefix. +++ -*** New command 'font-lock-update', bound to 'C-x x f'. -This command updates the syntax highlighting in this buffer. +*** New command 'emoji-insert' (bound to 'C-x 8 e e' and 'C-x 8 e i'). +This command guides you through various Emoji categories and +combinations in a graphical menu system. +++ -*** New command 'memory-report'. -This command opens a new buffer called "*Memory Report*" and gives a -summary of where Emacs is using memory currently. +*** New command 'emoji-search' (bound to 'C-x 8 e s'). +This command lets you search for Emojis based on names. +++ -*** New command 'submit-emacs-patch'. -This works like 'report-emacs-bug', but is more geared towards sending -patches to the Emacs issue tracker. +*** New command 'emoji-list' (bound to 'C-x 8 e l'). +This command lists all Emojis (categorized by themes) in a special +buffer and lets you choose one of them. --- -*** New face 'apropos-button'. -Applies to buttons that indicate a face. +*** New command 'emoji-recent' (bound to 'C-x 8 e r'). +This command lets you choose among the Emojis you have recently +inserted. +++ -*** New face 'font-lock-doc-markup-face'. -Intended for documentation mark-up syntax and tags inside text that -uses 'font-lock-doc-face', which it should appropriately stand out -against and harmonize with. It would typically be used in structured -documentation comments in program source code by language-specific -modes, for mark-up conventions like Haddock, Javadoc or Doxygen. By -default this face inherits from 'font-lock-constant-face'. +*** New command 'emoji-describe' (bound to 'C-x 8 e d'). +This command will tell you the name of the Emoji at point. (This +command also works for non-Emoji characters.) -+++ -*** New face box style 'flat-button'. -This is a plain 2D button, but uses the background color instead of -the foreground color. +** Help --- -*** New faces 'shortdoc-heading' and 'shortdoc-section'. -Applied to shortdoc headings and sections. +*** 'C-h b' uses outlining by default. +Set 'describe-bindings-outline' to nil to get the old behavior. --- -*** New face 'separator-line'. -This is used by 'make-separator-line' (see below). +*** Jumping to function/variable source now saves mark before moving point. +Jumping to source from "*Help*" buffer moves the point when the source +buffer is already open. Now, the old point is pushed to mark ring. +++ -*** 'redisplay-skip-fontification-on-input' helps Emacs keep up with fast input. -This is another attempt to solve the problem of handling high key repeat rate -and other "slow scrolling" situations. It is hoped it behaves better -than 'fast-but-imprecise-scrolling' and 'jit-lock-defer-time'. -It is not enabled by default. +*** New key bindings in "*Help*" buffers: 'n' and 'p'. +These will take you (respectively) to the next and previous "page". --- -*** Obsolete aliases are no longer hidden from command completion. -Completion of command names now considers obsolete aliases as -candidates, if they were marked obsolete in the current major version -of Emacs. Invoking a command via an obsolete alias now mentions the -obsolescence fact and shows the new name of the command. - -+++ -*** Support for '(box . SIZE)' 'cursor-type'. -By default, 'box' cursor always has a filled box shape. But if you -specify 'cursor-type' to be '(box . SIZE)', the cursor becomes a hollow -box if the point is on an image larger than SIZE pixels in any -dimension. - -+++ -*** The user can now customize how "default" values are prompted for. -The new utility function 'format-prompt' has been added which uses the -new 'minibuffer-default-prompt-format' user option to format "default" -prompts. This means that prompts that look like "Enter a number -(default 10)" can be customized to look like, for instance, "Enter a -number [10]", or not have the default displayed at all, like "Enter a -number". (This only affects callers that were altered to use -'format-prompt'.) - ---- -*** New help window when Emacs prompts before opening a large file. -Commands like 'find-file' or 'visit-tags-table' ask to visit a file -normally or literally when the file is larger than a certain size (by -default, 9.5 MiB). Press '?' or 'C-h' in that prompt to read more -about the different options to visit a file, how you can disable the -prompt, and how you can tweak the file size threshold. - -+++ -*** Emacs now defaults to UTF-8 instead of ISO-8859-1. -This is only for the default, where the user has set no 'LANG' (or -similar) variable or environment. This change should lead to no -user-visible changes for normal usage. +*** 'describe-char' now also outputs the name of emoji combinations. ---- -*** 'global-display-fill-column-indicator-mode' skips some buffers. -By default, turning on 'global-display-fill-column-indicator-mode' -doesn't turn on 'display-fill-column-indicator-mode' in special-mode -buffers. This can be controlled by customizing the user option -'global-display-fill-column-indicator-modes'. +** Outline Minor Mode +++ -*** 'nobreak-char-display' now also affects all non-ASCII space characters. -Previously, this was limited only to 'NO-BREAK SPACE' and hyphen -characters. Now it also covers the rest of the non-ASCII Unicode -space characters. Also, unlike in previous versions of Emacs, the -non-ASCII characters are displayed as themselves when -'nobreak-char-display' is t, i.e. they are not replaced on display -with the ASCII space and hyphen characters. +*** New user option 'outline-minor-mode-use-buttons'. +If non-nil, Outline Minor Mode will use buttons to hide/show outlines +in addition to the ellipsis. Default nil. --- -*** New backward compatibility variable 'nobreak-char-ascii-display'. -This variable is nil by default, and non-ASCII space and hyphen -characters are displayed as themselves, even if 'nobreak-char-display' -is non-nil. If 'nobreak-char-ascii-display' is set to a non-nil -value, the non-ASCII space and hyphen characters are instead displayed -as their ASCII counterparts: spaces and ASCII hyphen (a.k.a. "dash") -characters. This provides backward compatibility feature for the -change described above, where the non-ASCII characters are no longer -replaced with their ASCII counterparts when 'nobreak-char-display' is -t. You may need this on text-mode terminals that produce messed up -display when non-ASCII spaces and hyphens are written to the display. -(This variable is only effective when 'nobreak-char-display' is t.) +*** New user option 'outline-minor-mode-buttons'. +This is a list of pairs of open/close strings used to display buttons. +++ -*** Improved support for terminal emulators that encode the Meta flag. -Some terminal emulators set the 8th bit of Meta characters, and then -encode the resulting character code as if it were non-ASCII character -above codepoint 127. Previously, the only way of using these in Emacs -was to set up the terminal emulator to use the 'ESC' characters to send -Meta characters to Emacs, e.g., send "ESC x" when the user types -'M-x'. You can now avoid the need for this setup of such terminal -emulators by using the new input-meta-mode with the special value -'encoded' with these terminal emulators. +** Support for the WebP image format. +This support is built by default when the libwebp library is +available. To disable it, use the '--without-webp' configure flag. +Image specifiers can now use ':type webp'. ---- -*** 'auto-composition-mode' can now be selectively disabled on some TTYs. -Some text-mode terminals produce display glitches trying to compose -characters. The 'auto-composition-mode' can now have a string value -that names a terminal type; if the value returned by the 'tty-type' -function compares equal with that string, automatic composition will -be disabled in windows shown on that terminal. The Linux terminal -sets this up by default. - ---- -*** Support for the 'strike-through' face attribute on TTY frames. -If your terminal's termcap or terminfo database entry has the 'smxx' -capability defined, Emacs will now emit the prescribed escape -sequences necessary to render faces with the 'strike-through' -attribute on TTY frames. - ---- -*** TTY menu navigation is now supported in 'xterm-mouse-mode'. -TTY menus support mouse navigation and selection when 'xterm-mouse-mode' -is active. When run on a terminal, clicking on the menu bar with the -mouse now pops up a TTY menu by default instead of running the command -'tmm-menubar'. To restore the old behavior, set the user option -'tty-menu-open-use-tmm' to non-nil. - ---- -*** 'M-x report-emacs-bug' will no longer include "Recent messages" section. -These were taken from the "*Messages*" buffer, and may inadvertently -leak information from the reporting user. - ---- -*** 'C-u M-x dig' will now prompt for a query type to use. - ---- -*** Rudimentary support for the 'st' terminal emulator. -Emacs now supports 256 color display on the 'st' terminal emulator. +** Windows +++ -*** Update IRC-related references to point to Libera.Chat. -The Free Software Foundation and the GNU Project have moved their -official IRC channels from the Freenode network to Libera.Chat. For the -original announcement and the follow-up update, including more details, -see: +*** 'display-buffer' now can set up the body size of the chosen window. +For example, a 'display-buffer-alist' entry of -https://lists.gnu.org/archive/html/info-gnu/2021-06/msg00005.html -https://lists.gnu.org/archive/html/info-gnu/2021-06/msg00007.html - -Given the relocation of GNU and FSF's official IRC channels, as well -as #emacs and various other Emacs-themed channels (see the link below) -to Libera.Chat, IRC-related references in the Emacs repository have -now been updated to point to Libera.Chat. - -https://lists.gnu.org/archive/html/info-gnu-emacs/2021-06/msg00000.html - - -* Incompatible Editing Changes in Emacs 28.1 - ---- -** 'toggle-truncate-lines' now disables 'visual-line-mode'. -This is for symmetry with 'visual-line-mode', which disables -'truncate-lines'. - ---- -** 'electric-indent-mode' now also indents inside strings and comments. -(This only happens when indentation function also supports this.) - -To recover the previous behavior you can use: - - (add-hook 'electric-indent-functions - (lambda (_) (if (nth 8 (syntax-ppss)) 'no-indent))) - ---- -** The 'M-o' ('facemenu-keymap') global binding has been removed. -To restore the old binding, say something like: + '(window-width . (body-columns . 40))' - (require 'facemenu) - (define-key global-map "\M-o" 'facemenu-keymap) - (define-key facemenu-keymap "\es" 'center-line) - (define-key facemenu-keymap "\eS" 'center-paragraph) +will make the body of the chosen window 40 columns wide. For the +height use 'window-height' in combination with 'body-lines'. -The last two lines are not strictly necessary if you don't care about -having those two commands on the 'M-o' keymap; see the next section. - ---- -** The 'M-o M-s' and 'M-o M-S' global bindings have been removed. -Use 'M-x center-line' and 'M-x center-paragraph' instead. See the -previous section for how to get back the old bindings. Alternatively, -if you only want these two commands to have the global bindings they -had before, you can add the following to your init file: - - (define-key global-map "\M-o\M-s" 'center-line) - (define-key global-map "\M-o\M-S" 'center-paragraph) - ---- -** The 'M-o M-o' global binding has been removed. -Use 'M-x font-lock-fontify-block' instead, or the new 'C-x x f' -command, which updates the syntax highlighting in the current buffer. - ---- -** The escape sequence '\e[29~' in Xterm is now mapped to 'menu'. -Xterm sends this sequence for both 'F16' and 'Menu' keys -It used to be mapped to 'print' but we couldn't find a terminal -that uses this sequence for any kind of 'Print' key. -This makes the Menu key (see https://en.wikipedia.org/wiki/Menu_key) -work for 'context-menu-mode' in Xterm. - ---- -** New user option 'xterm-store-paste-on-kill-ring'. -If non-nil (the default), Emacs pushes pasted text onto the kill ring -(if using an xterm-like terminal that supports bracketed paste). -Setting this to nil inhibits that. +** Tab Bars and Tab Lines --- -** 'vc-print-branch-log' shows the change log from its root directory. -It previously used to use the default directory. +*** 'C-x t RET' creates a new tab when the provided tab name doesn't exist. --- -** 'project-shell' and 'shell' now use 'pop-to-buffer-same-window'. -This is to keep the same behavior as Eshell. +*** New keymap 'tab-bar-history-mode-map'. +By default, it contains 'C-c <left>' and 'C-c <right>' to browse +the history of tab window configurations back and forward. ---- -** In 'nroff-mode', 'center-line' is no longer bound to a key. -The original key binding was 'M-s', which interfered with I-search, -since the latter uses 'M-s' as a prefix key of the search prefix map. +** 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 +(started by directional formatting control characters such as RLO and +LRI). The new command 'highlight-confusing-reorderings' finds and +highlights segments of buffer text whose reordering for display is +suspicious and could be malicious. ---- -** In 'f90-mode', the backslash character ('\') no longer escapes. -For about a decade, the backslash character has no longer had a -special escape syntax in Fortran F90. To get the old behavior back, -say something like: - - (modify-syntax-entry ?\\ "\\" f90-mode-syntax-table) +** Emacs server and client changes +++ -** Setting 'fill-column' to nil is obsolete. -This undocumented use of 'fill-column' is now obsolete. To disable -auto filling, turn off 'auto-fill-mode' instead. - -For instance, you could add something like the following to your init -file: - - (add-hook 'foo-mode-hook (lambda () (auto-fill-mode -1)) - - -* Editing Changes in Emacs 28.1 - -** Input methods +*** New command-line option '-r' for emacsclient. +With this command-line option, Emacs reuses an existing graphical client +frame if one exists; otherwise it creates a new frame. +++ -*** Emacs now supports "transient" input methods. -A transient input method is enabled for inserting a single character, -and is then automatically disabled. 'C-x \' temporarily enables the -selected transient input method. Use 'C-u C-x \' to select a -transient input method (which can be different from the input method -enabled by 'C-\'). For example, 'C-u C-x \ compose RET' selects the -'compose' input method; then typing 'C-x \ 1 2' will insert the -character '½', and disable the 'compose' input method afterwards. -You can use 'C-x \' in incremental search to insert a single character -to the search string. +*** 'server-stop-automatically' can be used to automatically stop the server. +The Emacs server will be automatically stopped when certain conditions +are met. The conditions are given by the argument, which can be +'empty', 'delete-frame' or 'kill-terminal'. ---- -*** New input method 'compose' based on X Multi_key sequences. +* Editing Changes in Emacs 29.1 --- -*** New input method 'iso-transl' with the same keys as 'C-x 8'. -After selecting it as a transient input method with 'C-u C-x \ -iso-transl RET', it supports the same key sequences as 'C-x 8', -so e.g. like 'C-x 8 [' inserts a left single quotation mark, -'C-x \ [' does the same. +** Indentation of 'cl-flet' and 'cl-labels' has changed. +These forms now indent like this: ---- -*** New user option 'read-char-by-name-sort'. -It defines the sorting order of characters for completion of 'C-x 8 RET TAB' -and can be customized to sort them by codepoints instead of character names. -Additionally, you can group characters by Unicode blocks after customizing -'completions-group' and 'completions-group-sort'. + (cl-flet ((bla (x) + (* x x))) + (bla 42)) ---- -*** Improved language transliteration in Malayalam input methods. -Added a new Mozhi scheme. The inapplicable ITRANS scheme is now -deprecated. Errors in the Inscript method were corrected. - ---- -*** New input method 'cham'. -There's also a Cham greeting in "etc/HELLO". - ---- -*** New input methods for Lakota language orthographies. -Two orthographies are represented here, the Suggested Lakota -Orthography and what is known as the White Hat Orthography. Input -methods 'lakota-slo-prefix', 'lakota-slo-postfix', and -'lakota-white-hat-postfix' have been added. There is also a Lakota -greeting in "etc/HELLO". - -+++ -** Standalone 'M-y' allows interactive selection from previous kills. -'M-y' can now be typed after a command that is not a yank command. -When invoked like that, it prompts in the minibuffer for one of the -previous kills, offering completion and minibuffer-history navigation -through previous kills recorded in the kill ring. A similar feature -in Isearch can be invoked if you bind 'C-s M-y' to the command -'isearch-yank-pop'. When the user option 'yank-from-kill-ring-rotate' -is nil the kill ring is not rotated after 'yank-from-kill-ring'. +This change also affects 'cl-macrolet', 'cl-flet*' and +'cl-symbol-macrolet'. +++ -** New user option 'word-wrap-by-category'. -When word-wrap is enabled, and this option is non-nil, that allows -Emacs to break lines after more characters than just whitespace -characters. In particular, this significantly improves word-wrapping -for CJK text mixed with Latin text. +** New user option 'translate-upper-case-key-bindings'. +This can be set to nil to inhibit translating upper case keys to lower +case keys. +++ -** New command 'undo-redo'. -It undoes previous undo commands, but doesn't record itself as an -undoable command. It is bound to 'C-?' and 'C-M-_', the first binding -works well in graphical mode, and the second one is easy to hit on tty. - -For full conventional undo/redo behavior, you can also customize the -user option 'undo-no-redo' to t. - -+++ -** New commands 'copy-matching-lines' and 'kill-matching-lines'. -These commands are similar to the command 'flush-lines', -but add the matching lines to the kill ring as a single string, -including the newlines that separate the lines. - -+++ -** New user option 'kill-transform-function'. -This can be used to transform (and suppress) strings from entering the -kill ring. - -+++ -** 'save-interprogram-paste-before-kill' can now be a number. -In that case, it's interpreted as a limit on the size of the clipboard -data that will be saved to the 'kill-ring' prior to killing text: if -the size of the clipboard data is greater than or equal to the limit, -it will not be saved. - -+++ -** New user option 'tab-first-completion'. -If 'tab-always-indent' is 'complete', this new user option can be used to -further tweak whether to complete or indent. +** New command 'ensure-empty-lines'. +This command increases (or decreases) the number of empty lines before +point. --- -** 'indent-tabs-mode' is now a global minor mode instead of just a variable. - -+++ -** New choice 'permanent' for 'shift-select-mode'. -When the mark was activated by shifted motion keys, non-shifted motion -keys don't deactivate the mark after customizing 'shift-select-mode' -to 'permanent'. Similarly, the active mark will not be deactivated by -typing shifted motion keys. - -+++ -** The "Edit => Clear" menu item now obeys a rectangular region. - -+++ -** New command 'revert-buffer-with-fine-grain'. -Revert a buffer trying to be as non-destructive as possible, -preserving markers, properties and overlays. The new variable -'revert-buffer-with-fine-grain-max-seconds' specifies the maximum -number of seconds that 'revert-buffer-with-fine-grain' should spend -trying to be non-destructive, with a default value of 2 seconds. - -+++ -** New command 'revert-buffer-quick'. -This is bound to 'C-x x g' and is like 'revert-buffer', but prompts -less. +** Improved mouse behavior with auto-scrolling modes. +When clicking inside the 'scroll-margin' or 'hscroll-margin' region +the point is now moved only when releasing the mouse button. This no +longer results in a bogus selection, unless the mouse has been +effectively dragged. +++ -** New user option 'revert-buffer-quick-short-answers'. -This controls how the new 'revert-buffer-quick' ('C-x x g') command -prompts. A non-nil value will make it use 'y-or-n-p' rather than -'yes-or-no-p'. Defaults to nil. - -+++ -** New user option 'query-about-changed-file'. -If non-nil (the default), Emacs prompts as before when re-visiting a -file that has changed externally after it was visited the first time. -If nil, Emacs does not prompt, but instead shows the buffer with its -contents before the change, and provides instructions how to revert -the buffer. - ---- -** New value 'save-some-buffers-root' of 'save-some-buffers-default-predicate'. -When using this predicate, only buffers under the current project root -will be considered when saving buffers with 'save-some-buffers'. +** 'kill-ring-max' now defaults to 120. --- -** New user option 'save-place-abbreviate-file-names'. -This can simplify sharing the 'save-place-file' file across -different hosts. +** New user option 'yank-menu-max-items'. +Customize this option to limit the number of entries in the menu +"Edit->Paste from Kill Menu". The default is 60. ---- -** New user options 'copy-region-blink-delay' and 'delete-pair-blink-delay'. -'copy-region-blink-delay' specifies a delay to indicate the region -copied by 'kill-ring-save'. 'delete-pair-blink-delay' specifies -a delay to show the paired character to delete. +** Performing a pinch gesture on a touchpad now increases the text scale. ---- -** 'zap-up-to-char' now uses 'read-char-from-minibuffer'. -This allows navigating through the history of characters that have -been input. This is mostly useful for characters that have complex -input methods where inputting the character again may involve many -keystrokes. +** show-paren-mode +++ -** Input history for 'goto-line' can now be made local to every buffer. -In any event, line numbers used with 'goto-line' are kept in their own -history list. This should help make faster the process of finding -line numbers that were previously jumped to. By default, all buffers -share a single history list. To make every buffer have its own -history list, customize the user option 'goto-line-history-local'. +*** New user option 'show-paren-context-when-offscreen'. +When non-nil, if the point is in a closing delimiter and the opening +delimiter is offscreen, shows some context around the opening +delimiter in the echo area. Default nil. -+++ -** New command 'goto-line-relative' for use in a narrowed buffer. -It moves point to the line relative to the accessible portion of the -narrowed buffer. 'M-g M-g' in Info is rebound to this command. -When 'widen-automatically' is non-nil, 'goto-line' widens the narrowed -buffer to be able to move point to the inaccessible portion. -'goto-line-relative' is bound to 'C-x n g'. +** Comint +++ -** 'goto-char' prompts for the character position. -When called interactively, 'goto-char' now offers the position at -point as the default. +*** 'comint-term-environment' is now aware of connection-local variables. +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. -** Auto-saving via 'auto-save-visited-mode' can now be inhibited. -Set the variable 'auto-save-visited-mode' buffer-locally to nil to -achieve that. - -+++ -** New command 'kdb-macro-redisplay' to force redisplay in keyboard macros. -This command is bound to 'C-x C-k d'. +** Mwheel --- -** 'blink-cursor-mode' is now enabled by default regardless of the UI. -It used to be enabled when Emacs is started in GUI mode but not when started -in text mode. The cursor still only actually blinks in GUI frames. - -** 'show-paren-mode' is now enabled by default. -To go back to the previous behavior, customize the user option of the -same name to nil. - -+++ -** New minor mode 'show-paren-local-mode'. -It serves as a local counterpart for 'show-paren-mode', allowing you -to toggle it separately in different buffers. To use it only in -programming modes, for example, add the following to your init file: - - (add-hook 'prog-mode-hook #'show-paren-local-mode) +*** 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 28.1 +* Changes in Specialized Modes and Packages in Emacs 29.1 -** Isearch and Replace +** Minibuffer and Completions -+++ -*** Interactive regular expression search now uses faces for sub-groups. -E.g., 'C-M-s foo-\([0-9]+\)' will now use the 'isearch-group-1' face -on the part of the regexp that matches the sub-expression "[0-9]+". -By default, there are two faces for sub-group highlighting, but you -can define more faces whose names are of the form 'isearch-group-N', -where N are successive numbers above 2. +*** The *Completions* buffer can now be automatically selected. +To enable this behavior, customize the option 'completion-auto-select' +to t. Then pressing TAB will switch to the *Completions* buffer when +it pops up that buffer. -This is controlled by the 'search-highlight-submatches' user option. -This feature is available only on terminals that have enough colors to -distinguish between sub-expression highlighting. +*** New user option 'completion-wrap-movement'. +When non-nil, the commands 'next-completion' and 'previous-completion' +automatically wrap around on reaching the beginning or the end of +the *Completions* buffer. -+++ -*** Interactive regular expression replace now uses faces for sub-groups. -Like 'search-highlight-submatches', this is controlled by the new user option -'query-replace-highlight-submatches'. - -+++ -*** New key 'M-s M-.' starts isearch looking for the thing at point. -This key is bound to the new command 'isearch-forward-thing-at-point'. -The new user option 'isearch-forward-thing-at-point' defines -a list of symbols to try to get the "thing" at point. By default, -the first element of the list is 'region' that tries to yank -the currently active region to the search string. - -+++ -*** New user option 'isearch-wrap-pause' defines how to wrap the search. -There are choices to disable wrapping completely and to wrap immediately. -When wrapping immediately, it consistently handles the numeric arguments -of 'C-s' ('isearch-repeat-forward') and 'C-r' ('isearch-repeat-backward'), -continuing with the remaining count after wrapping. - -+++ -*** New user option 'isearch-repeat-on-direction-change'. -When this option is set, direction changes in Isearch move to another -search match, if there is one, instead of moving point to the other -end of the current match. - -+++ -*** New user option 'isearch-allow-motion'. -When 'isearch-allow-motion' is set, the commands 'beginning-of-buffer', -'end-of-buffer', 'scroll-up-command' and 'scroll-down-command', when -invoked during I-search, move respectively to the first occurrence of -the current search string in the buffer, the last one, the first one -after the current window, and the last one before the current window. -Additionally, users can change the meaning of other motion commands -during I-search by using their 'isearch-motion' property. The user -option 'isearch-motion-changes-direction' controls whether the -direction of the search changes after a motion command. - -+++ -*** New user option 'lazy-highlight-no-delay-length'. -Lazy highlighting of matches in Isearch now starts immediately if the -search string is at least this long. 'lazy-highlight-initial-delay' -still applies for shorter search strings, which avoids flicker in the -search buffer due to too many matches being highlighted. - -+++ -*** The default 'search-whitespace-regexp' value has changed. -This used to be "\\s-+", which meant that it was mode-dependent whether -newlines were included in the whitespace set. This has now been -changed to only match spaces and tab characters. - -** Dired - -+++ -*** New user option 'dired-kill-when-opening-new-dired-buffer'. -If non-nil, Dired will kill the current buffer when selecting a new -directory to display. - -+++ -*** Behavior change on 'dired-do-chmod'. -As a security precaution, Dired's M command no longer follows symbolic -links. Instead, it changes the symbolic link's own mode; this always -fails on platforms where such modes are immutable. - ---- -*** Behavior change on 'dired-clean-confirm-killing-deleted-buffers'. -Previously, if 'dired-clean-up-buffers-too' was non-nil, and -'dired-clean-confirm-killing-deleted-buffers' was nil, the buffers -wouldn't be killed. This combination will now kill the buffers. - -+++ -*** New user option 'dired-switches-in-mode-line'. -This user option controls how 'ls' switches are displayed in the mode -line, and allows truncating them (to preserve space on the mode line) -or showing them literally, either instead of, or in addition to, -displaying "by name" or "by date" sort order. - -+++ -*** New user option 'dired-compress-directory-default-suffix'. -This user option controls the default suffix for compressing a -directory. If it's nil, ".tar.gz" will be used. Refer to -'dired-compress-files-alist' for a list of supported suffixes. - -+++ -*** New user option 'dired-compress-file-default-suffix'. -This user option controls the default suffix for compressing files. -If it's nil, ".gz" will be used. Refer to 'dired-compress-file-alist' -for a list of supported suffixes. - ---- -*** Broken and circular links are shown with the 'dired-broken-symlink' face. - ---- -*** '=' ('dired-diff') will now put all backup files into the 'M-n' history. -When using '=' on a file with backup files, the default file to use -for diffing is the newest backup file. You can now use 'M-n' to quickly -select a different backup file instead. - -+++ -*** New user option 'dired-maybe-use-globstar'. -If set, enables globstar (recursive globbing) in shells that support -this feature, but have it turned off by default. This allows producing -directory listings with files matching a wildcard in all the -subdirectories of a given directory. The new variable -'dired-enable-globstar-in-shell' lists which shells can have globstar -enabled, and how to enable it. - -+++ -*** New user option 'dired-copy-dereference'. -If set to non-nil, Dired will dereference symbolic links when copying. -This can be switched off on a per-usage basis by providing -'dired-do-copy' with a 'C-u' prefix. - ---- -*** New user option 'dired-do-revert-buffer'. -Non-nil reverts the destination Dired buffer after performing one -of these operations: 'dired-do-copy', 'dired-do-rename', -'dired-do-symlink', 'dired-do-hardlink'. - ---- -*** New user option 'dired-mark-region'. -This option affects all Dired commands that mark files. When non-nil -and the region is active in Transient Mark mode, then Dired commands -operate only on files in the active region. The values 'file' and -'line' of this user option define the details of marking the file at -the end of the region. - -+++ -*** State changing VC operations are supported in Dired. -These operations are supported on files and directories via the new -command 'dired-vc-next-action'. - -+++ -*** 'dired-jump' and 'dired-jump-other-window' moved from 'dired-x' to 'dired'. -The 'dired-jump' and 'dired-jump-other-window' commands have been -moved from the 'dired-x' package to 'dired'. The user option -'dired-bind-jump' no longer has any effect and is now obsolete. -The commands are now bound to 'C-x C-j' and 'C-x 4 C-j' by default. - -To get the old behavior of 'dired-bind-jump' back and unbind the above -keys, add the following to your init file: - - (global-set-key "\C-x\C-j" nil) - (global-set-key "\C-x4\C-j" nil) - ---- -*** 'dired-query' now uses 'read-char-from-minibuffer'. -Using it instead of 'read-char-choice' allows using 'C-x o' -to switch to the help window displayed after typing 'C-h'. +** Isearch and Replace +++ -** Emacs 28.1 comes with Org v9.5. -See the file ORG-NEWS for user-visible changes in Org. +*** New user option 'char-fold-override' disables default character equivalences. -** Outline +** New minor mode 'glyphless-display-mode'. +This allows an easy way to toggle seeing all glyphless characters in +the current buffer. -+++ -*** New commands to cycle heading visibility. -Typing 'TAB' on a heading line cycles the current section between -"hide all", "subheadings", and "show all" states. Typing 'S-TAB' -anywhere in the buffer cycles the whole buffer between "only top-level -headings", "all headings and subheadings", and "show all" states. +** Registers +++ -*** New user option 'outline-minor-mode-cycle'. -This user option customizes 'outline-minor-mode', with the difference -that 'TAB' and 'S-TAB' on heading lines cycle heading visibility. -Typing 'TAB' on a heading line cycles the current section between -"hide all", "subheadings", and "show all" states. Typing 'S-TAB' on a -heading line cycles the whole buffer between "only top-level -headings", "all headings and subheadings", and "show all" states. - ---- -*** New user option 'outline-minor-mode-highlight'. -This user option customizes 'outline-minor-mode'. It puts -highlighting on heading lines using standard outline faces. This -works well only when there are no conflicts with faces used by the -major mode. +*** Buffer names can now be stored in registers. +For instance, to enable jumping to the "*Messages*" buffer with +'C-x r j m': -** Ispell + (set-register ?m '(buffer . "*Messages*")) -+++ -*** 'ispell-comments-and-strings' now accepts START and END arguments. -These arguments default to the active region when used interactively. +** pixel-fill +++ -*** New command 'ispell-comment-or-string-at-point'. - ---- -*** New user option 'ispell-help-timeout'. -This controls how long the ispell help (on the '?' key) is displayed. - -** Flyspell mode +*** This is a new package that deals with filling variable-pitch text. +++ -*** Corrections and actions menu can be optionally bound to 'mouse-3'. -When Flyspell mode highlights a word as misspelled, you can click on -it to display a menu of possible corrections and actions. You can now -easily bind this menu to 'down-mouse-3' (usually the right mouse button) -instead of 'mouse-2' (the default) by enabling 'context-menu-mode'. - ---- -*** The current dictionary is now displayed in the minor mode lighter. -Clicking the dictionary name changes the current dictionary. - -** Package - -*** The new NonGNU ELPA archive is enabled by default alongside GNU ELPA. -Thus, packages on NonGNU ELPA will appear by default in the list shown -by 'list-packages'. - ---- -*** '/ s' ('package-menu-filter-by-status') changed parameter handling. -The command was documented to take a comma-separated list of statuses -to filter by, but instead it used the parameter as a regexp. The -command has been changed so that it now works as documented, and -checks statuses not as a regexp, but instead an exact match from the -comma-separated list. - -+++ -*** New command 'package-browse-url' and keystroke 'w'. - -+++ -*** New commands to filter the package list. -The filter commands are bound to the following keys: - -key binding ---- ------- -/ a package-menu-filter-by-archive -/ d package-menu-filter-by-description -/ k package-menu-filter-by-keyword -/ N package-menu-filter-by-name-or-description -/ n package-menu-filter-by-name -/ s package-menu-filter-by-status -/ v package-menu-filter-by-version -/ m package-menu-filter-marked -/ u package-menu-filter-upgradable -/ / package-menu-filter-clear - -*** Option to automatically native-compile packages upon installation. -Customize the user option 'package-native-compile' to enable automatic -native compilation of packages when they are installed. That option -is nil by default; if set non-nil, and if your Emacs was built with -native-compilation support, each package will be natively compiled -when it is installed, by invoking an asynchronous Emacs subprocess to -run the native-compilation of the package files. (Be sure to leave -Emacs running until these asynchronous subprocesses exit, or else the -native-compilation will be aborted when you exit Emacs.) - ---- -*** Column widths in 'list-packages' display can now be customized. -See the new user options 'package-name-column-width', -'package-version-column-width', 'package-status-column-width', and -'package-archive-column-width'. +*** New function 'pixel-fill-region'. +This fills the region to be no wider than a specified pixel width. ** Info --- -*** New user option 'Info-warn-on-index-alternatives-wrap'. -This option affects what happens when using the ',' command after -looking up an entry with 'i' in info buffers. If non-nil (the -default), the ',' command will now display a warning when proceeding -beyond the final index match, and tapping ',' once more will then take -you to the first match. - -** Abbrev mode - -+++ -*** Emacs can now suggest to use an abbrev based on text you type. -A new user option, 'abbrev-suggest', enables the new abbrev suggestion -feature. When enabled, if a user manually types a piece of text that -could have saved enough typing by using an abbrev, a hint will be -displayed in the echo area, mentioning the abbrev that could have been -used instead. +*** New command 'Info-goto-node-web' and key binding 'G'. +This will take you to the gnu.org web server's version of the current +info node. This command only works for the Emacs and Emacs Lisp manuals. -** Bookmarks +** vc --- -*** Bookmarks can now be targets for new tabs. -When the bookmark.el library is loaded, a customize choice is added -to 'tab-bar-new-tab-choice' for new tabs to show the bookmark list. - ---- -*** New user option 'bookmark-set-fringe-mark'. -If non-nil, setting a bookmark will set a fringe mark on the current -line, and jumping to a bookmark will also set this mark. - ---- -*** New user option 'bookmark-menu-confirm-deletion'. -In Bookmark Menu mode, Emacs by default does not prompt for -confirmation when you type 'x' to execute the deletion of bookmarks -that have been marked for deletion. However, if this new option is -non-nil then Emacs will require confirmation with 'yes-or-no-p' before -deleting. - ---- -*** The 'list-bookmarks' menu is now based on 'tabulated-list-mode'. -The interactive bookmark list will now benefit from features in -'tabulated-list-mode' like sorting columns or changing column width. - -Support for the optional "inline" header line, allowing for a -header without using 'header-line-format', has been dropped. -The variables 'bookmark-bmenu-use-header-line' and -'bookmark-bmenu-inline-header-height' are now obsolete. - -** Recentf +*** 'C-x v v' on an unregistered file will now use the most specific backend. +Previously, if you had an SVN-covered "~/" directory, and a Git-covered +directory in "~/foo/bar", using 'C-x v v' on a new, unregistered file +"~/foo/bar/zot" would register it in the SVN repository in "~/" instead of +in the Git repository in "~/foo/bar". This makes this command +consistent with 'vc-responsible-backend'. ---- -*** The recentf files are no longer backed up. - ---- -*** 'recentf-auto-cleanup' now repeats daily when set to a time string. -When 'recentf-auto-cleanup' is set to a time string, it now repeats -every day, rather than only running once after the mode is turned on. - -** Calc - ---- -*** The behavior when doing forward-delete has been changed. -Previously, using the 'C-d' command would delete the final number in -the input field, no matter where point was. This has been changed to -work more traditionally, with 'C-d' deleting the next character. -Likewise, point isn't moved to the end of the string before inserting -digits. - -+++ -*** Setting the word size to zero disables word clipping. -The word size normally clips the results of certain bit-oriented -operations such as shifts and bitwise XOR. A word size of zero, set -by 'b w', makes the operation have effect on the whole argument values -and the result is not truncated in any way. - ---- -*** The '/' operator now has higher precedence in (La)TeX input mode. -It no longer has lower precedence than '+' and '-'. - ---- -*** New user option 'calc-make-windows-dedicated'. -When this user option is non-nil, Calc will mark its windows as -dedicated. - -** Calendar - -+++ -*** New user option 'calendar-time-zone-style'. -If 'numeric', calendar functions (eg 'calendar-sunrise-sunset') that display -time zones will use a form like "+0100" instead of "CET". - -** Imenu - -+++ -*** New user option 'imenu-max-index-time'. -If creating the imenu index takes longer than specified by this -option (default 5 seconds), imenu indexing is stopped. - -** ido - ---- -*** Switching on 'ido-mode' now also overrides 'ffap-file-finder'. - ---- -*** Killing virtual ido buffers interactively will make them go away. -Previously, killing a virtual ido buffer with 'ido-kill-buffer' didn't -do anything. This has now been changed, and killing virtual buffers -with that command will remove the buffer from recentf. - -** So Long - ---- -*** New 'so-long-predicate' function 'so-long-statistics-excessive-p'. -It efficiently detects the presence of a long line anywhere in the -buffer using 'buffer-line-statistics' (see above). This is now the -default predicate (replacing 'so-long-detected-long-line-p'). - ---- -*** Default values 'so-long-threshold' and 'so-long-max-lines' increased. -The values of these user options have been raised to 10000 bytes and 500 -lines respectively, to reduce the likelihood of false-positives when -'global-so-long-mode' is enabled. The latter value is now only used -by the old predicate, as the new predicate knows the longest line in -the entire buffer. - ---- -*** 'so-long-target-modes' now includes 'fundamental-mode' by default. -This means that 'global-so-long-mode' will also process files which were -not recognised. (This only has an effect if 'set-auto-mode' chooses -'fundamental-mode'; buffers which are simply in 'fundamental-mode' by -default are unaffected.) - ---- -*** New user options to preserve modes and variables. -The new options 'so-long-mode-preserved-minor-modes' and -'so-long-mode-preserved-variables' allow specified mode and variable -states to be maintained if 'so-long-mode' replaces the original major -mode. By default, these new options support 'view-mode'. - -** Grep - -+++ -*** New user option 'grep-match-regexp' matches grep markers to highlight. -Grep emits SGR ANSI escape sequences to color its output. The new -user option 'grep-match-regexp' holds the regular expression to match -the appropriate markers in order to provide highlighting in the source -buffer. The user option can be customized to accommodate other -grep-like tools. - ---- -*** The 'lgrep' command now ignores directories. -On systems where the grep command supports it, directories will be -skipped. - -*** Commands that use 'grep-find' now follow symlinks for command-line args. -This is because the default value of 'grep-find-template' now includes -the 'find' option '-H'. Commands that use that variable, including -indirectly via a call to 'xref-matches-in-directory', might be -affected. In particular, there should be no need anymore to ensure -any directory names on the 'find' command lines end in a slash. -This change is for better compatibility with old versions of non-GNU -'find', such as the one used on macOS. - ---- -*** New utility function 'grep-file-at-point'. -This returns the name of the file at point (if any) in 'grep-mode' -buffers. - -** Shell - ---- -*** New command in 'shell-mode': 'narrow-to-prompt'. -This is bound to 'C-x n d' in 'shell-mode' buffers, and narrows to the -command line under point (and any following output). - ---- -*** New user option 'shell-has-auto-cd'. -If non-nil, 'shell-mode' handles implicit "cd" commands, changing the -directory if the command is a directory. Useful for shells like "zsh" -that has this feature. - -** term-mode - ---- -*** New user option 'term-scroll-snap-to-bottom'. -By default, 'term' and 'ansi-term' will now recenter the buffer so -that the prompt is on the final line in the window. Setting this new -user option to nil inhibits this behavior. - ---- -*** New user option 'term-set-terminal-size' -If non-nil, the 'LINES' and 'COLUMNS' environment variables will be set -based on the current window size. In previous versions of Emacs, this -was always done (and that could lead to odd displays when resizing the -window after starting). This variable defaults to nil. - ---- -*** 'term-mode' now supports "bright" color codes. -"Bright" ANSI color codes are now displayed using the color values -defined in 'term-color-bright-*'. In addition, bold text with regular -ANSI colors can be displayed as "bright" if 'ansi-color-bold-is-bright' -is non-nil. - -** Eshell - ---- -*** 'eshell-hist-ignoredups' can now also be used to mimic "erasedups" in bash. - ---- -*** Environment variable 'INSIDE_EMACS' is now copied to subprocesses. -Its value contains the result of evaluating '(format "%s,eshell" -emacs-version)'. Other package names, like "tramp", could also be included. - ---- -*** Eshell no longer re-initializes its keymap every call. -This allows users to use (define-key eshell-mode-map ...) as usual. -Some modules have their own minor mode now to account for these -changes. - -*** Support for bookmark.el. -The command 'bookmark-set' (bound to 'C-x r m') is now supported, and -will create a bookmark that opens the current directory in Eshell. - -** Archive mode - ---- -*** Archive Mode can now parse ".squashfs" files. - -*** Can now modify members of 'ar' archives. - -*** Display of summaries is unified between backends. - -*** New user option and command to control displayed columns. -New user option 'archive-hidden-columns' and new command -'archive-hideshow-column' let you control which columns are displayed -and which are kept hidden. - ---- -*** New command bound to 'C': 'archive-copy-file'. -This command extracts the file at point and writes its data to a -file. - -** browse-url - -*** Added support for custom URL handlers. -There is a new variable 'browse-url-default-handlers' and a user -option 'browse-url-handlers' being alists with '(REGEXP-OR-PREDICATE -. FUNCTION)' entries allowing to define different browsing FUNCTIONs -depending on the URL to be browsed. The variable is for default -handlers provided by Emacs itself or external packages, the user -option is for the user (and allows for overriding the default -handlers). - -Formerly, one could do the same by setting -'browse-url-browser-function' to such an alist. This usage is still -supported but deprecated. - -*** Categorization of browsing commands into internal vs. external. -All standard browsing commands such as 'browse-url-firefox', -'browse-url-mail', or 'eww' have been categorized into internal (URL -is browsed in Emacs) or external (an external application is spawned -with the URL). This is done by adding a 'browse-url-browser-kind' -symbol property to the browsing commands. With a new command -'browse-url-with-browser-kind', an URL can explicitly be browsed with -either an internal or external browser. +** Message --- -*** Support for browsing of remote files. -If a remote file is specified, a local temporary copy of that file is -passed to the browser. +*** New user option 'mml-attach-file-at-the-end'. +If non-nil, 'C-c C-a' will put attached files at the end of the message. --- -*** Support for the conkeror browser is now obsolete. +*** Message Mode now supports image yanking. --- -*** Support for the Mosaic browser has been removed. -This support has been obsolete since 25.1. - -** Completion List Mode - -*** Improved navigation in the "*Completions*" buffer. -New key bindings have been added to 'completion-list-mode': 'n' and -'p' now navigate completions, and 'M-g M-c' switches to the -minibuffer and back to the completion list buffer. - -+++ -** profiler.el -The results displayed by 'profiler-report' now have the usage figures -at the left hand side followed by the function name. This is intended -to make better use of the horizontal space, in particular eliminating -the truncation of function names. There is no way to get the former -layout back. - -** Icomplete - ---- -*** New user option 'icomplete-matches-format'. -This allows controlling the current/total number of matches for the -prompt prefix. - -+++ -*** New minor modes 'icomplete-vertical-mode' and 'fido-vertical-mode'. -These modes modify Icomplete ('M-x icomplete-mode') and Fido ('M-x -fido-mode'), to display completion candidates vertically instead of -horizontally. In Icomplete, completions are rotated and selection -kept at the top. In Fido, completions scroll like a typical dropdown -widget. Both these new minor modes will turn on their non-vertical -counterparts first, if they are not on already. +*** New user option 'message-server-alist'. +This controls automatic insertion of the "X-Message-SMTP-Method" +header before sending a message. ---- -*** Default value of 'icomplete-compute-delay' has been changed to 0.15 s. +** HTML Mode --- -*** Default value of 'icomplete-max-delay-chars' has been changed to 2. +*** HTML Mode now supports "text/html" and "image/*" yanking. ---- -*** Reduced blinking while completing the next completions set. -Icomplete doesn't hide the hint with the previously computed -completions anymore when compute delay is in effect, or the previous -computation has been aborted by input. Instead it shows the previous -completions until the new ones are ready. +** Texinfo Mode --- -*** Change in meaning of 'icomplete-show-matches-on-no-input'. -Previously, choosing a different completion with commands like 'C-.' -and then hitting 'RET' would choose the default completion. Doing this -will now choose the completion under point instead. Also when this option -is nil, completions are not shown when the minibuffer reads a file name -with initial input as the default directory. +*** 'texinfo-mode' now has a specialised 'narrow-to-defun' definition. +It narrows to the current node. -** Windmove +** eww/shr +++ -*** New user options to customize windmove keybindings. -These options include 'windmove-default-keybindings', -'windmove-display-default-keybindings', -'windmove-delete-default-keybindings', -'windmove-swap-states-default-keybindings'. -Also new mode 'windmove-mode' enables the customized keybindings. - -** Occur mode - ---- -*** New bindings in occur-mode. -The command 'next-error-no-select' is now bound to 'n' and -'previous-error-no-select' is bound to 'p'. - ---- -*** New command 'recenter-current-error'. -It is bound to 'l' in Occur or compilation buffers, and recenters the -current displayed occurrence/error. - ---- -*** Matches in target buffers are now highlighted as in 'compilation-mode'. -The method of highlighting is specified by the user options -'next-error-highlight' and 'next-error-highlight-no-select'. - ---- -*** A fringe arrow in the "*Occur*" buffer indicates the selected match. - ---- -*** Occur mode may use a different type for 'occur-target' property values. -The value was previously always a marker set to the start of the first -match on the line but can now also be a list of '(BEGIN . END)' pairs -of markers delimiting each match on the line. -This is a fully compatible change to the internal occur-mode -implementation, and code creating their own occur-mode buffers will -work as before. - -** Emacs Lisp mode - ---- -*** The mode-line now indicates whether we're using lexical or dynamic scoping. +*** New user option 'shr-allowed-images'. +This complements 'shr-blocked-images', but allows specifying just the +allowed images. +++ -*** A space between an open paren and a symbol changes the indentation rule. -The presence of a space between an open paren and a symbol now is -taken as a statement by the programmer that this should be indented -as a data list rather than as a piece of code. - -** Lisp Mode - -*** New minor mode 'cl-font-lock-built-in-mode' for 'lisp-mode'. -The mode provides refined highlighting of built-in functions, types, -and variables. - ---- -*** Lisp mode now uses 'common-lisp-indent-function'. -To revert to the previous behavior, -'(setq lisp-indent-function 'lisp-indent-function)' from 'lisp-mode-hook'. - -** Change Logs and VC +*** New user option 'shr-use-xwidgets-for-media'. +If non-nil (and Emacs has been built with support for xwidgets), +display <video> elements with an xwidget. Note that this is +experimental, and is known to crash Emacs on some systems, and just +doesn't work on other systems. Also see etc/PROBLEMS. +++ -*** 'vc-revert-show-diff' now has a third possible value: 'kill'. -If this user option is 'kill', then the diff buffer will be killed -after the 'vc-revert' action instead of buried. - ---- -*** More VC commands can be used from non-file buffers. -The relevant commands are those that don't change the VC state. -The non-file buffers which can use VC commands are those that have -their 'default-directory' under VC. - ---- -*** New face 'log-view-commit-body'. -This is used when expanding commit messages from 'vc-print-root-log' -and similar commands. - ---- -*** New faces for 'vc-dir' buffers. -Those are: 'vc-dir-header', 'vc-dir-header-value', 'vc-dir-directory', -'vc-dir-file', 'vc-dir-mark-indicator', 'vc-dir-status-warning', -'vc-dir-status-edited', 'vc-dir-status-up-to-date', -'vc-dir-status-ignored'. - ---- -*** The responsible VC backend is now the most specific one. -'vc-responsible-backend' loops over the backends in -'vc-handled-backends' to determine which backend is responsible for a -specific (unregistered) file. Previously, the first matching backend -was chosen, but now the one with the most specific path is chosen (in -case there's a directory handled by one backend inside another). - ---- -*** New command 'vc-dir-root' uses the root directory without asking. - ---- -*** New commands 'vc-dir-mark-registered-files' (bound to '* r') and -'vc-dir-mark-unregistered-files'. - ---- -*** Support for bookmark.el. -Bookmark locations can refer to VC directory buffers. - ---- -*** New user option 'vc-hg-create-bookmark'. -It controls whether a bookmark or branch will be created when you -invoke 'C-u C-x v s' ('vc-create-tag'). - ---- -*** 'vc-hg' now uses 'hg summary' to populate extra 'vc-dir' headers. - ---- -*** New user option 'vc-git-revision-complete-only-branches'. -If non-nil, only branches and remotes are considered when doing -completion over Git branch names. The default is nil, which causes -tags to be considered as well. - ---- -*** New user option 'vc-git-log-switches'. -String or list of strings specifying switches for Git log under VC. - ---- -*** Command 'vc-switch-backend' is now obsolete. -If you are still using it with any regularity, please file a bug -report with some details. +*** New user option 'eww-url-transformers'. +These are used to alter an URL before using it. By default it removes +the common "utm_" trackers from URLs. ** Gnus -+++ -*** New user option 'gnus-topic-display-predicate'. -This can be used to inhibit the display of some topics completely. - -+++ -*** nnimap now supports the oauth2.el library. - -+++ -*** New Summary buffer sort options for extra headers. -The extra header sort option ('C-c C-s C-x') prompts for a header -and fails if no sort function has been defined. Sorting by -Newsgroups ('C-c C-s C-u') has been pre-defined. - -+++ -*** The '#' command in the Group and Summary buffer now toggles, -instead of sets, the process mark. - -+++ -*** New user option 'gnus-process-mark-toggle'. -If non-nil (the default), the '#' command in the Group and Summary -buffers will toggle, instead of set, the process mark. - -+++ -*** New user option 'gnus-registry-register-all'. -If non-nil (the default), create registry entries for all messages. -If nil, don't automatically create entries, they must be created -manually. - -+++ -*** New user options to customise the summary line specs "%[" and "%]". -Four new options introduced in customisation group -'gnus-summary-format'. These are 'gnus-sum-opening-bracket', -'gnus-sum-closing-bracket', 'gnus-sum-opening-bracket-adopted', and -'gnus-sum-closing-bracket-adopted'. Their default values are "[", "]", -"<", ">" respectively. These options control the appearance of "%[" -and "%]" specs in the summary line format. "%[" will normally display -the value of 'gnus-sum-opening-bracket', but can also be -'gnus-sum-opening-bracket-adopted' for the adopted articles. "%]" will -normally display the value of 'gnus-sum-closing-bracket', but can also -be 'gnus-sum-closing-bracket-adopted' for the adopted articles. - -+++ -*** New user option 'gnus-paging-select-next'. -This controls what happens when using commands like 'SPC' and 'DEL' to -page the current article. If non-nil (the default), go to the -next/prev article, but if nil, do nothing at the end/start of the article. - -+++ -*** New gnus-search library. -A new unified search syntax which can be used across multiple -supported search engines. Set 'gnus-search-use-parsed-queries' to -non-nil to enable. - -+++ -*** New value for user option 'smiley-style'. -Smileys can now be rendered with emojis instead of small images when -using the new 'emoji' value in 'smiley-style'. - -+++ -*** New user option 'gnus-agent-eagerly-store-articles'. -If non-nil (which is the default), the Gnus Agent will store all read -articles in the Agent cache. - -+++ -*** New user option 'gnus-global-groups'. -Gnus handles private groups differently from public (i.e., NNTP-like) -groups. Most importantly, Gnus doesn't download external images from -mail-like groups. This can be overridden by putting group names in -'gnus-global-groups': Any group present in that list will be treated -like a public group. - -+++ -*** New scoring types for the Date header. -You can now score based on the relative age of an article with the new -'<' and '>' date scoring types. - -+++ -*** User-defined scoring is now possible. -The new type is 'score-fn'. More information in the Gnus manual node -"(gnus) Score File Format". - -+++ -*** New backend 'nnselect'. -The newly added 'nnselect' backend allows creating groups from an -arbitrary list of articles that may come from multiple groups and -servers. These groups generally behave like any other group: they may -be ephemeral or persistent, and allow article marking, moving, -deletion, etc. 'nnselect' groups may be created like any other group, -but there are three convenience functions for the common case of -obtaining the list of articles as a result of a search: -'gnus-group-make-search-group' ('G g') that will prompt for an 'nnir' -search query and create a persistent group for that search; -'gnus-group-read-ephemeral-search-group' ('G G') that will prompt for -an 'nnir' search query and create an ephemeral group for that search; -and 'gnus-summary-make-group-from-search' ('C-c C-p') that will create -a persistent group with the search parameters of a current ephemeral -search group. - -As part of this addition, the user option 'nnir-summary-line-format' -has been removed; its functionality is now available directly in the -'gnus-summary-line-format' specs '%G' and '%g'. The user option -'gnus-refer-thread-use-nnir' has been renamed to -'gnus-refer-thread-use-search'. - -+++ -*** New user option 'gnus-dbus-close-on-sleep'. -On systems with D-Bus support, it is now possible to register a signal -to close all Gnus servers before the system sleeps. - -+++ -*** The key binding of 'gnus-summary-search-article-forward' has changed. -This command was previously on 'M-s' and shadowed the global 'M-s' -search prefix. The command has now been moved to 'M-s M-s'. (For -consistency, the 'M-s M-r' key binding has been added for the -'gnus-summary-search-article-backward' command.) - ---- -*** The value for "all" in the 'large-newsgroup-initial' group parameter has changed. -It was previously nil, which didn't work, because nil is -indistinguishable from not being present. The new value for "all" is -the symbol 'all'. - -+++ -*** The name of dependent Gnus sessions has changed from "slave" to "child". -The names of the commands 'gnus-slave', 'gnus-slave-no-server' and -'gnus-slave-unplugged' have changed to 'gnus-child', -'gnus-child-no-server' and 'gnus-child-unplugged' respectively. - -+++ -*** The 'W Q' summary mode command now takes a numerical prefix to -allow adjusting the fill width. - -+++ -*** New variable 'mm-inline-font-lock'. -This variable is supposed to be bound by callers to determine whether -inline MIME parts (that support it) are supposed to be font-locked or -not. - -** Message - ---- -*** Respect 'message-forward-ignored-headers' more. -Previously, this user option would not be consulted if -'message-forward-show-mml' was nil and forwarding as MIME. - -+++ -*** New user option 'message-forward-included-mime-headers'. -This is used when forwarding messages as MIME, but not using MML. - -+++ -*** Message now supports the OpenPGP header. -To generate these headers, add the new function -'message-add-openpgp-header' to 'message-send-hook'. The header will -be generated according to the new 'message-openpgp-header' user -option. - ---- -*** A change to how "Mail-Copies-To: never" is handled. -If a user has specified "Mail-Copies-To: never", and Message was asked -to do a "wide reply", some other arbitrary recipient would end up in -the resulting "To" header, while the remaining recipients would be put -in the "Cc" header. This is somewhat misleading, as it looks like -you're responding to a specific person in particular. This has been -changed so that all the recipients are put in the "To" header in these -instances. - -+++ -*** New command to start Emacs in Message mode to send an email. -Emacs can be defined as a handler for the "x-scheme-handler/mailto" -MIME type with the following command: "emacs -f message-mailto %u". -An "emacs-mail.desktop" file has been included, suitable for -installing in desktop directories like "/usr/share/applications" or -"~/.local/share/applications". -Clicking on a 'mailto:' link in other applications will then open -Emacs with headers filled out according to the link, e.g. -"mailto:larsi@gnus.org?subject=This+is+a+test". If you prefer -emacsclient, use "emacsclient -e '(message-mailto "%u")'" -or "emacsclient-mail.desktop". - ---- -*** Change to default value of 'message-draft-headers' user option. -The 'Date' symbol has been removed from the default value, meaning that -draft or delayed messages will get a date reflecting when the message -was sent. To restore the original behavior of dating a message -from when it is first saved or delayed, add the symbol 'Date' back to -this user option. - -+++ -*** New command to take screenshots. -In Message mode buffers, the 'C-c C-p' ('message-insert-screenshot') -command has been added. It depends on using an external program to -take the actual screenshot, and defaults to "ImageMagick import". - -** Smtpmail - -+++ -*** smtpmail now supports using the oauth2.el library. - -+++ -*** New user option 'smtpmail-store-queue-variables'. -If non-nil, SMTP variables will be stored together with the queued -messages, and will then be used when sending with -'M-x smtpmail-send-queued-mail'. - -+++ -*** Allow direct selection of smtp authentication mechanism. -A server entry retrieved by auth-source can request a desired smtp -authentication mechanism by setting a value for the key 'smtp-auth'. - -** ElDoc - -+++ -*** New user option 'eldoc-echo-area-display-truncation-message'. -If non-nil (the default), eldoc will display a message saying -something like "(Documentation truncated. Use `M-x eldoc-doc-buffer' -to see rest)" when a message has been truncated. If nil, truncated -messages will be marked with just "..." at the end. - -+++ -*** New hook 'eldoc-documentation-functions'. -This hook is intended to be used for registering doc string functions. -These functions don't need to produce the doc string right away, they -may arrange for it to be produced asynchronously. The results of all -doc string functions are accessible to the user through the user -option 'eldoc-documentation-strategy'. - -*** New hook 'eldoc-display-functions'. -This hook is intended to be used for displaying doc strings. The -functions receive the doc string composed according to -'eldoc-documentation-strategy' and are tasked with displaying it to -the user. Examples of such functions would use the echo area, a -separate buffer, or a tooltip. - -+++ -*** New user option 'eldoc-documentation-strategy'. -The built-in choices available for this user option let users compose -the results of 'eldoc-documentation-functions' in various ways, even -if some of those functions are synchronous and some asynchronous. -The user option replaces 'eldoc-documentation-function', which is now -obsolete. - -*** 'eldoc-echo-area-use-multiline-p' is now handled by ElDoc. -The user option 'eldoc-echo-area-use-multiline-p' is now handled -by the ElDoc library itself. Functions in -'eldoc-documentation-functions' don't need to worry about consulting -it when producing a doc string. - -** Tramp - -+++ -*** New connection method "mtp". -It allows accessing media devices like cell phones, tablets or -cameras. - -+++ -*** New connection method "sshfs". -It allows accessing remote files via a file system mounted with -'sshfs'. - -+++ -*** Tramp supports SSH authentication via a hardware security key now. -This requires at least OpenSSH 8.2, and a FIDO U2F compatible -security key, like yubikey, solokey, or nitrokey. - -+++ -*** Trashed remote files are moved to the local trash directory. -All remote files that are trashed are moved to the local trash -directory, except remote encrypted files, which are always deleted. - -+++ -*** New command 'tramp-crypt-add-directory'. -This command marks a remote directory to contain only encrypted files. -See the "(tramp) Keeping files encrypted" node of the Tramp manual for -details. This feature is experimental. - -+++ -*** Support of direct asynchronous process invocation. -When Tramp connection property "direct-async-process" is set to -non-nil for a given connection, 'make-process' and 'start-file-process' -calls are performed directly as in "ssh ... <command>". This avoids -initialization performance penalties. See the "(tramp) Improving -performance of asynchronous remote processes" node of the Tramp manual -for details, and also for a discussion or restrictions. This feature -is experimental. - -+++ -*** New user option 'tramp-debug-to-file'. -When non-nil, this user option instructs Tramp to mirror the debug -buffer to a file under the "/tmp/" directory. This is useful, if (in -rare cases) Tramp blocks Emacs, and we need further debug information. - -+++ -*** Tramp supports lock files now. -In order to deactivate this, set user option -'remote-file-name-inhibit-locks' to t. - -+++ -*** Writing sensitive data locally requires confirmation. -Writing auto-save, backup or lock files to the local temporary -directory must be confirmed. In order to suppress this confirmation, -set user option 'tramp-allow-unsafe-temporary-files' to t. - -+++ -*** 'make-directory' of a remote directory honors the default file modes. - -** gdb-mi - -*** New user option 'gdb-registers-enable-filter'. -If non-nil, apply a register filter based on -'gdb-registers-filter-pattern-list'. - -+++ -*** gdb-mi can now save and restore window configurations. -Use 'gdb-save-window-configuration' to save window configuration to a -file and 'gdb-load-window-configuration' to load from a file. These -commands can also be accessed through the menu bar under "Gud => -GDB-Windows". 'gdb-default-window-configuration-file', when non-nil, -is loaded when GDB starts up. - -+++ -*** gdb-mi can now restore window configuration after quitting. -Set 'gdb-restore-window-configuration-after-quit' to non-nil and Emacs -will remember the window configuration before GDB started and restore -it after GDB quits. A toggle button is also provided under "Gud => -GDB-Windows" menu item. - -+++ -*** gdb-mi now has a better logic for displaying source buffers. -Now GDB only uses one source window to display source file by default. -Customize 'gdb-max-source-window-count' to use more than one window. -Control source file display by 'gdb-display-source-buffer-action'. - -+++ -*** The default value of 'gdb-mi-decode-strings' is now t. -This means that the default coding-system is now used to decode strings -and source file names from GDB. - -** Compilation mode - ---- -*** New function 'ansi-color-compilation-filter'. -This function is meant to be used in 'compilation-filter-hook'. - ---- -*** New user option 'ansi-color-for-compilation-mode'. -This controls what 'ansi-color-compilation-filter' does. - -*** Regexp matching of messages is now case-sensitive by default. -The variable 'compilation-error-case-fold-search' can be set for -case-insensitive matching of messages when the old behavior is -required, but the recommended solution is to use a correctly matching -regexp instead. - ---- -*** New user option 'compilation-search-all-directories'. -When doing parallel builds, directories and compilation errors may -arrive in the "*compilation*" buffer out-of-order. If this option is -non-nil (the default), Emacs will now search backwards in the buffer -for any directory the file with errors may be in. If nil, this won't -be done (and this restores how this previously worked). - ---- -*** Messages from ShellCheck are now recognized. - ---- -*** Messages from Visual Studio that mention column numbers are now recognized. - -** Hi Lock mode - ---- -*** Matching in 'hi-lock-mode' can be case-sensitive. -The matching is case-sensitive when a regexp contains upper case -characters and 'search-upper-case' is non-nil. 'highlight-phrase' -also uses 'search-whitespace-regexp' to substitute spaces in regexp -search. - ---- -*** The default value of 'hi-lock-highlight-range' was enlarged. -The new default value is 2000000 (2 megabytes). - -** Whitespace mode - -+++ -*** New style 'missing-newline-at-eof'. -If present in 'whitespace-style' (as it is by default), the final -character in the buffer will be highlighted if the buffer doesn't end -with a newline. - ---- -*** The default 'whitespace-enable-predicate' predicate has changed. -It used to check elements in the list version of -'whitespace-global-modes' with 'eq', but now uses 'derived-mode-p'. - -** Texinfo - --- -*** New user option 'texinfo-texi2dvi-options'. -This is used when invoking 'texi2dvi' from 'texinfo-tex-buffer'. +*** Gnus now uses a variable-pitch font in the headers by default. +To get the monospace font back, you can put something like the +following in your .gnus file: ---- -*** New commands for moving in and between environments. -An "environment" is something that ends with '@end'. The commands are -'C-c C-c C-f' (next end), 'C-c C-c C-b' (previous end), -'C-c C-c C-n' (next start) and 'C-c C-c C-p' (previous start), as well -as 'C-c .', which will alternate between the start and the end of the -current environment. - -** Rmail + (set-face-attribute 'gnus-header nil :inherit 'unspecified) --- -*** New user option 'rmail-re-abbrevs'. -Its default value matches localized abbreviations of the "reply" -prefix on the Subject line in various languages. +*** The default value of 'gnus-treat-fold-headers' is now 'head'. --- -*** New user option 'rmail-show-message-set-modified'. -If set non-nil, showing an unseen message will set the Rmail buffer's -modified flag. The default is nil, to preserve the old behavior. - -** CC Mode +*** New face 'gnus-header'. +All other 'gnus-header-*' faces inherit from this face now. +++ -*** Added support for Doxygen documentation style. -'doxygen' is now a valid 'c-doc-comment-style' which recognises all -comment styles supported by Doxygen (namely '///', '//!', '/** … */' -and '/*! … */'. 'gtkdoc' remains the default for C and C++ modes; to -use 'doxygen' by default one might evaluate: - - (setq-default c-doc-comment-style - '((java-mode . javadoc) - (pike-mode . autodoc) - (c-mode . doxygen) - (c++-mode . doxygen))) - -or use it in a custom 'c-style'. +*** New user option 'gnus-treat-emojize-symbols'. +If non-nil, symbols that have an emoji representation will be +displayed as emojis. Default nil. +++ -*** Added support to line up '?' and ':' of a ternary operator. -The new 'c-lineup-ternary-bodies' function can be used as a lineup -function to align question mark and colon which are part of a ternary -operator ('?:'). For example: - - return arg % 2 == 0 ? arg / 2 - : (3 * arg + 1); - -To enable, add it to appropriate entries in 'c-offsets-alist', e.g.: +*** New command 'gnus-article-emojize-symbols'. +This is bound to 'W D e' and will display symbols that have emoji +representation as emojis. - (c-set-offset 'arglist-cont '(c-lineup-ternary-bodies - c-lineup-gcc-asm-reg)) - (c-set-offset 'arglist-cont-nonempty '(c-lineup-ternary-bodies - c-lineup-gcc-asm-reg - c-lineup-arglist)) - (c-set-offset 'statement-cont '(c-lineup-ternary-bodies +)) - -** Images - ---- -*** You can explicitly specify base_uri for svg images. -':base-uri' image property can be used to explicitly specify base_uri -for embedded images into svg. ':base-uri' is supported for both file -and data svg images. +** EIEIO +++ -*** 'svg-embed-base-uri-image' added to embed images. -'svg-embed-base-uri-image' can be used to embed images located -relatively to 'file-name-directory' of the ':base-uri' svg image property. -This works much faster than 'svg-embed'. +*** 'slot-value' can now be used to access slots of 'cl-defstruct' objects. -+++ -*** New function 'image-cache-size'. -This function returns the size of the current image cache, in bytes. +** align --- -*** Animated images stop automatically under high CPU pressure sooner. -Previously, an animated image would stop animating if any single image -took more than two seconds to display. The new algorithm maintains a -decaying average of delays, and if this number gets too high, the -animation is stopped. +*** Alignment in 'text-mode' has changed. +Previously, 'M-x align' didn't do anything, and you had to say 'C-u +M-x align' for it to work. This has now been changed. The default +regexp for 'C-u M-x align-regexp' has also been changed to be easier +for inexperienced users to use. -+++ -*** The 'n' and 'p' commands (next/previous image) now respect Dired order. -These commands would previously display the next/previous image in -lexicographic order, but will now find the "parent" Dired buffer and -select the next/previous image file according to how the files are -sorted there. The commands have also been extended to work when the -"parent" buffer is an archive mode (i.e., zip file or the like) or tar -mode buffer. - ---- -*** 'image-converter' is now restricted to formats in 'auto-mode-alist'. -When using external image converters, the external program is queried -for what formats it supports. This list may contain formats that are -problematic in some contexts (like PDFs), so this list is now filtered -based on 'auto-mode-alist'. Only file names that map to 'image-mode' -are now supported. - ---- -*** The background and foreground of images now default to face colors. -When an image doesn't specify a foreground or background color, Emacs -now uses colors from the face used to draw the surrounding text -instead of the frame's default colors. - -To load images with the default frame colors use the ':foreground' and -':background' image attributes, for example: - - (create-image "filename" nil nil - :foreground (face-attribute 'default :foreground) - :background (face-attribute 'default :background)) - -This change only affects image types that support foreground and -background colors or transparency, such as xbm, pbm, svg, png and gif. - -+++ -*** Image smoothing can now be explicitly enabled or disabled. -Smoothing applies a bilinear filter while scaling or rotating an image -to prevent aliasing and other unwanted effects. The new image -property ':transform-smoothing' can be set to t to force smoothing -and nil to disable smoothing. - -The default behavior of smoothing on down-scaling and not smoothing -on up-scaling remains unchanged. - -+++ -*** New user option 'image-transform-smoothing'. -This controls whether to use smoothing or not for an image. Values -include nil (no smoothing), t (do smoothing) or a predicate function -that's called with the image object and should return nil/t. +** eww +++ -*** SVG images now support user stylesheets. -The ':css' image attribute can be used to override the default CSS -stylesheet for an image. The default sets 'font-family' and -'font-size' to match the current face, so an image with 'height="1em"' -will match the font size in use where it is embedded. +*** New user option to automatically rename EWW buffers. +The 'eww-auto-rename-buffer' user option can be configured to rename +rendered web pages by using their title, URL, or a user-defined +function which returns a string. For the first two cases, the length +of the resulting name is controlled by 'eww-buffer-name-length'. By +default, no automatic renaming is performed. -This feature relies on librsvg 2.48 or above being available. - -+++ -*** Image properties support 'em' sizes. -Size image properties, for example ':height', ':max-height', etc., can -be given a cons of the form '(SIZE . em)', where SIZE is an integer or -float which is multiplied by the font size to calculate the image -size, and 'em' is a symbol. - -** EWW - -+++ -*** New user option 'eww-use-browse-url'. -This is a regexp that can be set to alter how links are followed in eww. - -+++ -*** New user option 'eww-retrieve-command'. -This can be used to download data via an external command. If nil -(the default), then 'url-retrieve' is used. When 'sync', then -'url-retrieve-synchronously' is used. A list of strings specifies -an external program with parameters. - -+++ -*** New Emacs command line convenience command. -The 'eww-browse' command has been added, which allows you to register -Emacs as a MIME handler for "text/x-uri", and will call 'eww' on the -supplied URL. Usage example: "emacs -f eww-browse https://gnu.org". +** Help -+++ -*** 'eww-download-directory' will now use the XDG location, if defined. -However, if "~/Downloads/" already exists, that will continue to be -used. +*** New user option 'help-link-key-to-documentation'. +When this option is non-nil (which is the default), key bindings +displayed in the "*Help*" buffer will be linked to the documentation +for the command they are bound to. This does not affect listings of +key bindings and functions (such as 'C-h b'). ---- -*** The command 'eww-follow-link' now supports custom mailto: handlers. -The function that is invoked when clicking on or otherwise following a -'mailto:' link in an EWW buffer can now be customized. For more -information, see the related entry about 'shr-browse-url' below. +** info-look --- -*** Support for bookmark.el. -The command 'bookmark-set' (bound to 'C-x r m') is now supported, and -will create a bookmark that opens the current URL in EWW. +*** info-look specs can now be expanded at run time instead of a load time. +The new ':doc-spec-function' element can be used to compute the +':doc-spec' element when the user asks for info on that particular +mode (instead of at load time). -** SHR - ---- -*** The command 'shr-browse-url' now supports custom mailto handlers. -Clicking on or otherwise following a 'mailto:' link in an HTML buffer -rendered by SHR previously invoked the command 'browse-url-mailto'. -This is still the case by default, but if you customize -'browse-url-mailto-function' or 'browse-url-handlers' to call some -other function, it will now be called instead of the default. - ---- -*** New user option 'shr-offer-extend-specpdl'. -If this is nil, rendering of HTML that requires enlarging -'max-specpdl-size', the number of Lisp variable bindings, will be -aborted, and Emacs will not ask you whether to enlarge -'max-specpdl-size' to complete the rendering. The default is t, which -preserves the original behavior. +** subr-x +++ -*** New user option 'shr-max-width'. -If this user option is non-nil, and 'shr-width' is nil, then SHR will -use the value of 'shr-max-width' to limit the width of the rendered -HTML. The default is 120 characters, so even if you have very wide -frames, HTML text will be rendered more narrowly, which usually leads -to a more readable text. Customize it to nil to get the previous -behavior of rendering as wide as the 'window-width' allows. If -'shr-width' is non-nil, it overrides this option. +*** New macro 'with-memoization' provides a very primitive form of memoization. ---- -*** New faces for heading elements. -Those are 'shr-h1', 'shr-h2', 'shr-h3', 'shr-h4', 'shr-h5', 'shr-h6'. - -** Project - ---- -*** New user option 'project-vc-merge-submodules'. +** ansi-color --- -*** Project commands now have their own history. -Previously used project directories are now suggested by all commands -that prompt for a project directory. - -+++ -*** New prefix keymap 'project-prefix-map'. -Key sequences that invoke project-related commands start with the -prefix 'C-x p'. Type 'C-x p C-h' to show the full list. - -+++ -*** New commands 'project-dired', 'project-vc-dir', 'project-shell', -'project-eshell'. These commands run Dired/VC-Dir and Shell/Eshell in -a project's root directory, respectively. - -+++ -*** New command 'project-compile'. -This command runs compilation in the current project's root directory. - -+++ -*** New command 'project-switch-project'. -This command lets you "switch" to another project and run a project -command chosen from a dispatch menu. - -+++ -*** New commands 'project-shell-command' and 'project-async-shell-command'. -These commands run 'shell-command' and 'async-shell-command' in a -project's root directory, respectively. - -+++ -*** New user option 'project-list-file'. -This specifies the file in which to save the list of known projects. - -+++ -*** New command 'project-remember-projects-under'. -This command can automatically locate and index projects in a -directory and optionally also its subdirectories, storing them in -'project-list-file'. +*** Support for ANSI 256-color and 24-bit colors. +256-color and 24-bit color codes are now handled by ANSI color +filters and displayed with the specified color. -+++ -*** New commands 'project-forget-project' and 'project-forget-projects-under'. -These commands let you interactively remove entries from the list of projects -in 'project-list-file'. - -+++ -*** New command 'project-forget-zombie-projects'. -This command detects indexed projects that have since been deleted, -and removes them from the list of known projects in 'project-list-file'. +** term-mode --- -*** 'project-find-file' now accepts non-existent file names. -This is to allow easy creation of files inside some nested -sub-directory. - -+++ -*** 'project-find-file' doesn't use the string at point as default input. -Now it's only suggested as part of the "future history", accessible -via 'M-n'. - -+++ -*** New command 'project-find-dir' runs Dired in a directory inside project. +*** Support for ANSI 256-color and 24-bit colors, italic and other fonts. +Term-mode can now display 256-color and 24-bit color codes. It can +also handle ANSI codes for faint, italic and blinking text, displaying +it with new 'term-{faint,italic,slow-blink,fast-blink}' faces. ** Xref -+++ -*** New user options to automatically show the first Xref match. -The new user option 'xref-auto-jump-to-first-definition' controls the -behavior of 'xref-find-definitions' and its variants, like -'xref-find-definitions-other-window': if it's t or 'show', the first -match is automatically displayed; if it's 'move', point in the -"*xref*" buffer is automatically moved to the first match without -displaying it. -The new user option 'xref-auto-jump-to-first-xref' changes the -behavior of Xref commands such as 'xref-find-references', -'xref-find-apropos', and 'project-find-regexp', which are expected to -display many matches that the user would like to -visit. 'xref-auto-jump-to-first-xref' changes their behavior much in -the same way as 'xref-auto-jump-to-first-definition' affects the -"find-definitions" commands. +*** 'project-find-file' and 'project-or-external-find-file' now accept +a prefix argument which is interpreted to mean "include all files". ---- -*** New user options 'xref-search-program' and 'xref-search-program-alist'. -So far 'grep' and 'ripgrep' are supported. 'ripgrep' seems to offer better -performance in certain cases, in particular for case-insensitive -searches. +*** 'project-kill-buffers' can display the list of buffers to kill. +Customize the user option 'project-kill-buffers-display-buffer-list' +to enable the display of the buffer list. +++ -*** New commands 'xref-prev-group' and 'xref-next-group'. -These commands are bound respectively to 'P' and 'N', and navigate to -the first item of the previous or next group in the "*xref*" buffer. - ---- -*** New alternative value for 'xref-show-definitions-function': -'xref-show-definitions-completing-read'. +*** New command 'xref-go-forward'. +It is bound to 'C-M-,' and jumps to the location where 'xref-go-back' +('M-,', also known as 'xref-pop-marker-stack') was invoked previously. ---- -*** The two existing alternatives for 'xref-show-definitions-function' -have been renamed to have "proper" public names and documented -('xref-show-definitions-buffer' and -'xref-show-definitions-buffer-at-bottom'). +** File notifications +++ -*** New command 'xref-quit-and-pop-marker-stack'. -This command is bound to 'M-,' in "*xref*" buffers. This combination -is easy to press semi-accidentally if the user wants to go back in the -middle of choosing the exact definition to go to, and this should do -TRT. +*** The new command 'file-notify-rm-all-watches' removes all file notifications. ---- -*** New value 'project-relative' for 'xref-file-name-display'. -If chosen, file names in "*xref*" buffers will be displayed relative -to the 'project-root' of the current project, when available. +** Sql --- -*** Prefix arg of 'xref-goto-xref' quits the "*xref*" buffer. -So typing 'C-u RET' in the "*xref*" buffer quits its window -before navigating to the selected location. - -+++ -*** The 'TAB' key binding in "*xref*" buffers is obsolete. -Use 'C-u RET' instead. The 'TAB' binding in "*xref*" buffers is still -supported, but we plan on removing it in a future version; at that -time, the command 'xref-quit-and-goto-xref' will no longer have a key -binding in 'xref--xref-buffer-mode-map'. +*** Sql now supports sending of passwords in-process. +To improve security, if an sql product has ':password-in-comint' set +to t, a password supplied via the minibuffer will be sent in-process, +as opposed to via the command-line. ---- -*** New user option 'etags-xref-prefer-current-file'. -When non-nil, matches for identifiers in the file visited by the -current buffer will be shown first in the "*xref*" buffer. +** Image Mode +++ -*** The etags Xref backend now honors 'tags-apropos-additional-actions'. -You can customize it to augment the output of 'xref-find-apropos', -like it affected the output of 'tags-apropos', which is obsolete since -Emacs 25.1. - -** Battery - ---- -*** UPower is now the default battery status backend when available. -UPower support via the function 'battery-upower' was added in Emacs -26.1, but was disabled by default. It is now the default value of -'battery-status-function' when the system provides a UPower D-Bus -service. The user options 'battery-upower-device' and -'battery-upower-subscribe' control which power sources to query and -whether to respond to status change notifications in addition to -polling, respectively. - ---- -*** A richer syntax can be used to format battery status information. -The user options 'battery-mode-line-format' and -'battery-echo-area-format' now support the full formatting syntax of -the function 'format-spec' documented under node "(elisp) Custom Format -Strings". The new syntax includes specifiers for padding and -truncation, amongst other things. - -** bug-reference.el - ---- -*** Bug reference mode uses auto-setup. -If 'bug-reference-mode' or 'bug-reference-prog-mode' have been -activated, their respective hook has been run, and both -'bug-reference-bug-regexp' and 'bug-reference-url-format' are still -not set, it tries to guess appropriate values for those two variables. -There are three guessing mechanisms so far: based on version control -information of the current buffer's file, based on -newsgroup/mail-folder name and several news and mail message headers -in Gnus buffers, and based on IRC channel and network in rcirc and ERC -buffers. All the mechanisms are extensible with custom rules, see the -variables 'bug-reference-setup-from-vc-alist', -'bug-reference-setup-from-mail-alist', and -'bug-reference-setup-from-irc-alist'. - -** HTML Mode - ---- -*** A new skeleton for adding relative URLs has been added. -It's bound to the 'C-c C-c f' keystroke, and prompts for a local file -name. - -** Widget +*** New command 'image-transform-fit-to-window'. +This command fits the image to the current window by scaling down or +up as necessary. Unlike 'image-transform-fit-both', this does not +only scale the image down, but up as well. It is bound to "s w" in +Image Mode by default. +++ -*** 'widget-choose' now supports menus in extended format. - ---- -*** The 'editable-list' widget now supports moving items up and down. -You can now move items up and down by deleting and then reinserting -them, using the 'DEL' and 'INS' buttons respectively. This is useful -in Custom buffers, for example, to change the order of the elements in -a list. - -** Diff - ---- -*** New face 'diff-changed-unspecified'. -This is used to highlight "changed" lines (those marked with '!') in -context diffs, when 'diff-use-changed-face' is non-nil. +*** 'image-transform-fit-to-(height|width)' are now obsolete. +Use the new command 'image-transform-fit-to-window' instead. +The keybinding for 'image-transform-fit-to-width' is now 's i'. --- -*** New 'diff-mode' font locking face 'diff-error'. -This face is used for error messages from 'diff'. - -+++ -*** New command 'diff-refresh-hunk'. -This new command (bound to 'C-c C-l') regenerates the current hunk. - -** thing-at-point - -+++ -*** New 'thing-at-point' target: 'existing-filename'. -This is like 'filename', but is a full path, and is nil if the file -doesn't exist. - -+++ -*** New 'thing-at-point' target: 'string'. -If point is inside a string, it returns that string. - -+++ -*** New variable 'thing-at-point-provider-alist'. -This allows mode-specific alterations to how 'thing-at-point' works. +*** User option 'image-auto-resize' can now be set to 'fit-window'. +This works like 'image-transform-fit-to-window'. ---- -*** thing-at-point now respects fields. -'thing-at-point' (and all functions that use it, like -'symbol-at-point') will narrow to the current field (if any) before -trying to identify the thing at point. +*** 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, which means no limit. --- -*** New function 'thing-at-mouse'. -This is like 'thing-at-point', but uses the mouse event position instead. +*** New user option 'image-text-based-formats'. +This controls whether or not to show a message when opening certain +image formats saying how to edit it as text. The default is to show +this message for SVG and XPM. ** Image-Dired +++ -*** New user option 'image-dired-thumb-visible-marks'. -If non-nil (the default), use the new face 'image-dired-thumb-mark' -for marked images. +*** 'image-dired-display-image-mode' is now based on 'image-mode'. +This avoids converting images in the background, and makes Image-Dired +noticeably faster. New keybindings from 'image-mode' are now +available in the "*image-dired-display-image*" buffer; press '?' or +'h' in that buffer to see the full list. Finally, some commands and +user options that are no longer needed are now obsolete: +'image-dired-cmd-create-temp-image-options', +'image-dired-cmd-create-temp-image-program', +'image-dired-display-current-image-full', +'image-dired-display-current-image-sized', +'image-dired-display-window-height-correction', +'image-dired-display-window-width-correction', +'image-dired-temp-image-file'. --- -*** New command 'image-dired-delete-marked'. - ---- -*** 'image-dired-mouse-toggle-mark' is now sensitive to the active region. -If the region is active, this command now toggles Dired marks of all -the thumbnails in the region. - -** Flymake mode - -+++ -*** New command 'flymake-show-project-diagnostics'. -This lists all diagnostics for buffers in the currently active -project. The listing is similar to the one obtained by -'flymake-show-buffer-diagnostics', but adds a column for the -project-relative file name. For backends which support it, -'flymake-show-project-diagnostics' also lists diagnostics for files -that have not yet been visited. - -+++ -*** New user options to customize Flymake's mode-line. -The new user option 'flymake-mode-line-format' is a mix of strings and -symbols like 'flymake-mode-line-title', 'flymake-mode-line-exception' -and 'flymake-mode-line-counters'. The new user option -'flymake-mode-line-counter-format' is a mix of strings and symbols -like 'flymake-mode-line-error-counter', -'flymake-mode-line-warning-counter' and 'flymake-mode-line-note-counter'. +*** Navigation and marking commands now work in image display buffer. +The following new bindings have been added: -** Time + n / SPC image-dired-display-next-thumbnail-original + p / DEL image-dired-display-previous-thumbnail-original + m image-dired-mark-thumb-original-file + d image-dired-flag-thumb-original-file + u image-dired-unmark-thumb-original-file --- -*** 'display-time-world' has been renamed to 'world-clock'. -'world-clock' creates a buffer with an updating time display using -several time zones. It is hoped that the new names are more -discoverable. - -The following commands have been renamed: - - 'display-time-world' to 'world-clock' - 'display-time-world-mode' to 'world-clock-mode' - 'display-time-world-display' to 'world-clock-display' - 'display-time-world-timer' to 'world-clock-update' - -The following user options have been renamed: - - 'display-time-world-list' to 'world-clock-list' - 'display-time-world-time-format' to 'world-clock-time-format' - 'display-time-world-buffer-name' to 'world-clock-buffer-name' - 'display-time-world-timer-enable' to 'world-clock-timer-enable' - 'display-time-world-timer-second' to 'world-clock-timer-second' - -The old names are now obsolete. +*** Reduce dependency on external "exiftool" command. +The 'image-dired-copy-with-exif-file-name' no longer requires an +external "exiftool" command to be available. The user options +'image-dired-cmd-read-exif-data-program' and +'image-dired-cmd-read-exif-data-options' are now obsolete. --- -*** 'world-clock-mode' can no longer be turned on interactively. -Use 'world-clock' to turn on that mode. - -** Python mode +*** New command for the thumbnail buffer. +The new command 'image-dired-unmark-all-marks' has been added. It is +bound to 'U' in the thumbnail and display buffer. --- -*** New user option 'python-forward-sexp-function'. -This allows the user easier customization of whether to use block-based -navigation or not. +*** Support Thumbnail Managing Standard v0.9.0 (Dec 2020). +This standard allows sharing generated thumbnails across different +programs. Version 0.9.0 adds two larger thumbnail sizes: 512x512 and +1024x1024 pixels. See the user option 'image-dired-thumbnail-storage' +to use it; it is not enabled by default. --- -*** 'python-shell-interpreter' now defaults to python3 on systems with python3. +*** Support GraphicsMagick command line tools. +Support for the GraphicsMagick command line tool ("gm") has been +added, and is used instead of ImageMagick when it is available. --- -*** 'C-c C-r' can now be used on arbitrary regions. -The command previously extended the start of the region to the start -of the line, but will now actually send the marked region, as -documented. - -** Ruby Mode +*** New face 'image-dired-thumb-flagged'. +If 'image-dired-thumb-mark' is non-nil (the default), this face is +used for images that are flagged for deletion in the Dired buffer +associated with Image-Dired. --- -*** 'ruby-use-smie' is declared obsolete. -SMIE is now always enabled and 'ruby-use-smie' only controls whether -indentation is done using SMIE or with the old ad-hoc code. +*** 'image-dired-slideshow-start' is now bound to 'S'. +It is bound in both the thumbnail and display buffer. --- -*** Indentation has changed when 'ruby-align-chained-calls' is non-nil. -This previously used to align subsequent lines with the last sibling, -but it now aligns with the first sibling (which is the preferred style -in Ruby). - -** CPerl Mode +*** The 'image-dired-slideshow-start' command no longer prompts. +It no longer inconveniently prompts for a number of images and a +delay: it runs indefinitely, but stops automatically on any command. +You can set the delay with a prefix argument, or a negative prefix +argument to prompt for a delay. Customize the user option +'image-dired-slideshow-delay' to change the default from 5 seconds. --- -*** New face 'perl-heredoc', used for heredoc elements. +*** Support for bookmark.el. +The command 'bookmark-set' (bound to 'C-x r m') is now supported in +the thumbnail view, and will create a bookmark that opens the current +directory in Image-Dired. --- -*** The command 'cperl-set-style' offers the new value "PBP". -This value customizes Emacs to use the style recommended in Damian -Conway's book "Perl Best Practices" for indentation and formatting -of conditionals. - -** Perl mode +*** New user option 'image-dired-marking-shows-next'. +If this option is non-nil (the default), marking, unmarking or +flagging an image in either the thumbnail or display buffer shows the +next image. --- -*** New face 'perl-non-scalar-variable'. -This is used to fontify non-scalar variables. - -** Octave Mode - -+++ -*** Line continuations in double-quoted strings now use a backslash. -Typing 'C-M-j' (bound to 'octave-indent-new-comment-line') now follows -the behavior introduced in Octave 3.8 of using a backslash as a line -continuation marker within double-quoted strings, and an ellipsis -everywhere else. - -+++ -** EasyPG -GPG key servers can now be queried for keys with the -'M-x epa-search-keys' command. Keys can then be added to your -personal key ring. - -** Etags - -+++ -*** Etags now supports the Mercury programming language. -See https://mercurylang.org. - -+++ -*** Etags command line option '--declarations' now has Mercury-specific behavior. -All Mercury declarations are tagged by default. However, for -compatibility with 'etags' support for Prolog, predicates and -functions appearing first in clauses will also be tagged if 'etags' is -invoked with the '--declarations' command-line option. - -** Comint +*** Image information is now shown in the header line. +This replaces the message most navigation commands in the thumbnail +buffer used to show at the bottom of the screen. +++ -*** Support for OSC escape sequences. -Adding the new 'comint-osc-process-output' to -'comint-output-filter-functions' enables the interpretation of OSC -("Operating System Command") escape sequences in comint buffers. By -default, only OSC 8, for hyperlinks, and OSC 7, for directory -tracking, are acted upon. Adding more entries to -'comint-osc-handlers' allows a customized treatment of further escape -sequences. - -+++ -*** 'comint-delete-output' can now save deleted text in the kill-ring. -Interactively, 'C-u C-c C-o' triggers this new optional behavior. - -** ansi-color.el - ---- -*** Colors are now defined by faces. -ANSI SGR codes now have corresponding faces to describe their -appearance, e.g. 'ansi-color-bold'. +*** 'image-dired-show-all-from-dir-max-files' has been increased to 500. +This option controls asking for confirmation when starting Image-Dired +in a directory with many files. However, Image-Dired creates +thumbnails in the background these days, so this is not as important +as it used to be, back when entering a large directory could lock up +Emacs for tens of seconds. In addition, you can now customize this +option to nil to disable this confirmation completely. --- -*** Support for "bright" color codes. -"Bright" ANSI color codes are now displayed when applying ANSI color -filters using the color values defined by the faces -'ansi-color-bright-COLOR'. In addition, bold text with regular ANSI -colors can be displayed as "bright" if 'ansi-color-bold-is-bright' is -non-nil. - -** ERC - -*** Starting with Emacs 28.1 and ERC 5.4, see the ERC-NEWS file for -user-visible changes in ERC. +*** Make 'image-dired-rotate-thumbnail-(left|right)' obsolete. +Instead, use 'M-x image-dired-refresh-thumb' to generate a new +thumbnail, or 'M-x image-rotate' to rotate the thumbnail without +updating the thumbnail file. -** xwidget-webkit mode - ---- -*** New xwidget commands. -'xwidget-webkit-uri' (return the current URL), 'xwidget-webkit-title' -(return the current title), and 'xwidget-webkit-goto-history' (goto a -point in history). - ---- -*** Downloading files from xwidget-webkit is now supported. -The new user option 'xwidget-webkit-download-dir' says where to download to. - ---- -*** New command 'xwidget-webkit-clone-and-split-below'. -Open a new window below displaying the current URL. - ---- -*** New command 'xwidget-webkit-clone-and-split-right'. -Open a new window to the right displaying the current URL. - ---- -*** Pixel-based scrolling. -The 'xwidget-webkit-scroll-up', 'xwidget-webkit-scroll-down' commands -now supports scrolling arbitrary pixel values. It now treats the -optional 2nd argument as the pixel values to scroll. - ---- -*** New commands for scrolling. -The new commands 'xwidget-webkit-scroll-up-line', -'xwidget-webkit-scroll-down-line', 'xwidget-webkit-scroll-forward', -'xwidget-webkit-scroll-backward' can be used to scroll webkit by the -height of lines or width of chars. - ---- -*** New user option 'xwidget-webkit-bookmark-jump-new-session'. -When non-nil, use a new xwidget webkit session after bookmark jump. -Otherwise, it will use 'xwidget-webkit-last-session'. - -** Checkdoc - ---- -*** No longer warns about command substitutions by default. -Checkdoc used to warn about "too many command substitutions" (as in -"\\[foo-command]"), even if you only used ten of them in a docstring. -On modern machines, you can have hundreds or thousands of command -substitutions before it becomes a performance issue, so this warning -is now disabled by default. To re-enable this warning, customize the -user option 'checkdoc-max-keyref-before-warn'. - ---- -*** New user option 'checkdoc-column-zero-backslash-before-paren'. -Checkdoc warns if there is a left parenthesis in column zero of a -documentation string. That warning can now be disabled by customizing -this new user option to nil. This is useful if you don't expect -your code to be edited with an Emacs older than version 27.1. - ---- -*** Now checks the prompt format for 'yes-or-no-p'. -In addition to verifying the format of the prompt for 'y-or-n-p', -checkdoc will now check the format of 'yes-or-no-p'. - ---- -*** New command 'checkdoc-dired'. -This can be used to run checkdoc on files from a Dired buffer. +** Dired -*** No longer checks for 'A-' modifiers. -Checkdoc recommends usage of command substitutions ("\\[foo-command]") -in favor of writing keybindings like 'C-c f'. It now no longer warns -about the 'A-' modifier as it is not used very much in practice, and -this warning therefore mostly led to false positives. +*** New user option 'dired-free-space'. +Dired will now, by default, include the free space in the first line +instead of having it on a separate line. To get the previous behavior +back, say: -** Enriched mode + (setq dired-free-space 'separate) --- -*** 'C-a' is by default no longer bound to 'beginning-of-line-text'. -This is so 'C-a' works as in other modes, and in particular holding -Shift while typing 'C-a', i.e. 'C-S-a', will now highlight the text. - -** Gravatar - ---- -*** New user option 'gravatar-service' for host to query for gravatars. -Defaults to 'libravatar', with 'unicornify' and 'gravatar' as options. - -** MH-E mail handler for Emacs - -Functions and variables related to handling junk mail have been -renamed to not associate color with sender quality. - -+++ -*** New names for mh-junk interactive functions. -Function 'mh-junk-whitelist' is renamed 'mh-junk-allowlist'. -Function 'mh-junk-blacklist' is renamed 'mh-junk-blocklist'. - -+++ -*** New binding for 'mh-junk-allowlist'. -The key binding for 'mh-junk-allowlist' is changed from 'J w' to 'J a'. -The old binding is supported but warns that it is obsolete. +*** New user option 'dired-make-directory-clickable'. +If non-nil (which is the default), hitting 'RET' or 'mouse-1' on +the directory components at the directory displayed at the start of +the buffer will take you to that directory. -+++ -*** New names for some hooks. -'mh-whitelist-msg-hook' is renamed 'mh-allowlist-msg-hook'. -'mh-blacklist-msg-hook' is renamed 'mh-blocklist-msg-hook'. +** Exif -+++ -*** New names for some user options. -User option 'mh-whitelist-preserves-sequences-flag' is renamed -'mh-allowlist-preserves-sequences-flag'. - -+++ -*** New names for some faces. -Face 'mh-folder-blacklisted' is renamed 'mh-folder-blocklisted'. -Face 'mh-folder-whitelisted' is renamed 'mh-folder-allowlisted'. +*** New function 'exif-field'. +This is a convenience function to extract the field data from +'exif-parse-file' and 'exif-parse-buffer'. -** Rcirc - -+++ -*** rcirc now supports SASL authentication. - ---- -*** #emacs on Libera.chat has been added to 'rcirc-server-alist'. +** Xwidgets --- -*** rcirc connects asynchronously. +*** New user option 'xwidget-webkit-buffer-name-format'. +Using this option you can control how the xwidget-webkit buffers are +named. --- -*** Integrate formatting into 'rcirc-send-string'. -The function now accepts a variable number of arguments. +*** 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. +++ -*** Deprecate 'rcirc-command' in favor of 'rcirc-define-command'. -The new macro handles multiple and optional arguments. - ---- -*** Add basic IRCv3 support. -This includes support for the capabilities: 'server-time', 'batch', -'message-ids', 'invite-notify', 'multi-prefix' and 'standard-replies'. - ---- -*** Add mouse property support to 'rcirc-track-minor-mode'. - ---- -*** Improve support for IRC markup codes. - ---- -*** Check 'auth-sources' for server passwords. +*** New minor mode 'xwidget-webkit-edit-mode'. +When this mode is enabled, self-inserting characters and other common +web browser shortcut keys are redefined to send themselves to the +WebKit widget. +++ -*** Implement repeated reconnection strategy. -See 'rcirc-reconnect-attempts'. - -** MPC - ---- -*** New command 'mpc-goto-playing-song'. -This command, bound to 'o' in any 'mpc-mode' buffer, moves point to -the currently playing song in the "*MPC-Songs*" buffer. - ---- -*** New user option 'mpc-cover-image-re'. -If non-nil, it is a regexp that should match a valid cover image. - -** Miscellaneous - ---- -*** 'shell-script-mode' now supports 'outline-minor-mode'. -The outline headings have lines that start with "###". - ---- -*** fileloop will now skip missing files instead of signalling an error. - ---- -*** 'tabulated-list-mode' can now restore original display order. -Many commands (like 'C-x C-b') are derived from 'tabulated-list-mode', -and that mode allows the user to sort on any column. There was -previously no easy way to get back to the original displayed order -after sorting, but giving a -1 numerical prefix to the sorting command -will now restore the original order. - ---- -*** 'M-left' and 'M-right' now move between columns in 'tabulated-list-mode'. - ---- -*** New variable 'hl-line-overlay-priority'. -This can be used to change the priority of the hl-line overlays. +*** New minor mode 'xwidget-webkit-isearch-mode'. +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 'mailcap-view-file'. -This command will open a viewer based on the file type, as determined -by "~/.mailcap" and related files and variables. - ---- -*** New user option 'remember-diary-regexp'. - ---- -*** New user option 'remember-text-format-function'. - ---- -*** New user option 'authinfo-hide-elements'. -This can be set to nil to inhibit hiding passwords in ".authinfo" files. - ---- -*** 'hexl-mode' scrolling commands now heed 'next-screen-context-lines'. -Previously, 'hexl-scroll-down' and 'hexl-scroll-up' would scroll -up/down an entire window, but they now work more like the standard -scrolling commands. - ---- -*** New user option 'bibtex-unify-case-function'. -This new option allows the user to customize how case is converted -when unifying entries. +*** 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. --- -*** The user option 'bibtex-maintain-sorted-entries' now permits -user-defined sorting schemes. +*** On X11, the WebKit inspector is now available inside xwidgets. +To access the inspector, right click on the widget and select "Inspect +Element". --- -*** New user option 'reveal-auto-hide'. -If non-nil (the default), revealed text is automatically hidden when -point leaves the text. If nil, the text is not hidden again. Instead -'M-x reveal-hide-revealed' can be used to hide all the revealed text. +*** "Open in New Window" in a WebKit widget's context menu now works. +The newly created buffer will be displayed via 'display-buffer', which +can be customized through the usual mechanism of 'display-buffer-alist' +and friends. ---- -*** New user option 'ffap-file-name-with-spaces'. -If non-nil, 'find-file-at-point' and friends will try to guess more -expansively to identify a file name with spaces. Default value is -nil. - ---- -*** Two new commands for centering in 'doc-view-mode'. -The new commands 'doc-view-center-page-horizontally' (bound to 'c h') -and 'doc-view-center-page-vertically' (bound to 'c v') center the page -horizontally and vertically, respectively. - ---- -*** 'tempo-define-template' can now re-assign templates to tags. -Previously, assigning a new template to an already defined tag had no -effect. +** Tramp --- -*** The width of the buffer-name column in 'list-buffers' is now dynamic. -The width now depends on the width of the window, but will never be -wider than the length of the longest buffer name, except that it will -never be narrower than 19 characters. - -+++ -*** New diary sexp 'diary-offset'. -It offsets another diary sexp by a number of days. This is useful -when for example your organization has a committee meeting two days -after every monthly meeting which takes place on the third Thursday, -or if you would like to attend a virtual meeting scheduled in a -different timezone causing a difference in the date. +*** 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:~". ---- -*** The old non-SMIE indentation of 'sh-mode' has been removed. +** Browse URL --- -*** 'mspools-show' is now autoloaded. +*** Support for the Netscape web browser has been removed. +This support has been obsolete since Emacs 25.1. The final version of +the Netscape web browser was released in February, 2008. --- -*** Loading dunnet.el in batch mode doesn't start the game any more. -Instead you need to do "emacs -f dun-batch" to start the game in -batch mode. +*** Support for the Galeon web browser has been removed. +This support has been obsolete since Emacs 25.1. The final version of +the Galeon web browser was released in September, 2008. -* New Modes and Packages in Emacs 28.1 +* New Modes and Packages in Emacs 29.1 +++ -** New mode 'repeat-mode' to allow shorter key sequences. -Type 'M-x repeat-mode' to enable this mode. You can then type -'C-x u u' instead of 'C-x u C-x u' to undo many changes, 'C-x o o' -instead of 'C-x o C-x o' to switch windows, 'C-x { { } } ^ ^ v v' to -resize the selected window interactively, 'M-g n n p p' to navigate -next-error matches. Any other key exits this temporarily enabled -transient mode that supports shorter keys, and then after exiting from -this mode, the last typed key uses the default key binding. - -The user option 'repeat-exit-key' defines an additional key usable to -exit the mode like 'isearch-exit' ('RET'). - -The user option 'repeat-exit-timeout' (default nil, which means -forever) specifies the number of seconds of idle time after which to -break the repetition chain automatically. - -When user option 'repeat-keep-prefix' is non-nil, the prefix arg of -the previous command is kept. This can be used to e.g. reverse the -window navigation direction with 'C-x o M-- o o' or to set a new step -with 'C-x { C-5 { { {', which will set the window resizing step to 5 -columns. - -'M-x describe-repeat-maps' will display a buffer showing -which commands are repeatable in 'repeat-mode'. - ---- -** New themes 'modus-vivendi' and 'modus-operandi'. -These themes are designed to conform with the highest standard for -color-contrast accessibility (WCAG AAA). You can load either of them -using 'M-x customize-themes' or 'load-theme' from your init file. -Consult the Modus Themes Info manual for more information on the user -options they provide. - -** Dictionary mode -This is a mode for searching a RFC 2229 dictionary server. -'dictionary' opens a buffer for starting operations. -'dictionary-search' performs a lookup for a word. It also supports a -'dictionary-tooltip-mode' which performs a lookup of the word under -the mouse in 'dictionary-tooltip-dictionary' (which must be customized -first). - ---- -** Lisp Data mode -The new command 'lisp-data-mode' enables a major mode for buffers -composed of Lisp symbolic expressions that do not form a computer -program. The ".dir-locals.el" file is automatically set to use this -mode, as are other data files produced by Emacs. - -+++ -** New global mode 'global-goto-address-mode'. -This will enable 'goto-address-mode' in all buffers. - -** transient.el -This library implements support for powerful keyboard-driven menus. -Such menus can be used as simple visual command dispatchers. More -complex menus take advantage of infix arguments, which are somewhat -similar to prefix arguments, but are more flexible and discoverable. - -** hierarchy.el -This library can create, query, navigate and display hierarchical -structures. - ---- -** New major mode for displaying the "etc/AUTHORS" file. -This new 'etc-authors-mode' provides font-locking for displaying the -"etc/AUTHORS" file from the Emacs distribution, and not much else. +** New mode 'erts-mode'. +This mode is used to edit files geared towards testing actions in +Emacs buffers, like indentation and the like. The new ert function +'ert-test-erts-file' is used to parse these files. -* Incompatible Lisp Changes in Emacs 28.1 - -+++ -** Emacs now prints a backtrace when signaling an error in batch mode. -This makes debugging Emacs Lisp scripts run in batch mode easier. To -get back the old behavior, set the new variable -'backtrace-on-error-noninteractive' to a nil value. - ---- -** Some floating-point numbers are now handled differently by the Lisp reader. -In previous versions of Emacs, numbers with a trailing dot and an exponent -were read as integers and the exponent ignored: 2.e6 was interpreted as the -integer 2. Such numerals are now read as floats with the exponent included: -2.e6 is now read as the floating-point value 2000000.0. -That is, '(read-from-string "1.e3")' => '(1000.0 . 4)' now. - ---- -** 'equal' no longer examines some contents of window configurations. -Instead, it considers window configurations to be equal only if they -are 'eq'. To compare contents, use 'compare-window-configurations' -instead. This change helps fix a bug in 'sxhash-equal', which returned -incorrect hashes for window configurations and some other objects. - -+++ -** The 'lexical-binding' local variable is always enabled. -Previously, if 'enable-local-variables' was nil, a 'lexical-binding' -local variable would not be heeded. This has now changed, and a file -with a 'lexical-binding' cookie is always heeded. To revert to the -old behavior, set 'permanently-enabled-local-variables' to nil. - -+++ -** '&rest' in argument lists must always be followed by a variable name. -Omitting the variable name after '&rest' was previously tolerated in -some cases but not consistently so; it could lead to crashes or -outright wrong results. Since the utility was marginal at best, it is -now an error to omit the variable. - ---- -** 'kill-all-local-variables' has changed how it handles non-symbol hooks. -The function is documented to eliminate all buffer-local bindings -except variables with a 'permanent-local' property, or hooks that -have elements with a 'permanent-local-hook' property. In addition, it -would also keep lambda expressions in hooks sometimes. The latter has -now been changed: The function will now also remove these. - -+++ -** Temporary buffers no longer run certain buffer hooks. -The macros 'with-temp-buffer' and 'with-temp-file' no longer run the -hooks 'kill-buffer-hook', 'kill-buffer-query-functions', and -'buffer-list-update-hook' for the temporary buffers they create. This -avoids slowing them down when a lot of these hooks are defined. - -+++ -** New face 'child-frame-border' and frame parameter 'child-frame-border-width'. -The face and width of child frames borders can now be determined -separately from those of normal frames. To minimize backward -incompatibility, child frames without a 'child-frame-border-width' -parameter will fall back to using 'internal-border-width'. However, -the new 'child-frame-border' face does constitute a breaking change -since child frames' borders no longer use the 'internal-border' face. - ---- -** 'run-at-time' now tries harder to implement the t TIME parameter. -If TIME is t, the timer runs at an integral multiple of REPEAT. -(I.e., if given a REPEAT of 60, it'll run at 08:11:00, 08:12:00, -08:13:00.) However, when a machine goes to sleep (or otherwise didn't -get a time slot to run when the timer was scheduled), the timer would -then fire every 60 seconds after the time the timer was fired. This -has now changed, and the timer code now recomputes the integral -multiple every time it runs, which means that if the laptop wakes at -08:16:43, it'll fire at that time, but then at 08:17:00, 08:18:00... - ---- -** 'parse-partial-sexp' now signals an error if TO is smaller than FROM. -Previously, this would lead to the function interpreting FROM as TO and -vice versa, which would be confusing when passing in OLDSTATE, which -refers to the old state at FROM. - -+++ -** 'global-mode-string' constructs should end with a space. -This was previously not formalized, which led to combinations of modes -displaying data "smushed together" on the mode line. - -+++ -** 'overlays-in' now handles zero-length overlays slightly differently. -Previously, zero-length overlays at the end of the buffer were included -in the result (if the region queried for stopped at that position). -The same was not the case if the buffer had been narrowed to exclude -the real end of the buffer. This has now been changed, and -zero-length overlays at 'point-max' are always included in the results. - ---- -** 'replace-match' now runs modification hooks slightly later. -The function is documented to leave point after the replacement text, -but this was not always the case if a modification hook inserted text -in front of the replaced text -- 'replace-match' would instead leave -point where the end of the inserted text would have been before the -hook ran. 'replace-match' now always leaves point after the -replacement text. - -+++ -** 'completing-read-default' sets completion variables buffer-locally. -'minibuffer-completion-table' and related variables are now set buffer-locally -in the minibuffer instead of being set via a global let-binding. - ---- -** XML serialization functions now reject invalid characters. -Previously, 'xml-print' would produce invalid XML when given a string -with characters that are not valid in XML (see -https://www.w3.org/TR/xml/#charsets). Now it rejects such strings. - ---- -** JSON - ---- -*** JSON number parsing is now stricter. -Numbers with a leading plus sign, leading zeros, or a missing integer -component are now rejected by 'json-read' and friends. This makes -them more compliant with the JSON specification and consistent with -the native JSON parsing functions. +* Incompatible Lisp Changes in Emacs 29.1 ---- -*** JSON functions support the semantics of RFC 8259. -The JSON functions 'json-serialize', 'json-insert', -'json-parse-string', and 'json-parse-buffer' now implement some of the -semantics of RFC 8259 instead of the earlier RFC 4627. In particular, -these functions now accept top-level JSON values that are neither -arrays nor objects. +** User option 'mail-source-ignore-errors' is now obsolete. +The whole mechanism for prompting users to continue in case of +mail-source errors has been removed, so this option is no longer +needed. ---- -*** Some JSON encoding functions are now obsolete. -The functions 'json-encode-number', 'json-encode-hash-table', -'json-encode-key', and 'json-encode-list' are now obsolete. - -The first two are kept as aliases of 'json-encode', which should be -used instead. Uses of 'json-encode-list' should be changed to call -one of 'json-encode', 'json-encode-alist', 'json-encode-plist', or -'json-encode-array' instead. - -+++ -*** Native JSON functions now signal an error if libjansson is unavailable. -This affects 'json-serialize', 'json-insert', 'json-parse-string', -and 'json-parse-buffer'. This can happen if Emacs was compiled with -libjansson, but the DLL cannot be found and/or loaded by Emacs at run -time. Previously, Emacs would display a message and return nil in -these cases. - -+++ -** The use of positional arguments in 'define-minor-mode' is obsolete. -These were actually rendered obsolete in Emacs 21 but were never -marked as such. +** Fonts --- -** 'pcomplete-ignore-case' is now an obsolete alias of 'completion-ignore-case'. - -+++ -** 'completions-annotations' face is not used when the caller puts own face. -This affects the suffix specified by completion 'annotation-function'. +*** Emacs now supports 'medium' fonts. +Emacs previously didn't distinguish between the 'regular'/'normal' +weight and the 'medium' weight, but it now also supports the (heavier) +'medium' weight. However, this means that if you previously specified +a weight of 'normal' and the font doesn't have this weight, Emacs +won't find the font spec. In these cases, replacing ":weight 'normal" +with ":weight 'medium" should fix the issue. -+++ -** An active minibuffer now has major mode 'minibuffer-mode'. -This is instead of the erroneous 'minibuffer-inactive-mode' it -formerly had. +** Keymap descriptions have changed. +'help--describe-command', 'C-h b' and associated functions that output +keymap descriptions have changed. In particular, prefix commands are +not output at all, and instead of "??" for closures/functions, +"[closure]"/"[lambda]" is output. --- -** 'make-text-button' no longer modifies text properties of its first argument. -When its first argument is a string, 'make-text-button' no longer -modifies the string's text properties; instead, it uses and returns -a copy of the string. This helps avoid trouble when strings are -shared or constants. - -+++ -** Some properties from completion tables are now preserved. -If 'minibuffer-allow-text-properties' is non-nil, doing completion -over a table of strings with properties will no longer remove all the -properties before returning. This affects things like 'completing-read'. +** 'downcase' details have changed slightly. +In certain locales, changing the case of an ASCII-range character may +turn it into a multibyte character, most notably with "I" in Turkish +(the lowercase is "ı", 0x0131). Previously, 'downcase' on a unibyte +string was buggy, and would mistakenly just return the lower byte of +this, 0x31 (the digit "1"). 'downcase' on a unibyte string has now +been changed to downcase such characters as if they were ASCII. To +get proper locale-dependent downcasing, the string has to be converted +to multibyte first. (This goes for the other case-changing functions, +too.) --- -** 'dns-query' now consistently uses Lisp integers to represent integers. -Formerly it made an exception for integer components of SOA records, -because SOA serial numbers can exceed fixnum ranges on 32-bit platforms. -Emacs now supports bignums so this old glitch is no longer needed. - -+++ -** The '&define' keyword in an Edebug specification now disables backtracking. -The implementation was buggy, and multiple '&define' forms in an '&or' -form should be exceedingly rare. See the Info node "(elisp) Backtracking" in -the Emacs Lisp reference manual for background. - -+++ -** The error 'ftp-error' belongs also to category 'remote-file-error'. - -+++ -** The WHEN argument of 'make-obsolete' and related functions is mandatory. -The use of those functions without a WHEN argument was marked obsolete -back in Emacs 23.1. The affected functions are: 'make-obsolete', -'define-obsolete-function-alias', 'make-obsolete-variable', -'define-obsolete-variable-alias'. - -+++ -** 'inhibit-nul-byte-detection' is renamed to 'inhibit-null-byte-detection'. +** Functions in 'tramp-foreign-file-name-handler-alist' have changed. +Functions to determine which Tramp file name handler to use are now +passed a file name in dissected form (via 'tramp-dissect-file-name') +instead of in string form. --- -** Some functions are no longer considered safe by 'unsafep': -'replace-regexp-in-string', 'catch', 'throw', 'error', 'signal' -and 'play-sound-file'. +** 'def' indentation changes. +In 'emacs-lisp-mode', forms with a symbol with a name that start with +"def" have been automatically indented as if they were 'defun'-like +forms, for instance: ---- -** 'sql-*-statement-starters' are no longer user options. -These variables describe facts about the SQL standard and -product-specific additions. There should be no need for users to -customize them. + (defzot 1 + 2 3) ---- -** Some locale-related variables have been removed. -The Lisp variables 'previous-system-messages-locale' and -'previous-system-time-locale' have been removed, as they were created -by mistake and were not useful to Lisp code. +This heuristic has now been removed, and all functions/macros that +want to be indented this way have to be marked with ---- -** Function 'lm-maintainer' is replaced with 'lm-maintainers'. -The former is now declared obsolete. + (declare (indent defun)) -+++ -** facemenu.el is no longer preloaded. -To use functions/variables from the package, you now have to say -'(require 'facemenu)' or similar. +or the like. If the function/macro definition itself can't be +changed, the indentation can also be adjusted by saying something +like: ---- -** 'facemenu-color-alist' is now obsolete, and is not used. + (put 'defzot 'lisp-indent-function 'defun) --- -** The variable 'keyboard-type' is obsolete and not dynamically scoped any more. - -+++ -** The 'values' variable is now obsolete. -Using it just contributes to the growth of the Emacs memory -footprint. - ---- -** The 'load-dangerous-libraries' variable is now obsolete. -It was used to allow loading Lisp libraries compiled by XEmacs, a -modified version of Emacs which is no longer actively maintained. -This is no longer supported, and setting this variable has no effect. - -+++ -** The macro 'with-displayed-buffer-window' is now obsolete. -Use macro 'with-current-buffer-window' with action alist entry 'body-function'. +** The 'inhibit-changing-match-data' variable is now obsolete. +Instead, functions like 'string-match' and 'looking-at' now take an +optional 'inhibit-modify' argument. --- -** The rfc2368.el library is now obsolete. -Use rfc6068.el instead. The main difference is that -'rfc2368-parse-mailto-url' and 'rfc2368-unhexify-string' assumed that -the strings were all-ASCII, while 'rfc6068-parse-mailto-url' and -'rfc6068-unhexify-string' parse UTF-8 strings. +** 'gnus-define-keys' is now obsolete. +Use 'define-keymap' instead. --- -** The inversion.el library is now obsolete. +** MozRepl has been removed from js.el. +MozRepl was removed from Firefox in 2017, so this code doesn't work +with recent versions of Firefox. --- -** The metamail.el library is now obsolete. - -** Edebug changes +** The function 'image-dired-get-exif-data' is now obsolete. +Use 'exif-parse-file' and 'exif-field' instead. --- -*** 'get-edebug-spec' is obsolete, replaced by 'edebug-get-spec'. - -+++ -*** The spec operator ':name NAME' is obsolete, use '&name' instead. +** 'insert-directory' alternatives should not change the free disk space line. +This change is now applied in 'dired-insert-directory'. -+++ -*** The spec element 'function-form' is obsolete, use 'form' instead. - -+++ -*** New function 'def-edebug-elem-spec' to define Edebug spec elements. -These used to be defined with 'def-edebug-spec' thus conflating the -two name spaces, which lead to name collisions. -The use of 'def-edebug-spec' to define Edebug spec elements is -declared obsolete. - ---- -** The sb-image.el library is now obsolete. -This was a compatibility kludge which is no longer needed. - ---- -** Some libraries obsolete since Emacs 23 have been removed: -ledit.el, lmenu.el, lucid.el and old-whitespace.el. - ---- ** Some functions and variables obsolete since Emacs 23 have been removed: -'GOLD-map', 'advertised-xscheme-send-previous-expression', -'allout-init', 'bookmark-jump-noselect', -'bookmark-read-annotation-text-func', 'buffer-menu-mode-hook', -'c-forward-into-nomenclature', 'char-coding-system-table', -'char-valid-p', 'charset-bytes', 'charset-id', 'charset-list', -'choose-completion-delete-max-match', 'complete-in-turn', -'completion-base-size', 'completion-common-substring', -'crm-minibuffer-complete', 'crm-minibuffer-complete-and-exit', -'crm-minibuffer-completion-help', 'custom-mode', 'custom-mode-hook', -'define-key-rebound-commands', 'define-mode-overload-implementation', -'detect-coding-with-priority', 'dirtrack-debug', -'dirtrack-debug-toggle', 'dynamic-completion-table', -'easy-menu-precalculate-equivalent-keybindings', -'epa-display-verify-result', 'epg-passphrase-callback-function', -'erc-announced-server-name', 'erc-default-coding-system', -'erc-process', 'erc-send-command', 'eshell-report-bug', -'eval-next-after-load', 'exchange-dot-and-mark', 'ffap-bug', -'ffap-submit-bug', 'ffap-version', 'file-cache-mouse-choose-completion', -'forward-point', 'generic-char-p', 'global-highlight-changes', -'hi-lock-face-history', 'hi-lock-regexp-history', -'highlight-changes-active-string', 'highlight-changes-initial-state', -'highlight-changes-passive-string', -'icalendar--datetime-to-noneuropean-date', 'image-mode-maybe', -'imenu-example--name-and-position', 'ispell-aspell-supports-utf8', -'lisp-mode-auto-fill', 'locate-file-completion', 'make-coding-system', -'menu-bar-files-menu', 'minibuffer-local-must-match-filename-map', -'mouse-choose-completion', 'mouse-major-mode-menu', -'mouse-popup-menubar', 'mouse-popup-menubar-stuff', -'newsticker-groups-filename', 'nnir-swish-e-index-file', -'nnmail-fix-eudora-headers', 'non-iso-charset-alist', -'nonascii-insert-offset', 'nonascii-translation-table', -'password-read-and-add', 'pre-abbrev-expand-hook', 'princ-list', -'print-help-return-message', 'process-filter-multibyte-p', -'read-file-name-predicate', 'remember-buffer', 'rmail-highlight-face', -'rmail-message-filter', 'semantic-after-idle-scheduler-reparse-hooks', -'semantic-after-toplevel-bovinate-hook', -'semantic-before-idle-scheduler-reparse-hooks', -'semantic-before-toplevel-bovination-hook', -'semantic-bovinate-from-nonterminal-full', -'semantic-bovinate-region-until-error', 'semantic-bovinate-toplevel', -'semantic-bovination-working-type', -'semantic-decorate-pending-decoration-hooks', -'semantic-edits-incremental-reparse-failed-hooks', -'semantic-eldoc-current-symbol-info', 'semantic-expand-nonterminal', -'semantic-file-token-stream', 'semantic-find-dependency', -'semantic-find-nonterminal', 'semantic-flex', 'semantic-flex-buffer', -'semantic-flex-keyword-get', 'semantic-flex-keyword-p', -'semantic-flex-keyword-put', 'semantic-flex-keywords', -'semantic-flex-list', 'semantic-flex-make-keyword-table', -'semantic-flex-map-keywords', 'semantic-flex-token-end', -'semantic-flex-token-start', 'semantic-flex-token-text', -'semantic-imenu-bucketize-type-parts', -'semantic-imenu-expand-type-parts', 'semantic-imenu-expandable-token', -'semantic-init-db-hooks', 'semantic-init-hooks', -'semantic-init-mode-hooks', 'semantic-java-prototype-nonterminal', -'semantic-nonterminal-abstract', 'semantic-nonterminal-full-name', -'semantic-nonterminal-leaf', 'semantic-nonterminal-protection', -'semantic-something-to-stream', 'semantic-tag-make-assoc-list', -'semantic-token-type-parent', 'semantic-toplevel-bovine-cache', -'semantic-toplevel-bovine-table', 'semanticdb-mode-hooks', -'set-coding-priority', 'set-process-filter-multibyte', -'shadows-compare-text-p', 'shell-dirtrack-toggle', -'speedbar-navigating-speed', 'speedbar-update-speed', 't-mouse-mode', -'term-dynamic-simple-complete', 'tooltip-hook', 'tpu-have-ispell', -'url-generate-unique-filename', 'url-temporary-directory', -'vc-arch-command', 'vc-default-working-revision' (variable), -'vc-mtn-command', 'vc-revert-buffer', 'vc-workfile-version', -'vcursor-toggle-vcursor-map', 'w32-focus-frame', 'w32-select-font', -'wisent-lex-make-token-table'. - ---- -** Some functions and variables obsolete since Emacs 22 have been removed: -'erc-current-network', 'gnus-article-hide-pgp-hook', -'gnus-inews-mark-gcc-as-read', 'gnus-treat-display-xface', -'gnus-treat-strip-pgp', 'nnmail-spool-file'. - ---- -** The obsolete function 'thread-alive-p' has been removed. - ---- -** The variable 'force-new-style-backquotes' has been removed. -This removes the final remaining trace of old-style backquotes. - ---- -** Some obsolete variable and function aliases in dbus.el have been removed. -In Emacs 24.3, the variable 'dbus-event-error-hooks' was renamed to -'dbus-event-error-functions' and the function -'dbus-call-method-non-blocking' was renamed to 'dbus-call-method'. -The old names, which were kept as obsolete aliases of the new names, -have now been removed. - ---- -** 'find-function-source-path' renamed and re-documented. -The 'find-function' command (and various related commands) were -documented to respect 'find-function-source-path', and to search for -objects in files specified by that variable. It's unclear when this -actually changed, but at some point (perhaps decades ago) these -commands started using 'load-history' to determine where symbols had -been defined (which is much faster). The doc strings of all the -affected function have been updated. 'find-function-source-path' was -still being used by 'find-library' and related commands, so the -user option has been renamed to 'find-library-source-path', and -'find-function-source-path' is now an obsolete variable alias. - ---- -** The macro 'vc-call' no longer evaluates its second argument twice. - -** Xref migrated from EIEIO to cl-defstruct for its core objects. -This means that 'oref' and 'with-slots' no longer works on them, and -'make-instance' can no longer be used to create those instances (which -wasn't recommended anyway). Packages should restrict themselves to -using functions like 'xref-make', 'xref-make-match', -'xref-make-*-location', as well as accessor functions -'xref-item-summary' and 'xref-item-location'. - -Among the benefits are better performance (noticeable when there are a -lot of matches) and improved flexibility: 'xref-match-item' instances -do not require that 'location' inherits from 'xref-location' anymore -(that class was removed), so packages can create new location types to -use with "match items" without adding EIEIO as a dependency. - - -* Lisp Changes in Emacs 28.1 - -+++ -** The 'interactive' syntax has been extended to allow listing applicable modes. -Forms like '(interactive "p" dired-mode)' can be used to annotate the -commands as being applicable for modes derived from 'dired-mode', -or if the mode is a minor mode, when the current buffer has that -minor mode activated. Note that using this form will create byte code -that is not compatible with byte code in previous Emacs versions. -Also note that by default these annotations have no effect, unless the -new option 'read-extended-command-predicate' option is customized to call -'command-completion-default-include-p' or a similar function. - -+++ -** New 'declare' forms to control completion of commands in 'M-x'. -'(declare (completion PREDICATE))' can be used as a general predicate -to say whether the command should be considered a completion candidate -when completing with 'M-x TAB'. - -'(declare (modes MODE...))' can be used as a short-hand way of saying -that the command should be considered a completion candidate when -completing on commands from buffers in major modes derived from -MODE..., or, if it's a minor mode, when that minor mode is enabled in -the current buffer. - -Note that these forms will only have their effect if the -'read-extended-command-predicate' option is customized to call -'command-completion-default-include-p' or a similar function. The -default value of 'read-extended-command-predicate' is nil, which means -no commands that match what you have typed are excluded from being -completion candidates. - -+++ -** 'define-minor-mode' now takes an ':interactive' argument. -This can be used for specifying which modes this minor mode is meant -for, or to make the new minor mode non-interactive. The default value -is t. - -+++ -** 'define-derived-mode' now takes an ':interactive' argument. -This can be used to control whether the defined mode is a command -or not, and is useful when defining commands that aren't meant to be -used by users directly. - -+++ -** 'define-globalized-minor-mode' now takes a ':predicate' parameter. -This can be used to control which major modes the minor mode should be -used in. +'find-emacs-lisp-shadows', 'newsticker-cache-filename', +'unify-8859-on-decoding-mode', 'unify-8859-on-encoding-mode', +'vc-arch-command'. +++ -** 'condition-case' now allows for a success handler. -It is written as '(:success BODY...)' where BODY is executed -whenever the protected form terminates without error, with the -specified variable bound to the value of the protected form. +** Base64 encoding no longer tolerates latin-1 input. +The functions 'base64-encode-string', 'base64url-encode-string', +'base64-encode-region' and 'base64url-encode-region' no longer accept +characters in the range U+0080..U+00FF as substitutes for single bytes +in the range 128..255, but signal an error for all multibyte characters. +The input must be encoded text. -+++ -** New function 'benchmark-call' to measure the execution time of a function. -Additionally, the number of repetitions can be expressed as a minimal duration -in seconds. - -+++ -** The value thrown to the 'exit' label can now be a function. -This is in addition to values t or nil. If the value is a function, -the command loop will call it with zero arguments before returning. - -+++ -** The behavior of 'format-spec' is now closer to that of 'format'. -In order for the two functions to behave more consistently, -'format-spec' now pads and truncates based on string width rather than -length, and also supports format specifications that include a -truncating precision field, such as "%.2a". - ---- -** 'defvar' detects the error of defining a variable currently lexically bound. -Such mixes are always signs that the outer lexical binding was an -error and should have used dynamic binding instead. - ---- -** New variable 'inhibit-mouse-event-check'. -If bound to non-nil, a command with '(interactive "e")' doesn't signal -an error when invoked by input event that is not a mouse click (e.g., -a key sequence). - ---- -** New variable 'redisplay-skip-initial-frame' to enable batch redisplay tests. -Setting it to nil forces the redisplay to do its job even in the -initial frame used in batch mode. - -+++ -** Doc strings can now link to customization groups. -Text like "customization group `whitespace'" will be made into a -button. When clicked, it will open a Custom buffer displaying that -customization group. - -+++ -** Doc strings can now link to man pages. -Text like "man page `chmod(1)'" will be made into a button. When -clicked, it will open a Man mode buffer displaying that man page. - -+++ -** Buffers can now be created with certain hooks disabled. -The functions 'get-buffer-create' and 'generate-new-buffer' accept a -new optional argument INHIBIT-BUFFER-HOOKS. If non-nil, the new -buffer does not run the hooks 'kill-buffer-hook', -'kill-buffer-query-functions', and 'buffer-list-update-hook'. This -avoids slowing down internal or temporary buffers that are never -presented to users or passed on to other applications. - -+++ -** New command 'make-directory-autoloads'. -This does the same as the old command 'update-directory-autoloads', -but has different semantics: Instead of passing in the output file via -the dynamically bound 'generated-autoload-file' variable, the output -file is now a explicit parameter. - ---- -** Dragging a file into Emacs pushes the file name onto 'file-name-history'. - ---- -** The 'easymenu' library is now preloaded. - ---- -** The 'iso-transl' library is now preloaded. -This means that keystrokes like 'Alt-[' are defined by default, -instead of only becoming available after doing (for instance) -'C-x 8 <letter>'. - ---- -** ':safe' settings in 'defcustom' are now propagated to the loaddefs files. - -+++ -** New ':type' for 'defcustom' for nonnegative integers. -The new 'natnum' type can be used for options that should be -nonnegative integers. - -+++ -** ERT can now output more verbose test failure reports. -If the 'EMACS_TEST_VERBOSE' environment variable is set, failure -summaries will include the failing condition. - -** Byte compiler changes - -+++ -*** New byte-compiler check for missing dynamic variable declarations. -It is meant as an (experimental) aid for converting Emacs Lisp code -to lexical binding, where dynamic (special) variables bound in one -file can affect code in another. For details, see the manual section -"(elisp) Converting to Lexical Binding". - -+++ -*** 'byte-recompile-directory' can now compile symlinked ".el" files. -This is achieved by giving a non-nil FOLLOW-SYMLINKS parameter. - ---- -*** The byte-compiler now warns about too wide documentation strings. -By default, it will warn if a documentation string is wider than the -largest of 'byte-compile-docstring-max-column' or 'fill-column' -characters. - -+++ -*** 'byte-compile-file' optional argument LOAD is now obsolete. -To load the file after byte-compiling, add a call to 'load' from Lisp -or use 'M-x emacs-lisp-byte-compile-and-load' interactively. - -** Macroexp - ---- -*** New function 'macroexp-file-name' to know the name of the current file. - ---- -*** New function 'macroexp-compiling-p' to know if we're compiling. - ---- -*** New function 'macroexp-warn-and-return' to help emit warnings. -This used to be named 'macroexp--warn-and-return' and has proved useful -and well-behaved enough to lose the "internal" marker. - -** map.el - ---- -*** Alist keys are now consistently compared with 'equal' by default. -Until now, 'map-elt' and 'map-delete' compared alist keys with 'eq' by -default. They now use 'equal' instead, for consistency with -'map-put!' and 'map-contains-key'. - -*** Pcase 'map' pattern added keyword symbols abbreviation. -A pattern like '(map :sym)' binds the map's value for ':sym' to 'sym', -equivalent to '(map (:sym sym))'. - ---- -*** The function 'map-copy' now uses 'copy-alist' on alists. -This is a slightly deeper copy than the previous 'copy-sequence'. - ---- -*** The function 'map-contains-key' now supports plists. - ---- -*** More consistent duplicate key handling in 'map-merge-with'. -Until now, 'map-merge-with' promised to call its function argument -whenever multiple maps contained 'eql' keys. However, this did not -always coincide with the keys that were actually merged, which could -be 'equal' instead. The function argument is now called whenever keys -are merged, for greater consistency with 'map-merge' and 'map-elt'. - -** pcase - -+++ -*** The 'or' pattern now binds the union of the vars of its sub-patterns. -If a variable is not bound by the subpattern that matched, it gets bound -to nil. This was already sometimes the case, but it is now guaranteed. - -+++ -*** The 'pred' pattern can now take the form '(pred (not FUN))'. -This is like '(pred (lambda (x) (not (FUN x))))' but results -in better code. - ---- -*** New function 'pcase-compile-patterns' to write other macros. - -+++ -*** Added 'cl-type' pattern. -The new 'cl-type' pattern compares types using 'cl-typep', which allows -comparing simple types like '(cl-type integer)', as well as forms like -'(cl-type (integer 0 10))'. - -+++ -*** New macro 'pcase-setq'. -This macro is the 'setq' equivalent of 'pcase-let', which allows for -destructuring patterns in a 'setq' form. - -** Edebug - -*** Edebug specification lists can use some new keywords: + +* Lisp Changes in Emacs 29.1 +++ -**** '&interpose SPEC FUN ARGS..' lets FUN control parsing after SPEC. -More specifically, FUN is called with 'HEAD PF ARGS..' where -PF is a parsing function that expects a single argument (the specs to -use) and HEAD is the code that matched SPEC. +** New variable 'lisp-directory' holds the directory of Emacs's own Lisp files. +++ -**** '&error MSG' unconditionally aborts the current edebug instrumentation. +** New facility for handling session state: 'multisession-value'. +This can be used as a convenient way to store (simple) application +state, and 'M-x list-multisession-values' allows users to list +(and edit) this data. +++ -**** '&name SPEC FUN' extracts the current name from the code matching SPEC. - -** Dynamic modules changes +** New function 'get-display-property'. +This is like 'get-text-property', but works on the 'display' text +property. +++ -*** Type aliases for module functions and finalizers. -The module header 'emacs-module.h' now contains type aliases -'emacs_function' and 'emacs_finalizer' for module functions and -finalizers, respectively. +** New function 'add-text-display-property'. +This is like 'put-text-property', but works on the 'display' text +property. +++ -*** Module functions can now be made interactive. -Use 'make_interactive' to give a module function an interactive -specification. +** New 'min-width' 'display' property. +This allows setting a minimum display width for a region of text. +++ -*** Module functions can now install an optional finalizer. -The finalizer is called when the function object is garbage-collected. -Use 'set_function_finalizer' to set the finalizer and -'get_function_finalizer' to retrieve it. +** New event type 'touch-end'. +This event is sent whenever the user's finger moves off the mouse +wheel on some mice, or when the user's finger moves off the touchpad. +++ -*** Modules can now open a channel to an existing pipe process. -Modules can use the new module function 'open_channel' to do that. -On capable systems, modules can use this functionality to -asynchronously send data back to Emacs. +** New event type 'pinch'. +This event is sent when a user peforms a pinch gesture on a touchpad, +which is comprised of placing two fingers on the touchpad and moving +them towards or away from each other. -+++ -*** A new module API 'make_unibyte_string'. -It can be used to create Lisp strings with arbitrary byte sequences -(a.k.a. "raw bytes"). +** Keymaps and key definitions +++ -** Shorthands for Lisp symbols. -Shorthands are a general purpose namespacing system to make Emacs -Lisp's symbol-naming etiquette easier to use. A shorthand is any -symbolic form found in Lisp source that "abbreviates" a symbol's print -name. Among other applications, this feature can be used to avoid -name clashes and namespace pollution by renaming an entire file's -worth of symbols with proper and longer prefixes, without actually -touching the Lisp source. For details, see the manual section -"(elisp) Shorthands". +*** New functions for defining and manipulating keystrokes have been added. +These all take just the syntax defined by 'key-valid-p'. None of the +older functions have been depreciated or altered, but are deemphasised +in the documentation. +++ -** New function 'string-search'. -This function takes two string parameters and returns the position of -the first instance of the former string in the latter. +*** Use 'keymap-set' instead of 'define-key'. +++ -** New function 'string-replace'. -This function works along the line of 'replace-regexp-in-string', but -it matches on fixed strings instead of regexps, and does not change -the global match state. +*** Use 'keymap-global-set' instead of 'global-set-key'. +++ -** New function 'ensure-list'. -This function makes a list of its object if it's not a list already. -If it's already a list, the list is returned as is. +*** Use 'keymap-local-set' instead of 'local-set-key'. +++ -** New function 'split-string-shell-command'. -This splits a shell command string into separate components, -respecting quoting with single ('like this') and double ("like this") -quotes, as well as backslash quoting (like\ this). +*** Use 'keymap-global-unset' instead of 'global-unset-key'. +++ -** New function 'string-clean-whitespace'. -This removes whitespace from a string. +*** Use 'keymap-local-unset' instead of 'local-unset-key'. +++ -** New function 'string-fill'. -Word-wrap a string so that no lines are longer that a specific length. +*** Use 'keymap-substitute' instead of 'substitute-key-definition'. +++ -** New function 'string-limit'. -Return (up to) a specific substring length. +*** Use 'keymap-set-after' instead of 'define-key-after'. +++ -** New function 'string-lines'. -Return a list of strings representing the individual lines in a -string. +*** Use 'keymap-lookup' instead of 'lookup-keymap' and 'key-binding'. +++ -** New function 'string-pad'. -Pad a string to a specific length. +*** Use 'keymap-local-lookup' instead of 'local-key-binding'. +++ -** New function 'string-chop-newline'. -Remove a trailing newline from a string. +*** Use 'keymap-global-lookup' instead of 'global-key-binding'. +++ -** New function 'replace-regexp-in-region'. +*** '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 'replace-string-in-region'. +*** 'read-multiple-choice' now takes an optional SHOW-HELP argument. +If non-nil, show the help buffer immediately, before any user input. +++ -** New function 'file-name-with-extension'. -This function allows a canonical way to set/replace the extension of a -file name. +*** 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 'file-modes-number-to-symbolic' to convert a numeric -file mode specification into symbolic form. - -+++ -** New function 'file-name-concat'. -This appends file name components to a directory name and returns the -result. +--- +*** New function 'key-parse'. +This is like 'kbd', but only returns vectors instead of a mix of +vectors and strings. +++ -** New function 'file-backup-file-names'. -This function returns the list of file names of all the backup files -for the specified file. +** 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 'directory-empty-p'. -This predicate tests whether a given file name is an accessible -directory and whether it contains no other directories or files. +** New function 'file-name-split'. +This returns a list of all the components of a file name. +++ -** New function 'buffer-local-boundp'. -This predicate says whether a symbol is bound in a specific buffer. +** New macro 'with-undo-amalgamate'. +It records a particular sequence of operations as a single undo step. +++ -** New function 'always'. -This is identical to 'ignore', but returns t instead. +** New command 'yank-media'. +This command supports yanking non-plain-text media like images and +HTML from other applications into Emacs. It is only supported in +modes that have registered support for it, and only on capable +platforms. +++ -** New function 'sxhash-equal-including-properties'. -This is identical to 'sxhash-equal' but also accounts for string -properties. - ---- -** New function 'buffer-line-statistics'. -This function returns some statistics about the line lengths in a buffer. - ---- -** New function 'color-values-from-color-spec'. -This can be used to parse RGB color specs in several formats and -convert them to a list '(R G B)' of primary color values. - ---- -** New function 'custom-add-choice'. -This function can be used by modes to add elements to the -'choice' customization type of a variable. - ---- -** New function 'decoded-time-period'. -It interprets a decoded time structure as a period and returns the -equivalent period in seconds. +** New command 'yank-media-types'. +This command lets you examine all data in the current selection and +the clipboard, and insert it into the buffer. +++ -** New function 'dom-print'. +** New text property 'inhibit-isearch'. +If set, 'isearch' will skip these areas, which can be useful (for +instance) when covering huge amounts of data (that has no meaningful +searchable data, like image data) with a 'display' text property. +++ -** New function 'dom-remove-attribute'. +** 'insert-image' now takes an INHIBIT-ISEARCH optional parameter. +It marks the image with the 'inhibit-isearch' text property, which +inhibits 'isearch' matching the STRING parameter. --- -** New function 'dns-query-asynchronous'. -It takes the same parameters as 'dns-query', but adds a callback -parameter. - -** New function 'garbage-collect-maybe' to trigger GC early. +** New user option 'pp-use-max-width'. +If non-nil, 'pp' will attempt to limit the line length when formatting +long lists and vectors. --- -** New function 'get-locale-names'. -This utility function returns a list of names of locales available on -the current system. +** New function 'pp-emacs-lisp-code'. +'pp' formats general Lisp sexps. This function does much the same, +but applies formatting rules appropriate for Emacs Lisp code. +++ -** New function 'insert-into-buffer'. -This inserts the contents of the current buffer into another buffer. +** New function 'file-has-changed-p'. +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. +++ -** New function 'json-available-p'. -This predicate returns non-nil if Emacs is built with libjansson -support, and it is available on the current system. - ---- -** New function 'mail-header-parse-addresses-lax'. -This takes a comma-separated string and returns a list of mail/name -pairs. - ---- -** New function 'mail-header-parse-address-lax'. -Parse a string as a mail address-like string. +** 'abbreviate-file-name' now respects magic file name handlers. --- -** New function 'make-separator-line'. -Make a string appropriate for usage as a visual separator line. - -+++ -** New function 'num-processors'. -Return the number of processors on the system. - -+++ -** New function 'object-intervals'. -This function returns a copy of the list of intervals (i.e., text -properties) in the object in question (which must either be a string -or a buffer). - -+++ -** New function 'process-lines-ignore-status'. -This is like 'process-lines', but does not signal an error if the -return status is non-zero. 'process-lines-handling-status' has also -been added, and takes a callback to handle the return status. - -+++ -** New function 'require-theme'. -This function is like 'require', but searches 'custom-theme-load-path' -instead of 'load-path'. It can be used by Custom themes to load -supporting Lisp files when 'require' is unsuitable. - -+++ -** New function 'seq-union'. -This function takes two sequences and returns a list of all elements -that appear in either of them, with no two elements that compare equal -appearing in the result. - -+++ -** New function 'syntax-class-to-char'. -This does almost the opposite of 'string-to-syntax' -- it returns the -syntax descriptor (a character) given a raw syntax descriptor (an -integer). +** New function 'font-has-char-p'. +This can be used to check whether a specific font has a glyph for a +character. +++ -** New functions 'null-device' and 'path-separator'. -These functions return the connection local value of the respective -variables. This can be used for remote hosts. +** 'window-text-pixel-size' now accepts a new argument 'ignore-line-at-end'. +This controls whether or not the last screen line of the text being +measured will be counted for the purpose of calculating the text +dimensions. +++ -** New predicate functions 'length<', 'length>' and 'length='. -Using these functions may be more efficient than using 'length' (if -the length of a (long) list is being computed just to compare this -length to a number). +** 'window-text-pixel-size' understands a new meaning of 'from'. +Specifying a cons as the from argument allows to start measuring text +from a specified amount of pixels above or below a position. -+++ -** New macro 'dlet' to dynamically bind variables. +** XDG support -+++ -** New macro 'with-existing-directory'. -This macro binds 'default-directory' to some other existing directory -if 'default-directory' doesn't exist, and then executes the body forms. +*** New function 'xdg-state-home' returns 'XDG_STATE_HOME' environment variable. +This new location, introduced in the XDG Base Directory Specification +version 0.8 (8th May 2021), "contains state data that should persist +between (application) restarts, but that is not important or portable +enough to the user that it should be stored in $XDG_DATA_HOME". +++ -** New variable 'current-minibuffer-command'. -This is like 'this-command', but it is bound recursively when entering -the minibuffer. - -+++ -** New variable 'inhibit-interaction' to make user prompts signal an error. -If this is bound to something non-nil, functions like -'read-from-minibuffer', 'read-char' (and related) will signal an -'inhibited-interaction' error. +** New macro 'with-delayed-message'. +This macro is like 'progn', but will output the specified message if +the body takes longer to execute than the specified timeout. --- -** New variable 'indent-line-ignored-functions'. -This allows modes to cycle through a set of indentation functions -appropriate for those modes. +** New function 'funcall-with-delayed-message'. +This function is like 'funcall', but will output the specified message +if the function takes longer to execute than the specified timeout. -+++ -** New variable 'print-integers-as-characters' modifies integer printing. -If this variable is non-nil, character syntax is used for printing -numbers when this makes sense, such as '?A' for 65. - -+++ -** New variable 'tty-menu-calls-mouse-position-function'. -This controls whether 'mouse-position-function' is called by functions -that retrieve the mouse position when that happens during TTY menu -handling. Lisp programs that set 'mouse-position-function' should -also set this variable non-nil if they are compatible with the tty -menu handling. - -+++ -** New variables that hold default buffer names for shell output. -The new constants 'shell-command-buffer-name' and -'shell-command-buffer-name-async' store the default buffer names -for the output of, respectively, synchronous and async shell -commands. +** Locale --- -** New variables 'read-char-choice-use-read-key' and 'y-or-n-p-use-read-key'. -When non-nil, then functions 'read-char-choice' and 'y-or-n-p' -(respectively) use the function 'read-key' to read a character instead -of using the minibuffer. - -+++ -** New variable 'global-minor-modes'. -This variable holds a list of currently enabled global minor modes (as -a list of symbols). - -+++ -** New buffer-local variable 'local-minor-modes'. -This permanently buffer-local variable holds a list of currently -enabled non-global minor modes in the current buffer (as a list of -symbols). - -+++ -** New completion function 'affixation-function' to add prefix/suffix. -It accepts a list of completions and should return a list where -each element is a list with three elements: a completion, -a prefix string, and a suffix string. - -+++ -** New completion function 'group-function' for grouping candidates. -It takes two arguments: a completion candidate and a 'transform' flag. - -+++ -** New error symbol 'minibuffer-quit'. -Signaling it has almost the same effect as 'quit' except that it -doesn't cause keyboard macro termination. - -+++ -** New error 'remote-file-error', a subcategory of 'file-error'. -It is signaled if a remote file operation fails due to internal -reasons, and could block Emacs. It does not replace 'file-error' -signals for the usual cases. Timers, process filters and process -functions, which run remote file operations, shall protect themselves -against this error. - -If such an error occurs, please report this as bug via 'M-x report-emacs-bug'. -Until it is solved you could ignore such errors by performing - - (setq debug-ignored-errors (cons 'remote-file-error debug-ignored-errors)) - -+++ -** New macro 'named-let' added to subr-x.el. -It provides Scheme's "named let" looping construct. +*** New variable 'current-locale-environment'. +This holds the value of the previous call to 'set-locale-environment'. --- -** Emacs now attempts to test for high-rate subprocess output more fairly. -When several subprocesses produce output simultaneously at high rate, -Emacs will now by default attempt to service them all in a round-robin -fashion. Set the new variable 'process-prioritize-lower-fds' to a -non-nil value to get back the old behavior, whereby after reading -from a subprocess, Emacs would check for output of other subprocesses -in a way that is likely to read from the same process again. +*** New macro 'with-locale-environment'. +This macro can be used to change the locale temporarily while +executing code. -+++ -** 'set-process-buffer' now updates the process mark. -The mark will be set to point to the end of the new buffer. +** Tabulated List Mode +++ -** 'unlock-buffer' displays warnings instead of signaling. -Instead of signaling 'file-error' conditions for file system level -errors, the function now calls 'display-warning' and continues as if -the error did not occur. +*** A column can now be set to an image descriptor. +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. +++ -** 'read-char-from-minibuffer' and 'y-or-n-p' support 'help-form'. -If you bind 'help-form' to a non-nil value while calling these functions, -then pressing 'C-h' ('help-char') causes the function to evaluate 'help-form' -and display the result. +** :keys in 'menu-item' can now be a function. +If so, it is called whenever the menu is computed, and can be used to +calculate the keys dynamically. +++ -** 'read-number' now has its own history variable. -Additionally, the function now accepts a HIST argument which can be -used to specify a custom history variable. +** New major mode 'clean-mode'. +This is a new major mode meant for debugging. It kills absolutely all +local variables and removes overlays and text properties. +++ -** 'set-window-configuration' now takes two optional parameters, -'dont-set-frame' and 'dont-set-miniwindow'. The first of these, when -non-nil, instructs the function not to select the frame recorded in -the configuration. The second prevents the current minibuffer being -replaced by the one stored in the configuration. - ---- -** 'count-windows' now takes an optional parameter ALL-FRAMES. -The semantics are as with 'walk-windows'. - -+++ -** 'truncate-string-ellipsis' now uses '…' by default. -Modes that use 'truncate-string-to-width' with non-nil, non-string -argument ELLIPSIS, will now indicate truncation using '…' when -the selected frame can display it, and using "..." otherwise. - -+++ -** 'string-width' now accepts two optional arguments FROM and TO. -This allows calculating the width of a substring without consing a -new string. - -+++ -** 'directory-files' now takes an additional COUNT parameter. -The parameter makes 'directory-files' return COUNT first file names -from a directory. If MATCH is also given, the function will return -first COUNT file names that match the expression. The same COUNT -parameter has been added to 'directory-files-and-attributes'. +** 'kill-all-local-variables' can now kill all local variables. +If given the new optional KILL-PERMANENT argument, also kill permanent +local variables. +++ -** 'count-lines' can now ignore invisible lines. -This is controlled by the optional parameter IGNORE-INVISIBLE-LINES. +** Third 'mapconcat' argument SEPARATOR is now optional. +An explicit nil always meant the empty string, now it can be left out. --- -** 'count-words' now crosses field boundaries. -Originally, 'count-words' would stop counting at the first field -boundary it encountered; now it keeps counting all the way to the -region's (or buffer's) end. +** Themes can now be made obsolete. +Using 'make-obsolete' on a theme is now supported. This will make +'load-theme' issue a warning when loading the theme. +++ -** File-related APIs can optionally follow symlinks. -The functions 'file-modes', 'set-file-modes', and 'set-file-times' now -have an optional argument specifying whether to follow symbolic links. +** New function 'define-keymap'. +This function allows defining a number of keystrokes with one form. +++ -** 'format-seconds' can now be used for sub-second times. -The new optional "," parameter has been added, and -'(format-seconds "%mm %,1ss" 66.4)' will now result in "1m 6.4s". - -+++ -** 'parse-time-string' can now parse ISO 8601 format strings. -These have a format like "2020-01-15T16:12:21-08:00". - ---- -** 'lookup-key' is more allowing when searching for extended menu items. -When looking for a menu item '[menu-bar Foo-Bar]', first try to find -an exact match, then look for the lowercased '[menu-bar foo-bar]'. -It will only try to downcase ASCII characters in the range "A-Z". -This improves backwards-compatibility when converting menus to use -'easy-menu-define'. +** New macro 'defvar-keymap'. +This macro allows defining keymap variables more conveniently. --- -** 'make-network-process', 'make-serial-process' ':coding' behavior change. -Previously, passing ':coding nil' to either of these functions would -override any non-nil binding for 'coding-system-for-read' and -'coding-system-for-write'. For consistency with 'make-process' and -'make-pipe-process', passing ':coding nil' is now ignored. No code in -Emacs depended on the previous behavior; if you really want the -process' coding-system to be nil, use 'set-process-coding-system' -after the process has been created, or pass in ':coding '(nil nil)'. +** 'kbd' can now be used in built-in, preloaded libraries. +It no longer depends on edmacro.el and cl-lib.el. +++ -** 'open-network-stream' now accepts a ':coding' argument. -This allows specifying the coding systems used by a network process -for encoding and decoding without having to bind -'coding-system-for-{read,write}' or call 'set-process-coding-system'. +** New function 'image-at-point-p'. +This function returns t if point is on a valid image, and nil +otherwise. +++ -** 'open-network-stream' can now take a ':capability-command' that's a function. -The function is called with the greeting from the server as its only -parameter, and allows sending different TLS capability commands to the -server based on that greeting. +** New function 'string-pixel-width'. +This returns the width of a string in pixels. This can be useful when +dealing with variable pitch fonts and glyphs that have widths that +aren't integer multiples of the default font. +++ -** 'open-gnutls-stream' now also accepts a ':coding' argument. +** New function 'string-glyph-split'. +This function splits a string into a list of strings representing +separate glyphs. This takes into account combining characters and +grapheme clusters. --- -** 'process-attributes' now works under OpenBSD, too. +** 'lookup-key' is more permissive when searching for extended menu items. +In Emacs 28.1, the behavior of 'lookup-key' was changed: when looking +for a menu item '[menu-bar Foo-Bar]', first try to find an exact +match, then look for the lowercased '[menu-bar foo-bar]'. -+++ -** 'format-spec' now takes an optional SPLIT parameter. -If non-nil, 'format-spec' will split the resulting string into a list -of strings, based on where the format specs (and expansions) were. +This has been extended, so that when looking for a menu item with a +symbol containing spaces, as in '[menu-bar Foo\ Bar]', first look for +an exact match, then the lowercased '[menu-bar foo\ bar]' and finally +'[menu-bar foo-bar]'. This further improves backwards-compatibility +when converting menus to use 'easy-menu-define'. ---- -** 'unload-feature' now also tries to undo additions to buffer-local hooks. - ---- -** 'while-no-input-ignore-events' accepts more special events. -The special events 'dbus-event' and 'file-notify' are now ignored in -'while-no-input' when added to this variable. - ---- -** 'start-process-shell-command' and 'start-file-process-shell-command' -do not support the old calling conventions any longer. +** xwidgets +++ -** 'yes-or-no-p' and 'y-or-n-p' PROMPT parameter no longer needs trailing space. -In other words, the prompt can now end with "?" instead of "? ". This -has been the case since Emacs 24.4 but was not announced or documented -until now. (Checkdoc has also been updated to accept this convention.) +*** The function 'make-xwidget' now accepts an optional RELATED argument. +This argument is used as another widget for the newly created WebKit +widget to share settings and subprocesses with. It must be another +WebKit widget. +++ -** The 'uniquify' argument in 'auto-save-file-name-transforms' can be a symbol. -If this symbol is one of the members of 'secure-hash-algorithms', -Emacs constructs the nondirectory part of the auto-save file name by -applying that 'secure-hash' to the buffer file name. This avoids any -risk of excessively long file names. +*** New function 'xwidget-perform-lispy-event'. +This function allows you to send events to xwidgets. Usually, some +equivalent of the event will be sent, but there is no guarantee of +what the widget will actually receive. -+++ -** New user option 'process-file-return-signal-string'. -It controls, whether 'process-file' returns a string when a remote -process is interrupted by a signal. - -** EIEIO Changes - -+++ -*** The macro 'oref-default' can now be used with 'setf'. -It is now defined as a generalized variable that can be used with -'setf' to modify the value stored in a given class slot. - ---- -*** 'form' in '(eql form)' specializers in 'cl-defmethod' is now evaluated. -This corresponds to the behavior of defmethod in Common Lisp Object System. -For compatibility, '(eql SYMBOL)' does not evaluate SYMBOL, for now. - -** D-Bus +On GTK+, only key and function key events are implemented. +++ -*** Property values can be typed explicitly. -'dbus-register-property' and 'dbus-set-property' accept now optional -type symbols. Both functions propagate D-Bus errors. +*** New function 'xwidget-webkit-load-html'. +This function is used to load HTML text into WebKit xwidgets +directly, in contrast to creating a temporary file to hold the +markup, and passing the URI of the file as an argument to +'xwidget-webkit-goto-uri'. +++ -*** Registered properties can have the new access type ':write'. +*** New functions for performing searches on WebKit xwidgets. +Some new functions, such as 'xwidget-webkit-search', have been added +for performing searches on WebKit xwidgets. +++ -*** In case of problems, handlers can emit proper D-Bus error messages now. +*** New function 'xwidget-webkit-back-forward-list'. +This function is used to obtain the history of page-loads in a given +WebKit xwidget. +++ -*** D-Bus errors, which have been converted from incoming D-Bus error -messages, contain the error name of that message now. +*** New function 'xwidget-webkit-estimated-load-progress'. +This function is used to obtain the estimated progress of page loading +in a given WebKit xwidget. +++ -*** D-Bus messages can be monitored with the new command 'dbus-monitor'. +*** New function 'xwidget-webkit-stop-loading'. +This function is used to terminate all data transfer during page loads +in a given WebKit xwidget. +++ -*** D-Bus events have changed their internal structure. -They carry now the destination and the error-name of an event. They -also keep the type information of their arguments. Use the -'dbus-event-*' accessor functions. - -** Buttons +*** 'load-changed' xwidget events are now more detailed. +In particular, they can now have different arguments based on the +state of the WebKit widget. 'load-finished' is sent when a load has +completed, 'load-started' when a load first starts, 'load-redirected' +after a redirect, and 'load-committed' when the WebKit widget first +commits to the load. +++ -*** New minor mode 'button-mode'. -This minor mode does nothing except install 'button-buffer-map' as -a minor mode map (which binds the 'TAB' / 'S-TAB' key bindings to navigate -to buttons), and can be used in any view-mode-like buffer that has -buttons in it. +*** New event type 'xwidget-display-event'. +These events are sent whenever an xwidget requests that Emacs display +another xwidget. The only arguments to this event are the xwidget +that should be displayed, and the xwidget that asked to display it. +++ -*** New utility function 'button-buttonize'. -This function takes a string and returns a string propertized in a way -that makes it a valid button. +*** 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. ---- -** 'text-scale-mode' can now adjust font size of the header line. -When the new buffer local variable 'text-scale-remap-header-line' -is non-nil, 'text-scale-adjust' will also scale the text in the header -line when displaying that buffer. - -This is useful for major modes that arrange their display in a tabular -form below the header line. It is enabled by default in -'tabulated-list-mode' and its derived modes, and disabled by default -elsewhere. - ---- -** 'ascii' is now a coding system alias for 'us-ascii'. - ---- -** New coding-systems for EBCDIC variants. -New coding-systems 'ibm256', 'ibm273', 'ibm274', 'ibm277', 'ibm278', -'ibm280', 'ibm281', 'ibm284', 'ibm285', 'ibm290', 'ibm297'. These are -variants of the EBCDIC encoding tailored to some European and Japanese -locales. They are also available as aliases 'ebcdic-cp-*' (e.g., -'ebcdic-cp-fi' for the Finnish variant 'ibm278'), and 'cp2xx' (e.g., -'cp278' for 'ibm278'). There are also new charsets 'ibm2xx' to -support these coding-systems. +** New variable 'help-buffer-under-preparation'. +This variable is bound to t during the preparation of a "*Help*" buffer. +++ -** New 'Bindat type expression' description language. -This new system is provided by the new macro 'bindat-type' and -obsoletes the old data layout specifications. It supports -arbitrary-size integers, recursive types, and more. See the Info node -"(elisp) Byte Packing" in the ELisp manual for more details. +** Timestamps like (1 . 1000) now work without warnings being generated. +For example, (time-add nil '(1 . 1000)) no longer warns that the +(1 . 1000) acts like (1000 . 1000000). This warning, which was a +temporary transition aid for Emacs 27, has served its purpose. +++ -** New macro 'with-environment-variables'. -This macro allows setting environment variables temporarily when -executing a form. - - -* Changes in Emacs 28.1 on Non-Free Operating Systems +** 'date-to-time' now assumes earliest values if its argument lacks +month, day, or time. For example, (date-to-time "2021-12-04") now +assumes a time of 00:00 instead of signaling an error. +++ -** On MS-Windows, Emacs can now use the native image API to display images. -Emacs can now use the MS-Windows GDI+ library to load and display -images in JPEG, PNG, GIF and TIFF formats. This support is available -unless Emacs was configured '--without-native-image-api'. - -This feature is experimental, and needs to be turned on to be used. -To turn this on, set the variable 'w32-use-native-image-API' to a -non-nil value. Please report any bugs you find while using the native -image API via 'M-x report-emacs-bug'. +** New events for taking advantage of touchscreen devices. +The events 'touchscreen-begin, 'touchscreen-update', and +'touchscreen-end' have been added to take better advantage of +touch-capable display panels. +++ -** On MS-Windows, Emacs can now toggle the IME. -A new function 'w32-set-ime-open-status' can now be used to disable -and enable the MS-Windows native Input Method Editor (IME) at run -time. A companion function 'w32-get-ime-open-status' returns the -current IME activation status. +** New error symbol 'permission-denied'. +This is a subcategory of 'file-error', and is signaled when some file +operation fails because the OS doesn't allow Emacs to access a file or +a directory. --- -** On macOS, 's-<left>' and 's-<right>' are now bound to -'move-beginning-of-line' and 'move-end-of-line' respectively. The commands -to select previous/next frame are still bound to 's-~' and 's-`'. - -+++ -** On macOS, Emacs can now load dynamic modules with a ".dylib" suffix. -'module-file-suffix' now has the value ".dylib" on macOS, but the -".so" suffix is supported as well. - ---- -** On macOS, the user option 'make-pointer-invisible' is now honored. - ---- -** On macOS, Xwidget is now supported. -If Emacs was built with xwidget support, you can access the embedded -webkit browser with 'M-x xwidget-webkit-browse-url'. Viewing two -instances of xwidget webkit is not supported. + +* Changes in Emacs 29.1 on Non-Free Operating Systems ---- -*** New user option 'xwidget-webkit-enable-plugins'. -If non-nil, enable plugins in xwidget. (This is only available on -macOS.) +** MS-Windows +++ -** New macOS Contacts back-end for EUDC. -This backend works on newer versions of macOS and is generally -preferred over the eudcb-mab.el backend. +*** Emacs now supports system dark mode. +On Windows 10 (version 1809 and higher) and Windows 11, Emacs will now +follow the system's dark mode: GUI frames use the appropriate light or +dark title bar and scroll bars, based on the user's Windows-wide color +settings. ---------------------------------------------------------------------- diff --git a/etc/NEWS.28 b/etc/NEWS.28 new file mode 100644 index 00000000000..f1bf2fe67d1 --- /dev/null +++ b/etc/NEWS.28 @@ -0,0 +1,4612 @@ +GNU Emacs NEWS -- history of user-visible changes. + +Copyright (C) 2019-2021 Free Software Foundation, Inc. +See the end of the file for license conditions. + +Please send Emacs bug reports to 'bug-gnu-emacs@gnu.org'. +If possible, use 'M-x report-emacs-bug'. + +This file is about changes in Emacs version 28. + +See file HISTORY for a list of GNU Emacs versions and release dates. +See files NEWS.27, NEWS.26, ..., NEWS.18, and NEWS.1-17 for changes +in older Emacs versions. + +You can narrow news to a specific version by calling 'view-emacs-news' +with a prefix argument or by typing 'C-u C-h C-n'. + +Temporary note: ++++ indicates that all relevant manuals in doc/ have been updated. +--- means no change in the manuals is needed. +When you add a new item, use the appropriate mark if you are sure it +applies, and please also update docstrings as needed. + + +* Installation Changes in Emacs 28.1 + +** Emacs now optionally supports native compilation of Lisp files. +To enable this, configure Emacs with the '--with-native-compilation' option. +This requires the libgccjit library to be installed and functional, +and also requires GCC and Binutils to be available when Lisp code is +natively compiled. See the Info node "(elisp) Native Compilation" for +more details. + +If you build Emacs with native compilation, but without zlib, be sure +to configure with the '--without-compress-install' option, so that the +installed *.el files are not compressed; otherwise, you will not be +able to use JIT native compilation of the installed *.el files. + +Note that JIT native compilation is done in a fresh session of Emacs +that is run in a subprocess, so it can legitimately report some +warnings and errors that aren't uncovered by byte-compilation. We +recommend examining any such warnings before you decide they are +false. + +** The Cairo graphics library is now used by default if present. +'--with-cairo' is now the default, if the appropriate development files +are found by 'configure'. Note that building with Cairo means using +Pango instead of libXFT for font support. Since Pango 1.44 has +removed support for bitmapped fonts, this may require you to adjust +your font settings. + +Note also that 'FontBackend' settings in ".Xdefaults" or +".Xresources", or 'font-backend' frame parameter settings in your init +files, may need to be adjusted, as 'xft' is no longer a valid backend +when using Cairo. Use 'ftcrhb' if your Emacs was built with HarfBuzz +text shaping support, and 'ftcr' otherwise. You can determine this by +checking 'system-configuration-features'. The 'ftcr' backend will +still be available when HarfBuzz is supported, but will not be used by +default. We strongly recommend building with HarfBuzz support. 'x' is +still a valid backend. + +--- +** 'configure' now warns about building with libXft support. +libXft is unmaintained, and causes a number of problems with modern +fonts including but not limited to crashes; support for it may be +removed in a future version of Emacs. Please consider using +Cairo + HarfBuzz instead. + +--- +** 'configure' now warns about not using HarfBuzz if using Cairo. +We want to encourage people to use the most modern font features +available, and this is the Cairo graphics library + HarfBuzz for font +shaping, so 'configure' now recommends that combination. + +--- +** Building without double buffering support. +'configure --with-xdbe=no' can now be used to disable double buffering +at build time. + +--- +** The configure option '--without-makeinfo' has been removed. +This was only ever relevant when building from a repository checkout. +This now requires makeinfo, which is part of the texinfo package. + +--- +** New configure option '--disable-year2038'. +This causes Emacs to use only 32-bit time_t on platforms that have +both 32- and 64-bit time_t. This may help when linking Emacs with a +library with an ABI requiring traditional 32-bit time_t. This option +currently affects only 32-bit ARM and x86 running GNU/Linux with glibc +2.34 and later. Emacs now defaults to 64-bit time_t on these +platforms. + +--- +** Support for building with '-fcheck-pointer-bounds' has been removed. +GCC has withdrawn the '-fcheck-pointer-bounds' option and support for +its implementation has been removed from the Linux kernel. + +--- +** The ftx font backend driver has been removed. +It was declared obsolete in Emacs 27.1. + +--- +** Emacs no longer supports old OpenBSD systems. +OpenBSD 5.3 and older releases are no longer supported, as they lack +proper pty support that Emacs needs. + + +* Startup Changes in Emacs 28.1 + +--- +** In GTK builds, Emacs now supports startup notification. +This means that Emacs won't steal keyboard focus upon startup +(when started via the Desktop) if the user is typing into another +application. + +--- +** Errors in 'kill-emacs-hook' no longer prevent Emacs from shutting down. +If a function in that hook signals an error in an interactive Emacs, +the user will be prompted on whether to continue. If the user doesn't +answer within five seconds, Emacs will continue shutting down anyway. + +** Emacs now supports loading a Secure Computing filter. +This is supported only on capable GNU/Linux systems. To activate, +invoke Emacs with the '--seccomp=FILE' command-line option. FILE must +name a binary file containing an array of 'struct sock_filter' +structures. Emacs will then install that list of Secure Computing +filters into its own process early during the startup process. You +can use this functionality to put an Emacs process in a sandbox to +avoid security issues when executing untrusted code. See the manual +page for 'seccomp' system call, for details about Secure Computing +filters. + +** Emacs can support 24-bit color TTY without terminfo database. +If your text-mode terminal supports 24-bit true color, but your system +lacks the terminfo database, you can instruct Emacs to support 24-bit +true color by setting 'COLORTERM=truecolor' in the environment. This is +useful on systems such as FreeBSD which ships only with "etc/termcap". + +--- +** File names given on the command line are now be pushed onto history. +The file names will be pushed onto 'file-name-history', like the names +of files visited via 'C-x C-f' and other commands. + + +* Changes in Emacs 28.1 + +--- +** Emacs now supports Unicode Standard version 14.0. + ++++ +** Improved support for Emoji. +On capable systems, Emacs now correctly displays Emoji and Emoji +sequences by default, provided that a suitable font is available to +Emacs. With a few exceptions, all of the Emoji sequences specified by +Unicode 14.0 are automatically composed and displayed as a single +colorful glyph. This is achieved by changes in the Emacs font +configuration, and by additional character-composition rules for the +Emoji codepoints that follow from the Unicode-defined sequences. + +If your system lacks a suitable font, we recommend to install "Noto +Color Emoji"; Emacs will use it automatically if it's installed. If +you prefer to use another font for Emoji, customize your fontset like +this: + + (set-fontset-font t 'emoji + '("My New Emoji Font" . "iso10646-1") nil 'prepend) + +The Emoji characters are now assigned to a special script, 'emoji', so +as to make it easier to customize fontsets for Emoji display, as in +the above example. (Previously, the Emoji characters were assigned to +the 'symbol' script, together with other symbol and punctuation +characters.) + ++++ +** 'glyphless-char-display-control' now applies to Variation Selectors. +VS-1 through VS-16 are now displayed as 'thin-space' by default when +not composed with previous characters (typically, as part of Emoji +sequences). + ++++ +** New command 'execute-extended-command-for-buffer'. +This new command, bound to 'M-S-x', works like +'execute-extended-command', but limits the set of commands to the +commands that have been determined to be particularly useful with the +current mode. + ++++ +** New user option 'read-extended-command-predicate'. +This user option controls how 'M-x' performs completion of commands when +you type 'TAB'. By default, any command that matches what you have +typed is considered a completion candidate, but you can customize this +option to exclude commands that are not applicable to the current +buffer's major and minor modes, and respect the command's completion +predicate (if any). + ++++ +** Completion on 'M-x' shows key bindings for commands. +When 'suggest-key-bindings' is non-nil (as it is by default), the +completion list popped up by 'M-x' shows the key bindings for all the +commands shown in the list of candidate completions that have a key +binding. + ++++ +** New user option 'completions-detailed'. +When non-nil, some commands like 'describe-symbol' show more detailed +completions with more information in completion prefix and suffix. +The default is nil. + +--- +** 'C-s' in 'M-x' now once again searches over completions. +In Emacs 23, typing 'M-x' ('read-extended-command') and then 'C-s' (to +do an interactive search) would search over possible completions. +This was lost in Emacs 24, but is now back again. + ++++ +** User option 'completions-format' supports a new value 'one-column'. + ++++ +** New system for displaying documentation for groups of functions. +This can either be used by saying 'M-x shortdoc-display-group' and +choosing a group, or clicking a button in the "*Help*" buffers when +looking at the doc string of a function that belongs to one of these +groups. + ++++ +** New minor mode 'context-menu-mode' for context menus popped by 'mouse-3'. +When this mode is enabled, clicking 'down-mouse-3' (usually, the +right mouse button) anywhere in the buffer pops up a menu whose +contents depends on surrounding context near the mouse click. +You can change the order of the default sub-menus in the context menu +by customizing the user option 'context-menu-functions'. You can also +invoke the context menu by pressing 'S-<F10>' or, on macOS, by +clicking 'C-down-mouse-1'. + ++++ +** A new keymap for buffer actions has been added. +The 'C-x x' keymap now holds keystrokes for various buffer-oriented +commands. The new keystrokes are 'C-x x g' ('revert-buffer-quick'), +'C-x x r' ('rename-buffer'), 'C-x x u' ('rename-uniquely'), 'C-x x n' +('clone-buffer'), 'C-x x i' ('insert-buffer'), 'C-x x t' +('toggle-truncate-lines') and 'C-x x f' ('font-lock-update'). + ++++ +** Modifiers now go outside angle brackets in pretty-printed key bindings. +For example, 'RET' with Control and Meta modifiers is now shown as +'C-M-<return>' instead of '<C-M-return>'. Either variant can be used +as input; functions such as 'kbd' and 'read-kbd-macro' accept both +styles as equivalent (they have done so for a long time). + +--- +** 'eval-expression' no longer signals an error on incomplete expressions. +Previously, typing 'M-: ( RET' would result in Emacs saying "End of +file during parsing" and dropping out of the minibuffer. The user +would have to type 'M-: M-p' to edit and redo the expression. Now +Emacs will echo the message and allow the user to continue editing. + ++++ +** 'eval-last-sexp' now handles 'defvar'/'defcustom'/'defface' specially. +This command would previously not redefine values defined by these +forms, but this command has now been changed to work more like +'eval-defun', and reset the values as specified. + +--- +** New user option 'use-short-answers'. +When non-nil, the function 'y-or-n-p' is used instead of +'yes-or-no-p'. This eliminates the need to define an alias that maps +one to another in the init file. The same user option also controls +whether the function 'read-answer' accepts short answers. + ++++ +** New user option 'kill-buffer-delete-auto-save-files'. +If non-nil, killing a buffer that has an auto-save file will prompt +the user for whether that auto-save file should be deleted. (Note +that 'delete-auto-save-files', if non-nil, was previously documented +to result in deletion of auto-save files when killing a buffer without +unsaved changes, but this has apparently not worked for several +decades, so the documented semantics of this variable has been changed +to match the behavior.) + ++++ +** New user option 'next-error-message-highlight'. +In addition to a fringe arrow, 'next-error' error may now optionally +highlight the current error message in the 'next-error' buffer. +This user option can be also customized to keep highlighting on all +visited errors, so you can have an overview what errors were already visited. + +--- +** New choice 'next-error-quit-window' for 'next-error-found-function'. +When 'next-error-found-function' is customized to 'next-error-quit-window', +then typing the numeric prefix argument 0 before the command 'next-error' +will quit the source window after visiting the next occurrence. + ++++ +** New user option 'file-preserve-symlinks-on-save'. +This controls what Emacs does when saving buffers that visit files via +symbolic links, and 'file-precious-flag' is non-nil. + ++++ +** New user option 'copy-directory-create-symlink'. +If non-nil, will make 'copy-directory' (when used on a symbolic +link) copy the link instead of following the link. The default is +nil, so the default behavior is unchanged. + ++++ +** New user option 'ignored-local-variable-values'. +This is the opposite of 'safe-local-variable-values' -- it's an alist +of variable-value pairs that are to be ignored when reading a +local-variables section of a file. + +--- +** Specific warnings can now be disabled from the warning buffer. +When a warning is displayed to the user, the resulting buffer now has +buttons which allow making permanent changes to the treatment of that +warning. Automatic showing of the warning can be disabled (although +it is still logged to the "*Messages*" buffer), or the warning can be +disabled entirely. + ++++ +** ".dir-locals.el" now supports setting 'auto-mode-alist'. +The new 'auto-mode-alist' specification in ".dir-locals.el" files can +now be used to override the global 'auto-mode-alist' in the current +directory tree. + +--- +** User option 'uniquify-buffer-name-style' can now be a function. +This user option can be one of the predefined styles or a function to +personalize the uniquified buffer name. + +--- +** 'remove-hook' is now an interactive command. + +--- +** 'expand-file-name' now checks for null bytes in filenames. +The function will now check for null bytes in both NAME and +DEFAULT-DIRECTORY arguments, as well as in the 'default-directory' +buffer-local variable, when its value is used. If null bytes are +found, 'expand-file-name' will signal an error. +This means that practically all file-related operations will now check +file names for null bytes, thus avoiding subtle bugs with silently +using only the part of file name up to the first null byte. + +--- +** Frames + ++++ +*** The key prefix 'C-x 5 5' displays next command buffer in a new frame. +It's bound to the command 'other-frame-prefix' that requests the buffer +of the next command to be displayed in a new frame. + ++++ +*** New command 'clone-frame' (bound to 'C-x 5 c'). +This is like 'C-x 5 2', but uses the window configuration and frame +parameters of the current frame instead of 'default-frame-alist'. +When called interactively with a prefix arg, the window configuration +is not cloned. + +--- +*** Default values of 'frame-title-format' and 'icon-title-format' have changed. +These variables are used to display the title bar of visible frames +and the title bar of an iconified frame. They now show the name of +the current buffer and the text "GNU Emacs" instead of the value of +'invocation-name'. To get the old behavior back, add the following to +your init file: + + (setq frame-title-format '(multiple-frames "%b" + ("" invocation-name "@" system-name))) + ++++ +*** New frame parameter 'drag-with-tab-line'. +This parameter, similar to 'drag-with-header-line', allows moving frames +by dragging the tab lines of their topmost windows with the mouse. + ++++ +*** New optional behavior of 'delete-other-frames'. +When invoked with a prefix argument, 'delete-other-frames' now +iconifies frames, rather than deleting them. + +--- +*** Commands 'set-frame-width' and 'set-frame-height' now prompt for values. +These commands now prompt for the value via the minibuffer, instead of +requiring the user to specify the value via the prefix argument. + +** Windows + ++++ +*** The key prefix 'C-x 4 1' displays next command buffer in the same window. +It's bound to the command 'same-window-prefix' that requests the buffer +of the next command to be displayed in the same window. + ++++ +*** The key prefix 'C-x 4 4' displays next command buffer in a new window. +It's bound to the command 'other-window-prefix' that requests the buffer +of the next command to be displayed in a new window. + ++++ +*** New command 'recenter-other-window', bound to 'S-M-C-l'. +Like 'recenter-top-bottom', but acting on the other window. + ++++ +*** New user option 'delete-window-choose-selected'. +This allows specifying how Emacs chooses which window will be the +frame's selected window after the currently selected window is +deleted. + ++++ +*** New argument NO-OTHER for some window functions. +'get-lru-window', 'get-mru-window' and 'get-largest-window' now accept a +new optional argument NO-OTHER which, if non-nil, avoids returning a +window whose 'no-other-window' parameter is non-nil. + ++++ +*** New 'display-buffer' function 'display-buffer-use-least-recent-window'. +This is like 'display-buffer-use-some-window', but won't reuse the +current window, and when called repeatedly will try not to reuse a +previously selected window. + ++++ +*** New function 'window-bump-use-time'. +This updates the use time of a window. + +** Minibuffer + ++++ +*** Minibuffer scrolling is now conservative by default. +This is controlled by the new variable 'scroll-minibuffer-conservatively'. +It is t by default; setting it to nil will cause scrolling in the +minibuffer obey the value of 'scroll-conservatively'. + ++++ +*** Improved handling of minibuffers on switching frames. +By default, when you switch to another frame, an active minibuffer now +moves to the newly selected frame. Nevertheless, the effect of what +you type in the minibuffer happens in the frame where the minibuffer +was first activated. An alternative behavior is available by +customizing 'minibuffer-follows-selected-frame' to nil. Here, the +minibuffer stays in the frame where you first opened it, and you must +switch back to this frame to continue or abort its command. The old +behavior, which mixed these two, can be approximated by customizing +'minibuffer-follows-selected-frame' to a value which is neither nil +nor t. + ++++ +*** New user option 'read-minibuffer-restore-windows'. +When customized to nil, it uses 'minibuffer-restore-windows' in +'minibuffer-exit-hook' to remove only the window showing the +"*Completions*" buffer, but keeps all other windows created +while the minibuffer was active. + +--- +*** New variable 'redisplay-adhoc-scroll-in-resize-mini-windows'. +Customizing it to nil will disable the ad-hoc auto-scrolling of +minibuffer text shown in mini-windows when resizing those windows. +The default heuristics of that scrolling can be counter productive in +some corner cases, though the cure might be worse than the disease. +This said, the effect should be negligible in the vast majority of +cases anyway. + +** Mode Line + ++++ +*** New user option 'mode-line-compact'. +If non-nil, repeating spaces are compressed into a single space. If +'long', this is only done when the mode line is longer than the +current window width (in columns). + ++++ +*** New user options to control format of line/column numbers in the mode line. +'mode-line-position-line-format' is the line number format (when +'line-number-mode' is on), 'mode-line-position-column-format' is +the column number format (when 'column-number-mode' is on), and +'mode-line-position-column-line-format' is the combined format (when +both modes are on). + +** Tab Bars and Tab Lines + ++++ +*** The prefix key 'C-x t t' can be used to display a buffer in a new tab. +Typing 'C-x t t' before a command will cause the buffer shown by that +command to be displayed in a new tab. 'C-x t t' is bound to the +command 'other-tab-prefix'. + ++++ +*** New command 'C-x t C-r' to open file read-only in the other tab. + ++++ +*** The tab bar now supports more mouse commands. +Clicking 'mouse-2' closes the tab, 'mouse-3' displays the context menu +with items that operate on the clicked tab. Dragging the tab with +'mouse-1' moves it to another position on the tab bar. Mouse wheel +scrolling switches to the previous/next tab, and holding the Shift key +during scrolling moves the tab to the left/right. + ++++ +*** Frame-specific appearance of the tab bar when 'tab-bar-show' is a number. +When 'tab-bar-show' is a number, the tab bar on different frames can +be shown or hidden independently, as determined by the number of tabs +on each frame compared to the numerical value of 'tab-bar-show'. + ++++ +*** New command 'toggle-frame-tab-bar'. +It can be used to enable/disable the tab bar on the currently selected +frame regardless of the values of 'tab-bar-mode' and 'tab-bar-show'. +This allows enabling/disabling the tab bar independently on different +frames. + ++++ +*** New user option 'tab-bar-format' defines a list of tab bar items. +When it contains 'tab-bar-format-global' (possibly appended after +'tab-bar-format-align-right'), then after enabling 'display-time-mode' +(or any other mode that uses 'global-mode-string') it displays time +aligned to the right on the tab bar instead of on the mode line. +When 'tab-bar-format-tabs' is replaced with 'tab-bar-format-tabs-groups', +the tab bar displays tab groups. + ++++ +*** New optional key binding for 'tab-last'. +If you customize the user option 'tab-bar-select-tab-modifiers' to +allow selecting tabs using their index numbers, the '<MODIFIER>-9' key +is bound to 'tab-last', and switches to the last tab. Here <MODIFIER> +is any of the modifiers in the list that is the value of +'tab-bar-select-tab-modifiers'. You can also use positive indices, +which count from the last tab: 1 is the last tab, 2 the one before +that, etc. + +--- +*** New command 'tab-duplicate' bound to 'C-x t n'. + +--- +*** 'C-x t N' creates a new tab at the specified absolute position. +The position is provided as prefix arg, and specifies an index that +starts at 1. Negative values count from the end of the tab bar. + +--- +*** 'C-x t M' moves the current tab to the specified absolute position. +The position is provided as prefix arg, whose interpretation is as in +'C-x t N'. + +--- +*** 'C-x t G' assigns a tab to a named group of tabs. +'tab-close-group' closes all tabs that belong to the selected group. +The user option 'tab-bar-new-tab-group' defines the default group of +new tabs. After customizing 'tab-bar-tab-post-change-group-functions' +to 'tab-bar-move-tab-to-group', changing the group of a tab will also +move it closer to other tabs in the same group. + +--- +*** New user option 'tab-bar-tab-name-format-function'. + +--- +*** New user option 'tab-line-tab-name-format-function'. + +--- +*** The tabs in the tab line can now be scrolled using horizontal scroll. +If your mouse or trackpad supports it, you can now scroll tabs when +the mouse pointer is in the tab line by scrolling left or right. + +--- +*** New tab-line faces and user options. +The face 'tab-line-tab-special' is used for tabs whose buffers are +special, i.e. buffers that don't visit a file. The face +'tab-line-tab-modified' is used to display modified, file-backed +buffers. The face 'tab-line-tab-inactive-alternate' is used to +display inactive tabs with an alternating background color, making +them easier to distinguish, especially if the face 'tab-line-tab' is +configured to not display with a box; this alternate face is only +applied when the user option 'tab-line-tab-face-functions' is so +configured. That option may also be used to customize tab-line faces +in other ways. + +** Mouse wheel + +--- +*** Mouse wheel scrolling now defaults to one line at a time. + +--- +*** Mouse wheel scrolling now works on more parts of frame's display. +When using 'mouse-wheel-mode', the mouse wheel will now scroll also when +the mouse cursor is on the scroll bars, fringes, margins, header line, +and mode line. ('mouse-wheel-mode' is enabled by default on most graphical +displays.) + ++++ +*** Mouse wheel scrolling with Shift modifier now scrolls horizontally. +This works in text buffers and over images. Typing a numeric prefix arg +(e.g. 'M-5') before starting horizontal scrolling changes its step value. +The value is saved in the user option 'mouse-wheel-scroll-amount-horizontal'. + +** Customize + +--- +*** Customize buffers can now be reverted with 'C-x x g'. + +--- +*** Most customize commands now hide obsolete user options. +Obsolete user options are no longer shown in the listings produced by +the commands 'customize', 'customize-group', 'customize-apropos' and +'customize-changed'. + +To customize obsolete user options, use 'customize-option' or +'customize-saved'. + +--- +*** New SVG icons for checkboxes and arrows. +They will be used automatically instead of the old icons. If Emacs is +built without SVG support, the old icons will be used instead. + +** Help + +--- +*** The order of things displayed in the "*Help*" buffer has been changed. +The indented "administrative" block (containing the "probably +introduced" and "other relevant functions" (and similar things) has +been moved to after the doc string. + ++++ +*** New command 'describe-command' shows help for a command. +This can be used instead of 'describe-function' for interactive +commands and is globally bound to 'C-h x'. + ++++ +*** New command 'describe-keymap' describes keybindings in a keymap. + +--- +*** New command 'apropos-function'. +This works like 'C-u M-x apropos-command' but is more discoverable. + +--- +*** New keybinding 'C-h R' prompts for an Info manual and displays it. + +--- +*** Keybindings in 'help-mode' use the new 'help-key-binding' face. +This face is added by 'substitute-command-keys' to any "\[command]" +substitution. The return value of that function should consequently +be assumed to be a propertized string. To prevent the function from +adding the 'help-key-binding' face, call 'substitute-command-keys' +with the new optional argument NO-FACE non-nil. + +Note that the new face will also be used in tooltips. When using the +GTK toolkit, this is only true if 'x-gtk-use-system-tooltips' is t. + ++++ +*** New user option 'help-enable-symbol-autoload'. +If non-nil, displaying help for an autoloaded function whose +'autoload' form provides no documentation string will try to load the +file it's from. This will give more extensive help for such +functions. + +--- +*** The 'help-for-help' ('C-h C-h') screen has been redesigned. + ++++ +*** New convenience commands with short keys in the Help buffer. +New command 'help-view-source' ('s') will view the source file (if +any) of the current help topic. New command 'help-goto-info' ('i') +will look up the current symbol (if any) in Info. New command +'help-customize' ('c') will customize the user option or the face +(if any) whose doc string is being shown in the Help buffer. + +--- +*** New user option 'describe-bindings-outline'. +It enables outlines in the output buffer of 'describe-bindings' that +can provide a better overview in a long list of available bindings. + ++++ +*** New commands to describe buttons and widgets. +'widget-describe' (on a widget) will pop up a help buffer and give a +description of the properties. Likewise 'button-describe' does the +same for a button. + +--- +*** Improved "find definition" feature of "*Help*" buffers. +Now clicking on the link to find the definition of functions generated +by 'cl-defstruct', or variables generated by 'define-derived-mode', +for example, will go to the exact place where they are defined. + +--- +*** New commands 'apropos-next-symbol' and 'apropos-previous-symbol'. +These new navigation commands are bound to 'n' and 'p' in +'apropos-mode'. + +--- +*** The command 'view-lossage' can now be invoked from the menu bar. +The menu bar "Help" menu now has a "Show Recent Inputs" item under the +"Describe" sub-menu. + ++++ +*** New command 'lossage-size'. +It allows users to change the maximum number of keystrokes and +commands recorded for the purpose of 'view-lossage'. + +--- +*** Closing the "*Help*" buffer from the toolbar now buries the buffer. +In previous Emacs versions, the "*Help*" buffer was killed instead when +clicking the "X" icon in the tool bar. + +--- +*** 'g' ('revert-buffer') in 'help-mode' no longer requires confirmation. + +** File Locks + ++++ +*** New user option 'lock-file-name-transforms'. +This option allows controlling where lock files are written. It uses +the same syntax as 'auto-save-file-name-transforms'. + ++++ +*** New user option 'remote-file-name-inhibit-locks'. +When non-nil, this option suppresses lock files for remote files. +Default is nil. + ++++ +*** New minor mode 'lock-file-mode'. +This command, called interactively, toggles the local value of +'create-lockfiles' in the current buffer. + +** Emacs Server + ++++ +*** New user option 'server-client-instructions'. +When emacsclient connects, Emacs will (by default) output a message +about how to exit the client frame. If 'server-client-instructions' +is set to nil, this message is inhibited. + ++++ +*** New command 'server-edit-abort'. +This command (not bound to any key by default) can be used to abort +an edit instead of marking it as "Done" (which the 'C-x #' command +does). The 'emacsclient' program exits with an abnormal status as +result of this command. + ++++ +*** New desktop integration for connecting to the server. +If your operating system’s desktop environment is +freedesktop.org-compatible (which is true of most GNU/Linux and other +recent Unix-like desktops), you may use the new "Emacs (Client)" +desktop menu entry to open files in an existing Emacs instance rather +than starting a new one. The daemon starts if it is not already +running. + +** Miscellaneous + ++++ +*** New command 'font-lock-update', bound to 'C-x x f'. +This command updates the syntax highlighting in this buffer. + ++++ +*** New command 'memory-report'. +This command opens a new buffer called "*Memory Report*" and gives a +summary of where Emacs is using memory currently. + ++++ +*** New command 'submit-emacs-patch'. +This works like 'report-emacs-bug', but is more geared towards sending +patches to the Emacs issue tracker. + +--- +*** New face 'apropos-button'. +Applies to buttons that indicate a face. + ++++ +*** New face 'font-lock-doc-markup-face'. +Intended for documentation mark-up syntax and tags inside text that +uses 'font-lock-doc-face', which it should appropriately stand out +against and harmonize with. It would typically be used in structured +documentation comments in program source code by language-specific +modes, for mark-up conventions like Haddock, Javadoc or Doxygen. By +default this face inherits from 'font-lock-constant-face'. + ++++ +*** New face box style 'flat-button'. +This is a plain 2D button, but uses the background color instead of +the foreground color. + +--- +*** New faces 'shortdoc-heading' and 'shortdoc-section'. +Applied to shortdoc headings and sections. + +--- +*** New face 'separator-line'. +This is used by 'make-separator-line' (see below). + ++++ +*** 'redisplay-skip-fontification-on-input' helps Emacs keep up with fast input. +This is another attempt to solve the problem of handling high key repeat rate +and other "slow scrolling" situations. It is hoped it behaves better +than 'fast-but-imprecise-scrolling' and 'jit-lock-defer-time'. +It is not enabled by default. + +--- +*** Obsolete aliases are no longer hidden from command completion. +Completion of command names now considers obsolete aliases as +candidates, if they were marked obsolete in the current major version +of Emacs. Invoking a command via an obsolete alias now mentions the +obsolescence fact and shows the new name of the command. + ++++ +*** Support for '(box . SIZE)' 'cursor-type'. +By default, 'box' cursor always has a filled box shape. But if you +specify 'cursor-type' to be '(box . SIZE)', the cursor becomes a hollow +box if the point is on an image larger than SIZE pixels in any +dimension. + ++++ +*** The user can now customize how "default" values are prompted for. +The new utility function 'format-prompt' has been added which uses the +new 'minibuffer-default-prompt-format' user option to format "default" +prompts. This means that prompts that look like "Enter a number +(default 10)" can be customized to look like, for instance, "Enter a +number [10]", or not have the default displayed at all, like "Enter a +number". (This only affects callers that were altered to use +'format-prompt'.) + +--- +*** New help window when Emacs prompts before opening a large file. +Commands like 'find-file' or 'visit-tags-table' ask to visit a file +normally or literally when the file is larger than a certain size (by +default, 9.5 MiB). Press '?' or 'C-h' in that prompt to read more +about the different options to visit a file, how you can disable the +prompt, and how you can tweak the file size threshold. + ++++ +*** Emacs now defaults to UTF-8 instead of ISO-8859-1. +This is only for the default, where the user has set no 'LANG' (or +similar) variable or environment. This change should lead to no +user-visible changes for normal usage. + +--- +*** 'global-display-fill-column-indicator-mode' skips some buffers. +By default, turning on 'global-display-fill-column-indicator-mode' +doesn't turn on 'display-fill-column-indicator-mode' in special-mode +buffers. This can be controlled by customizing the user option +'global-display-fill-column-indicator-modes'. + ++++ +*** 'nobreak-char-display' now also affects all non-ASCII space characters. +Previously, this was limited only to 'NO-BREAK SPACE' and hyphen +characters. Now it also covers the rest of the non-ASCII Unicode +space characters. Also, unlike in previous versions of Emacs, the +non-ASCII characters are displayed as themselves when +'nobreak-char-display' is t, i.e. they are not replaced on display +with the ASCII space and hyphen characters. + +--- +*** New backward compatibility variable 'nobreak-char-ascii-display'. +This variable is nil by default, and non-ASCII space and hyphen +characters are displayed as themselves, even if 'nobreak-char-display' +is non-nil. If 'nobreak-char-ascii-display' is set to a non-nil +value, the non-ASCII space and hyphen characters are instead displayed +as their ASCII counterparts: spaces and ASCII hyphen (a.k.a. "dash") +characters. This provides backward compatibility feature for the +change described above, where the non-ASCII characters are no longer +replaced with their ASCII counterparts when 'nobreak-char-display' is +t. You may need this on text-mode terminals that produce messed up +display when non-ASCII spaces and hyphens are written to the display. +(This variable is only effective when 'nobreak-char-display' is t.) + ++++ +*** Improved support for terminal emulators that encode the Meta flag. +Some terminal emulators set the 8th bit of Meta characters, and then +encode the resulting character code as if it were non-ASCII character +above codepoint 127. Previously, the only way of using these in Emacs +was to set up the terminal emulator to use the 'ESC' characters to send +Meta characters to Emacs, e.g., send "ESC x" when the user types +'M-x'. You can now avoid the need for this setup of such terminal +emulators by using the new input-meta-mode with the special value +'encoded' with these terminal emulators. + +--- +*** 'auto-composition-mode' can now be selectively disabled on some TTYs. +Some text-mode terminals produce display glitches trying to compose +characters. The 'auto-composition-mode' can now have a string value +that names a terminal type; if the value returned by the 'tty-type' +function compares equal with that string, automatic composition will +be disabled in windows shown on that terminal. The Linux terminal +sets this up by default. + +--- +*** Support for the 'strike-through' face attribute on TTY frames. +If your terminal's termcap or terminfo database entry has the 'smxx' +capability defined, Emacs will now emit the prescribed escape +sequences necessary to render faces with the 'strike-through' +attribute on TTY frames. + +--- +*** TTY menu navigation is now supported in 'xterm-mouse-mode'. +TTY menus support mouse navigation and selection when 'xterm-mouse-mode' +is active. When run on a terminal, clicking on the menu bar with the +mouse now pops up a TTY menu by default instead of running the command +'tmm-menubar'. To restore the old behavior, set the user option +'tty-menu-open-use-tmm' to non-nil. + +--- +*** 'M-x report-emacs-bug' will no longer include "Recent messages" section. +These were taken from the "*Messages*" buffer, and may inadvertently +leak information from the reporting user. + +--- +*** 'C-u M-x dig' will now prompt for a query type to use. + +--- +*** Rudimentary support for the 'st' terminal emulator. +Emacs now supports 256 color display on the 'st' terminal emulator. + ++++ +*** Update IRC-related references to point to Libera.Chat. +The Free Software Foundation and the GNU Project have moved their +official IRC channels from the Freenode network to Libera.Chat. For the +original announcement and the follow-up update, including more details, +see: + +https://lists.gnu.org/archive/html/info-gnu/2021-06/msg00005.html +https://lists.gnu.org/archive/html/info-gnu/2021-06/msg00007.html + +Given the relocation of GNU and FSF's official IRC channels, as well +as #emacs and various other Emacs-themed channels (see the link below) +to Libera.Chat, IRC-related references in the Emacs repository have +now been updated to point to Libera.Chat. + +https://lists.gnu.org/archive/html/info-gnu-emacs/2021-06/msg00000.html + + +* Incompatible Editing Changes in Emacs 28.1 + +--- +** 'toggle-truncate-lines' now disables 'visual-line-mode'. +This is for symmetry with 'visual-line-mode', which disables +'truncate-lines'. + +--- +** 'electric-indent-mode' now also indents inside strings and comments. +(This only happens when indentation function also supports this.) + +To recover the previous behavior you can use: + + (add-hook 'electric-indent-functions + (lambda (_) (if (nth 8 (syntax-ppss)) 'no-indent))) + +--- +** The 'M-o' ('facemenu-keymap') global binding has been removed. +To restore the old binding, say something like: + + (require 'facemenu) + (define-key global-map "\M-o" 'facemenu-keymap) + (define-key facemenu-keymap "\es" 'center-line) + (define-key facemenu-keymap "\eS" 'center-paragraph) + +The last two lines are not strictly necessary if you don't care about +having those two commands on the 'M-o' keymap; see the next section. + +--- +** The 'M-o M-s' and 'M-o M-S' global bindings have been removed. +Use 'M-x center-line' and 'M-x center-paragraph' instead. See the +previous section for how to get back the old bindings. Alternatively, +if you only want these two commands to have the global bindings they +had before, you can add the following to your init file: + + (define-key global-map "\M-o\M-s" 'center-line) + (define-key global-map "\M-o\M-S" 'center-paragraph) + +--- +** The 'M-o M-o' global binding has been removed. +Use 'M-x font-lock-fontify-block' instead, or the new 'C-x x f' +command, which updates the syntax highlighting in the current buffer. + +--- +** The escape sequence '\e[29~' in Xterm is now mapped to 'menu'. +Xterm sends this sequence for both 'F16' and 'Menu' keys +It used to be mapped to 'print' but we couldn't find a terminal +that uses this sequence for any kind of 'Print' key. +This makes the Menu key (see https://en.wikipedia.org/wiki/Menu_key) +work for 'context-menu-mode' in Xterm. + +--- +** New user option 'xterm-store-paste-on-kill-ring'. +If non-nil (the default), Emacs pushes pasted text onto the kill ring +(if using an xterm-like terminal that supports bracketed paste). +Setting this to nil inhibits that. + +--- +** 'vc-print-branch-log' shows the change log from its root directory. +It previously used to use the default directory. + +--- +** 'project-shell' and 'shell' now use 'pop-to-buffer-same-window'. +This is to keep the same behavior as Eshell. + +--- +** In 'nroff-mode', 'center-line' is no longer bound to a key. +The original key binding was 'M-s', which interfered with I-search, +since the latter uses 'M-s' as a prefix key of the search prefix map. + +--- +** In 'f90-mode', the backslash character ('\') no longer escapes. +For about a decade, the backslash character has no longer had a +special escape syntax in Fortran F90. To get the old behavior back, +say something like: + + (modify-syntax-entry ?\\ "\\" f90-mode-syntax-table) + ++++ +** Setting 'fill-column' to nil is obsolete. +This undocumented use of 'fill-column' is now obsolete. To disable +auto filling, turn off 'auto-fill-mode' instead. + +For instance, you could add something like the following to your init +file: + + (add-hook 'foo-mode-hook (lambda () (auto-fill-mode -1)) + + +* Editing Changes in Emacs 28.1 + +** Input methods + ++++ +*** Emacs now supports "transient" input methods. +A transient input method is enabled for inserting a single character, +and is then automatically disabled. 'C-x \' temporarily enables the +selected transient input method. Use 'C-u C-x \' to select a +transient input method (which can be different from the input method +enabled by 'C-\'). For example, 'C-u C-x \ compose RET' selects the +'compose' input method; then typing 'C-x \ 1 2' will insert the +character '½', and disable the 'compose' input method afterwards. +You can use 'C-x \' in incremental search to insert a single character +to the search string. + +--- +*** New input method 'compose' based on X Multi_key sequences. + +--- +*** New input method 'iso-transl' with the same keys as 'C-x 8'. +After selecting it as a transient input method with 'C-u C-x \ +iso-transl RET', it supports the same key sequences as 'C-x 8', +so e.g. like 'C-x 8 [' inserts a left single quotation mark, +'C-x \ [' does the same. + +--- +*** New user option 'read-char-by-name-sort'. +It defines the sorting order of characters for completion of 'C-x 8 RET TAB' +and can be customized to sort them by codepoints instead of character names. +Additionally, you can group characters by Unicode blocks after customizing +'completions-group' and 'completions-group-sort'. + +--- +*** Improved language transliteration in Malayalam input methods. +Added a new Mozhi scheme. The inapplicable ITRANS scheme is now +deprecated. Errors in the Inscript method were corrected. + +--- +*** New input method 'cham'. +There's also a Cham greeting in "etc/HELLO". + +--- +*** New input methods for Lakota language orthographies. +Two orthographies are represented here, the Suggested Lakota +Orthography and what is known as the White Hat Orthography. Input +methods 'lakota-slo-prefix', 'lakota-slo-postfix', and +'lakota-white-hat-postfix' have been added. There is also a Lakota +greeting in "etc/HELLO". + ++++ +** Standalone 'M-y' allows interactive selection from previous kills. +'M-y' can now be typed after a command that is not a yank command. +When invoked like that, it prompts in the minibuffer for one of the +previous kills, offering completion and minibuffer-history navigation +through previous kills recorded in the kill ring. A similar feature +in Isearch can be invoked if you bind 'C-s M-y' to the command +'isearch-yank-pop'. When the user option 'yank-from-kill-ring-rotate' +is nil the kill ring is not rotated after 'yank-from-kill-ring'. + ++++ +** New user option 'word-wrap-by-category'. +When word-wrap is enabled, and this option is non-nil, that allows +Emacs to break lines after more characters than just whitespace +characters. In particular, this significantly improves word-wrapping +for CJK text mixed with Latin text. + ++++ +** New command 'undo-redo'. +It undoes previous undo commands, but doesn't record itself as an +undoable command. It is bound to 'C-?' and 'C-M-_', the first binding +works well in graphical mode, and the second one is easy to hit on tty. + +For full conventional undo/redo behavior, you can also customize the +user option 'undo-no-redo' to t. + ++++ +** New commands 'copy-matching-lines' and 'kill-matching-lines'. +These commands are similar to the command 'flush-lines', +but add the matching lines to the kill ring as a single string, +including the newlines that separate the lines. + ++++ +** New user option 'kill-transform-function'. +This can be used to transform (and suppress) strings from entering the +kill ring. + ++++ +** 'save-interprogram-paste-before-kill' can now be a number. +In that case, it's interpreted as a limit on the size of the clipboard +data that will be saved to the 'kill-ring' prior to killing text: if +the size of the clipboard data is greater than or equal to the limit, +it will not be saved. + ++++ +** New user option 'tab-first-completion'. +If 'tab-always-indent' is 'complete', this new user option can be used to +further tweak whether to complete or indent. + +--- +** 'indent-tabs-mode' is now a global minor mode instead of just a variable. + ++++ +** New choice 'permanent' for 'shift-select-mode'. +When the mark was activated by shifted motion keys, non-shifted motion +keys don't deactivate the mark after customizing 'shift-select-mode' +to 'permanent'. Similarly, the active mark will not be deactivated by +typing shifted motion keys. + ++++ +** The "Edit => Clear" menu item now obeys a rectangular region. + ++++ +** New command 'revert-buffer-with-fine-grain'. +Revert a buffer trying to be as non-destructive as possible, +preserving markers, properties and overlays. The new variable +'revert-buffer-with-fine-grain-max-seconds' specifies the maximum +number of seconds that 'revert-buffer-with-fine-grain' should spend +trying to be non-destructive, with a default value of 2 seconds. + ++++ +** New command 'revert-buffer-quick'. +This is bound to 'C-x x g' and is like 'revert-buffer', but prompts +less. + ++++ +** New user option 'revert-buffer-quick-short-answers'. +This controls how the new 'revert-buffer-quick' ('C-x x g') command +prompts. A non-nil value will make it use 'y-or-n-p' rather than +'yes-or-no-p'. Defaults to nil. + ++++ +** New user option 'query-about-changed-file'. +If non-nil (the default), Emacs prompts as before when re-visiting a +file that has changed externally after it was visited the first time. +If nil, Emacs does not prompt, but instead shows the buffer with its +contents before the change, and provides instructions how to revert +the buffer. + +--- +** New value 'save-some-buffers-root' of 'save-some-buffers-default-predicate'. +When using this predicate, only buffers under the current project root +will be considered when saving buffers with 'save-some-buffers'. + +--- +** New user option 'save-place-abbreviate-file-names'. +This can simplify sharing the 'save-place-file' file across +different hosts. + +--- +** New user options 'copy-region-blink-delay' and 'delete-pair-blink-delay'. +'copy-region-blink-delay' specifies a delay to indicate the region +copied by 'kill-ring-save'. 'delete-pair-blink-delay' specifies +a delay to show the paired character to delete. + +--- +** 'zap-up-to-char' now uses 'read-char-from-minibuffer'. +This allows navigating through the history of characters that have +been input. This is mostly useful for characters that have complex +input methods where inputting the character again may involve many +keystrokes. + ++++ +** Input history for 'goto-line' can now be made local to every buffer. +In any event, line numbers used with 'goto-line' are kept in their own +history list. This should help make faster the process of finding +line numbers that were previously jumped to. By default, all buffers +share a single history list. To make every buffer have its own +history list, customize the user option 'goto-line-history-local'. + ++++ +** New command 'goto-line-relative' for use in a narrowed buffer. +It moves point to the line relative to the accessible portion of the +narrowed buffer. 'M-g M-g' in Info is rebound to this command. +When 'widen-automatically' is non-nil, 'goto-line' widens the narrowed +buffer to be able to move point to the inaccessible portion. +'goto-line-relative' is bound to 'C-x n g'. + ++++ +** 'goto-char' prompts for the character position. +When called interactively, 'goto-char' now offers the position at +point as the default. + +** Auto-saving via 'auto-save-visited-mode' can now be inhibited. +Set the variable 'auto-save-visited-mode' buffer-locally to nil to +achieve that. + ++++ +** New command 'kdb-macro-redisplay' to force redisplay in keyboard macros. +This command is bound to 'C-x C-k d'. + +--- +** 'blink-cursor-mode' is now enabled by default regardless of the UI. +It used to be enabled when Emacs is started in GUI mode but not when started +in text mode. The cursor still only actually blinks in GUI frames. + +** 'show-paren-mode' is now enabled by default. +To go back to the previous behavior, customize the user option of the +same name to nil. + ++++ +** New minor mode 'show-paren-local-mode'. +It serves as a local counterpart for 'show-paren-mode', allowing you +to toggle it separately in different buffers. To use it only in +programming modes, for example, add the following to your init file: + + (add-hook 'prog-mode-hook #'show-paren-local-mode) + + +* Changes in Specialized Modes and Packages in Emacs 28.1 + +** Isearch and Replace + ++++ +*** Interactive regular expression search now uses faces for sub-groups. +E.g., 'C-M-s foo-\([0-9]+\)' will now use the 'isearch-group-1' face +on the part of the regexp that matches the sub-expression "[0-9]+". +By default, there are two faces for sub-group highlighting, but you +can define more faces whose names are of the form 'isearch-group-N', +where N are successive numbers above 2. + +This is controlled by the 'search-highlight-submatches' user option. +This feature is available only on terminals that have enough colors to +distinguish between sub-expression highlighting. + ++++ +*** Interactive regular expression replace now uses faces for sub-groups. +Like 'search-highlight-submatches', this is controlled by the new user option +'query-replace-highlight-submatches'. + ++++ +*** New key 'M-s M-.' starts isearch looking for the thing at point. +This key is bound to the new command 'isearch-forward-thing-at-point'. +The new user option 'isearch-forward-thing-at-point' defines +a list of symbols to try to get the "thing" at point. By default, +the first element of the list is 'region' that tries to yank +the currently active region to the search string. + ++++ +*** New user option 'isearch-wrap-pause' defines how to wrap the search. +There are choices to disable wrapping completely and to wrap immediately. +When wrapping immediately, it consistently handles the numeric arguments +of 'C-s' ('isearch-repeat-forward') and 'C-r' ('isearch-repeat-backward'), +continuing with the remaining count after wrapping. + ++++ +*** New user option 'isearch-repeat-on-direction-change'. +When this option is set, direction changes in Isearch move to another +search match, if there is one, instead of moving point to the other +end of the current match. + ++++ +*** New user option 'isearch-allow-motion'. +When 'isearch-allow-motion' is set, the commands 'beginning-of-buffer', +'end-of-buffer', 'scroll-up-command' and 'scroll-down-command', when +invoked during I-search, move respectively to the first occurrence of +the current search string in the buffer, the last one, the first one +after the current window, and the last one before the current window. +Additionally, users can change the meaning of other motion commands +during I-search by using their 'isearch-motion' property. The user +option 'isearch-motion-changes-direction' controls whether the +direction of the search changes after a motion command. + ++++ +*** New user option 'lazy-highlight-no-delay-length'. +Lazy highlighting of matches in Isearch now starts immediately if the +search string is at least this long. 'lazy-highlight-initial-delay' +still applies for shorter search strings, which avoids flicker in the +search buffer due to too many matches being highlighted. + ++++ +*** The default 'search-whitespace-regexp' value has changed. +This used to be "\\s-+", which meant that it was mode-dependent whether +newlines were included in the whitespace set. This has now been +changed to only match spaces and tab characters. + +** Dired + ++++ +*** New user option 'dired-kill-when-opening-new-dired-buffer'. +If non-nil, Dired will kill the current buffer when selecting a new +directory to display. + ++++ +*** Behavior change on 'dired-do-chmod'. +As a security precaution, Dired's M command no longer follows symbolic +links. Instead, it changes the symbolic link's own mode; this always +fails on platforms where such modes are immutable. + +--- +*** Behavior change on 'dired-clean-confirm-killing-deleted-buffers'. +Previously, if 'dired-clean-up-buffers-too' was non-nil, and +'dired-clean-confirm-killing-deleted-buffers' was nil, the buffers +wouldn't be killed. This combination will now kill the buffers. + ++++ +*** New user option 'dired-switches-in-mode-line'. +This user option controls how 'ls' switches are displayed in the mode +line, and allows truncating them (to preserve space on the mode line) +or showing them literally, either instead of, or in addition to, +displaying "by name" or "by date" sort order. + ++++ +*** New user option 'dired-compress-directory-default-suffix'. +This user option controls the default suffix for compressing a +directory. If it's nil, ".tar.gz" will be used. Refer to +'dired-compress-files-alist' for a list of supported suffixes. + ++++ +*** New user option 'dired-compress-file-default-suffix'. +This user option controls the default suffix for compressing files. +If it's nil, ".gz" will be used. Refer to 'dired-compress-file-alist' +for a list of supported suffixes. + +--- +*** Broken and circular links are shown with the 'dired-broken-symlink' face. + +--- +*** '=' ('dired-diff') will now put all backup files into the 'M-n' history. +When using '=' on a file with backup files, the default file to use +for diffing is the newest backup file. You can now use 'M-n' to quickly +select a different backup file instead. + ++++ +*** New user option 'dired-maybe-use-globstar'. +If set, enables globstar (recursive globbing) in shells that support +this feature, but have it turned off by default. This allows producing +directory listings with files matching a wildcard in all the +subdirectories of a given directory. The new variable +'dired-enable-globstar-in-shell' lists which shells can have globstar +enabled, and how to enable it. + ++++ +*** New user option 'dired-copy-dereference'. +If set to non-nil, Dired will dereference symbolic links when copying. +This can be switched off on a per-usage basis by providing +'dired-do-copy' with a 'C-u' prefix. + +--- +*** New user option 'dired-do-revert-buffer'. +Non-nil reverts the destination Dired buffer after performing one +of these operations: 'dired-do-copy', 'dired-do-rename', +'dired-do-symlink', 'dired-do-hardlink'. + +--- +*** New user option 'dired-mark-region'. +This option affects all Dired commands that mark files. When non-nil +and the region is active in Transient Mark mode, then Dired commands +operate only on files in the active region. The values 'file' and +'line' of this user option define the details of marking the file at +the end of the region. + ++++ +*** State changing VC operations are supported in Dired. +These operations are supported on files and directories via the new +command 'dired-vc-next-action'. + ++++ +*** 'dired-jump' and 'dired-jump-other-window' moved from 'dired-x' to 'dired'. +The 'dired-jump' and 'dired-jump-other-window' commands have been +moved from the 'dired-x' package to 'dired'. The user option +'dired-bind-jump' no longer has any effect and is now obsolete. +The commands are now bound to 'C-x C-j' and 'C-x 4 C-j' by default. + +To get the old behavior of 'dired-bind-jump' back and unbind the above +keys, add the following to your init file: + + (global-set-key "\C-x\C-j" nil) + (global-set-key "\C-x4\C-j" nil) + +--- +*** 'dired-query' now uses 'read-char-from-minibuffer'. +Using it instead of 'read-char-choice' allows using 'C-x o' +to switch to the help window displayed after typing 'C-h'. + ++++ +** Emacs 28.1 comes with Org v9.5. +See the file ORG-NEWS for user-visible changes in Org. + +** Outline + ++++ +*** New commands to cycle heading visibility. +Typing 'TAB' on a heading line cycles the current section between +"hide all", "subheadings", and "show all" states. Typing 'S-TAB' +anywhere in the buffer cycles the whole buffer between "only top-level +headings", "all headings and subheadings", and "show all" states. + ++++ +*** New user option 'outline-minor-mode-cycle'. +This user option customizes 'outline-minor-mode', with the difference +that 'TAB' and 'S-TAB' on heading lines cycle heading visibility. +Typing 'TAB' on a heading line cycles the current section between +"hide all", "subheadings", and "show all" states. Typing 'S-TAB' on a +heading line cycles the whole buffer between "only top-level +headings", "all headings and subheadings", and "show all" states. + +--- +*** New user option 'outline-minor-mode-highlight'. +This user option customizes 'outline-minor-mode'. It puts +highlighting on heading lines using standard outline faces. This +works well only when there are no conflicts with faces used by the +major mode. + +** Ispell + ++++ +*** 'ispell-comments-and-strings' now accepts START and END arguments. +These arguments default to the active region when used interactively. + ++++ +*** New command 'ispell-comment-or-string-at-point'. + +--- +*** New user option 'ispell-help-timeout'. +This controls how long the ispell help (on the '?' key) is displayed. + +** Flyspell mode + ++++ +*** Corrections and actions menu can be optionally bound to 'mouse-3'. +When Flyspell mode highlights a word as misspelled, you can click on +it to display a menu of possible corrections and actions. You can now +easily bind this menu to 'down-mouse-3' (usually the right mouse button) +instead of 'mouse-2' (the default) by enabling 'context-menu-mode'. + +--- +*** The current dictionary is now displayed in the minor mode lighter. +Clicking the dictionary name changes the current dictionary. + +** Package + +*** The new NonGNU ELPA archive is enabled by default alongside GNU ELPA. +Thus, packages on NonGNU ELPA will appear by default in the list shown +by 'list-packages'. + +--- +*** '/ s' ('package-menu-filter-by-status') changed parameter handling. +The command was documented to take a comma-separated list of statuses +to filter by, but instead it used the parameter as a regexp. The +command has been changed so that it now works as documented, and +checks statuses not as a regexp, but instead an exact match from the +comma-separated list. + ++++ +*** New command 'package-browse-url' and keystroke 'w'. + ++++ +*** New commands to filter the package list. +The filter commands are bound to the following keys: + +key binding +--- ------- +/ a package-menu-filter-by-archive +/ d package-menu-filter-by-description +/ k package-menu-filter-by-keyword +/ N package-menu-filter-by-name-or-description +/ n package-menu-filter-by-name +/ s package-menu-filter-by-status +/ v package-menu-filter-by-version +/ m package-menu-filter-marked +/ u package-menu-filter-upgradable +/ / package-menu-filter-clear + +*** Option to automatically native-compile packages upon installation. +Customize the user option 'package-native-compile' to enable automatic +native compilation of packages when they are installed. That option +is nil by default; if set non-nil, and if your Emacs was built with +native-compilation support, each package will be natively compiled +when it is installed, by invoking an asynchronous Emacs subprocess to +run the native-compilation of the package files. (Be sure to leave +Emacs running until these asynchronous subprocesses exit, or else the +native-compilation will be aborted when you exit Emacs.) + +--- +*** Column widths in 'list-packages' display can now be customized. +See the new user options 'package-name-column-width', +'package-version-column-width', 'package-status-column-width', and +'package-archive-column-width'. + +** Info + +--- +*** New user option 'Info-warn-on-index-alternatives-wrap'. +This option affects what happens when using the ',' command after +looking up an entry with 'i' in info buffers. If non-nil (the +default), the ',' command will now display a warning when proceeding +beyond the final index match, and tapping ',' once more will then take +you to the first match. + +** Abbrev mode + ++++ +*** Emacs can now suggest to use an abbrev based on text you type. +A new user option, 'abbrev-suggest', enables the new abbrev suggestion +feature. When enabled, if a user manually types a piece of text that +could have saved enough typing by using an abbrev, a hint will be +displayed in the echo area, mentioning the abbrev that could have been +used instead. + +** Bookmarks + +--- +*** Bookmarks can now be targets for new tabs. +When the bookmark.el library is loaded, a customize choice is added +to 'tab-bar-new-tab-choice' for new tabs to show the bookmark list. + +--- +*** New user option 'bookmark-set-fringe-mark'. +If non-nil, setting a bookmark will set a fringe mark on the current +line, and jumping to a bookmark will also set this mark. + +--- +*** New user option 'bookmark-menu-confirm-deletion'. +In Bookmark Menu mode, Emacs by default does not prompt for +confirmation when you type 'x' to execute the deletion of bookmarks +that have been marked for deletion. However, if this new option is +non-nil then Emacs will require confirmation with 'yes-or-no-p' before +deleting. + +--- +*** The 'list-bookmarks' menu is now based on 'tabulated-list-mode'. +The interactive bookmark list will now benefit from features in +'tabulated-list-mode' like sorting columns or changing column width. + +Support for the optional "inline" header line, allowing for a +header without using 'header-line-format', has been dropped. +The variables 'bookmark-bmenu-use-header-line' and +'bookmark-bmenu-inline-header-height' are now obsolete. + +** Recentf + +--- +*** The recentf files are no longer backed up. + +--- +*** 'recentf-auto-cleanup' now repeats daily when set to a time string. +When 'recentf-auto-cleanup' is set to a time string, it now repeats +every day, rather than only running once after the mode is turned on. + +** Calc + +--- +*** The behavior when doing forward-delete has been changed. +Previously, using the 'C-d' command would delete the final number in +the input field, no matter where point was. This has been changed to +work more traditionally, with 'C-d' deleting the next character. +Likewise, point isn't moved to the end of the string before inserting +digits. + ++++ +*** Setting the word size to zero disables word clipping. +The word size normally clips the results of certain bit-oriented +operations such as shifts and bitwise XOR. A word size of zero, set +by 'b w', makes the operation have effect on the whole argument values +and the result is not truncated in any way. + +--- +*** The '/' operator now has higher precedence in (La)TeX input mode. +It no longer has lower precedence than '+' and '-'. + +--- +*** New user option 'calc-make-windows-dedicated'. +When this user option is non-nil, Calc will mark its windows as +dedicated. + +** Calendar + ++++ +*** New user option 'calendar-time-zone-style'. +If 'numeric', calendar functions (eg 'calendar-sunrise-sunset') that display +time zones will use a form like "+0100" instead of "CET". + +** Imenu + ++++ +*** New user option 'imenu-max-index-time'. +If creating the imenu index takes longer than specified by this +option (default 5 seconds), imenu indexing is stopped. + +** ido + +--- +*** Switching on 'ido-mode' now also overrides 'ffap-file-finder'. + +--- +*** Killing virtual ido buffers interactively will make them go away. +Previously, killing a virtual ido buffer with 'ido-kill-buffer' didn't +do anything. This has now been changed, and killing virtual buffers +with that command will remove the buffer from recentf. + +** So Long + +--- +*** New 'so-long-predicate' function 'so-long-statistics-excessive-p'. +It efficiently detects the presence of a long line anywhere in the +buffer using 'buffer-line-statistics' (see above). This is now the +default predicate (replacing 'so-long-detected-long-line-p'). + +--- +*** Default values 'so-long-threshold' and 'so-long-max-lines' increased. +The values of these user options have been raised to 10000 bytes and 500 +lines respectively, to reduce the likelihood of false-positives when +'global-so-long-mode' is enabled. The latter value is now only used +by the old predicate, as the new predicate knows the longest line in +the entire buffer. + +--- +*** 'so-long-target-modes' now includes 'fundamental-mode' by default. +This means that 'global-so-long-mode' will also process files which were +not recognised. (This only has an effect if 'set-auto-mode' chooses +'fundamental-mode'; buffers which are simply in 'fundamental-mode' by +default are unaffected.) + +--- +*** New user options to preserve modes and variables. +The new options 'so-long-mode-preserved-minor-modes' and +'so-long-mode-preserved-variables' allow specified mode and variable +states to be maintained if 'so-long-mode' replaces the original major +mode. By default, these new options support 'view-mode'. + +** Grep + ++++ +*** New user option 'grep-match-regexp' matches grep markers to highlight. +Grep emits SGR ANSI escape sequences to color its output. The new +user option 'grep-match-regexp' holds the regular expression to match +the appropriate markers in order to provide highlighting in the source +buffer. The user option can be customized to accommodate other +grep-like tools. + +--- +*** The 'lgrep' command now ignores directories. +On systems where the grep command supports it, directories will be +skipped. + +*** Commands that use 'grep-find' now follow symlinks for command-line args. +This is because the default value of 'grep-find-template' now includes +the 'find' option '-H'. Commands that use that variable, including +indirectly via a call to 'xref-matches-in-directory', might be +affected. In particular, there should be no need anymore to ensure +any directory names on the 'find' command lines end in a slash. +This change is for better compatibility with old versions of non-GNU +'find', such as the one used on macOS. + +--- +*** New utility function 'grep-file-at-point'. +This returns the name of the file at point (if any) in 'grep-mode' +buffers. + +** Shell + +--- +*** New command in 'shell-mode': 'narrow-to-prompt'. +This is bound to 'C-x n d' in 'shell-mode' buffers, and narrows to the +command line under point (and any following output). + +--- +*** New user option 'shell-has-auto-cd'. +If non-nil, 'shell-mode' handles implicit "cd" commands, changing the +directory if the command is a directory. Useful for shells like "zsh" +that has this feature. + +** term-mode + +--- +*** New user option 'term-scroll-snap-to-bottom'. +By default, 'term' and 'ansi-term' will now recenter the buffer so +that the prompt is on the final line in the window. Setting this new +user option to nil inhibits this behavior. + +--- +*** New user option 'term-set-terminal-size' +If non-nil, the 'LINES' and 'COLUMNS' environment variables will be set +based on the current window size. In previous versions of Emacs, this +was always done (and that could lead to odd displays when resizing the +window after starting). This variable defaults to nil. + +--- +*** 'term-mode' now supports "bright" color codes. +"Bright" ANSI color codes are now displayed using the color values +defined in 'term-color-bright-*'. In addition, bold text with regular +ANSI colors can be displayed as "bright" if 'ansi-color-bold-is-bright' +is non-nil. + +** Eshell + +--- +*** 'eshell-hist-ignoredups' can now also be used to mimic "erasedups" in bash. + +--- +*** Environment variable 'INSIDE_EMACS' is now copied to subprocesses. +Its value contains the result of evaluating '(format "%s,eshell" +emacs-version)'. Other package names, like "tramp", could also be included. + +--- +*** Eshell no longer re-initializes its keymap every call. +This allows users to use (define-key eshell-mode-map ...) as usual. +Some modules have their own minor mode now to account for these +changes. + +*** Support for bookmark.el. +The command 'bookmark-set' (bound to 'C-x r m') is now supported, and +will create a bookmark that opens the current directory in Eshell. + +** Archive mode + +--- +*** Archive Mode can now parse ".squashfs" files. + +*** Can now modify members of 'ar' archives. + +*** Display of summaries is unified between backends. + +*** New user option and command to control displayed columns. +New user option 'archive-hidden-columns' and new command +'archive-hideshow-column' let you control which columns are displayed +and which are kept hidden. + +--- +*** New command bound to 'C': 'archive-copy-file'. +This command extracts the file at point and writes its data to a +file. + +** browse-url + +*** Added support for custom URL handlers. +There is a new variable 'browse-url-default-handlers' and a user +option 'browse-url-handlers' being alists with '(REGEXP-OR-PREDICATE +. FUNCTION)' entries allowing to define different browsing FUNCTIONs +depending on the URL to be browsed. The variable is for default +handlers provided by Emacs itself or external packages, the user +option is for the user (and allows for overriding the default +handlers). + +Formerly, one could do the same by setting +'browse-url-browser-function' to such an alist. This usage is still +supported but deprecated. + +*** Categorization of browsing commands into internal vs. external. +All standard browsing commands such as 'browse-url-firefox', +'browse-url-mail', or 'eww' have been categorized into internal (URL +is browsed in Emacs) or external (an external application is spawned +with the URL). This is done by adding a 'browse-url-browser-kind' +symbol property to the browsing commands. With a new command +'browse-url-with-browser-kind', an URL can explicitly be browsed with +either an internal or external browser. + +--- +*** Support for browsing of remote files. +If a remote file is specified, a local temporary copy of that file is +passed to the browser. + +--- +*** Support for the conkeror browser is now obsolete. + +--- +*** Support for the Mosaic browser has been removed. +This support has been obsolete since 25.1. + +** Completion List Mode + +*** Improved navigation in the "*Completions*" buffer. +New key bindings have been added to 'completion-list-mode': 'n' and +'p' now navigate completions, and 'M-g M-c' switches to the +minibuffer and back to the completion list buffer. + ++++ +** profiler.el +The results displayed by 'profiler-report' now have the usage figures +at the left hand side followed by the function name. This is intended +to make better use of the horizontal space, in particular eliminating +the truncation of function names. There is no way to get the former +layout back. + +** Icomplete + +--- +*** New user option 'icomplete-matches-format'. +This allows controlling the current/total number of matches for the +prompt prefix. + ++++ +*** New minor modes 'icomplete-vertical-mode' and 'fido-vertical-mode'. +These modes modify Icomplete ('M-x icomplete-mode') and Fido ('M-x +fido-mode'), to display completion candidates vertically instead of +horizontally. In Icomplete, completions are rotated and selection +kept at the top. In Fido, completions scroll like a typical dropdown +widget. Both these new minor modes will turn on their non-vertical +counterparts first, if they are not on already. + +--- +*** Default value of 'icomplete-compute-delay' has been changed to 0.15 s. + +--- +*** Default value of 'icomplete-max-delay-chars' has been changed to 2. + +--- +*** Reduced blinking while completing the next completions set. +Icomplete doesn't hide the hint with the previously computed +completions anymore when compute delay is in effect, or the previous +computation has been aborted by input. Instead it shows the previous +completions until the new ones are ready. + +--- +*** Change in meaning of 'icomplete-show-matches-on-no-input'. +Previously, choosing a different completion with commands like 'C-.' +and then hitting 'RET' would choose the default completion. Doing this +will now choose the completion under point instead. Also when this option +is nil, completions are not shown when the minibuffer reads a file name +with initial input as the default directory. + +** Windmove + ++++ +*** New user options to customize windmove keybindings. +These options include 'windmove-default-keybindings', +'windmove-display-default-keybindings', +'windmove-delete-default-keybindings', +'windmove-swap-states-default-keybindings'. +Also new mode 'windmove-mode' enables the customized keybindings. + +** Occur mode + +--- +*** New bindings in occur-mode. +The command 'next-error-no-select' is now bound to 'n' and +'previous-error-no-select' is bound to 'p'. + +--- +*** New command 'recenter-current-error'. +It is bound to 'l' in Occur or compilation buffers, and recenters the +current displayed occurrence/error. + +--- +*** Matches in target buffers are now highlighted as in 'compilation-mode'. +The method of highlighting is specified by the user options +'next-error-highlight' and 'next-error-highlight-no-select'. + +--- +*** A fringe arrow in the "*Occur*" buffer indicates the selected match. + +--- +*** Occur mode may use a different type for 'occur-target' property values. +The value was previously always a marker set to the start of the first +match on the line but can now also be a list of '(BEGIN . END)' pairs +of markers delimiting each match on the line. +This is a fully compatible change to the internal occur-mode +implementation, and code creating their own occur-mode buffers will +work as before. + +** Emacs Lisp mode + +--- +*** The mode-line now indicates whether we're using lexical or dynamic scoping. + ++++ +*** A space between an open paren and a symbol changes the indentation rule. +The presence of a space between an open paren and a symbol now is +taken as a statement by the programmer that this should be indented +as a data list rather than as a piece of code. + +** Lisp Mode + +*** New minor mode 'cl-font-lock-built-in-mode' for 'lisp-mode'. +The mode provides refined highlighting of built-in functions, types, +and variables. + +--- +*** Lisp mode now uses 'common-lisp-indent-function'. +To revert to the previous behavior, +'(setq lisp-indent-function 'lisp-indent-function)' from 'lisp-mode-hook'. + +** Change Logs and VC + ++++ +*** 'vc-revert-show-diff' now has a third possible value: 'kill'. +If this user option is 'kill', then the diff buffer will be killed +after the 'vc-revert' action instead of buried. + +--- +*** More VC commands can be used from non-file buffers. +The relevant commands are those that don't change the VC state. +The non-file buffers which can use VC commands are those that have +their 'default-directory' under VC. + +--- +*** New face 'log-view-commit-body'. +This is used when expanding commit messages from 'vc-print-root-log' +and similar commands. + +--- +*** New faces for 'vc-dir' buffers. +Those are: 'vc-dir-header', 'vc-dir-header-value', 'vc-dir-directory', +'vc-dir-file', 'vc-dir-mark-indicator', 'vc-dir-status-warning', +'vc-dir-status-edited', 'vc-dir-status-up-to-date', +'vc-dir-status-ignored'. + +--- +*** The responsible VC backend is now the most specific one. +'vc-responsible-backend' loops over the backends in +'vc-handled-backends' to determine which backend is responsible for a +specific (unregistered) file. Previously, the first matching backend +was chosen, but now the one with the most specific path is chosen (in +case there's a directory handled by one backend inside another). + +--- +*** New command 'vc-dir-root' uses the root directory without asking. + +--- +*** New commands 'vc-dir-mark-registered-files' (bound to '* r') and +'vc-dir-mark-unregistered-files'. + +--- +*** Support for bookmark.el. +Bookmark locations can refer to VC directory buffers. + +--- +*** New user option 'vc-hg-create-bookmark'. +It controls whether a bookmark or branch will be created when you +invoke 'C-u C-x v s' ('vc-create-tag'). + +--- +*** 'vc-hg' now uses 'hg summary' to populate extra 'vc-dir' headers. + +--- +*** New user option 'vc-git-revision-complete-only-branches'. +If non-nil, only branches and remotes are considered when doing +completion over Git branch names. The default is nil, which causes +tags to be considered as well. + +--- +*** New user option 'vc-git-log-switches'. +String or list of strings specifying switches for Git log under VC. + +--- +*** Command 'vc-switch-backend' is now obsolete. +If you are still using it with any regularity, please file a bug +report with some details. + +** Gnus + ++++ +*** New user option 'gnus-topic-display-predicate'. +This can be used to inhibit the display of some topics completely. + ++++ +*** nnimap now supports the oauth2.el library. + ++++ +*** New Summary buffer sort options for extra headers. +The extra header sort option ('C-c C-s C-x') prompts for a header +and fails if no sort function has been defined. Sorting by +Newsgroups ('C-c C-s C-u') has been pre-defined. + ++++ +*** The '#' command in the Group and Summary buffer now toggles, +instead of sets, the process mark. + ++++ +*** New user option 'gnus-process-mark-toggle'. +If non-nil (the default), the '#' command in the Group and Summary +buffers will toggle, instead of set, the process mark. + ++++ +*** New user option 'gnus-registry-register-all'. +If non-nil (the default), create registry entries for all messages. +If nil, don't automatically create entries, they must be created +manually. + ++++ +*** New user options to customise the summary line specs "%[" and "%]". +Four new options introduced in customisation group +'gnus-summary-format'. These are 'gnus-sum-opening-bracket', +'gnus-sum-closing-bracket', 'gnus-sum-opening-bracket-adopted', and +'gnus-sum-closing-bracket-adopted'. Their default values are "[", "]", +"<", ">" respectively. These options control the appearance of "%[" +and "%]" specs in the summary line format. "%[" will normally display +the value of 'gnus-sum-opening-bracket', but can also be +'gnus-sum-opening-bracket-adopted' for the adopted articles. "%]" will +normally display the value of 'gnus-sum-closing-bracket', but can also +be 'gnus-sum-closing-bracket-adopted' for the adopted articles. + ++++ +*** New user option 'gnus-paging-select-next'. +This controls what happens when using commands like 'SPC' and 'DEL' to +page the current article. If non-nil (the default), go to the +next/prev article, but if nil, do nothing at the end/start of the article. + ++++ +*** New gnus-search library. +A new unified search syntax which can be used across multiple +supported search engines. Set 'gnus-search-use-parsed-queries' to +non-nil to enable. + ++++ +*** New value for user option 'smiley-style'. +Smileys can now be rendered with emojis instead of small images when +using the new 'emoji' value in 'smiley-style'. + ++++ +*** New user option 'gnus-agent-eagerly-store-articles'. +If non-nil (which is the default), the Gnus Agent will store all read +articles in the Agent cache. + ++++ +*** New user option 'gnus-global-groups'. +Gnus handles private groups differently from public (i.e., NNTP-like) +groups. Most importantly, Gnus doesn't download external images from +mail-like groups. This can be overridden by putting group names in +'gnus-global-groups': Any group present in that list will be treated +like a public group. + ++++ +*** New scoring types for the Date header. +You can now score based on the relative age of an article with the new +'<' and '>' date scoring types. + ++++ +*** User-defined scoring is now possible. +The new type is 'score-fn'. More information in the Gnus manual node +"(gnus) Score File Format". + ++++ +*** New backend 'nnselect'. +The newly added 'nnselect' backend allows creating groups from an +arbitrary list of articles that may come from multiple groups and +servers. These groups generally behave like any other group: they may +be ephemeral or persistent, and allow article marking, moving, +deletion, etc. 'nnselect' groups may be created like any other group, +but there are three convenience functions for the common case of +obtaining the list of articles as a result of a search: +'gnus-group-make-search-group' ('G g') that will prompt for an 'nnir' +search query and create a persistent group for that search; +'gnus-group-read-ephemeral-search-group' ('G G') that will prompt for +an 'nnir' search query and create an ephemeral group for that search; +and 'gnus-summary-make-group-from-search' ('C-c C-p') that will create +a persistent group with the search parameters of a current ephemeral +search group. + +As part of this addition, the user option 'nnir-summary-line-format' +has been removed; its functionality is now available directly in the +'gnus-summary-line-format' specs '%G' and '%g'. The user option +'gnus-refer-thread-use-nnir' has been renamed to +'gnus-refer-thread-use-search'. + ++++ +*** New user option 'gnus-dbus-close-on-sleep'. +On systems with D-Bus support, it is now possible to register a signal +to close all Gnus servers before the system sleeps. + ++++ +*** The key binding of 'gnus-summary-search-article-forward' has changed. +This command was previously on 'M-s' and shadowed the global 'M-s' +search prefix. The command has now been moved to 'M-s M-s'. (For +consistency, the 'M-s M-r' key binding has been added for the +'gnus-summary-search-article-backward' command.) + +--- +*** The value for "all" in the 'large-newsgroup-initial' group parameter has changed. +It was previously nil, which didn't work, because nil is +indistinguishable from not being present. The new value for "all" is +the symbol 'all'. + ++++ +*** The name of dependent Gnus sessions has changed from "slave" to "child". +The names of the commands 'gnus-slave', 'gnus-slave-no-server' and +'gnus-slave-unplugged' have changed to 'gnus-child', +'gnus-child-no-server' and 'gnus-child-unplugged' respectively. + ++++ +*** The 'W Q' summary mode command now takes a numerical prefix to +allow adjusting the fill width. + ++++ +*** New variable 'mm-inline-font-lock'. +This variable is supposed to be bound by callers to determine whether +inline MIME parts (that support it) are supposed to be font-locked or +not. + +** Message + +--- +*** Respect 'message-forward-ignored-headers' more. +Previously, this user option would not be consulted if +'message-forward-show-mml' was nil and forwarding as MIME. + ++++ +*** New user option 'message-forward-included-mime-headers'. +This is used when forwarding messages as MIME, but not using MML. + ++++ +*** Message now supports the OpenPGP header. +To generate these headers, add the new function +'message-add-openpgp-header' to 'message-send-hook'. The header will +be generated according to the new 'message-openpgp-header' user +option. + +--- +*** A change to how "Mail-Copies-To: never" is handled. +If a user has specified "Mail-Copies-To: never", and Message was asked +to do a "wide reply", some other arbitrary recipient would end up in +the resulting "To" header, while the remaining recipients would be put +in the "Cc" header. This is somewhat misleading, as it looks like +you're responding to a specific person in particular. This has been +changed so that all the recipients are put in the "To" header in these +instances. + ++++ +*** New command to start Emacs in Message mode to send an email. +Emacs can be defined as a handler for the "x-scheme-handler/mailto" +MIME type with the following command: "emacs -f message-mailto %u". +An "emacs-mail.desktop" file has been included, suitable for +installing in desktop directories like "/usr/share/applications" or +"~/.local/share/applications". +Clicking on a 'mailto:' link in other applications will then open +Emacs with headers filled out according to the link, e.g. +"mailto:larsi@gnus.org?subject=This+is+a+test". If you prefer +emacsclient, use "emacsclient -e '(message-mailto "%u")'" +or "emacsclient-mail.desktop". + +--- +*** Change to default value of 'message-draft-headers' user option. +The 'Date' symbol has been removed from the default value, meaning that +draft or delayed messages will get a date reflecting when the message +was sent. To restore the original behavior of dating a message +from when it is first saved or delayed, add the symbol 'Date' back to +this user option. + ++++ +*** New command to take screenshots. +In Message mode buffers, the 'C-c C-p' ('message-insert-screenshot') +command has been added. It depends on using an external program to +take the actual screenshot, and defaults to "ImageMagick import". + +** Smtpmail + ++++ +*** smtpmail now supports using the oauth2.el library. + ++++ +*** New user option 'smtpmail-store-queue-variables'. +If non-nil, SMTP variables will be stored together with the queued +messages, and will then be used when sending with +'M-x smtpmail-send-queued-mail'. + ++++ +*** Allow direct selection of smtp authentication mechanism. +A server entry retrieved by auth-source can request a desired smtp +authentication mechanism by setting a value for the key 'smtp-auth'. + +** ElDoc + ++++ +*** New user option 'eldoc-echo-area-display-truncation-message'. +If non-nil (the default), eldoc will display a message saying +something like "(Documentation truncated. Use `M-x eldoc-doc-buffer' +to see rest)" when a message has been truncated. If nil, truncated +messages will be marked with just "..." at the end. + ++++ +*** New hook 'eldoc-documentation-functions'. +This hook is intended to be used for registering doc string functions. +These functions don't need to produce the doc string right away, they +may arrange for it to be produced asynchronously. The results of all +doc string functions are accessible to the user through the user +option 'eldoc-documentation-strategy'. + +*** New hook 'eldoc-display-functions'. +This hook is intended to be used for displaying doc strings. The +functions receive the doc string composed according to +'eldoc-documentation-strategy' and are tasked with displaying it to +the user. Examples of such functions would use the echo area, a +separate buffer, or a tooltip. + ++++ +*** New user option 'eldoc-documentation-strategy'. +The built-in choices available for this user option let users compose +the results of 'eldoc-documentation-functions' in various ways, even +if some of those functions are synchronous and some asynchronous. +The user option replaces 'eldoc-documentation-function', which is now +obsolete. + +*** 'eldoc-echo-area-use-multiline-p' is now handled by ElDoc. +The user option 'eldoc-echo-area-use-multiline-p' is now handled +by the ElDoc library itself. Functions in +'eldoc-documentation-functions' don't need to worry about consulting +it when producing a doc string. + +** Tramp + ++++ +*** New connection method "mtp". +It allows accessing media devices like cell phones, tablets or +cameras. + ++++ +*** New connection method "sshfs". +It allows accessing remote files via a file system mounted with +'sshfs'. + ++++ +*** Tramp supports SSH authentication via a hardware security key now. +This requires at least OpenSSH 8.2, and a FIDO U2F compatible +security key, like yubikey, solokey, or nitrokey. + ++++ +*** Trashed remote files are moved to the local trash directory. +All remote files that are trashed are moved to the local trash +directory, except remote encrypted files, which are always deleted. + ++++ +*** New command 'tramp-crypt-add-directory'. +This command marks a remote directory to contain only encrypted files. +See the "(tramp) Keeping files encrypted" node of the Tramp manual for +details. This feature is experimental. + ++++ +*** Support of direct asynchronous process invocation. +When Tramp connection property "direct-async-process" is set to +non-nil for a given connection, 'make-process' and 'start-file-process' +calls are performed directly as in "ssh ... <command>". This avoids +initialization performance penalties. See the "(tramp) Improving +performance of asynchronous remote processes" node of the Tramp manual +for details, and also for a discussion or restrictions. This feature +is experimental. + ++++ +*** New user option 'tramp-debug-to-file'. +When non-nil, this user option instructs Tramp to mirror the debug +buffer to a file under the "/tmp/" directory. This is useful, if (in +rare cases) Tramp blocks Emacs, and we need further debug information. + ++++ +*** Tramp supports lock files now. +In order to deactivate this, set user option +'remote-file-name-inhibit-locks' to t. + ++++ +*** Writing sensitive data locally requires confirmation. +Writing auto-save, backup or lock files to the local temporary +directory must be confirmed. In order to suppress this confirmation, +set user option 'tramp-allow-unsafe-temporary-files' to t. + ++++ +*** 'make-directory' of a remote directory honors the default file modes. + +** gdb-mi + +*** New user option 'gdb-registers-enable-filter'. +If non-nil, apply a register filter based on +'gdb-registers-filter-pattern-list'. + ++++ +*** gdb-mi can now save and restore window configurations. +Use 'gdb-save-window-configuration' to save window configuration to a +file and 'gdb-load-window-configuration' to load from a file. These +commands can also be accessed through the menu bar under "Gud => +GDB-Windows". 'gdb-default-window-configuration-file', when non-nil, +is loaded when GDB starts up. + ++++ +*** gdb-mi can now restore window configuration after quitting. +Set 'gdb-restore-window-configuration-after-quit' to non-nil and Emacs +will remember the window configuration before GDB started and restore +it after GDB quits. A toggle button is also provided under "Gud => +GDB-Windows" menu item. + ++++ +*** gdb-mi now has a better logic for displaying source buffers. +Now GDB only uses one source window to display source file by default. +Customize 'gdb-max-source-window-count' to use more than one window. +Control source file display by 'gdb-display-source-buffer-action'. + ++++ +*** The default value of 'gdb-mi-decode-strings' is now t. +This means that the default coding-system is now used to decode strings +and source file names from GDB. + +** Compilation mode + +--- +*** New function 'ansi-color-compilation-filter'. +This function is meant to be used in 'compilation-filter-hook'. + +--- +*** New user option 'ansi-color-for-compilation-mode'. +This controls what 'ansi-color-compilation-filter' does. + +*** Regexp matching of messages is now case-sensitive by default. +The variable 'compilation-error-case-fold-search' can be set for +case-insensitive matching of messages when the old behavior is +required, but the recommended solution is to use a correctly matching +regexp instead. + +--- +*** New user option 'compilation-search-all-directories'. +When doing parallel builds, directories and compilation errors may +arrive in the "*compilation*" buffer out-of-order. If this option is +non-nil (the default), Emacs will now search backwards in the buffer +for any directory the file with errors may be in. If nil, this won't +be done (and this restores how this previously worked). + +--- +*** Messages from ShellCheck are now recognized. + +--- +*** Messages from Visual Studio that mention column numbers are now recognized. + +** Hi Lock mode + +--- +*** Matching in 'hi-lock-mode' can be case-sensitive. +The matching is case-sensitive when a regexp contains upper case +characters and 'search-upper-case' is non-nil. 'highlight-phrase' +also uses 'search-whitespace-regexp' to substitute spaces in regexp +search. + +--- +*** The default value of 'hi-lock-highlight-range' was enlarged. +The new default value is 2000000 (2 megabytes). + +** Whitespace mode + ++++ +*** New style 'missing-newline-at-eof'. +If present in 'whitespace-style' (as it is by default), the final +character in the buffer will be highlighted if the buffer doesn't end +with a newline. + +--- +*** The default 'whitespace-enable-predicate' predicate has changed. +It used to check elements in the list version of +'whitespace-global-modes' with 'eq', but now uses 'derived-mode-p'. + +** Texinfo + +--- +*** New user option 'texinfo-texi2dvi-options'. +This is used when invoking 'texi2dvi' from 'texinfo-tex-buffer'. + +--- +*** New commands for moving in and between environments. +An "environment" is something that ends with '@end'. The commands are +'C-c C-c C-f' (next end), 'C-c C-c C-b' (previous end), +'C-c C-c C-n' (next start) and 'C-c C-c C-p' (previous start), as well +as 'C-c .', which will alternate between the start and the end of the +current environment. + +** Rmail + +--- +*** New user option 'rmail-re-abbrevs'. +Its default value matches localized abbreviations of the "reply" +prefix on the Subject line in various languages. + +--- +*** New user option 'rmail-show-message-set-modified'. +If set non-nil, showing an unseen message will set the Rmail buffer's +modified flag. The default is nil, to preserve the old behavior. + +** CC Mode + ++++ +*** Added support for Doxygen documentation style. +'doxygen' is now a valid 'c-doc-comment-style' which recognises all +comment styles supported by Doxygen (namely '///', '//!', '/** … */' +and '/*! … */'. 'gtkdoc' remains the default for C and C++ modes; to +use 'doxygen' by default one might evaluate: + + (setq-default c-doc-comment-style + '((java-mode . javadoc) + (pike-mode . autodoc) + (c-mode . doxygen) + (c++-mode . doxygen))) + +or use it in a custom 'c-style'. + ++++ +*** Added support to line up '?' and ':' of a ternary operator. +The new 'c-lineup-ternary-bodies' function can be used as a lineup +function to align question mark and colon which are part of a ternary +operator ('?:'). For example: + + return arg % 2 == 0 ? arg / 2 + : (3 * arg + 1); + +To enable, add it to appropriate entries in 'c-offsets-alist', e.g.: + + (c-set-offset 'arglist-cont '(c-lineup-ternary-bodies + c-lineup-gcc-asm-reg)) + (c-set-offset 'arglist-cont-nonempty '(c-lineup-ternary-bodies + c-lineup-gcc-asm-reg + c-lineup-arglist)) + (c-set-offset 'statement-cont '(c-lineup-ternary-bodies +)) + +** Images + +--- +*** You can explicitly specify base_uri for svg images. +':base-uri' image property can be used to explicitly specify base_uri +for embedded images into svg. ':base-uri' is supported for both file +and data svg images. + ++++ +*** 'svg-embed-base-uri-image' added to embed images. +'svg-embed-base-uri-image' can be used to embed images located +relatively to 'file-name-directory' of the ':base-uri' svg image property. +This works much faster than 'svg-embed'. + ++++ +*** New function 'image-cache-size'. +This function returns the size of the current image cache, in bytes. + +--- +*** Animated images stop automatically under high CPU pressure sooner. +Previously, an animated image would stop animating if any single image +took more than two seconds to display. The new algorithm maintains a +decaying average of delays, and if this number gets too high, the +animation is stopped. + ++++ +*** The 'n' and 'p' commands (next/previous image) now respect Dired order. +These commands would previously display the next/previous image in +lexicographic order, but will now find the "parent" Dired buffer and +select the next/previous image file according to how the files are +sorted there. The commands have also been extended to work when the +"parent" buffer is an archive mode (i.e., zip file or the like) or tar +mode buffer. + +--- +*** 'image-converter' is now restricted to formats in 'auto-mode-alist'. +When using external image converters, the external program is queried +for what formats it supports. This list may contain formats that are +problematic in some contexts (like PDFs), so this list is now filtered +based on 'auto-mode-alist'. Only file names that map to 'image-mode' +are now supported. + +--- +*** The background and foreground of images now default to face colors. +When an image doesn't specify a foreground or background color, Emacs +now uses colors from the face used to draw the surrounding text +instead of the frame's default colors. + +To load images with the default frame colors use the ':foreground' and +':background' image attributes, for example: + + (create-image "filename" nil nil + :foreground (face-attribute 'default :foreground) + :background (face-attribute 'default :background)) + +This change only affects image types that support foreground and +background colors or transparency, such as xbm, pbm, svg, png and gif. + ++++ +*** Image smoothing can now be explicitly enabled or disabled. +Smoothing applies a bilinear filter while scaling or rotating an image +to prevent aliasing and other unwanted effects. The new image +property ':transform-smoothing' can be set to t to force smoothing +and nil to disable smoothing. + +The default behavior of smoothing on down-scaling and not smoothing +on up-scaling remains unchanged. + ++++ +*** New user option 'image-transform-smoothing'. +This controls whether to use smoothing or not for an image. Values +include nil (no smoothing), t (do smoothing) or a predicate function +that's called with the image object and should return nil/t. + ++++ +*** SVG images now support user stylesheets. +The ':css' image attribute can be used to override the default CSS +stylesheet for an image. The default sets 'font-family' and +'font-size' to match the current face, so an image with 'height="1em"' +will match the font size in use where it is embedded. + +This feature relies on librsvg 2.48 or above being available. + ++++ +*** Image properties support 'em' sizes. +Size image properties, for example ':height', ':max-height', etc., can +be given a cons of the form '(SIZE . em)', where SIZE is an integer or +float which is multiplied by the font size to calculate the image +size, and 'em' is a symbol. + +** EWW + ++++ +*** New user option 'eww-use-browse-url'. +This is a regexp that can be set to alter how links are followed in eww. + ++++ +*** New user option 'eww-retrieve-command'. +This can be used to download data via an external command. If nil +(the default), then 'url-retrieve' is used. When 'sync', then +'url-retrieve-synchronously' is used. A list of strings specifies +an external program with parameters. + ++++ +*** New Emacs command line convenience command. +The 'eww-browse' command has been added, which allows you to register +Emacs as a MIME handler for "text/x-uri", and will call 'eww' on the +supplied URL. Usage example: "emacs -f eww-browse https://gnu.org". + ++++ +*** 'eww-download-directory' will now use the XDG location, if defined. +However, if "~/Downloads/" already exists, that will continue to be +used. + +--- +*** The command 'eww-follow-link' now supports custom mailto: handlers. +The function that is invoked when clicking on or otherwise following a +'mailto:' link in an EWW buffer can now be customized. For more +information, see the related entry about 'shr-browse-url' below. + +--- +*** Support for bookmark.el. +The command 'bookmark-set' (bound to 'C-x r m') is now supported, and +will create a bookmark that opens the current URL in EWW. + +** SHR + +--- +*** The command 'shr-browse-url' now supports custom mailto handlers. +Clicking on or otherwise following a 'mailto:' link in an HTML buffer +rendered by SHR previously invoked the command 'browse-url-mailto'. +This is still the case by default, but if you customize +'browse-url-mailto-function' or 'browse-url-handlers' to call some +other function, it will now be called instead of the default. + +--- +*** New user option 'shr-offer-extend-specpdl'. +If this is nil, rendering of HTML that requires enlarging +'max-specpdl-size', the number of Lisp variable bindings, will be +aborted, and Emacs will not ask you whether to enlarge +'max-specpdl-size' to complete the rendering. The default is t, which +preserves the original behavior. + ++++ +*** New user option 'shr-max-width'. +If this user option is non-nil, and 'shr-width' is nil, then SHR will +use the value of 'shr-max-width' to limit the width of the rendered +HTML. The default is 120 characters, so even if you have very wide +frames, HTML text will be rendered more narrowly, which usually leads +to a more readable text. Customize it to nil to get the previous +behavior of rendering as wide as the 'window-width' allows. If +'shr-width' is non-nil, it overrides this option. + +--- +*** New faces for heading elements. +Those are 'shr-h1', 'shr-h2', 'shr-h3', 'shr-h4', 'shr-h5', 'shr-h6'. + +** Project + +--- +*** New user option 'project-vc-merge-submodules'. + +--- +*** Project commands now have their own history. +Previously used project directories are now suggested by all commands +that prompt for a project directory. + ++++ +*** New prefix keymap 'project-prefix-map'. +Key sequences that invoke project-related commands start with the +prefix 'C-x p'. Type 'C-x p C-h' to show the full list. + ++++ +*** New commands 'project-dired', 'project-vc-dir', 'project-shell', +'project-eshell'. These commands run Dired/VC-Dir and Shell/Eshell in +a project's root directory, respectively. + ++++ +*** New command 'project-compile'. +This command runs compilation in the current project's root directory. + ++++ +*** New command 'project-switch-project'. +This command lets you "switch" to another project and run a project +command chosen from a dispatch menu. + ++++ +*** New commands 'project-shell-command' and 'project-async-shell-command'. +These commands run 'shell-command' and 'async-shell-command' in a +project's root directory, respectively. + ++++ +*** New user option 'project-list-file'. +This specifies the file in which to save the list of known projects. + ++++ +*** New command 'project-remember-projects-under'. +This command can automatically locate and index projects in a +directory and optionally also its subdirectories, storing them in +'project-list-file'. + ++++ +*** New commands 'project-forget-project' and 'project-forget-projects-under'. +These commands let you interactively remove entries from the list of projects +in 'project-list-file'. + ++++ +*** New command 'project-forget-zombie-projects'. +This command detects indexed projects that have since been deleted, +and removes them from the list of known projects in 'project-list-file'. + +--- +*** 'project-find-file' now accepts non-existent file names. +This is to allow easy creation of files inside some nested +sub-directory. + ++++ +*** 'project-find-file' doesn't use the string at point as default input. +Now it's only suggested as part of the "future history", accessible +via 'M-n'. + ++++ +*** New command 'project-find-dir' runs Dired in a directory inside project. + +** Xref + ++++ +*** New user options to automatically show the first Xref match. +The new user option 'xref-auto-jump-to-first-definition' controls the +behavior of 'xref-find-definitions' and its variants, like +'xref-find-definitions-other-window': if it's t or 'show', the first +match is automatically displayed; if it's 'move', point in the +"*xref*" buffer is automatically moved to the first match without +displaying it. +The new user option 'xref-auto-jump-to-first-xref' changes the +behavior of Xref commands such as 'xref-find-references', +'xref-find-apropos', and 'project-find-regexp', which are expected to +display many matches that the user would like to +visit. 'xref-auto-jump-to-first-xref' changes their behavior much in +the same way as 'xref-auto-jump-to-first-definition' affects the +"find-definitions" commands. + +--- +*** New user options 'xref-search-program' and 'xref-search-program-alist'. +So far 'grep' and 'ripgrep' are supported. 'ripgrep' seems to offer better +performance in certain cases, in particular for case-insensitive +searches. + ++++ +*** New commands 'xref-prev-group' and 'xref-next-group'. +These commands are bound respectively to 'P' and 'N', and navigate to +the first item of the previous or next group in the "*xref*" buffer. + +--- +*** New alternative value for 'xref-show-definitions-function': +'xref-show-definitions-completing-read'. + +--- +*** The two existing alternatives for 'xref-show-definitions-function' +have been renamed to have "proper" public names and documented +('xref-show-definitions-buffer' and +'xref-show-definitions-buffer-at-bottom'). + ++++ +*** New command 'xref-quit-and-pop-marker-stack'. +This command is bound to 'M-,' in "*xref*" buffers. This combination +is easy to press semi-accidentally if the user wants to go back in the +middle of choosing the exact definition to go to, and this should do +TRT. + +--- +*** New value 'project-relative' for 'xref-file-name-display'. +If chosen, file names in "*xref*" buffers will be displayed relative +to the 'project-root' of the current project, when available. + +--- +*** Prefix arg of 'xref-goto-xref' quits the "*xref*" buffer. +So typing 'C-u RET' in the "*xref*" buffer quits its window +before navigating to the selected location. + ++++ +*** The 'TAB' key binding in "*xref*" buffers is obsolete. +Use 'C-u RET' instead. The 'TAB' binding in "*xref*" buffers is still +supported, but we plan on removing it in a future version; at that +time, the command 'xref-quit-and-goto-xref' will no longer have a key +binding in 'xref--xref-buffer-mode-map'. + +--- +*** New user option 'etags-xref-prefer-current-file'. +When non-nil, matches for identifiers in the file visited by the +current buffer will be shown first in the "*xref*" buffer. + ++++ +*** The etags Xref backend now honors 'tags-apropos-additional-actions'. +You can customize it to augment the output of 'xref-find-apropos', +like it affected the output of 'tags-apropos', which is obsolete since +Emacs 25.1. + +** Battery + +--- +*** UPower is now the default battery status backend when available. +UPower support via the function 'battery-upower' was added in Emacs +26.1, but was disabled by default. It is now the default value of +'battery-status-function' when the system provides a UPower D-Bus +service. The user options 'battery-upower-device' and +'battery-upower-subscribe' control which power sources to query and +whether to respond to status change notifications in addition to +polling, respectively. + +--- +*** A richer syntax can be used to format battery status information. +The user options 'battery-mode-line-format' and +'battery-echo-area-format' now support the full formatting syntax of +the function 'format-spec' documented under node "(elisp) Custom Format +Strings". The new syntax includes specifiers for padding and +truncation, amongst other things. + +** bug-reference.el + +--- +*** Bug reference mode uses auto-setup. +If 'bug-reference-mode' or 'bug-reference-prog-mode' have been +activated, their respective hook has been run, and both +'bug-reference-bug-regexp' and 'bug-reference-url-format' are still +not set, it tries to guess appropriate values for those two variables. +There are three guessing mechanisms so far: based on version control +information of the current buffer's file, based on +newsgroup/mail-folder name and several news and mail message headers +in Gnus buffers, and based on IRC channel and network in rcirc and ERC +buffers. All the mechanisms are extensible with custom rules, see the +variables 'bug-reference-setup-from-vc-alist', +'bug-reference-setup-from-mail-alist', and +'bug-reference-setup-from-irc-alist'. + +** HTML Mode + +--- +*** A new skeleton for adding relative URLs has been added. +It's bound to the 'C-c C-c f' keystroke, and prompts for a local file +name. + +** Widget + ++++ +*** 'widget-choose' now supports menus in extended format. + +--- +*** The 'editable-list' widget now supports moving items up and down. +You can now move items up and down by deleting and then reinserting +them, using the 'DEL' and 'INS' buttons respectively. This is useful +in Custom buffers, for example, to change the order of the elements in +a list. + +** Diff + +--- +*** New face 'diff-changed-unspecified'. +This is used to highlight "changed" lines (those marked with '!') in +context diffs, when 'diff-use-changed-face' is non-nil. + +--- +*** New 'diff-mode' font locking face 'diff-error'. +This face is used for error messages from 'diff'. + ++++ +*** New command 'diff-refresh-hunk'. +This new command (bound to 'C-c C-l') regenerates the current hunk. + +** thing-at-point + ++++ +*** New 'thing-at-point' target: 'existing-filename'. +This is like 'filename', but is a full path, and is nil if the file +doesn't exist. + ++++ +*** New 'thing-at-point' target: 'string'. +If point is inside a string, it returns that string. + ++++ +*** New variable 'thing-at-point-provider-alist'. +This allows mode-specific alterations to how 'thing-at-point' works. + +--- +*** thing-at-point now respects fields. +'thing-at-point' (and all functions that use it, like +'symbol-at-point') will narrow to the current field (if any) before +trying to identify the thing at point. + +--- +*** New function 'thing-at-mouse'. +This is like 'thing-at-point', but uses the mouse event position instead. + +** Image-Dired + ++++ +*** New user option 'image-dired-thumb-visible-marks'. +If non-nil (the default), use the new face 'image-dired-thumb-mark' +for marked images. + +--- +*** New command 'image-dired-delete-marked'. + +--- +*** 'image-dired-mouse-toggle-mark' is now sensitive to the active region. +If the region is active, this command now toggles Dired marks of all +the thumbnails in the region. + +** Flymake mode + ++++ +*** New command 'flymake-show-project-diagnostics'. +This lists all diagnostics for buffers in the currently active +project. The listing is similar to the one obtained by +'flymake-show-buffer-diagnostics', but adds a column for the +project-relative file name. For backends which support it, +'flymake-show-project-diagnostics' also lists diagnostics for files +that have not yet been visited. + ++++ +*** New user options to customize Flymake's mode-line. +The new user option 'flymake-mode-line-format' is a mix of strings and +symbols like 'flymake-mode-line-title', 'flymake-mode-line-exception' +and 'flymake-mode-line-counters'. The new user option +'flymake-mode-line-counter-format' is a mix of strings and symbols +like 'flymake-mode-line-error-counter', +'flymake-mode-line-warning-counter' and 'flymake-mode-line-note-counter'. + +** Time + +--- +*** 'display-time-world' has been renamed to 'world-clock'. +'world-clock' creates a buffer with an updating time display using +several time zones. It is hoped that the new names are more +discoverable. + +The following commands have been renamed: + + 'display-time-world' to 'world-clock' + 'display-time-world-mode' to 'world-clock-mode' + 'display-time-world-display' to 'world-clock-display' + 'display-time-world-timer' to 'world-clock-update' + +The following user options have been renamed: + + 'display-time-world-list' to 'world-clock-list' + 'display-time-world-time-format' to 'world-clock-time-format' + 'display-time-world-buffer-name' to 'world-clock-buffer-name' + 'display-time-world-timer-enable' to 'world-clock-timer-enable' + 'display-time-world-timer-second' to 'world-clock-timer-second' + +The old names are now obsolete. + +--- +*** 'world-clock-mode' can no longer be turned on interactively. +Use 'world-clock' to turn on that mode. + +** Python mode + +--- +*** New user option 'python-forward-sexp-function'. +This allows the user easier customization of whether to use block-based +navigation or not. + +--- +*** 'python-shell-interpreter' now defaults to python3 on systems with python3. + +--- +*** 'C-c C-r' can now be used on arbitrary regions. +The command previously extended the start of the region to the start +of the line, but will now actually send the marked region, as +documented. + +** Ruby Mode + +--- +*** 'ruby-use-smie' is declared obsolete. +SMIE is now always enabled and 'ruby-use-smie' only controls whether +indentation is done using SMIE or with the old ad-hoc code. + +--- +*** Indentation has changed when 'ruby-align-chained-calls' is non-nil. +This previously used to align subsequent lines with the last sibling, +but it now aligns with the first sibling (which is the preferred style +in Ruby). + +** CPerl Mode + +--- +*** New face 'perl-heredoc', used for heredoc elements. + +--- +*** The command 'cperl-set-style' offers the new value "PBP". +This value customizes Emacs to use the style recommended in Damian +Conway's book "Perl Best Practices" for indentation and formatting +of conditionals. + +** Perl mode + +--- +*** New face 'perl-non-scalar-variable'. +This is used to fontify non-scalar variables. + +** Octave Mode + ++++ +*** Line continuations in double-quoted strings now use a backslash. +Typing 'C-M-j' (bound to 'octave-indent-new-comment-line') now follows +the behavior introduced in Octave 3.8 of using a backslash as a line +continuation marker within double-quoted strings, and an ellipsis +everywhere else. + ++++ +** EasyPG +GPG key servers can now be queried for keys with the +'M-x epa-search-keys' command. Keys can then be added to your +personal key ring. + +** Etags + ++++ +*** Etags now supports the Mercury programming language. +See https://mercurylang.org. + ++++ +*** Etags command line option '--declarations' now has Mercury-specific behavior. +All Mercury declarations are tagged by default. However, for +compatibility with 'etags' support for Prolog, predicates and +functions appearing first in clauses will also be tagged if 'etags' is +invoked with the '--declarations' command-line option. + +** Comint + ++++ +*** Support for OSC escape sequences. +Adding the new 'comint-osc-process-output' to +'comint-output-filter-functions' enables the interpretation of OSC +("Operating System Command") escape sequences in comint buffers. By +default, only OSC 8, for hyperlinks, and OSC 7, for directory +tracking, are acted upon. Adding more entries to +'comint-osc-handlers' allows a customized treatment of further escape +sequences. + ++++ +*** 'comint-delete-output' can now save deleted text in the kill-ring. +Interactively, 'C-u C-c C-o' triggers this new optional behavior. + +** ansi-color.el + +--- +*** Colors are now defined by faces. +ANSI SGR codes now have corresponding faces to describe their +appearance, e.g. 'ansi-color-bold'. + +--- +*** Support for "bright" color codes. +"Bright" ANSI color codes are now displayed when applying ANSI color +filters using the color values defined by the faces +'ansi-color-bright-COLOR'. In addition, bold text with regular ANSI +colors can be displayed as "bright" if 'ansi-color-bold-is-bright' is +non-nil. + +** ERC + +*** Starting with Emacs 28.1 and ERC 5.4, see the ERC-NEWS file for +user-visible changes in ERC. + +** xwidget-webkit mode + +--- +*** New xwidget commands. +'xwidget-webkit-uri' (return the current URL), 'xwidget-webkit-title' +(return the current title), and 'xwidget-webkit-goto-history' (goto a +point in history). + +--- +*** Downloading files from xwidget-webkit is now supported. +The new user option 'xwidget-webkit-download-dir' says where to download to. + +--- +*** New command 'xwidget-webkit-clone-and-split-below'. +Open a new window below displaying the current URL. + +--- +*** New command 'xwidget-webkit-clone-and-split-right'. +Open a new window to the right displaying the current URL. + +--- +*** Pixel-based scrolling. +The 'xwidget-webkit-scroll-up', 'xwidget-webkit-scroll-down' commands +now supports scrolling arbitrary pixel values. It now treats the +optional 2nd argument as the pixel values to scroll. + +--- +*** New commands for scrolling. +The new commands 'xwidget-webkit-scroll-up-line', +'xwidget-webkit-scroll-down-line', 'xwidget-webkit-scroll-forward', +'xwidget-webkit-scroll-backward' can be used to scroll webkit by the +height of lines or width of chars. + +--- +*** New user option 'xwidget-webkit-bookmark-jump-new-session'. +When non-nil, use a new xwidget webkit session after bookmark jump. +Otherwise, it will use 'xwidget-webkit-last-session'. + +** Checkdoc + +--- +*** No longer warns about command substitutions by default. +Checkdoc used to warn about "too many command substitutions" (as in +"\\[foo-command]"), even if you only used ten of them in a docstring. +On modern machines, you can have hundreds or thousands of command +substitutions before it becomes a performance issue, so this warning +is now disabled by default. To re-enable this warning, customize the +user option 'checkdoc-max-keyref-before-warn'. + +--- +*** New user option 'checkdoc-column-zero-backslash-before-paren'. +Checkdoc warns if there is a left parenthesis in column zero of a +documentation string. That warning can now be disabled by customizing +this new user option to nil. This is useful if you don't expect +your code to be edited with an Emacs older than version 27.1. + +--- +*** Now checks the prompt format for 'yes-or-no-p'. +In addition to verifying the format of the prompt for 'y-or-n-p', +checkdoc will now check the format of 'yes-or-no-p'. + +--- +*** New command 'checkdoc-dired'. +This can be used to run checkdoc on files from a Dired buffer. + +*** No longer checks for 'A-' modifiers. +Checkdoc recommends usage of command substitutions ("\\[foo-command]") +in favor of writing keybindings like 'C-c f'. It now no longer warns +about the 'A-' modifier as it is not used very much in practice, and +this warning therefore mostly led to false positives. + +** Enriched mode + +--- +*** 'C-a' is by default no longer bound to 'beginning-of-line-text'. +This is so 'C-a' works as in other modes, and in particular holding +Shift while typing 'C-a', i.e. 'C-S-a', will now highlight the text. + +** Gravatar + +--- +*** New user option 'gravatar-service' for host to query for gravatars. +Defaults to 'libravatar', with 'unicornify' and 'gravatar' as options. + +** MH-E mail handler for Emacs + +Functions and variables related to handling junk mail have been +renamed to not associate color with sender quality. + ++++ +*** New names for mh-junk interactive functions. +Function 'mh-junk-whitelist' is renamed 'mh-junk-allowlist'. +Function 'mh-junk-blacklist' is renamed 'mh-junk-blocklist'. + ++++ +*** New binding for 'mh-junk-allowlist'. +The key binding for 'mh-junk-allowlist' is changed from 'J w' to 'J a'. +The old binding is supported but warns that it is obsolete. + ++++ +*** New names for some hooks. +'mh-whitelist-msg-hook' is renamed 'mh-allowlist-msg-hook'. +'mh-blacklist-msg-hook' is renamed 'mh-blocklist-msg-hook'. + ++++ +*** New names for some user options. +User option 'mh-whitelist-preserves-sequences-flag' is renamed +'mh-allowlist-preserves-sequences-flag'. + ++++ +*** New names for some faces. +Face 'mh-folder-blacklisted' is renamed 'mh-folder-blocklisted'. +Face 'mh-folder-whitelisted' is renamed 'mh-folder-allowlisted'. + +** Rcirc + ++++ +*** rcirc now supports SASL authentication. + +--- +*** #emacs on Libera.chat has been added to 'rcirc-server-alist'. + +--- +*** rcirc connects asynchronously. + +--- +*** Integrate formatting into 'rcirc-send-string'. +The function now accepts a variable number of arguments. + ++++ +*** Deprecate 'rcirc-command' in favor of 'rcirc-define-command'. +The new macro handles multiple and optional arguments. + +--- +*** Add basic IRCv3 support. +This includes support for the capabilities: 'server-time', 'batch', +'message-ids', 'invite-notify', 'multi-prefix' and 'standard-replies'. + +--- +*** Add mouse property support to 'rcirc-track-minor-mode'. + +--- +*** Improve support for IRC markup codes. + +--- +*** Check 'auth-sources' for server passwords. + ++++ +*** Implement repeated reconnection strategy. +See 'rcirc-reconnect-attempts'. + +** MPC + +--- +*** New command 'mpc-goto-playing-song'. +This command, bound to 'o' in any 'mpc-mode' buffer, moves point to +the currently playing song in the "*MPC-Songs*" buffer. + +--- +*** New user option 'mpc-cover-image-re'. +If non-nil, it is a regexp that should match a valid cover image. + +** Miscellaneous + +--- +*** 'shell-script-mode' now supports 'outline-minor-mode'. +The outline headings have lines that start with "###". + +--- +*** fileloop will now skip missing files instead of signalling an error. + +--- +*** 'tabulated-list-mode' can now restore original display order. +Many commands (like 'C-x C-b') are derived from 'tabulated-list-mode', +and that mode allows the user to sort on any column. There was +previously no easy way to get back to the original displayed order +after sorting, but giving a -1 numerical prefix to the sorting command +will now restore the original order. + +--- +*** 'M-left' and 'M-right' now move between columns in 'tabulated-list-mode'. + +--- +*** New variable 'hl-line-overlay-priority'. +This can be used to change the priority of the hl-line overlays. + ++++ +*** New command 'mailcap-view-file'. +This command will open a viewer based on the file type, as determined +by "~/.mailcap" and related files and variables. + +--- +*** New user option 'remember-diary-regexp'. + +--- +*** New user option 'remember-text-format-function'. + +--- +*** New user option 'authinfo-hide-elements'. +This can be set to nil to inhibit hiding passwords in ".authinfo" files. + +--- +*** 'hexl-mode' scrolling commands now heed 'next-screen-context-lines'. +Previously, 'hexl-scroll-down' and 'hexl-scroll-up' would scroll +up/down an entire window, but they now work more like the standard +scrolling commands. + +--- +*** New user option 'bibtex-unify-case-function'. +This new option allows the user to customize how case is converted +when unifying entries. + +--- +*** The user option 'bibtex-maintain-sorted-entries' now permits +user-defined sorting schemes. + +--- +*** New user option 'reveal-auto-hide'. +If non-nil (the default), revealed text is automatically hidden when +point leaves the text. If nil, the text is not hidden again. Instead +'M-x reveal-hide-revealed' can be used to hide all the revealed text. + +--- +*** New user option 'ffap-file-name-with-spaces'. +If non-nil, 'find-file-at-point' and friends will try to guess more +expansively to identify a file name with spaces. Default value is +nil. + +--- +*** Two new commands for centering in 'doc-view-mode'. +The new commands 'doc-view-center-page-horizontally' (bound to 'c h') +and 'doc-view-center-page-vertically' (bound to 'c v') center the page +horizontally and vertically, respectively. + +--- +*** 'tempo-define-template' can now re-assign templates to tags. +Previously, assigning a new template to an already defined tag had no +effect. + +--- +*** The width of the buffer-name column in 'list-buffers' is now dynamic. +The width now depends on the width of the window, but will never be +wider than the length of the longest buffer name, except that it will +never be narrower than 19 characters. + ++++ +*** New diary sexp 'diary-offset'. +It offsets another diary sexp by a number of days. This is useful +when for example your organization has a committee meeting two days +after every monthly meeting which takes place on the third Thursday, +or if you would like to attend a virtual meeting scheduled in a +different timezone causing a difference in the date. + +--- +*** The old non-SMIE indentation of 'sh-mode' has been removed. + +--- +*** 'mspools-show' is now autoloaded. + +--- +*** Loading dunnet.el in batch mode doesn't start the game any more. +Instead you need to do "emacs -f dun-batch" to start the game in +batch mode. + + +* New Modes and Packages in Emacs 28.1 + ++++ +** New mode 'repeat-mode' to allow shorter key sequences. +Type 'M-x repeat-mode' to enable this mode. You can then type +'C-x u u' instead of 'C-x u C-x u' to undo many changes, 'C-x o o' +instead of 'C-x o C-x o' to switch windows, 'C-x { { } } ^ ^ v v' to +resize the selected window interactively, 'M-g n n p p' to navigate +next-error matches. Any other key exits this temporarily enabled +transient mode that supports shorter keys, and then after exiting from +this mode, the last typed key uses the default key binding. + +The user option 'repeat-exit-key' defines an additional key usable to +exit the mode like 'isearch-exit' ('RET'). + +The user option 'repeat-exit-timeout' (default nil, which means +forever) specifies the number of seconds of idle time after which to +break the repetition chain automatically. + +When user option 'repeat-keep-prefix' is non-nil, the prefix arg of +the previous command is kept. This can be used to e.g. reverse the +window navigation direction with 'C-x o M-- o o' or to set a new step +with 'C-x { C-5 { { {', which will set the window resizing step to 5 +columns. + +'M-x describe-repeat-maps' will display a buffer showing +which commands are repeatable in 'repeat-mode'. + +--- +** New themes 'modus-vivendi' and 'modus-operandi'. +These themes are designed to conform with the highest standard for +color-contrast accessibility (WCAG AAA). You can load either of them +using 'M-x customize-themes' or 'load-theme' from your init file. +Consult the Modus Themes Info manual for more information on the user +options they provide. + +** Dictionary mode +This is a mode for searching a RFC 2229 dictionary server. +'dictionary' opens a buffer for starting operations. +'dictionary-search' performs a lookup for a word. It also supports a +'dictionary-tooltip-mode' which performs a lookup of the word under +the mouse in 'dictionary-tooltip-dictionary' (which must be customized +first). + +--- +** Lisp Data mode +The new command 'lisp-data-mode' enables a major mode for buffers +composed of Lisp symbolic expressions that do not form a computer +program. The ".dir-locals.el" file is automatically set to use this +mode, as are other data files produced by Emacs. + ++++ +** New global mode 'global-goto-address-mode'. +This will enable 'goto-address-mode' in all buffers. + +** transient.el +This library implements support for powerful keyboard-driven menus. +Such menus can be used as simple visual command dispatchers. More +complex menus take advantage of infix arguments, which are somewhat +similar to prefix arguments, but are more flexible and discoverable. + +** hierarchy.el +This library can create, query, navigate and display hierarchical +structures. + +--- +** New major mode for displaying the "etc/AUTHORS" file. +This new 'etc-authors-mode' provides font-locking for displaying the +"etc/AUTHORS" file from the Emacs distribution, and not much else. + + +* Incompatible Lisp Changes in Emacs 28.1 + ++++ +** Emacs now prints a backtrace when signaling an error in batch mode. +This makes debugging Emacs Lisp scripts run in batch mode easier. To +get back the old behavior, set the new variable +'backtrace-on-error-noninteractive' to a nil value. + +--- +** Some floating-point numbers are now handled differently by the Lisp reader. +In previous versions of Emacs, numbers with a trailing dot and an exponent +were read as integers and the exponent ignored: 2.e6 was interpreted as the +integer 2. Such numerals are now read as floats with the exponent included: +2.e6 is now read as the floating-point value 2000000.0. +That is, '(read-from-string "1.e3")' => '(1000.0 . 4)' now. + +--- +** 'equal' no longer examines some contents of window configurations. +Instead, it considers window configurations to be equal only if they +are 'eq'. To compare contents, use 'compare-window-configurations' +instead. This change helps fix a bug in 'sxhash-equal', which returned +incorrect hashes for window configurations and some other objects. + ++++ +** The 'lexical-binding' local variable is always enabled. +Previously, if 'enable-local-variables' was nil, a 'lexical-binding' +local variable would not be heeded. This has now changed, and a file +with a 'lexical-binding' cookie is always heeded. To revert to the +old behavior, set 'permanently-enabled-local-variables' to nil. + ++++ +** '&rest' in argument lists must always be followed by a variable name. +Omitting the variable name after '&rest' was previously tolerated in +some cases but not consistently so; it could lead to crashes or +outright wrong results. Since the utility was marginal at best, it is +now an error to omit the variable. + +--- +** 'kill-all-local-variables' has changed how it handles non-symbol hooks. +The function is documented to eliminate all buffer-local bindings +except variables with a 'permanent-local' property, or hooks that +have elements with a 'permanent-local-hook' property. In addition, it +would also keep lambda expressions in hooks sometimes. The latter has +now been changed: The function will now also remove these. + ++++ +** Temporary buffers no longer run certain buffer hooks. +The macros 'with-temp-buffer' and 'with-temp-file' no longer run the +hooks 'kill-buffer-hook', 'kill-buffer-query-functions', and +'buffer-list-update-hook' for the temporary buffers they create. This +avoids slowing them down when a lot of these hooks are defined. + ++++ +** New face 'child-frame-border' and frame parameter 'child-frame-border-width'. +The face and width of child frames borders can now be determined +separately from those of normal frames. To minimize backward +incompatibility, child frames without a 'child-frame-border-width' +parameter will fall back to using 'internal-border-width'. However, +the new 'child-frame-border' face does constitute a breaking change +since child frames' borders no longer use the 'internal-border' face. + +--- +** 'run-at-time' now tries harder to implement the t TIME parameter. +If TIME is t, the timer runs at an integral multiple of REPEAT. +(I.e., if given a REPEAT of 60, it'll run at 08:11:00, 08:12:00, +08:13:00.) However, when a machine goes to sleep (or otherwise didn't +get a time slot to run when the timer was scheduled), the timer would +then fire every 60 seconds after the time the timer was fired. This +has now changed, and the timer code now recomputes the integral +multiple every time it runs, which means that if the laptop wakes at +08:16:43, it'll fire at that time, but then at 08:17:00, 08:18:00... + +--- +** 'parse-partial-sexp' now signals an error if TO is smaller than FROM. +Previously, this would lead to the function interpreting FROM as TO and +vice versa, which would be confusing when passing in OLDSTATE, which +refers to the old state at FROM. + ++++ +** 'global-mode-string' constructs should end with a space. +This was previously not formalized, which led to combinations of modes +displaying data "smushed together" on the mode line. + ++++ +** 'overlays-in' now handles zero-length overlays slightly differently. +Previously, zero-length overlays at the end of the buffer were included +in the result (if the region queried for stopped at that position). +The same was not the case if the buffer had been narrowed to exclude +the real end of the buffer. This has now been changed, and +zero-length overlays at 'point-max' are always included in the results. + +--- +** 'replace-match' now runs modification hooks slightly later. +The function is documented to leave point after the replacement text, +but this was not always the case if a modification hook inserted text +in front of the replaced text -- 'replace-match' would instead leave +point where the end of the inserted text would have been before the +hook ran. 'replace-match' now always leaves point after the +replacement text. + ++++ +** 'completing-read-default' sets completion variables buffer-locally. +'minibuffer-completion-table' and related variables are now set buffer-locally +in the minibuffer instead of being set via a global let-binding. + +--- +** XML serialization functions now reject invalid characters. +Previously, 'xml-print' would produce invalid XML when given a string +with characters that are not valid in XML (see +https://www.w3.org/TR/xml/#charsets). Now it rejects such strings. + +--- +** JSON + +--- +*** JSON number parsing is now stricter. +Numbers with a leading plus sign, leading zeros, or a missing integer +component are now rejected by 'json-read' and friends. This makes +them more compliant with the JSON specification and consistent with +the native JSON parsing functions. + +--- +*** JSON functions support the semantics of RFC 8259. +The JSON functions 'json-serialize', 'json-insert', +'json-parse-string', and 'json-parse-buffer' now implement some of the +semantics of RFC 8259 instead of the earlier RFC 4627. In particular, +these functions now accept top-level JSON values that are neither +arrays nor objects. + +--- +*** Some JSON encoding functions are now obsolete. +The functions 'json-encode-number', 'json-encode-hash-table', +'json-encode-key', and 'json-encode-list' are now obsolete. + +The first two are kept as aliases of 'json-encode', which should be +used instead. Uses of 'json-encode-list' should be changed to call +one of 'json-encode', 'json-encode-alist', 'json-encode-plist', or +'json-encode-array' instead. + ++++ +*** Native JSON functions now signal an error if libjansson is unavailable. +This affects 'json-serialize', 'json-insert', 'json-parse-string', +and 'json-parse-buffer'. This can happen if Emacs was compiled with +libjansson, but the DLL cannot be found and/or loaded by Emacs at run +time. Previously, Emacs would display a message and return nil in +these cases. + ++++ +** The use of positional arguments in 'define-minor-mode' is obsolete. +These were actually rendered obsolete in Emacs 21 but were never +marked as such. + +--- +** 'pcomplete-ignore-case' is now an obsolete alias of 'completion-ignore-case'. + ++++ +** 'completions-annotations' face is not used when the caller puts own face. +This affects the suffix specified by completion 'annotation-function'. + ++++ +** An active minibuffer now has major mode 'minibuffer-mode'. +This is instead of the erroneous 'minibuffer-inactive-mode' it +formerly had. + +--- +** 'make-text-button' no longer modifies text properties of its first argument. +When its first argument is a string, 'make-text-button' no longer +modifies the string's text properties; instead, it uses and returns +a copy of the string. This helps avoid trouble when strings are +shared or constants. + ++++ +** Some properties from completion tables are now preserved. +If 'minibuffer-allow-text-properties' is non-nil, doing completion +over a table of strings with properties will no longer remove all the +properties before returning. This affects things like 'completing-read'. + +--- +** 'dns-query' now consistently uses Lisp integers to represent integers. +Formerly it made an exception for integer components of SOA records, +because SOA serial numbers can exceed fixnum ranges on 32-bit platforms. +Emacs now supports bignums so this old glitch is no longer needed. + ++++ +** The '&define' keyword in an Edebug specification now disables backtracking. +The implementation was buggy, and multiple '&define' forms in an '&or' +form should be exceedingly rare. See the Info node "(elisp) Backtracking" in +the Emacs Lisp reference manual for background. + ++++ +** The error 'ftp-error' belongs also to category 'remote-file-error'. + ++++ +** The WHEN argument of 'make-obsolete' and related functions is mandatory. +The use of those functions without a WHEN argument was marked obsolete +back in Emacs 23.1. The affected functions are: 'make-obsolete', +'define-obsolete-function-alias', 'make-obsolete-variable', +'define-obsolete-variable-alias'. + ++++ +** 'inhibit-nul-byte-detection' is renamed to 'inhibit-null-byte-detection'. + +--- +** Some functions are no longer considered safe by 'unsafep': +'replace-regexp-in-string', 'catch', 'throw', 'error', 'signal' +and 'play-sound-file'. + +--- +** 'sql-*-statement-starters' are no longer user options. +These variables describe facts about the SQL standard and +product-specific additions. There should be no need for users to +customize them. + +--- +** Some locale-related variables have been removed. +The Lisp variables 'previous-system-messages-locale' and +'previous-system-time-locale' have been removed, as they were created +by mistake and were not useful to Lisp code. + +--- +** Function 'lm-maintainer' is replaced with 'lm-maintainers'. +The former is now declared obsolete. + ++++ +** facemenu.el is no longer preloaded. +To use functions/variables from the package, you now have to say +'(require 'facemenu)' or similar. + +--- +** 'facemenu-color-alist' is now obsolete, and is not used. + +--- +** The variable 'keyboard-type' is obsolete and not dynamically scoped any more. + ++++ +** The 'values' variable is now obsolete. +Using it just contributes to the growth of the Emacs memory +footprint. + +--- +** The 'load-dangerous-libraries' variable is now obsolete. +It was used to allow loading Lisp libraries compiled by XEmacs, a +modified version of Emacs which is no longer actively maintained. +This is no longer supported, and setting this variable has no effect. + ++++ +** The macro 'with-displayed-buffer-window' is now obsolete. +Use macro 'with-current-buffer-window' with action alist entry 'body-function'. + +--- +** The rfc2368.el library is now obsolete. +Use rfc6068.el instead. The main difference is that +'rfc2368-parse-mailto-url' and 'rfc2368-unhexify-string' assumed that +the strings were all-ASCII, while 'rfc6068-parse-mailto-url' and +'rfc6068-unhexify-string' parse UTF-8 strings. + +--- +** The inversion.el library is now obsolete. + +--- +** The metamail.el library is now obsolete. + +** Edebug changes + +--- +*** 'get-edebug-spec' is obsolete, replaced by 'edebug-get-spec'. + ++++ +*** The spec operator ':name NAME' is obsolete, use '&name' instead. + ++++ +*** The spec element 'function-form' is obsolete, use 'form' instead. + ++++ +*** New function 'def-edebug-elem-spec' to define Edebug spec elements. +These used to be defined with 'def-edebug-spec' thus conflating the +two name spaces, which lead to name collisions. +The use of 'def-edebug-spec' to define Edebug spec elements is +declared obsolete. + +--- +** The sb-image.el library is now obsolete. +This was a compatibility kludge which is no longer needed. + +--- +** Some libraries obsolete since Emacs 23 have been removed: +ledit.el, lmenu.el, lucid.el and old-whitespace.el. + +--- +** Some functions and variables obsolete since Emacs 23 have been removed: +'GOLD-map', 'advertised-xscheme-send-previous-expression', +'allout-init', 'bookmark-jump-noselect', +'bookmark-read-annotation-text-func', 'buffer-menu-mode-hook', +'c-forward-into-nomenclature', 'char-coding-system-table', +'char-valid-p', 'charset-bytes', 'charset-id', 'charset-list', +'choose-completion-delete-max-match', 'complete-in-turn', +'completion-base-size', 'completion-common-substring', +'crm-minibuffer-complete', 'crm-minibuffer-complete-and-exit', +'crm-minibuffer-completion-help', 'custom-mode', 'custom-mode-hook', +'define-key-rebound-commands', 'define-mode-overload-implementation', +'detect-coding-with-priority', 'dirtrack-debug', +'dirtrack-debug-toggle', 'dynamic-completion-table', +'easy-menu-precalculate-equivalent-keybindings', +'epa-display-verify-result', 'epg-passphrase-callback-function', +'erc-announced-server-name', 'erc-default-coding-system', +'erc-process', 'erc-send-command', 'eshell-report-bug', +'eval-next-after-load', 'exchange-dot-and-mark', 'ffap-bug', +'ffap-submit-bug', 'ffap-version', 'file-cache-mouse-choose-completion', +'forward-point', 'generic-char-p', 'global-highlight-changes', +'hi-lock-face-history', 'hi-lock-regexp-history', +'highlight-changes-active-string', 'highlight-changes-initial-state', +'highlight-changes-passive-string', +'icalendar--datetime-to-noneuropean-date', 'image-mode-maybe', +'imenu-example--name-and-position', 'ispell-aspell-supports-utf8', +'lisp-mode-auto-fill', 'locate-file-completion', 'make-coding-system', +'menu-bar-files-menu', 'minibuffer-local-must-match-filename-map', +'mouse-choose-completion', 'mouse-major-mode-menu', +'mouse-popup-menubar', 'mouse-popup-menubar-stuff', +'newsticker-groups-filename', 'nnir-swish-e-index-file', +'nnmail-fix-eudora-headers', 'non-iso-charset-alist', +'nonascii-insert-offset', 'nonascii-translation-table', +'password-read-and-add', 'pre-abbrev-expand-hook', 'princ-list', +'print-help-return-message', 'process-filter-multibyte-p', +'read-file-name-predicate', 'remember-buffer', 'rmail-highlight-face', +'rmail-message-filter', 'semantic-after-idle-scheduler-reparse-hooks', +'semantic-after-toplevel-bovinate-hook', +'semantic-before-idle-scheduler-reparse-hooks', +'semantic-before-toplevel-bovination-hook', +'semantic-bovinate-from-nonterminal-full', +'semantic-bovinate-region-until-error', 'semantic-bovinate-toplevel', +'semantic-bovination-working-type', +'semantic-decorate-pending-decoration-hooks', +'semantic-edits-incremental-reparse-failed-hooks', +'semantic-eldoc-current-symbol-info', 'semantic-expand-nonterminal', +'semantic-file-token-stream', 'semantic-find-dependency', +'semantic-find-nonterminal', 'semantic-flex', 'semantic-flex-buffer', +'semantic-flex-keyword-get', 'semantic-flex-keyword-p', +'semantic-flex-keyword-put', 'semantic-flex-keywords', +'semantic-flex-list', 'semantic-flex-make-keyword-table', +'semantic-flex-map-keywords', 'semantic-flex-token-end', +'semantic-flex-token-start', 'semantic-flex-token-text', +'semantic-imenu-bucketize-type-parts', +'semantic-imenu-expand-type-parts', 'semantic-imenu-expandable-token', +'semantic-init-db-hooks', 'semantic-init-hooks', +'semantic-init-mode-hooks', 'semantic-java-prototype-nonterminal', +'semantic-nonterminal-abstract', 'semantic-nonterminal-full-name', +'semantic-nonterminal-leaf', 'semantic-nonterminal-protection', +'semantic-something-to-stream', 'semantic-tag-make-assoc-list', +'semantic-token-type-parent', 'semantic-toplevel-bovine-cache', +'semantic-toplevel-bovine-table', 'semanticdb-mode-hooks', +'set-coding-priority', 'set-process-filter-multibyte', +'shadows-compare-text-p', 'shell-dirtrack-toggle', +'speedbar-navigating-speed', 'speedbar-update-speed', 't-mouse-mode', +'term-dynamic-simple-complete', 'tooltip-hook', 'tpu-have-ispell', +'url-generate-unique-filename', 'url-temporary-directory', +'vc-arch-command', 'vc-default-working-revision' (variable), +'vc-mtn-command', 'vc-revert-buffer', 'vc-workfile-version', +'vcursor-toggle-vcursor-map', 'w32-focus-frame', 'w32-select-font', +'wisent-lex-make-token-table'. + +--- +** Some functions and variables obsolete since Emacs 22 have been removed: +'erc-current-network', 'gnus-article-hide-pgp-hook', +'gnus-inews-mark-gcc-as-read', 'gnus-treat-display-xface', +'gnus-treat-strip-pgp', 'nnmail-spool-file'. + +--- +** The obsolete function 'thread-alive-p' has been removed. + +--- +** The variable 'force-new-style-backquotes' has been removed. +This removes the final remaining trace of old-style backquotes. + +--- +** Some obsolete variable and function aliases in dbus.el have been removed. +In Emacs 24.3, the variable 'dbus-event-error-hooks' was renamed to +'dbus-event-error-functions' and the function +'dbus-call-method-non-blocking' was renamed to 'dbus-call-method'. +The old names, which were kept as obsolete aliases of the new names, +have now been removed. + +--- +** 'find-function-source-path' renamed and re-documented. +The 'find-function' command (and various related commands) were +documented to respect 'find-function-source-path', and to search for +objects in files specified by that variable. It's unclear when this +actually changed, but at some point (perhaps decades ago) these +commands started using 'load-history' to determine where symbols had +been defined (which is much faster). The doc strings of all the +affected function have been updated. 'find-function-source-path' was +still being used by 'find-library' and related commands, so the +user option has been renamed to 'find-library-source-path', and +'find-function-source-path' is now an obsolete variable alias. + +--- +** The macro 'vc-call' no longer evaluates its second argument twice. + +** Xref migrated from EIEIO to cl-defstruct for its core objects. +This means that 'oref' and 'with-slots' no longer works on them, and +'make-instance' can no longer be used to create those instances (which +wasn't recommended anyway). Packages should restrict themselves to +using functions like 'xref-make', 'xref-make-match', +'xref-make-*-location', as well as accessor functions +'xref-item-summary' and 'xref-item-location'. + +Among the benefits are better performance (noticeable when there are a +lot of matches) and improved flexibility: 'xref-match-item' instances +do not require that 'location' inherits from 'xref-location' anymore +(that class was removed), so packages can create new location types to +use with "match items" without adding EIEIO as a dependency. + + +* Lisp Changes in Emacs 28.1 + ++++ +** The 'interactive' syntax has been extended to allow listing applicable modes. +Forms like '(interactive "p" dired-mode)' can be used to annotate the +commands as being applicable for modes derived from 'dired-mode', +or if the mode is a minor mode, when the current buffer has that +minor mode activated. Note that using this form will create byte code +that is not compatible with byte code in previous Emacs versions. +Also note that by default these annotations have no effect, unless the +new option 'read-extended-command-predicate' option is customized to call +'command-completion-default-include-p' or a similar function. + ++++ +** New 'declare' forms to control completion of commands in 'M-x'. +'(declare (completion PREDICATE))' can be used as a general predicate +to say whether the command should be considered a completion candidate +when completing with 'M-x TAB'. + +'(declare (modes MODE...))' can be used as a short-hand way of saying +that the command should be considered a completion candidate when +completing on commands from buffers in major modes derived from +MODE..., or, if it's a minor mode, when that minor mode is enabled in +the current buffer. + +Note that these forms will only have their effect if the +'read-extended-command-predicate' option is customized to call +'command-completion-default-include-p' or a similar function. The +default value of 'read-extended-command-predicate' is nil, which means +no commands that match what you have typed are excluded from being +completion candidates. + ++++ +** 'define-minor-mode' now takes an ':interactive' argument. +This can be used for specifying which modes this minor mode is meant +for, or to make the new minor mode non-interactive. The default value +is t. + ++++ +** 'define-derived-mode' now takes an ':interactive' argument. +This can be used to control whether the defined mode is a command +or not, and is useful when defining commands that aren't meant to be +used by users directly. + ++++ +** 'define-globalized-minor-mode' now takes a ':predicate' parameter. +This can be used to control which major modes the minor mode should be +used in. + ++++ +** 'condition-case' now allows for a success handler. +It is written as '(:success BODY...)' where BODY is executed +whenever the protected form terminates without error, with the +specified variable bound to the value of the protected form. + ++++ +** New function 'benchmark-call' to measure the execution time of a function. +Additionally, the number of repetitions can be expressed as a minimal duration +in seconds. + ++++ +** The value thrown to the 'exit' label can now be a function. +This is in addition to values t or nil. If the value is a function, +the command loop will call it with zero arguments before returning. + ++++ +** The behavior of 'format-spec' is now closer to that of 'format'. +In order for the two functions to behave more consistently, +'format-spec' now pads and truncates based on string width rather than +length, and also supports format specifications that include a +truncating precision field, such as "%.2a". + +--- +** 'defvar' detects the error of defining a variable currently lexically bound. +Such mixes are always signs that the outer lexical binding was an +error and should have used dynamic binding instead. + +--- +** New variable 'inhibit-mouse-event-check'. +If bound to non-nil, a command with '(interactive "e")' doesn't signal +an error when invoked by input event that is not a mouse click (e.g., +a key sequence). + +--- +** New variable 'redisplay-skip-initial-frame' to enable batch redisplay tests. +Setting it to nil forces the redisplay to do its job even in the +initial frame used in batch mode. + ++++ +** Doc strings can now link to customization groups. +Text like "customization group `whitespace'" will be made into a +button. When clicked, it will open a Custom buffer displaying that +customization group. + ++++ +** Doc strings can now link to man pages. +Text like "man page `chmod(1)'" will be made into a button. When +clicked, it will open a Man mode buffer displaying that man page. + ++++ +** Buffers can now be created with certain hooks disabled. +The functions 'get-buffer-create' and 'generate-new-buffer' accept a +new optional argument INHIBIT-BUFFER-HOOKS. If non-nil, the new +buffer does not run the hooks 'kill-buffer-hook', +'kill-buffer-query-functions', and 'buffer-list-update-hook'. This +avoids slowing down internal or temporary buffers that are never +presented to users or passed on to other applications. + ++++ +** New command 'make-directory-autoloads'. +This does the same as the old command 'update-directory-autoloads', +but has different semantics: Instead of passing in the output file via +the dynamically bound 'generated-autoload-file' variable, the output +file is now a explicit parameter. + +--- +** Dragging a file into Emacs pushes the file name onto 'file-name-history'. + +--- +** The 'easymenu' library is now preloaded. + +--- +** The 'iso-transl' library is now preloaded. +This means that keystrokes like 'Alt-[' are defined by default, +instead of only becoming available after doing (for instance) +'C-x 8 <letter>'. + +--- +** ':safe' settings in 'defcustom' are now propagated to the loaddefs files. + ++++ +** New ':type' for 'defcustom' for nonnegative integers. +The new 'natnum' type can be used for options that should be +nonnegative integers. + ++++ +** ERT can now output more verbose test failure reports. +If the 'EMACS_TEST_VERBOSE' environment variable is set, failure +summaries will include the failing condition. + +** Byte compiler changes + ++++ +*** New byte-compiler check for missing dynamic variable declarations. +It is meant as an (experimental) aid for converting Emacs Lisp code +to lexical binding, where dynamic (special) variables bound in one +file can affect code in another. For details, see the manual section +"(elisp) Converting to Lexical Binding". + ++++ +*** 'byte-recompile-directory' can now compile symlinked ".el" files. +This is achieved by giving a non-nil FOLLOW-SYMLINKS parameter. + +--- +*** The byte-compiler now warns about too wide documentation strings. +By default, it will warn if a documentation string is wider than the +largest of 'byte-compile-docstring-max-column' or 'fill-column' +characters. + ++++ +*** 'byte-compile-file' optional argument LOAD is now obsolete. +To load the file after byte-compiling, add a call to 'load' from Lisp +or use 'M-x emacs-lisp-byte-compile-and-load' interactively. + +** Macroexp + +--- +*** New function 'macroexp-file-name' to know the name of the current file. + +--- +*** New function 'macroexp-compiling-p' to know if we're compiling. + +--- +*** New function 'macroexp-warn-and-return' to help emit warnings. +This used to be named 'macroexp--warn-and-return' and has proved useful +and well-behaved enough to lose the "internal" marker. + +** map.el + +--- +*** Alist keys are now consistently compared with 'equal' by default. +Until now, 'map-elt' and 'map-delete' compared alist keys with 'eq' by +default. They now use 'equal' instead, for consistency with +'map-put!' and 'map-contains-key'. + +*** Pcase 'map' pattern added keyword symbols abbreviation. +A pattern like '(map :sym)' binds the map's value for ':sym' to 'sym', +equivalent to '(map (:sym sym))'. + +--- +*** The function 'map-copy' now uses 'copy-alist' on alists. +This is a slightly deeper copy than the previous 'copy-sequence'. + +--- +*** The function 'map-contains-key' now supports plists. + +--- +*** More consistent duplicate key handling in 'map-merge-with'. +Until now, 'map-merge-with' promised to call its function argument +whenever multiple maps contained 'eql' keys. However, this did not +always coincide with the keys that were actually merged, which could +be 'equal' instead. The function argument is now called whenever keys +are merged, for greater consistency with 'map-merge' and 'map-elt'. + +** pcase + ++++ +*** The 'or' pattern now binds the union of the vars of its sub-patterns. +If a variable is not bound by the subpattern that matched, it gets bound +to nil. This was already sometimes the case, but it is now guaranteed. + ++++ +*** The 'pred' pattern can now take the form '(pred (not FUN))'. +This is like '(pred (lambda (x) (not (FUN x))))' but results +in better code. + +--- +*** New function 'pcase-compile-patterns' to write other macros. + ++++ +*** Added 'cl-type' pattern. +The new 'cl-type' pattern compares types using 'cl-typep', which allows +comparing simple types like '(cl-type integer)', as well as forms like +'(cl-type (integer 0 10))'. + ++++ +*** New macro 'pcase-setq'. +This macro is the 'setq' equivalent of 'pcase-let', which allows for +destructuring patterns in a 'setq' form. + +** Edebug + +*** Edebug specification lists can use some new keywords: + ++++ +**** '&interpose SPEC FUN ARGS..' lets FUN control parsing after SPEC. +More specifically, FUN is called with 'HEAD PF ARGS..' where +PF is a parsing function that expects a single argument (the specs to +use) and HEAD is the code that matched SPEC. + ++++ +**** '&error MSG' unconditionally aborts the current edebug instrumentation. + ++++ +**** '&name SPEC FUN' extracts the current name from the code matching SPEC. + +** Dynamic modules changes + ++++ +*** Type aliases for module functions and finalizers. +The module header 'emacs-module.h' now contains type aliases +'emacs_function' and 'emacs_finalizer' for module functions and +finalizers, respectively. + ++++ +*** Module functions can now be made interactive. +Use 'make_interactive' to give a module function an interactive +specification. + ++++ +*** Module functions can now install an optional finalizer. +The finalizer is called when the function object is garbage-collected. +Use 'set_function_finalizer' to set the finalizer and +'get_function_finalizer' to retrieve it. + ++++ +*** Modules can now open a channel to an existing pipe process. +Modules can use the new module function 'open_channel' to do that. +On capable systems, modules can use this functionality to +asynchronously send data back to Emacs. + ++++ +*** A new module API 'make_unibyte_string'. +It can be used to create Lisp strings with arbitrary byte sequences +(a.k.a. "raw bytes"). + ++++ +** Shorthands for Lisp symbols. +Shorthands are a general purpose namespacing system to make Emacs +Lisp's symbol-naming etiquette easier to use. A shorthand is any +symbolic form found in Lisp source that "abbreviates" a symbol's print +name. Among other applications, this feature can be used to avoid +name clashes and namespace pollution by renaming an entire file's +worth of symbols with proper and longer prefixes, without actually +touching the Lisp source. For details, see the manual section +"(elisp) Shorthands". + ++++ +** New function 'string-search'. +This function takes two string parameters and returns the position of +the first instance of the former string in the latter. + ++++ +** New function 'string-replace'. +This function works along the line of 'replace-regexp-in-string', but +it matches on fixed strings instead of regexps, and does not change +the global match state. + ++++ +** New function 'ensure-list'. +This function makes a list of its object if it's not a list already. +If it's already a list, the list is returned as is. + ++++ +** New function 'split-string-shell-command'. +This splits a shell command string into separate components, +respecting quoting with single ('like this') and double ("like this") +quotes, as well as backslash quoting (like\ this). + ++++ +** New function 'string-clean-whitespace'. +This removes whitespace from a string. + ++++ +** New function 'string-fill'. +Word-wrap a string so that no lines are longer that a specific length. + ++++ +** New function 'string-limit'. +Return (up to) a specific substring length. + ++++ +** New function 'string-lines'. +Return a list of strings representing the individual lines in a +string. + ++++ +** New function 'string-pad'. +Pad a string to a specific length. + ++++ +** New function 'string-chop-newline'. +Remove a trailing newline from a string. + ++++ +** New function 'replace-regexp-in-region'. + ++++ +** New function 'replace-string-in-region'. + ++++ +** New function 'file-name-with-extension'. +This function allows a canonical way to set/replace the extension of a +file name. + ++++ +** New function 'file-modes-number-to-symbolic' to convert a numeric +file mode specification into symbolic form. + ++++ +** New function 'file-name-concat'. +This appends file name components to a directory name and returns the +result. + ++++ +** New function 'file-backup-file-names'. +This function returns the list of file names of all the backup files +for the specified file. + ++++ +** New function 'directory-empty-p'. +This predicate tests whether a given file name is an accessible +directory and whether it contains no other directories or files. + ++++ +** New function 'buffer-local-boundp'. +This predicate says whether a symbol is bound in a specific buffer. + ++++ +** New function 'always'. +This is identical to 'ignore', but returns t instead. + ++++ +** New function 'sxhash-equal-including-properties'. +This is identical to 'sxhash-equal' but also accounts for string +properties. + +--- +** New function 'buffer-line-statistics'. +This function returns some statistics about the line lengths in a buffer. + +--- +** New function 'color-values-from-color-spec'. +This can be used to parse RGB color specs in several formats and +convert them to a list '(R G B)' of primary color values. + +--- +** New function 'custom-add-choice'. +This function can be used by modes to add elements to the +'choice' customization type of a variable. + +--- +** New function 'decoded-time-period'. +It interprets a decoded time structure as a period and returns the +equivalent period in seconds. + ++++ +** New function 'dom-print'. + ++++ +** New function 'dom-remove-attribute'. + +--- +** New function 'dns-query-asynchronous'. +It takes the same parameters as 'dns-query', but adds a callback +parameter. + +** New function 'garbage-collect-maybe' to trigger GC early. + +--- +** New function 'get-locale-names'. +This utility function returns a list of names of locales available on +the current system. + ++++ +** New function 'insert-into-buffer'. +This inserts the contents of the current buffer into another buffer. + ++++ +** New function 'json-available-p'. +This predicate returns non-nil if Emacs is built with libjansson +support, and it is available on the current system. + +--- +** New function 'mail-header-parse-addresses-lax'. +This takes a comma-separated string and returns a list of mail/name +pairs. + +--- +** New function 'mail-header-parse-address-lax'. +Parse a string as a mail address-like string. + +--- +** New function 'make-separator-line'. +Make a string appropriate for usage as a visual separator line. + ++++ +** New function 'num-processors'. +Return the number of processors on the system. + ++++ +** New function 'object-intervals'. +This function returns a copy of the list of intervals (i.e., text +properties) in the object in question (which must either be a string +or a buffer). + ++++ +** New function 'process-lines-ignore-status'. +This is like 'process-lines', but does not signal an error if the +return status is non-zero. 'process-lines-handling-status' has also +been added, and takes a callback to handle the return status. + ++++ +** New function 'require-theme'. +This function is like 'require', but searches 'custom-theme-load-path' +instead of 'load-path'. It can be used by Custom themes to load +supporting Lisp files when 'require' is unsuitable. + ++++ +** New function 'seq-union'. +This function takes two sequences and returns a list of all elements +that appear in either of them, with no two elements that compare equal +appearing in the result. + ++++ +** New function 'syntax-class-to-char'. +This does almost the opposite of 'string-to-syntax' -- it returns the +syntax descriptor (a character) given a raw syntax descriptor (an +integer). + ++++ +** New functions 'null-device' and 'path-separator'. +These functions return the connection local value of the respective +variables. This can be used for remote hosts. + ++++ +** New predicate functions 'length<', 'length>' and 'length='. +Using these functions may be more efficient than using 'length' (if +the length of a (long) list is being computed just to compare this +length to a number). + ++++ +** New macro 'dlet' to dynamically bind variables. + ++++ +** New macro 'with-existing-directory'. +This macro binds 'default-directory' to some other existing directory +if 'default-directory' doesn't exist, and then executes the body forms. + ++++ +** New variable 'current-minibuffer-command'. +This is like 'this-command', but it is bound recursively when entering +the minibuffer. + ++++ +** New variable 'inhibit-interaction' to make user prompts signal an error. +If this is bound to something non-nil, functions like +'read-from-minibuffer', 'read-char' (and related) will signal an +'inhibited-interaction' error. + +--- +** New variable 'indent-line-ignored-functions'. +This allows modes to cycle through a set of indentation functions +appropriate for those modes. + ++++ +** New variable 'print-integers-as-characters' modifies integer printing. +If this variable is non-nil, character syntax is used for printing +numbers when this makes sense, such as '?A' for 65. + ++++ +** New variable 'tty-menu-calls-mouse-position-function'. +This controls whether 'mouse-position-function' is called by functions +that retrieve the mouse position when that happens during TTY menu +handling. Lisp programs that set 'mouse-position-function' should +also set this variable non-nil if they are compatible with the tty +menu handling. + ++++ +** New variables that hold default buffer names for shell output. +The new constants 'shell-command-buffer-name' and +'shell-command-buffer-name-async' store the default buffer names +for the output of, respectively, synchronous and async shell +commands. + +--- +** New variables 'read-char-choice-use-read-key' and 'y-or-n-p-use-read-key'. +When non-nil, then functions 'read-char-choice' and 'y-or-n-p' +(respectively) use the function 'read-key' to read a character instead +of using the minibuffer. + ++++ +** New variable 'global-minor-modes'. +This variable holds a list of currently enabled global minor modes (as +a list of symbols). + ++++ +** New buffer-local variable 'local-minor-modes'. +This permanently buffer-local variable holds a list of currently +enabled non-global minor modes in the current buffer (as a list of +symbols). + ++++ +** New completion function 'affixation-function' to add prefix/suffix. +It accepts a list of completions and should return a list where +each element is a list with three elements: a completion, +a prefix string, and a suffix string. + ++++ +** New completion function 'group-function' for grouping candidates. +It takes two arguments: a completion candidate and a 'transform' flag. + ++++ +** New error symbol 'minibuffer-quit'. +Signaling it has almost the same effect as 'quit' except that it +doesn't cause keyboard macro termination. + ++++ +** New error 'remote-file-error', a subcategory of 'file-error'. +It is signaled if a remote file operation fails due to internal +reasons, and could block Emacs. It does not replace 'file-error' +signals for the usual cases. Timers, process filters and process +functions, which run remote file operations, shall protect themselves +against this error. + +If such an error occurs, please report this as bug via 'M-x report-emacs-bug'. +Until it is solved you could ignore such errors by performing + + (setq debug-ignored-errors (cons 'remote-file-error debug-ignored-errors)) + ++++ +** New macro 'named-let' added to subr-x.el. +It provides Scheme's "named let" looping construct. + +--- +** Emacs now attempts to test for high-rate subprocess output more fairly. +When several subprocesses produce output simultaneously at high rate, +Emacs will now by default attempt to service them all in a round-robin +fashion. Set the new variable 'process-prioritize-lower-fds' to a +non-nil value to get back the old behavior, whereby after reading +from a subprocess, Emacs would check for output of other subprocesses +in a way that is likely to read from the same process again. + ++++ +** 'set-process-buffer' now updates the process mark. +The mark will be set to point to the end of the new buffer. + ++++ +** 'unlock-buffer' displays warnings instead of signaling. +Instead of signaling 'file-error' conditions for file system level +errors, the function now calls 'display-warning' and continues as if +the error did not occur. + ++++ +** 'read-char-from-minibuffer' and 'y-or-n-p' support 'help-form'. +If you bind 'help-form' to a non-nil value while calling these functions, +then pressing 'C-h' ('help-char') causes the function to evaluate 'help-form' +and display the result. + ++++ +** 'read-number' now has its own history variable. +Additionally, the function now accepts a HIST argument which can be +used to specify a custom history variable. + ++++ +** 'set-window-configuration' now takes two optional parameters, +'dont-set-frame' and 'dont-set-miniwindow'. The first of these, when +non-nil, instructs the function not to select the frame recorded in +the configuration. The second prevents the current minibuffer being +replaced by the one stored in the configuration. + +--- +** 'count-windows' now takes an optional parameter ALL-FRAMES. +The semantics are as with 'walk-windows'. + ++++ +** 'truncate-string-ellipsis' now uses '…' by default. +Modes that use 'truncate-string-to-width' with non-nil, non-string +argument ELLIPSIS, will now indicate truncation using '…' when +the selected frame can display it, and using "..." otherwise. + ++++ +** 'string-width' now accepts two optional arguments FROM and TO. +This allows calculating the width of a substring without consing a +new string. + ++++ +** 'directory-files' now takes an additional COUNT parameter. +The parameter makes 'directory-files' return COUNT first file names +from a directory. If MATCH is also given, the function will return +first COUNT file names that match the expression. The same COUNT +parameter has been added to 'directory-files-and-attributes'. + ++++ +** 'count-lines' can now ignore invisible lines. +This is controlled by the optional parameter IGNORE-INVISIBLE-LINES. + +--- +** 'count-words' now crosses field boundaries. +Originally, 'count-words' would stop counting at the first field +boundary it encountered; now it keeps counting all the way to the +region's (or buffer's) end. + ++++ +** File-related APIs can optionally follow symlinks. +The functions 'file-modes', 'set-file-modes', and 'set-file-times' now +have an optional argument specifying whether to follow symbolic links. + ++++ +** 'format-seconds' can now be used for sub-second times. +The new optional "," parameter has been added, and +'(format-seconds "%mm %,1ss" 66.4)' will now result in "1m 6.4s". + ++++ +** 'parse-time-string' can now parse ISO 8601 format strings. +These have a format like "2020-01-15T16:12:21-08:00". + +--- +** 'lookup-key' is more allowing when searching for extended menu items. +When looking for a menu item '[menu-bar Foo-Bar]', first try to find +an exact match, then look for the lowercased '[menu-bar foo-bar]'. +It will only try to downcase ASCII characters in the range "A-Z". +This improves backwards-compatibility when converting menus to use +'easy-menu-define'. + +--- +** 'make-network-process', 'make-serial-process' ':coding' behavior change. +Previously, passing ':coding nil' to either of these functions would +override any non-nil binding for 'coding-system-for-read' and +'coding-system-for-write'. For consistency with 'make-process' and +'make-pipe-process', passing ':coding nil' is now ignored. No code in +Emacs depended on the previous behavior; if you really want the +process' coding-system to be nil, use 'set-process-coding-system' +after the process has been created, or pass in ':coding '(nil nil)'. + ++++ +** 'open-network-stream' now accepts a ':coding' argument. +This allows specifying the coding systems used by a network process +for encoding and decoding without having to bind +'coding-system-for-{read,write}' or call 'set-process-coding-system'. + ++++ +** 'open-network-stream' can now take a ':capability-command' that's a function. +The function is called with the greeting from the server as its only +parameter, and allows sending different TLS capability commands to the +server based on that greeting. + ++++ +** 'open-gnutls-stream' now also accepts a ':coding' argument. + +--- +** 'process-attributes' now works under OpenBSD, too. + ++++ +** 'format-spec' now takes an optional SPLIT parameter. +If non-nil, 'format-spec' will split the resulting string into a list +of strings, based on where the format specs (and expansions) were. + +--- +** 'unload-feature' now also tries to undo additions to buffer-local hooks. + +--- +** 'while-no-input-ignore-events' accepts more special events. +The special events 'dbus-event' and 'file-notify' are now ignored in +'while-no-input' when added to this variable. + +--- +** 'start-process-shell-command' and 'start-file-process-shell-command' +do not support the old calling conventions any longer. + ++++ +** 'yes-or-no-p' and 'y-or-n-p' PROMPT parameter no longer needs trailing space. +In other words, the prompt can now end with "?" instead of "? ". This +has been the case since Emacs 24.4 but was not announced or documented +until now. (Checkdoc has also been updated to accept this convention.) + ++++ +** The 'uniquify' argument in 'auto-save-file-name-transforms' can be a symbol. +If this symbol is one of the members of 'secure-hash-algorithms', +Emacs constructs the nondirectory part of the auto-save file name by +applying that 'secure-hash' to the buffer file name. This avoids any +risk of excessively long file names. + ++++ +** New user option 'process-file-return-signal-string'. +It controls, whether 'process-file' returns a string when a remote +process is interrupted by a signal. + +** EIEIO Changes + ++++ +*** The macro 'oref-default' can now be used with 'setf'. +It is now defined as a generalized variable that can be used with +'setf' to modify the value stored in a given class slot. + +--- +*** 'form' in '(eql form)' specializers in 'cl-defmethod' is now evaluated. +This corresponds to the behavior of defmethod in Common Lisp Object System. +For compatibility, '(eql SYMBOL)' does not evaluate SYMBOL, for now. + +** D-Bus + ++++ +*** Property values can be typed explicitly. +'dbus-register-property' and 'dbus-set-property' accept now optional +type symbols. Both functions propagate D-Bus errors. + ++++ +*** Registered properties can have the new access type ':write'. + ++++ +*** In case of problems, handlers can emit proper D-Bus error messages now. + ++++ +*** D-Bus errors, which have been converted from incoming D-Bus error +messages, contain the error name of that message now. + ++++ +*** D-Bus messages can be monitored with the new command 'dbus-monitor'. + ++++ +*** D-Bus events have changed their internal structure. +They carry now the destination and the error-name of an event. They +also keep the type information of their arguments. Use the +'dbus-event-*' accessor functions. + +** Buttons + ++++ +*** New minor mode 'button-mode'. +This minor mode does nothing except install 'button-buffer-map' as +a minor mode map (which binds the 'TAB' / 'S-TAB' key bindings to navigate +to buttons), and can be used in any view-mode-like buffer that has +buttons in it. + ++++ +*** New utility function 'button-buttonize'. +This function takes a string and returns a string propertized in a way +that makes it a valid button. + +--- +** 'text-scale-mode' can now adjust font size of the header line. +When the new buffer local variable 'text-scale-remap-header-line' +is non-nil, 'text-scale-adjust' will also scale the text in the header +line when displaying that buffer. + +This is useful for major modes that arrange their display in a tabular +form below the header line. It is enabled by default in +'tabulated-list-mode' and its derived modes, and disabled by default +elsewhere. + +--- +** 'ascii' is now a coding system alias for 'us-ascii'. + +--- +** New coding-systems for EBCDIC variants. +New coding-systems 'ibm256', 'ibm273', 'ibm274', 'ibm277', 'ibm278', +'ibm280', 'ibm281', 'ibm284', 'ibm285', 'ibm290', 'ibm297'. These are +variants of the EBCDIC encoding tailored to some European and Japanese +locales. They are also available as aliases 'ebcdic-cp-*' (e.g., +'ebcdic-cp-fi' for the Finnish variant 'ibm278'), and 'cp2xx' (e.g., +'cp278' for 'ibm278'). There are also new charsets 'ibm2xx' to +support these coding-systems. + ++++ +** New 'Bindat type expression' description language. +This new system is provided by the new macro 'bindat-type' and +obsoletes the old data layout specifications. It supports +arbitrary-size integers, recursive types, and more. See the Info node +"(elisp) Byte Packing" in the ELisp manual for more details. + ++++ +** New macro 'with-environment-variables'. +This macro allows setting environment variables temporarily when +executing a form. + + +* Changes in Emacs 28.1 on Non-Free Operating Systems + ++++ +** On MS-Windows, Emacs can now use the native image API to display images. +Emacs can now use the MS-Windows GDI+ library to load and display +images in JPEG, PNG, GIF and TIFF formats. This support is available +unless Emacs was configured '--without-native-image-api'. + +This feature is experimental, and needs to be turned on to be used. +To turn this on, set the variable 'w32-use-native-image-API' to a +non-nil value. Please report any bugs you find while using the native +image API via 'M-x report-emacs-bug'. + ++++ +** On MS-Windows, Emacs can now toggle the IME. +A new function 'w32-set-ime-open-status' can now be used to disable +and enable the MS-Windows native Input Method Editor (IME) at run +time. A companion function 'w32-get-ime-open-status' returns the +current IME activation status. + +-- +** On macOS, 's-<left>' and 's-<right>' are now bound to +'move-beginning-of-line' and 'move-end-of-line' respectively. The commands +to select previous/next frame are still bound to 's-~' and 's-`'. + ++++ +** On macOS, Emacs can now load dynamic modules with a ".dylib" suffix. +'module-file-suffix' now has the value ".dylib" on macOS, but the +".so" suffix is supported as well. + +--- +** On macOS, the user option 'make-pointer-invisible' is now honored. + +--- +** On macOS, Xwidget is now supported. +If Emacs was built with xwidget support, you can access the embedded +webkit browser with 'M-x xwidget-webkit-browse-url'. Viewing two +instances of xwidget webkit is not supported. + +--- +*** New user option 'xwidget-webkit-enable-plugins'. +If non-nil, enable plugins in xwidget. (This is only available on +macOS.) + ++++ +** New macOS Contacts back-end for EUDC. +This backend works on newer versions of macOS and is generally +preferred over the eudcb-mab.el backend. + + +---------------------------------------------------------------------- +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + + +Local variables: +coding: utf-8 +mode: outline +paragraph-separate: "[ ]*$" +end: diff --git a/etc/PROBLEMS b/etc/PROBLEMS index f94d8492d57..69ab6ccb745 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. @@ -1087,13 +1096,30 @@ The solution is to remove the corresponding lines from the appropriate 'fonts.alias' file, then run 'mkfontdir' in that directory, and then run 'xset fp rehash'. -** The 'oc-unicode' package doesn't work with Emacs 21. +** fcitx input methods don't work with xwidgets. + +fcitx-based input methods might not work when xwidgets are displayed, +such as inside an xwidget-webkit buffer. This manifests as the pre-edit +window of the input method disappearing, and the Emacs frame losing +input focus as soon as you try to type anything. You can work around +this problem by switching to IBus, or by using a native Emacs input +method and disabling XIM altogether. For example, you can add the +following line: + + Emacs.useXIM: false + +In your ~/.Xresources file, then run + + $ xrdb ~/.Xresources -This package tries to define more private charsets than there are free -slots now. The current built-in Unicode support is actually more -flexible. (Use option 'utf-translate-cjk-mode' if you need CJK -support.) Files encoded as emacs-mule using oc-unicode aren't -generally read correctly by Emacs 21. +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 @@ -1210,6 +1236,15 @@ A workaround is to not use 'klipper'/'clipit'. Upgrading 'klipper' to the one coming with KDE 3.3 or later might solve the problem; if it doesn't, set 'select-active-regions' to 'only' or nil. +*** Emacs doesn't receive the key "C-.", displaying an input field instead. + +This is caused by the IBus Emoji input panel, which is usually bound +to "C-.". You can disable that panel by running the following +command: + + $ gsettings set org.freedesktop.ibus.panel.emoji hotkey "[]" + + ** Window-manager and toolkit-related problems *** Emacs built with GTK+ toolkit produces corrupted display on HiDPI screen @@ -1302,6 +1337,12 @@ A better approach might be to avoid navigation from Nautilus to Emacs for such files, and instead to open the file in Emacs using Tramp remote file name syntax. +*** Gnome: GTK builds with XInput2 freeze when making a frame fullscreen. + +This problem exists with GTK 3.24.30 in GNOME 41.1 and possibly other +versions. The solution is to upgrade GNOME Shell to the version that +comes with GNOME 41.2. + *** KDE: When running on KDE, colors or fonts are not as specified for Emacs, or messed up. @@ -1649,6 +1690,18 @@ This happens on the proprietary X server ASTEC-X when the number of monitors is changed after the server has started. A workaround is to restart the X server after the monitor configuration has been changed. +*** Touchpad gestures don't work and emit warning messages. + +When pinching or swiping on your touchpad, you might see a warning +message that looks like: + + XInputWireToCookie: Unknown generic event. type 28 + +This happens when your XInput headers support XInput 2.4, but the +actual version of libXi installed does not. The solution is to +upgrade your libXi binaries to libXi 1.8.0 or later, to correspond +with your XInput headers. + * Runtime problems on character terminals *** With X forwarding, mouse highlighting can make Emacs slow. @@ -2292,20 +2345,6 @@ are compiling with the system's 'cc' and CFLAGS containing '-O5'. If so, you have hit a compiler bug. Please make sure to re-configure Emacs so that it isn't compiled with '-O5'. -*** AIX 4.3.x or 4.4: Compiling fails. - -This could happen if you use /bin/c89 as your compiler, instead of -the default 'cc'. /bin/c89 treats certain warnings, such as benign -redefinitions of macros, as errors, and fails the build. A solution -is to use the default compiler 'cc'. - -*** AIX 4: Some programs fail when run in a Shell buffer -with an error message like No terminfo entry for "unknown". - -On AIX, many terminal type definitions are not installed by default. -'unknown' is one of them. Install the "Special Generic Terminal -Definitions" to make them defined. - ** Solaris We list bugs in current versions here. See also the section on legacy @@ -2357,13 +2396,6 @@ runtime shared library, distributed with Windows 9X. A workaround is to build Emacs with MinGW runtime 3.x (the latest version is 3.20). -** addpm fails to run on Windows NT4, complaining about Shell32.dll - -This is likely to happen because Shell32.dll shipped with NT4 lacks -the updates required by Emacs. Installing Internet Explorer 4 solves -the problem. Note that it is NOT enough to install IE6, because doing -so will not install the Shell32.dll update. - ** A few seconds delay is seen at startup and for many file operations This happens when the Net Logon service is enabled. During Emacs @@ -2477,15 +2509,6 @@ C:\Users\<UserName>\): Look for the file 'emacs.lnk' there. -** Windows 95 and networking. - -To support server sockets, Emacs loads ws2_32.dll. If this file is -missing, all Emacs networking features are disabled. - -Old versions of Windows 95 may not have the required DLL. To use -Emacs's networking features on Windows 95, you must install the -"Windows Socket 2" update available from MicroSoft's support Web. - ** Emacs exits with "X protocol error" when run with an X server for MS-Windows. A certain X server for Windows had a bug which caused this. @@ -2522,11 +2545,6 @@ other) messages while waiting for a system function, which popped up the menu/dialog, to return the result of the dialog or pop-up menu interaction. -** Help text in tooltips does not work on old Windows versions - -Windows 95 and Windows NT up to version 4.0 do not support help text -for menus. Help text is only available in later versions of Windows. - ** Display problems with ClearType method of smoothing When "ClearType" method is selected as the "method to smooth edges of @@ -2801,6 +2819,17 @@ file; for example: "/usr/local/opt/libgccjit/lib/gcc/11" "/usr/local/opt/gcc/lib/gcc/11/gcc/x86_64-apple-darwin20/11.2.0") ":")) +* Runtime problems specific to PGTK + +** Some modifier keys doesn't work if Emacs is started in a systemd unit file. + +Environment variables may be different if there is a difference in the +behavior of keys between when started in the systemd unit file and +when started from the command line. + +Especially, PGTK Emacs needs environment variables LANG and +GTK_IM_MODULE. + * Build-time problems ** Configuration @@ -3145,15 +3174,6 @@ of PURESIZE in puresize.h. But in some of the cases listed above, this problem is a consequence of something else that is wrong. Be sure to check and fix the real problem. -*** OpenBSD 4.0 macppc: Segfault during dumping. - -The build aborts with signal 11 when the command './temacs --batch ---load loadup bootstrap' tries to load files.el. A workaround seems -to be to reduce the level of compiler optimization used during the -build (from -O2 to -O1). It is possible this is an OpenBSD -GCC problem specific to the macppc architecture, possibly only -occurring with older versions of GCC (e.g. 3.3.5). - *** openSUSE 10.3: Segfault in bcopy during dumping. This is due to a bug in the bcopy implementation in openSUSE 10.3. @@ -3308,8 +3328,51 @@ should do. pen@lysator.liu.se says (Feb 1998) that the Compose key does work if you link with the MIT X11 libraries instead of the Solaris X11 libraries. +** OpenBSD + +*** OpenBSD 4.0 macppc: Segfault during dumping. + +The build aborts with signal 11 when the command './temacs --batch +--load loadup bootstrap' tries to load files.el. A workaround seems +to be to reduce the level of compiler optimization used during the +build (from -O2 to -O1). It is possible this is an OpenBSD +GCC problem specific to the macppc architecture, possibly only +occurring with older versions of GCC (e.g. 3.3.5). + +** AIX + +*** AIX 4.3.x or 4.4: Compiling fails. + +This could happen if you use /bin/c89 as your compiler, instead of +the default 'cc'. /bin/c89 treats certain warnings, such as benign +redefinitions of macros, as errors, and fails the build. A solution +is to use the default compiler 'cc'. + +*** AIX 4: Some programs fail when run in a Shell buffer +with an error message like No terminfo entry for "unknown". + +On AIX, many terminal type definitions are not installed by default. +'unknown' is one of them. Install the "Special Generic Terminal +Definitions" to make them defined. + ** MS-Windows 95, 98, ME, and NT +*** MS-Windows 95: Networking. + +To support server sockets, Emacs loads ws2_32.dll. If this file is +missing, all Emacs networking features are disabled. + +Old versions of Windows 95 may not have the required DLL. To use +Emacs's networking features on Windows 95, you must install the +"Windows Socket 2" update available from MicroSoft's support Web. + +*** MS-Windows NT4: addpm fails to run, complaining about Shell32.dll + +This is likely to happen because Shell32.dll shipped with NT4 lacks +the updates required by Emacs. Installing Internet Explorer 4 solves +the problem. Note that it is NOT enough to install IE6, because doing +so will not install the Shell32.dll update. + *** MS-Windows NT/95: Problems running Perl under Emacs 'perl -de 0' just hangs when executed in an Emacs subshell. @@ -3373,6 +3436,11 @@ For Perl 4: } else { +*** MS-Windows NT/95: Help text in tooltips does not work + +Windows 95 and Windows NT up to version 4.0 do not support help text +for menus. Help text is only available in later versions of Windows. + *** MS-Windows 95: Alt-f6 does not get through to Emacs. This character seems to be trapped by the kernel in Windows 95. @@ -80,6 +80,10 @@ all interactive commands to see if they are only relevant in one particular mode. This requires care as some commands might be useful outside of the mode they were written for. +** Convert defvar foo-mode-map to defvar-keymap +Verify the conversion by comparing the value of the keymap before +converting it and after (you can see the value in 'C-h v'). + ** Write more tests Pick a fixed bug from the database, write a test case to make sure it stays fixed. Or pick your favorite programming major-mode, and write 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/e/README b/etc/e/README index dd2c8d64e25..1293292a878 100644 --- a/etc/e/README +++ b/etc/e/README @@ -1,12 +1,12 @@ -eterm-color.ti is a terminfo source file. eterm-color is a compiled -version produced by the terminfo compiler (tic). The compiled files -are binary, and depend on the version of tic, but they seem to be -system-independent and backwardly compatible. So there should be no -need to recompile the distributed binary version. If it is -necessary, use: +eterm-color.ti is a terminfo source file. eterm-color and +eterm-direct are compiled versions produced by the terminfo compiler +(tic). The compiled files are binary, and depend on the version of +tic, but they seem to be system-independent and backwardly compatible. +So there should be no need to recompile the distributed binary +version. If it is necessary, use: tic -o ../ ./eterm-color.ti -The compiled file is used by lisp/term.el, so if it is moved term.el -needs to be changed. terminfo requires it to be stored in an 'e' -subdirectory (the first character of the file name). +The compiled files are used by lisp/term.el, so if they are moved, +term.el needs to be changed. terminfo requires them to be stored in +an 'e' subdirectory (the first character of the file name). diff --git a/etc/e/eterm-color b/etc/e/eterm-color Binary files differindex bd3f5003ae6..bf44fa0f36d 100644 --- a/etc/e/eterm-color +++ b/etc/e/eterm-color diff --git a/etc/e/eterm-color.ti b/etc/e/eterm-color.ti index a6ef8149900..eeb9b0b6e6a 100644 --- a/etc/e/eterm-color.ti +++ b/etc/e/eterm-color.ti @@ -9,15 +9,16 @@ eterm-color|Emacs term.el terminal emulator term-protocol-version 0.96, # Any change to this file should be done at the same time with a # corresponding change to the TERMCAP environment variable in term.el. # Comments in term.el specify where each of these capabilities is implemented. - colors#8, + colors#256, cols#80, lines#24, - pairs#64, + pairs#32767, am, mir, msgr, xenl, bel=^G, + blink=\E[5m, bold=\E[1m, clear=\E[H\E[J, cr=\r, @@ -31,6 +32,7 @@ eterm-color|Emacs term.el terminal emulator term-protocol-version 0.96, cup=\E[%i%p1%d;%p2%dH, cuu1=\E[A, cuu=\E[%p1%dA, + dim=\E[2m, dch1=\E[P, dch=\E[%p1%dP, dl1=\E[M, @@ -60,14 +62,16 @@ eterm-color|Emacs term.el terminal emulator term-protocol-version 0.96, rc=\E8, rev=\E[7m, ri=\EM, + ritm=\E[23m, rmir=\E[4l, rmso=\E[27m, rmul=\E[24m, rs1=\Ec, sc=\E7, - setab=\E[%p1%{40}%+%dm, - setaf=\E[%p1%{30}%+%dm, + setab=\E[%?%p1%{8}%<%t4%p1%d%e%p1%{16}%<%t10%p1%{8}%-%d%e48;5;%p1%d%;m, + setaf=\E[%?%p1%{8}%<%t3%p1%d%e%p1%{16}%<%t9%p1%{8}%-%d%e38;5;%p1%d%;m, sgr0=\E[m, + sitm=\E[3m, smir=\E[4h, smul=\E[4m, smso=\E[7m, @@ -76,3 +80,10 @@ eterm-color|Emacs term.el terminal emulator term-protocol-version 0.96, # smcup=\E[?47h, # rmcup=\E[?47l, # rs2 may need to be added + +eterm-direct|Emacs term.el with direct-color indexing term-protocol-version 0.96, + use=eterm-color, + colors#0x1000000, + pairs#0x10000, + setab=\E[%?%p1%{8}%<%t4%p1%d%e48;2;%p1%{65536}%/%d;%p1%{256}%/%{255}%&%d;%p1%{255}%&%d%;m, + setaf=\E[%?%p1%{8}%<%t3%p1%d%e38;2;%p1%{65536}%/%d;%p1%{256}%/%{255}%&%d;%p1%{255}%&%d%;m, diff --git a/etc/e/eterm-direct b/etc/e/eterm-direct Binary files differnew file mode 100644 index 00000000000..c113c371369 --- /dev/null +++ b/etc/e/eterm-direct diff --git a/etc/images/README b/etc/images/README index 9bbe796cc95..561cfff7653 100644 --- a/etc/images/README +++ b/etc/images/README @@ -68,6 +68,7 @@ Emacs images and their source in the GNOME icons stock/ directory: bookmark_add.xpm actions/bookmark_add cancel.xpm slightly modified generic/stock_stop connect.xpm net/stock_connect + connect-to-url.xpm net/stock_connect-to-url contact.xpm net/stock_contact data-save.xpm data/stock_data-save delete.xpm generic/stock_delete diff --git a/etc/images/connect-to-url.pbm b/etc/images/connect-to-url.pbm Binary files differnew file mode 100644 index 00000000000..f142349f4a9 --- /dev/null +++ b/etc/images/connect-to-url.pbm diff --git a/etc/images/connect-to-url.xpm b/etc/images/connect-to-url.xpm new file mode 100644 index 00000000000..38fefeaf611 --- /dev/null +++ b/etc/images/connect-to-url.xpm @@ -0,0 +1,281 @@ +/* XPM */ +static char *connect_to_url[] = { +/* columns rows colors chars-per-pixel */ +"24 24 251 2 ", +" c black", +". c #010101", +"X c #000103", +"o c #010204", +"O c #010305", +"+ c #020407", +"@ c #020609", +"# c #03070C", +"$ c #04080D", +"% c #0F0F0D", +"& c #030A10", +"* c #050B10", +"= c #060C11", +"- c #070D13", +"; c #070D14", +": c #060C15", +"> c #070E14", +", c #0B1824", +"< c #0A1B2B", +"1 c #0A1C2E", +"2 c #141A20", +"3 c #161E25", +"4 c #181E23", +"5 c #0D2032", +"6 c #142534", +"7 c #1F2830", +"8 c #1D2933", +"9 c #102438", +"0 c #272622", +"q c #21292F", +"w c #272F36", +"e c #282F33", +"r c #222F3A", +"t c #2E3337", +"y c #2D373E", +"u c #32383C", +"i c #33383C", +"p c #343A3E", +"a c #43423C", +"s c #112941", +"d c #102A44", +"f c #132D47", +"g c #192F46", +"h c #17314B", +"j c #15314F", +"k c #163351", +"l c #163554", +"z c #173554", +"x c #1F3A53", +"c c #1D3955", +"v c #1A3958", +"b c #1C3B5B", +"n c #1F3C58", +"m c #1D3C5C", +"M c #1E3E5D", +"N c #1F3F5F", +"B c #303B44", +"V c #313C44", +"C c #313D47", +"Z c #213C56", +"A c #233E57", +"S c #1F405F", +"D c #374148", +"F c #2D4050", +"G c #25405B", +"H c #25425E", +"J c #214262", +"K c #244565", +"L c #264665", +"P c #254666", +"I c #2A4967", +"U c #284969", +"Y c #2A4C6C", +"T c #2C4F6F", +"R c #33526E", +"E c #385269", +"W c #2D5070", +"Q c #2E5172", +"! c #335473", +"~ c #3F5B75", +"^ c #3D5F7D", +"/ c #41494F", +"( c #646056", +") c #6C685E", +"_ c #505F6C", +"` c #48657C", +"' c #556A7A", +"] c #5B6C78", +"[ c #5F6F7B", +"{ c #5D6F7D", +"} c #706C62", +"| c #726D63", +" . c #78756B", +".. c #7D786E", +"X. c #60727F", +"o. c #807D74", +"O. c #8A857B", +"+. c #8B877E", +"@. c #4E6A83", +"#. c #4A6A86", +"$. c #4A7090", +"%. c #587790", +"&. c #5F7E95", +"*. c #587B98", +"=. c #6F7980", +"-. c #697F8F", +";. c #66839B", +":. c #6A879F", +">. c #708391", +",. c #728A9A", +"<. c #748898", +"1. c #758A99", +"2. c #7B8F9F", +"3. c #708DA4", +"4. c #7990A1", +"5. c #7292AB", +"6. c #7691A8", +"7. c #7693AB", +"8. c #7B98AE", +"9. c #7E98AD", +"0. c #7E9DB3", +"q. c #7F9EB4", +"w. c #8C8981", +"e. c #989389", +"r. c #A6A29B", +"t. c #8093A1", +"y. c #8598A3", +"u. c #8498A7", +"i. c #809AAD", +"p. c #8F9FAA", +"a. c #899FAE", +"s. c #819FB5", +"d. c #86A2B8", +"f. c #87A5BB", +"g. c #88A3B8", +"h. c #89A5BA", +"j. c #8FABBF", +"k. c #97A7B1", +"l. c #90AABE", +"z. c #91ABBF", +"x. c #98ACB9", +"c. c #AAA7A0", +"v. c #B1ADA4", +"b. c #B3B1AA", +"n. c #B7B3AA", +"m. c #A3B1BC", +"M. c #A5B1BC", +"N. c #A9B6BF", +"B. c #BEBBB5", +"V. c #C4C2BD", +"C. c #94AEC1", +"Z. c #96AEC1", +"A. c #94AFC2", +"S. c #95AFC2", +"D. c #96B0C3", +"F. c #98B0C3", +"G. c #9FB5C3", +"H. c #99B3C6", +"J. c #98B3C7", +"K. c #9AB3C6", +"L. c #9BB4C7", +"P. c #9FB8CA", +"I. c #9FB8CB", +"U. c #A2B8C9", +"Y. c #A3B9C9", +"T. c #A0B9CB", +"R. c #A3BACB", +"E. c #A0B9CC", +"W. c #A2BACC", +"Q. c #A4BDCE", +"!. c #A6BECF", +"~. c #B8BEC2", +"^. c #B8C3CA", +"/. c #BCC5CB", +"(. c #BDC8CE", +"). c #A8C0D1", +"_. c #AAC0D0", +"`. c #ABC1D1", +"'. c #ACC2D3", +"]. c #AAC5D7", +"[. c #B4C8D6", +"{. c #BDCBD5", +"}. c #B4C9D8", +"|. c #B6CAD8", +" X c #B8CBD9", +".X c #BBCDDB", +"XX c #B7D0E0", +"oX c #BDD3E2", +"OX c #BCD5E5", +"+X c #CECAC3", +"@X c #C5D2C8", +"#X c #C0D2DE", +"$X c #C4D3DF", +"%X c #CCD7DE", +"&X c #D2D8DC", +"*X c #E1DFDB", +"=X c #E2E1DD", +"-X c #C2D3E0", +";X c #C2D4E1", +":X c #C5D5E1", +">X c #C6D6E1", +",X c #C4D6E2", +"<X c #C5D6E3", +"1X c #C6D7E3", +"2X c #C3D7E4", +"3X c #C1D7E6", +"4X c #C7D8E3", +"5X c #C5D8E5", +"6X c #C7D9E5", +"7X c #CBD9E4", +"8X c #CBDAE5", +"9X c #CDDAE4", +"0X c #CCDBE5", +"qX c #CFDBE5", +"wX c #CBDCE7", +"eX c #C0D9E8", +"rX c #C2DBEA", +"tX c #C4DAE8", +"yX c #D0DEE7", +"uX c #D1DFE8", +"iX c #D0DFE9", +"pX c #D0E0EA", +"aX c #D1E1EB", +"sX c #D3E1EA", +"dX c #D4E1E9", +"fX c #D4E1EA", +"gX c #D5E2EA", +"hX c #D4E2EB", +"jX c #D6E2EB", +"kX c #D3E2EC", +"lX c #D8E3EA", +"zX c #DFE6EB", +"xX c #D9E4EC", +"cX c #D9E5ED", +"vX c #DAE5ED", +"bX c #DAE6ED", +"nX c #DCE7EE", +"mX c #DBE8EF", +"MX c #DDE8EF", +"NX c #DFE8EF", +"BX c #EAE8E3", +"VX c #EBEAE6", +"CX c #ECEBE8", +"ZX c #E9EEEA", +"AX c #F0EFEC", +"SX c #F2F0ED", +"DX c #E1ECF3", +"FX c #E4EDF3", +"GX c #E8EFF4", +"HX c #F0F3F1", +"JX c None", +/* pixels */ +"JXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJX", +"JXJXJXJXJXJXJXJXu D p t i V w JXJXJXJXJXJXJXJXJX", +"JXJXJXJXJXJXC X./.&XDXGX%X{.m._ r JXJXJXJXJXJXJX", +"JXJXJXJXJXi /.DXnXnXFXuX7X$X$XjXM.w JXJXJXJXJXJX", +"JXJXJXJX/ ^.qXbX1XkX5X5X-X;XsXqXjXN.B JXJXJXJXJX", +"JXJXJXe (.bXMXDXaXtXtX3XoXbXjXsXyX7Xx.q JXJXJXJX", +"JXJX7 k.jXbXbX5X3XeXrXOXXX1XsXyXwX$X|.4.3 JXJXJX", +"JXJXX.:XuXjX'.]._.y. G.sXW.|..X$X[.H.' JXJXJX", +"JXJXu.$XqXT.H.>. e.o. sXwX}.R.R.`.H.1.- JXJX", +"JX4 a.9.C.h.] a n.V.BXo. p.!.T.l.4.- JXJX", +"JX2 F.d.5.7. =XAXc.BXo. @X@XZX !.C.F.@.> JXJX", +" o.=XAXc.BXo. t.U.z.3.Y $ JXJX", +"BXBXBXBXVXBXBXAXVXO.CXo. P.C.!.I.J.C.;.L * JXJX", +"o.o.o.o.o. . .B.b...*X . $.*.T.J.A.h.Y c @ JXJX", +" .w.r.| +X . 1.C.3.L h JXJX", +"JXJX6 Q ^ 1.% w.r.| +X . @X@XHX h.:.M , JXJX", +"JXJXO x T #.] 0 +.} v.) -.s.H 9 O JXJXJX", +"JXJXJX+ n ! i.X.% % e.( Q Y %.0.&.f O JXJXJX", +"JXJXJXJX& A s.8.E A % % A K J R ` g @ JXJXJXJX", +"JXJXJXJXJX@ C ~ m M J N M b v l < O JXJXJXJXJX", +"JXJXJXJXJXJX : 5 d k z k d 1 & JXJXJXJXJXJX", +"JXJXJXJXJXJXJXJX JXJXJXJXJXJXJXJX", +"JXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJX", +"JXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJXJX" +}; diff --git a/etc/org.gnu.emacs.defaults.gschema.xml b/etc/org.gnu.emacs.defaults.gschema.xml new file mode 100644 index 00000000000..7c700ac0b65 --- /dev/null +++ b/etc/org.gnu.emacs.defaults.gschema.xml @@ -0,0 +1,51 @@ +<?xml version="1.0" encoding="utf-8"?> +<!-- Copyright (C) 2019-2020 Free Software Foundation, Inc. --> +<schemalist> + + <schema id="org.gnu.emacs.defaults"> + + <key name='alpha' type='s'><default>''</default></key> + <key name='auto-raise-lower' type='s'><default>''</default></key> + <key name='auto-lower' type='s'><default>''</default></key> + <key name='auto-raise' type='s'><default>''</default></key> + <key name='background' type='s'><default>''</default></key> + <key name='background-mode' type='s'><default>''</default></key> + <key name='bitmap-icon' type='s'><default>''</default></key> + <key name='border-color' type='s'><default>''</default></key> + <key name='border-width' type='s'><default>''</default></key> + <key name='buffer-predicate' type='s'><default>''</default></key> + <key name='cursor-blink' type='s'><default>''</default></key> + <key name='cursor-type' type='s'><default>''</default></key> + <key name='cursor-color' type='s'><default>''</default></key> + <key name='font' type='s'><default>''</default></key> + <key name='font-backend' type='s'><default>''</default></key> + <key name='foreground' type='s'><default>''</default></key> + <key name='fullscreen' type='s'><default>''</default></key> + <key name='horizontal-scroll-bars' type='s'><default>''</default></key> + <key name='icon-name' type='s'><default>''</default></key> + <key name='inhibit-double-buffering' type='s'><default>''</default></key> + <key name='internal-border' type='s'><default>''</default></key> + <key name='internal-border-width' type='s'><default>''</default></key> + <key name='left-fringe' type='s'><default>''</default></key> + <key name='line-spacing' type='s'><default>''</default></key> + <key name='menu-bar' type='s'><default>''</default></key> + <key name='minibuffer' type='s'><default>''</default></key> + <key name='name' type='s'><default>''</default></key> + <key name='pointer-color' type='s'><default>''</default></key> + <key name='reverse-video' type='s'><default>''</default></key> + <key name='right-fringe' type='s'><default>''</default></key> + <key name='screen-gamma' type='s'><default>''</default></key> + <key name='scroll-bar' type='s'><default>''</default></key> + <key name='scroll-bar-background' type='s'><default>''</default></key> + <key name='scroll-bar-foreground' type='s'><default>''</default></key> + <key name='scroll-bar-height' type='s'><default>''</default></key> + <key name='scroll-bar-width' type='s'><default>''</default></key> + <key name='scroll-bars' type='s'><default>''</default></key> + <key name='title' type='s'><default>''</default></key> + <key name='tool-bar' type='s'><default>''</default></key> + <key name='vertical-scroll-bars' type='s'><default>''</default></key> + <key name='wait-for-w-m' type='s'><default>''</default></key> + + </schema> + +</schemalist> diff --git a/etc/publicsuffix.txt b/etc/publicsuffix.txt index 5cc95b9000c..5529554d82d 100644 --- a/etc/publicsuffix.txt +++ b/etc/publicsuffix.txt @@ -7132,7 +7132,7 @@ org.zw // newGTLDs -// List of new gTLDs imported from https://www.icann.org/resources/registries/gtlds/v2/gtlds.json on 2021-10-08T15:12:46Z +// List of new gTLDs imported from https://www.icann.org/resources/registries/gtlds/v2/gtlds.json on 2021-11-13T15:12:42Z // This list is auto-generated, don't edit it manually. // aaa : 2015-02-26 American Automobile Association, Inc. aaa @@ -7647,7 +7647,7 @@ cars // casa : 2013-11-21 Registry Services, LLC casa -// case : 2015-09-03 CNH Industrial N.V. +// case : 2015-09-03 Helium TLDs Ltd case // cash : 2014-03-06 Binky Moon, LLC @@ -10317,9 +10317,6 @@ xin // xn--3ds443g : 2013-09-08 TLD REGISTRY LIMITED OY 在线 -// xn--3oq18vl8pn36a : 2015-07-02 Volkswagen (China) Investment Co., Ltd. -大众汽车 - // xn--3pxu8k : 2015-01-15 VeriSign Sarl 点看 @@ -10785,10 +10782,6 @@ s3-website.eu-west-2.amazonaws.com s3-website.eu-west-3.amazonaws.com s3-website.us-east-2.amazonaws.com -// Amsterdam Wireless: https://www.amsterdamwireless.nl/ -// Submitted by Imre Jonk <hostmaster@amsterdamwireless.nl> -amsw.nl - // Amune : https://amune.org/ // Submitted by Team Amune <cert@amune.org> t3l3p0rt.net @@ -10982,7 +10975,6 @@ za.com // No longer operated by CentralNic, these entries should be adopted and/or removed by current operators // Submitted by Gavin Brown <gavin.brown@centralnic.com> ar.com -gb.com hu.com kr.com no.com @@ -11036,10 +11028,6 @@ cx.ua discourse.group discourse.team -// ClearVox : http://www.clearvox.nl/ -// Submitted by Leon Rowland <leon@clearvox.nl> -virtueeldomein.nl - // Clever Cloud : https://www.clever-cloud.com/ // Submitted by Quentin Adam <noc@clever-cloud.com> cleverapps.io @@ -11642,12 +11630,6 @@ blogsite.xyz // Submitted by Dominik Menke <dom@digineo.de> dynv6.net -// Ellucian : https://ellucian.com -// Submitted by Josue Colon <CloudOps-Network@ellucian.com> -elluciancrmadvance.com -elluciancrmadvise.com -elluciancrmrecruit.com - // E4YOU spol. s.r.o. : https://e4you.cz/ // Submitted by Vladimir Dudr <info@e4you.cz> e4.cz @@ -11915,6 +11897,11 @@ fireweb.app // Submitted by Louis Chemineau <louis@chmn.me> flap.id +// FlashDrive : https://flashdrive.io +// Submitted by Eric Chan <support@flashdrive.io> +onflashdrive.app +fldrv.com + // fly.io: https://fly.io // Submitted by Kurt Mackey <kurt@fly.io> fly.dev diff --git a/etc/refcards/ru-refcard.tex b/etc/refcards/ru-refcard.tex index 179be0af885..018be36eb46 100644 --- a/etc/refcards/ru-refcard.tex +++ b/etc/refcards/ru-refcard.tex @@ -40,7 +40,7 @@ \newlength{\ColThreeWidth} \setlength{\ColThreeWidth}{25mm} -\newcommand{\versionemacs}[0]{28} % version of Emacs this is for +\newcommand{\versionemacs}[0]{29} % version of Emacs this is for \newcommand{\cyear}[0]{2021} % copyright year \newcommand\shortcopyrightnotice[0]{\vskip 1ex plus 2 fill diff --git a/etc/themes/adwaita-theme.el b/etc/themes/adwaita-theme.el index c98bec6cfa5..7d297df5260 100644 --- a/etc/themes/adwaita-theme.el +++ b/etc/themes/adwaita-theme.el @@ -96,6 +96,9 @@ default look of the Gnome 3 desktop.") `(gnus-cite-1 ((,class (:foreground "#00578E")))) `(gnus-cite-2 ((,class (:foreground "#0084C8")))) + `(image-dired-thumb-mark ((,class (:background "#CE5C00")))) + `(image-dired-thumb-flagged ((,class (:background "#B50000")))) + `(diff-added ((,class (:bold t :foreground "#4E9A06")))) `(diff-removed ((,class (:bold t :foreground "#F5666D")))))) diff --git a/etc/themes/deeper-blue-theme.el b/etc/themes/deeper-blue-theme.el index cfe8a5bfb28..5895693386c 100644 --- a/etc/themes/deeper-blue-theme.el +++ b/etc/themes/deeper-blue-theme.el @@ -82,6 +82,8 @@ `(ido-first-match ((,class (:weight normal :foreground "orange")))) `(ido-only-match ((,class (:foreground "green")))) `(ido-subdir ((,class (:foreground nil :inherit font-lock-keyword-face)))) + `(image-dired-thumb-flagged ((,class (:background "Red1")))) + `(image-dired-thumb-mark ((,class (:background "dodgerblue3")))) `(info-header-node ((,class (:foreground "DeepSkyBlue1")))) `(info-header-xref ((,class (:foreground "SeaGreen2")))) `(info-menu-header ((,class (:family "helv" :weight bold)))) diff --git a/etc/themes/dichromacy-theme.el b/etc/themes/dichromacy-theme.el index c59b24bef50..148ebd434cd 100644 --- a/etc/themes/dichromacy-theme.el +++ b/etc/themes/dichromacy-theme.el @@ -101,6 +101,9 @@ Ansi-Color faces are included.") `(gnus-header-subject ((,class (:foreground ,orange)))) `(gnus-header-name ((,class (:foreground ,skyblue)))) `(gnus-header-newsgroups ((,class (:foreground ,vermillion)))) + ;; Image-Dired + `(image-dired-thumb-flagged ((,class (:background ,vermillion)))) + `(image-dired-thumb-mark ((,class (:background ,orange)))) ;; Message faces `(message-header-name ((,class (:foreground ,skyblue)))) `(message-header-cc ((,class (:foreground ,vermillion)))) diff --git a/etc/themes/leuven-theme.el b/etc/themes/leuven-theme.el index 95ec303f706..514384ca2af 100644 --- a/etc/themes/leuven-theme.el +++ b/etc/themes/leuven-theme.el @@ -632,6 +632,8 @@ more...") `(ilog-echo-face ((,class (:height 2.0 :foreground "#006FE0")))) `(ilog-load-face ((,class (:foreground "#BA36A5")))) `(ilog-message-face ((,class (:foreground "#808080")))) + `(image-dired-thumb-flagged ((,class (:background "red")))) + `(image-dired-thumb-mark ((,class :background "#FFAAAA"))) `(indent-guide-face ((,class (:foreground "#D3D3D3")))) `(info-file ((,class (:family "Sans Serif" :height 1.8 :weight bold :box (:line-width 1 :color "#0000CC") :foreground "cornflower blue" :background "LightSteelBlue1")))) `(info-header-node ((,class (:underline t :foreground "orange")))) ; nodes in header diff --git a/etc/themes/light-blue-theme.el b/etc/themes/light-blue-theme.el index f49b37a15fd..547d2df04c0 100644 --- a/etc/themes/light-blue-theme.el +++ b/etc/themes/light-blue-theme.el @@ -29,6 +29,8 @@ (deftheme light-blue "Face colors utilizing a light blue background.") +(make-obsolete 'light-blue nil "29.1") + (let ((class '((class color) (min-colors 89)))) (custom-theme-set-faces 'light-blue diff --git a/etc/themes/manoj-dark-theme.el b/etc/themes/manoj-dark-theme.el index 0e5fb391198..e80403f5b34 100644 --- a/etc/themes/manoj-dark-theme.el +++ b/etc/themes/manoj-dark-theme.el @@ -221,6 +221,9 @@ jarring angry fruit salad look to reduce eye fatigue.") '(gnus-group-news-low-empty ((t (:foreground "DarkTurquoise")))) '(gnus-group-news-low-empty-face ((t (:foreground "DarkTurquoise")))) + ;; '(image-dired-thumb-flagged ((t (:background "red")))) + ;; '(image-dired-thumb-mark ((t (:background "Pink")))) + ;;message faces '(message-cited-text ((t (:foreground "red3")))) '(message-header-cc ((t (:bold t :foreground "chartreuse1" :weight bold)))) @@ -538,7 +541,6 @@ jarring angry fruit salad look to reduce eye fatigue.") '(ido-indicator ((t (:background "red1" :foreground "yellow1" :width condensed)))) '(ido-only-match ((t (:foreground "ForestGreen")))) '(ido-subdir ((t (:foreground "red1")))) - '(info-menu-5 ((t (:underline t)))) '(info-menu-header ((t (:bold t :weight bold)))) '(info-node ((t (:bold t :italic t :foreground "yellow")))) '(info-node ((t (:italic t :bold t :foreground "white" :slant italic :weight bold)))) diff --git a/etc/themes/modus-operandi-theme.el b/etc/themes/modus-operandi-theme.el index 350524779d6..9c183e744c4 100644 --- a/etc/themes/modus-operandi-theme.el +++ b/etc/themes/modus-operandi-theme.el @@ -4,24 +4,24 @@ ;; Author: Protesilaos Stavrou <info@protesilaos.com> ;; URL: https://gitlab.com/protesilaos/modus-themes -;; Version: 1.6.0 -;; Package-Requires: ((emacs "26.1")) +;; Version: 2.0.0 +;; Package-Requires: ((emacs "27.1")) ;; Keywords: faces, theme, accessibility ;; This file is part of GNU Emacs. -;; This program is free software; you can redistribute it and/or modify +;; 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. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: ;; diff --git a/etc/themes/modus-themes.el b/etc/themes/modus-themes.el index 7ab985c0771..406b8970aa5 100644 --- a/etc/themes/modus-themes.el +++ b/etc/themes/modus-themes.el @@ -4,25 +4,25 @@ ;; Author: Protesilaos Stavrou <info@protesilaos.com> ;; URL: https://gitlab.com/protesilaos/modus-themes -;; Version: 1.6.0 -;; Last-Modified: <2021-09-29 08:47:03 +0300> +;; Version: 2.0.0 +;; Last-Modified: <2021-12-24 12:35:25 +0200> ;; Package-Requires: ((emacs "27.1")) ;; Keywords: faces, theme, accessibility ;; This file is part of GNU Emacs. -;; This program is free software; you can redistribute it and/or modify +;; 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. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: ;; @@ -31,20 +31,19 @@ ;; 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: <https://protesilaos.com/modus-themes>). +;; themes, or available at: <https://protesilaos.com/emacs/modus-themes>). ;; ;; The themes share the following customization variables: ;; ;; modus-themes-headings (alist) ;; modus-themes-org-agenda (alist) ;; modus-themes-bold-constructs (boolean) +;; modus-themes-deuteranopia (boolean) ;; modus-themes-inhibit-reload (boolean) +;; modus-themes-intense-markup (boolean) ;; modus-themes-italic-constructs (boolean) -;; modus-themes-no-mixed-fonts (boolean) -;; modus-themes-scale-headings (boolean) +;; modus-themes-mixed-fonts (boolean) ;; modus-themes-subtle-line-numbers (boolean) -;; modus-themes-success-deuteranopia (boolean) -;; modus-themes-variable-pitch-headings (boolean) ;; modus-themes-variable-pitch-ui (boolean) ;; modus-themes-completions (choice) ;; modus-themes-diffs (choice) @@ -60,20 +59,6 @@ ;; modus-themes-region (choice) ;; modus-themes-syntax (choice) ;; -;; The default scale for headings is as follows (it can be customized as -;; well---remember, no scaling takes place by default): -;; -;; modus-themes-scale-1 1.05 -;; modus-themes-scale-2 1.1 -;; modus-themes-scale-3 1.15 -;; modus-themes-scale-4 1.2 -;; modus-themes-scale-title 1.3 -;; -;; There is another scaling-related option, which however is reserved -;; for special cases and is not used for headings: -;; -;; modus-themes-scale-small 0.9 -;; ;; There also exist two unique customization variables for overriding ;; color palette values. The specifics are documented in the manual. ;; The symbols are: @@ -87,14 +72,12 @@ ;; missing package or change you would like to see. ;; ;; ace-window -;; ag ;; alert ;; all-the-icons ;; annotate ;; ansi-color ;; anzu ;; apropos -;; apt-sources-list ;; artbollocks-mode ;; auctex and TeX ;; auto-dim-other-buffers @@ -107,7 +90,6 @@ ;; boon ;; bookmark ;; breakpoint (provided by built-in gdb-mi.el) -;; buffer-expose ;; calendar and diary ;; calfw ;; centaur-tabs @@ -125,7 +107,6 @@ ;; corfu ;; counsel ;; counsel-css -;; counsel-org-capture-string ;; cov ;; cperl-mode ;; css-mode @@ -137,28 +118,24 @@ ;; dashboard (emacs-dashboard) ;; deadgrep ;; debbugs -;; define-word ;; deft ;; dictionary ;; diff-hl ;; diff-mode ;; dim-autoload ;; dir-treeview -;; dired +;; Dired ;; dired-async ;; dired-git ;; dired-git-info ;; dired-narrow ;; dired-subtree -;; diredc ;; diredfl ;; diredp (dired+) -;; disk-usage ;; display-fill-column-indicator-mode ;; doom-modeline ;; dynamic-ruler ;; easy-jekyll -;; easy-kill ;; ebdb ;; ediff ;; eglot @@ -195,7 +172,6 @@ ;; flycheck-posframe ;; flymake ;; flyspell -;; flyspell-correct ;; flx ;; freeze-it ;; frog-menu @@ -207,10 +183,8 @@ ;; geiser ;; git-commit ;; git-gutter (and variants) -;; git-lens ;; git-rebase ;; git-timemachine -;; git-walktree ;; gnus ;; gotest ;; golden-ratio-scroll-screen @@ -219,25 +193,20 @@ ;; helm-switch-shell ;; helm-xref ;; helpful -;; highlight-blocks -;; highlight-defined -;; highlight-escape-sequences (`hes-mode') ;; highlight-indentation ;; highlight-numbers -;; highlight-symbol -;; highlight-tail ;; highlight-thing ;; hl-defined ;; hl-fill-column ;; hl-line-mode ;; hl-todo ;; hydra -;; hyperlist ;; ibuffer ;; icomplete ;; ido-mode ;; iedit ;; iflipb +;; image-dired ;; imenu-list ;; indium ;; info @@ -245,7 +214,6 @@ ;; interaction-log ;; ioccur ;; isearch, occur, etc. -;; isl (isearch-light) ;; ivy ;; ivy-posframe ;; jira (org-jira) @@ -269,21 +237,18 @@ ;; markup-faces (`adoc-mode') ;; mentor ;; messages -;; minibuffer-line ;; minimap ;; mmm-mode ;; mode-line ;; mood-line ;; mpdel ;; mu4e -;; mu4e-conversation ;; multiple-cursors +;; nano-modeline ;; neotree -;; no-emoji ;; notmuch ;; num3-mode ;; nxml-mode -;; objed ;; orderless ;; org ;; org-journal @@ -303,14 +268,11 @@ ;; pandoc-mode ;; paradox ;; paren-face -;; parrot ;; pass ;; pdf-tools ;; persp-mode ;; perspective ;; phi-grep -;; phi-search -;; pkgbuild-mode ;; pomidor ;; popup ;; powerline @@ -322,7 +284,6 @@ ;; quick-peek ;; racket-mode ;; rainbow-blocks -;; rainbow-identifiers ;; rainbow-delimiters ;; rcirc ;; recursion-indicator @@ -331,7 +292,6 @@ ;; ripgrep ;; rmail ;; ruler-mode -;; sallet ;; selectrum ;; selectrum-prescient ;; semantic @@ -348,13 +308,10 @@ ;; smerge ;; spaceline ;; speedbar -;; spell-fu -;; spray ;; stripes ;; suggest ;; switch-window ;; swiper -;; swoop ;; sx ;; symbol-overlay ;; syslog-mode @@ -376,12 +333,11 @@ ;; undo-tree ;; vc (vc-dir.el, vc-hooks.el) ;; vc-annotate (C-x v g) -;; vdiff ;; vertico +;; vertico-quick ;; vimish-fold ;; visible-mark ;; visual-regexp -;; volatile-highlights ;; vterm ;; wcheck-mode ;; web-mode @@ -589,9 +545,6 @@ cover the blue-cyan-magenta side of the spectrum." ;; while bg-tab-inactive should be combined with fg-dim, whereas ;; bg-tab-inactive-alt goes together with fg-main ;; - ;; bg-tab-bar is only intended for the bar that holds the tabs and - ;; can only be combined with fg-main - ;; ;; fg-escape-char-construct and fg-escape-char-backslash can ;; be combined bg-main, bg-dim, bg-alt ;; @@ -621,7 +574,6 @@ cover the blue-cyan-magenta side of the spectrum." (bg-region-accent . "#afafef") (bg-region-accent-subtle . "#efdfff") - (bg-tab-bar . "#d5d5d5") (bg-tab-active . "#f6f6f6") (bg-tab-inactive . "#b7b7b7") (bg-tab-inactive-accent . "#a9b4f6") @@ -834,9 +786,6 @@ symbol and the latter as a string.") ;; while bg-tab-inactive should be combined with fg-dim, whereas ;; bg-tab-inactive-alt goes together with fg-main ;; - ;; bg-tab-bar is only intended for the bar that holds the tabs and - ;; can only be combined with fg-main - ;; ;; fg-escape-char-construct and fg-escape-char-backslash can ;; be combined bg-main, bg-dim, bg-alt ;; @@ -866,7 +815,6 @@ symbol and the latter as a string.") (bg-region-accent . "#4f3d88") (bg-region-accent-subtle . "#240f55") - (bg-tab-bar . "#2c2c2c") (bg-tab-active . "#0e0e0e") (bg-tab-inactive . "#424242") (bg-tab-inactive-accent . "#35398f") @@ -915,10 +863,10 @@ symbol and the latter as a string.") (bg-diff-refine-changed . "#585800") (fg-diff-refine-changed . "#ffffcc") (bg-diff-refine-removed . "#852828") (fg-diff-refine-removed . "#ffd9eb") - (bg-diff-focus-added . "#203d20") (fg-diff-focus-added . "#b4ddb4") - (bg-diff-focus-added-deuteran . "#00405f") (fg-diff-focus-added-deuteran . "#bfe4ff") - (bg-diff-focus-changed . "#4a3a10") (fg-diff-focus-changed . "#d0daaf") - (bg-diff-focus-removed . "#5e2526") (fg-diff-focus-removed . "#eebdba") + (bg-diff-focus-added . "#1d3c25") (fg-diff-focus-added . "#b4ddb4") + (bg-diff-focus-added-deuteran . "#003959") (fg-diff-focus-added-deuteran . "#bfe4ff") + (bg-diff-focus-changed . "#424200") (fg-diff-focus-changed . "#d0daaf") + (bg-diff-focus-removed . "#500f29") (fg-diff-focus-removed . "#eebdba") (bg-mark-sel . "#002f2f") (fg-mark-sel . "#60cfa2") (bg-mark-del . "#5a0000") (fg-mark-del . "#ff99aa") @@ -1475,7 +1423,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,11 +1432,16 @@ 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) +(defface modus-themes-ui-variable-pitch nil + "Face for `modus-themes-variable-pitch-ui'. +The actual styling of the face is done by `modus-themes-faces'." + :group 'modus-theme-faces) + (defface modus-themes-graph-red-0 nil "Special subdued red face for use in graphs. This is intended to be applied in contexts such as the Org agenda @@ -1668,6 +1621,72 @@ The actual styling of the face is done by `modus-themes-faces'." The actual styling of the face is done by `modus-themes-faces'." :group 'modus-theme-faces) +;; "Grue" is "green" and "blue". +(defface modus-themes-grue nil + "Generic face for `modus-themes-deuteranopia' foreground. +The actual styling of the face is done by `modus-themes-faces'." + :group 'modus-themes-faces) + +(defface modus-themes-grue-active nil + "Face for `modus-themes-deuteranopia' active foreground. +The actual styling of the face is done by `modus-themes-faces'." + :group 'modus-themes-faces) + +(defface modus-themes-grue-nuanced nil + "Face for `modus-themes-deuteranopia' nuanced foreground. +The actual styling of the face is done by `modus-themes-faces'." + :group 'modus-themes-faces) + +(defface modus-themes-grue-background-active nil + "Face for `modus-themes-deuteranopia' active background. +The actual styling of the face is done by `modus-themes-faces'." + :group 'modus-themes-faces) + +(defface modus-themes-grue-background-intense nil + "Face for `modus-themes-deuteranopia' intense background. +The actual styling of the face is done by `modus-themes-faces'." + :group 'modus-themes-faces) + +(defface modus-themes-grue-background-subtle nil + "Face for `modus-themes-deuteranopia' subtle background. +The actual styling of the face is done by `modus-themes-faces'." + :group 'modus-themes-faces) + +(defface modus-themes-grue-background-refine nil + "Face for `modus-themes-deuteranopia' refined background. +The actual styling of the face is done by `modus-themes-faces'." + :group 'modus-themes-faces) + +(defface modus-themes-link-symlink nil + "Face for `modus-themes-links' symbolic link. +The actual styling of the face is done by `modus-themes-faces'." + :group 'modus-themes-faces) + +(defface modus-themes-link-broken nil + "Face for `modus-themes-links' broken link. +The actual styling of the face is done by `modus-themes-faces'." + :group 'modus-themes-faces) + +(defface modus-themes-tab-backdrop nil + "Face of backdrop in tabbed interfaces. +The actual styling of the face is done by `modus-themes-faces'." + :group 'modus-themes-faces) + +(defface modus-themes-tab-active nil + "Face of active tab. +The actual styling of the face is done by `modus-themes-faces'." + :group 'modus-themes-faces) + +(defface modus-themes-tab-inactive nil + "Face of inactive tab. +The actual styling of the face is done by `modus-themes-faces'." + :group 'modus-themes-faces) + +(defface modus-themes-markup-verbatim nil + "Face of verbatim markup. +The actual styling of the face is done by `modus-themes-faces'." + :group 'modus-themes-faces) + ;;; Customization variables @@ -1762,7 +1781,7 @@ For form, see `modus-themes-vivendi-colors'." :link '(info-link "(modus-themes) Bold constructs")) (defcustom modus-themes-variable-pitch-headings nil - "Use proportional fonts (variable-pitch) in headings." + "DEPRECATED: specify `variable-pitch' in `modus-themes-headings'." :group 'modus-themes :package-version '(modus-themes . "1.0.0") :version "28.1" @@ -1771,6 +1790,8 @@ For form, see `modus-themes-vivendi-colors'." :initialize #'custom-initialize-default :link '(info-link "(modus-themes) Headings' typeface")) +(make-obsolete 'modus-themes-variable-pitch-headings 'modus-themes-headings "2.0.0") + (defcustom modus-themes-variable-pitch-ui nil "Use proportional fonts (variable-pitch) in UI elements. This includes the mode line, header line, tab bar, and tab line." @@ -1782,30 +1803,44 @@ 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. - -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." +(define-obsolete-variable-alias + 'modus-themes-no-mixed-fonts + 'modus-themes-mixed-fonts "On 2021-10-02 for version 1.7.0") + +(defcustom modus-themes-mixed-fonts nil + "Non-nil to enable inheritance from `fixed-pitch' in some faces. + +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)) + (float :tag "Number (float) to adjust height by" :value 1.1) (choice :tag "Colors" (const :tag "Subtle colors" nil) (const :tag "Rainbow colors" rainbow) @@ -1824,71 +1859,86 @@ described below. Here is a sample, followed by a presentation of all available properties: (setq modus-themes-headings - '((1 . (background overline)) - (2 . (overline rainbow)) - (t . (monochrome)))) + (quote ((1 . (background overline variable-pitch 1.5)) + (2 . (overline rainbow 1.3)) + (3 . (overline 1.1)) + (t . (monochrome))))) By default (a nil value for this variable), all headings have a -bold typographic weight and use a desaturated text color. +bold typographic weight, use a desaturated text color, have a +font family that is the same as the `default' face (typically +monospaced), and a height that is equal to the `default' face's +height. A `rainbow' property makes the text color more saturated. An `overline' property draws a line above the area of the heading. -A `background' property adds a subtle tinted color to the +A `background' property applies 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. +A `monochrome' property makes the heading the same as the base +color, which is that of the `default' face's foreground. When +`background' is also set, `monochrome' changes its color to gray. +If both `monochrome' and `rainbow' are set, the former takes +precedence. + +A `variable-pitch' property changes the font family of the +heading to that of the `variable-pitch' face (normally a +proportionately spaced typeface). + +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. + +A number, expressed as a floating point (e.g. 1.5), adjusts the +height of the heading to that many times the base font size. The +default height is the same as 1.0, though it need not be +explicitly stated. 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 1.3) The order in which the properties are set is not significant. 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)))) + (quote ((1 . (background overline rainbow 1.5)) + (2 . (background overline 1.3)) + (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 will retain the original aesthetic for that level. For example: (setq modus-themes-headings - '((1 . t) ; keep the default style - (2 . (background overline)) - (t . (rainbow)))) ; style for all other headings + (quote ((1 . t) ; keep the default style + (2 . (background overline)) + (t . (rainbow))))) ; style for all other headings (setq modus-themes-headings - '((1 . (background overline)) - (2 . (rainbow no-bold)) - (t . t))) ; default style for all other levels + (quote ((1 . (background overline)) + (2 . (rainbow semibold)) + (t . t)))) ; default style for all other levels For Org users, the extent of the heading depends on the variable `org-fontify-whole-heading-line'. This affects the `overline' and `background' properties. Depending on the version of Org, -there may be others, such as `org-fontify-done-headline'. - -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." +there may be others, such as `org-fontify-done-headline'." :group 'modus-themes - :package-version '(modus-themes . "1.5.0") - :version "28.1" + :package-version '(modus-themes . "2.0.0") + :version "29.1" :type `(alist :options ,(mapcar (lambda (el) (list el modus-themes--headings-choice)) @@ -1907,11 +1957,11 @@ is a sample, followed by a description of all possible combinations: (setq modus-themes-org-agenda - '((header-block . (variable-pitch scale-title)) - (header-date . (grayscale workaholic bold-today)) - (event . (accented scale-small)) - (scheduled . uniform) - (habit . traffic-light))) + (quote ((header-block . (variable-pitch 1.5 semibold)) + (header-date . (grayscale workaholic bold-today 1.2)) + (event . (accented italic varied)) + (scheduled . uniform) + (habit . traffic-light)))) A `header-block' key applies to elements that concern the headings which demarcate blocks in the structure of the agenda. @@ -1921,19 +1971,30 @@ font size. Acceptable values come in the form of a list that can include either or both of those properties: - `variable-pitch' to use a proportionately spaced typeface; -- `scale-title' to increase height to `modus-themes-scale-title' - OR `no-scale' to set the font to the same height as the rest of - the buffer. - -In case both `scale-title' and `no-scale' are in the list, the -latter takes precedence. +- A number as a floating point (e.g. 1.5) to set the height of + the text to that many times the default font height. A float + of 1.0 or the symbol `no-scale' have the same effect of making + the font to the same height as the rest of the buffer. When + neither a number nor `no-scale' are present, the default is a + small increase in height (a value of 1.15). +- 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). + +In case both a number and `no-scale' are in the list, the latter +takes precedence. If two numbers are specified, the first one is +applied. Example usage: (header-block . nil) - (header-block . (scale-title)) + (header-block . (1.5)) (header-block . (no-scale)) - (header-block . (variable-pitch scale-title)) + (header-block . (variable-pitch 1.5)) + (header-block . (variable-pitch 1.5 semibold)) A `header-date' key covers date headings. Dates use only a foreground color by default (a nil value), with weekdays and @@ -1947,12 +2008,13 @@ that can include any of the following properties: terms of color; - `bold-today' to apply a bold typographic weight to the current date; -- `bold-all' to render all date headings in a bold weight. -- `scale-heading' increases the height of the date headings to - the value of `modus-themes-scale-1' (which is the first step in - the scale for regular headings). +- `bold-all' to render all date headings in a bold weight; - `underline-today' applies an underline to the current date - while removing the background it has by default. + while removing the background it has by default; +- A number as a floating point (e.g. 1.2) to set the height of + the text to that many times the default font height. The + default is the same as the base font height (the equivalent of + 1.0). For example: @@ -1961,28 +2023,38 @@ For example: (header-date . (grayscale bold-all)) (header-date . (grayscale workaholic)) (header-date . (grayscale workaholic bold-today)) - (header-date . (grayscale workaholic bold-today scale-heading)) + (header-date . (grayscale workaholic bold-today 1.2)) -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). - `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 @@ -2028,9 +2100,11 @@ value are passed as a symbol. Those are: The difference between ready and clear states is attenuated by painting both of them using shades of green. This option thus highlights the alert and overdue states. -- `traffic-light-deuteranopia' is like the `traffic-light' except - its three colors are red, yellow, and blue to be suitable for - users with red-green color deficiency (deuteranopia). +- When `modus-themes-deuteranopia' is non-nil the habit graph + uses a three-color style like the aforementioned + `traffic-light' variant, except that shades of blue are applied + instead of green. This is suitable for users with red-green + color deficiency (deuteranopia). For example: @@ -2038,8 +2112,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 . "2.0.0") + :version "29.1" :type '(set (cons :tag "Block header" (const header-block) @@ -2047,10 +2121,22 @@ For example: (choice :tag "Font style" (const :tag "Use the original typeface (default)" nil) (const :tag "Use `variable-pitch' font" variable-pitch)) + (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 "Scaling" (const :tag "Slight increase in height (default)" nil) (const :tag "Do not scale" no-scale) - (const :tag "Scale to match `modus-themes-scale-title'" scale-title)))) + (float :tag "Number (float) to adjust height by" :value 1.3)))) (cons :tag "Date header" :greedy t (const header-date) (set :tag "Header presentation" :greedy t @@ -2058,14 +2144,14 @@ For example: (const :tag "Do not differentiate weekdays from weekends" workaholic) (const :tag "Make today bold" bold-today) (const :tag "Make all dates bold" bold-all) - (const :tag "Increase font size (`modus-themes-scale-1')" scale-heading) + (float :tag "Number (float) to adjust height by" :value 1.05) (const :tag "Make today underlined; remove the background" underline-today))) (cons :tag "Event entry" :greedy t (const event) (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) @@ -2075,183 +2161,88 @@ For example: (const habit) (choice (const :tag "Follow the original design of `org-habit' (default)" nil) (const :tag "Do not distinguish between present and future variants" simplified) - (const :tag "Use only red, yellow, green" traffic-light) - (const :tag "Use only red, yellow, blue" traffic-light-deuteranopia)))) + (const :tag "Use only red, yellow, green" traffic-light)))) :set #'modus-themes--set-option :initialize #'custom-initialize-default :link '(info-link "(modus-themes) Org agenda")) (defcustom modus-themes-scale-headings nil - "Use font scaling for headings. - -For regular headings the scale is controlled by the variables -`modus-themes-scale-1' (smallest increase) and its variants all -the way up to `modus-themes-scale-4' (largest increase). - -While `modus-themes-scale-title' is reserved for special headings -that nominally are the largest on the scale (though that is not a -requirement). - -A special heading is, in this context, one that does not fit into -the syntax for heading levels that apply to the given mode. For -example, Org's #+title keyword lies outside the normal eight -levels of headings. Whereas, say, Markdown does not have such a -special heading." + "DEPRECATED: specify height in `modus-themes-headings'." :group 'modus-themes :package-version '(modus-themes . "1.2.0") :version "28.1" :type 'boolean :set #'modus-themes--set-option - :initialize #'custom-initialize-default - :link '(info-link "(modus-themes) Scaled headings")) - -(defcustom modus-themes-scale-1 1.05 - "Font size that is slightly larger than the base value. + :initialize #'custom-initialize-default) -This size is used for level 4 headings, such as in Org and -Markdown files. +(make-obsolete 'modus-themes-scale-headings 'modus-themes-headings "2.0.0") -The default value is a floating point that is interpreted as a -multiple of the base font size. It is recommended to use such a -value. - -However, the variable also accepts an integer, understood as an -absolute height that is 1/10 of the typeface's point size (e.g. a -value of 140 is the same as setting the font at 14 point size). -This will ignore the base font size and, thus, will not scale in -accordance with it in cases where it changes, such as while using -`text-scale-adjust'." +(defcustom modus-themes-scale-1 1.05 + "DEPRECATED: specify height in `modus-themes-headings'." :group 'modus-themes :package-version '(modus-themes . "1.2.0") :version "28.1" :type 'number :set #'modus-themes--set-option - :initialize #'custom-initialize-default - :link '(info-link "(modus-themes) Scaled heading sizes")) - -(defcustom modus-themes-scale-2 1.1 - "Font size slightly larger than `modus-themes-scale-1'. + :initialize #'custom-initialize-default) -This size is used for level 3 headings, such as in Org and -Markdown files. +(make-obsolete 'modus-themes-scale-1 'modus-themes-headings "2.0.0") -The default value is a floating point that is interpreted as a -multiple of the base font size. It is recommended to use such a -value. - -However, the variable also accepts an integer, understood as an -absolute height that is 1/10 of the typeface's point size (e.g. a -value of 140 is the same as setting the font at 14 point size). -This will ignore the base font size and, thus, will not scale in -accordance with it in cases where it changes, such as while using -`text-scale-adjust'." +(defcustom modus-themes-scale-2 1.1 + "DEPRECATED: specify height in `modus-themes-headings'." :group 'modus-themes :package-version '(modus-themes . "1.2.0") :version "28.1" :type 'number :set #'modus-themes--set-option - :initialize #'custom-initialize-default - :link '(info-link "(modus-themes) Scaled heading sizes")) - -(defcustom modus-themes-scale-3 1.15 - "Font size slightly larger than `modus-themes-scale-2'. + :initialize #'custom-initialize-default) -This size is used for level 2 headings, such as in Org and -Markdown files. +(make-obsolete 'modus-themes-scale-2 'modus-themes-headings "2.0.0") -The default value is a floating point that is interpreted as a -multiple of the base font size. It is recommended to use such a -value. - -However, the variable also accepts an integer, understood as an -absolute height that is 1/10 of the typeface's point size (e.g. a -value of 140 is the same as setting the font at 14 point size). -This will ignore the base font size and, thus, will not scale in -accordance with it in cases where it changes, such as while using -`text-scale-adjust'." +(defcustom modus-themes-scale-3 1.15 + "DEPRECATED: specify height in `modus-themes-headings'." :group 'modus-themes :package-version '(modus-themes . "1.2.0") :version "28.1" :type 'number :set #'modus-themes--set-option - :initialize #'custom-initialize-default - :link '(info-link "(modus-themes) Scaled heading sizes")) - -(defcustom modus-themes-scale-4 1.2 - "Font size slightly larger than `modus-themes-scale-3'. + :initialize #'custom-initialize-default) -This size is used for level 1 headings, such as in Org and -Markdown files. +(make-obsolete 'modus-themes-scale-3 'modus-themes-headings "2.0.0") -The default value is a floating point that is interpreted as a -multiple of the base font size. It is recommended to use such a -value. - -However, the variable also accepts an integer, understood as an -absolute height that is 1/10 of the typeface's point size (e.g. a -value of 140 is the same as setting the font at 14 point size). -This will ignore the base font size and, thus, will not scale in -accordance with it in cases where it changes, such as while using -`text-scale-adjust'." +(defcustom modus-themes-scale-4 1.2 + "DEPRECATED: specify height in `modus-themes-headings'." :group 'modus-themes :package-version '(modus-themes . "1.2.0") :version "28.1" :type 'number :set #'modus-themes--set-option - :initialize #'custom-initialize-default - :link '(info-link "(modus-themes) Scaled heading sizes")) + :initialize #'custom-initialize-default) -(define-obsolete-variable-alias 'modus-themes-scale-5 'modus-themes-scale-title "1.5.0") +(make-obsolete 'modus-themes-scale-4 'modus-themes-headings "2.0.0") (defcustom modus-themes-scale-title 1.3 - "Font size slightly larger than `modus-themes-scale-4'. - -This size is only used for 'special' top level headings, such as -Org's file title heading, denoted by the #+title key word, and -the Org agenda structure headers (see `modus-themes-org-agenda'). - -The default value is a floating point that is interpreted as a -multiple of the base font size. It is recommended to use such a -value. - -However, the variable also accepts an integer, understood as an -absolute height that is 1/10 of the typeface's point size (e.g. a -value of 140 is the same as setting the font at 14 point size). -This will ignore the base font size and, thus, will not scale in -accordance with it in cases where it changes, such as while using -`text-scale-adjust'." + "DEPRECATED: specify height in `modus-themes-headings'. +Same principle for `modus-themes-org-agenda'." :group 'modus-themes :package-version '(modus-themes . "1.5.0") :version "28.1" :type 'number :set #'modus-themes--set-option - :initialize #'custom-initialize-default - :link '(info-link "(modus-themes) Scaled heading sizes")) + :initialize #'custom-initialize-default) -(defcustom modus-themes-scale-small 0.9 - "Font size smaller than the default value. - -This size is only used in special contexts where users are -presented with the option to have smaller text on display (see -`modus-themes-org-agenda'). - -The default value is a floating point that is interpreted as a -multiple of the base font size. It is recommended to use such a -value. +(make-obsolete 'modus-themes-scale-title 'modus-themes-headings "2.0.0") -However, the variable also accepts an integer, understood as an -absolute height that is 1/10 of the typeface's point size (e.g. a -value of 140 is the same as setting the font at 14 point size). -This will ignore the base font size and, thus, will not scale in -accordance with it in cases where it changes, such as while using -`text-scale-adjust'." +(defcustom modus-themes-scale-small 0.9 + "DEPRECATED." :group 'modus-themes :package-version '(modus-themes . "1.6.0") :version "28.1" :type 'number :set #'modus-themes--set-option - :initialize #'custom-initialize-default - :link '(info-link "(modus-themes) Scaled heading sizes")) + :initialize #'custom-initialize-default) + +(make-obsolete 'modus-themes-scale-small nil "2.0.0") (defcustom modus-themes-fringes nil "Define the visibility of fringes. @@ -2289,12 +2280,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: @@ -2307,20 +2298,26 @@ The order in which the properties are set is not significant. In user configuration files the form may look like this: - (setq modus-themes-lang-checkers '(text-also background)) + (setq modus-themes-lang-checkers (quote (text-also background))) 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")) @@ -2369,50 +2366,6 @@ respectively." :initialize #'custom-initialize-default :link '(info-link "(modus-themes) Org mode blocks")) -(defcustom modus-themes-org-habit nil - "Deprecated in version 1.5.0 favor of `modus-themes-org-agenda'. - -Control the presentation of the `org-habit' graph. - -The default is meant to conform with the original aesthetic of -`org-habit'. It employs all four color codes that correspond to -the org-habit states---clear, ready, alert, and overdue---while -distinguishing between their present and future variants. This -results in a total of eight colors in use: red, yellow, green, -blue, in tinted and shaded versions. They cover the full set of -information provided by the `org-habit' consistency graph. - -Option `simplified' is like the default except that it removes -the dichotomy between current and future variants by applying -uniform color-coded values. It applies a total of four colors: -red, yellow, green, blue. They produce a simplified consistency -graph that is more legible (or less \"busy\") than the default. -The intent is to shift focus towards the distinction between the -four states of a habit task, rather than each state's -present/future outlook. - -Option `traffic-light' further reduces the available colors to -red, yellow, and green. As in `simplified', present and future -variants appear uniformly, but differently from it, the 'clear' -state is rendered in a green hue, instead of the original blue. -This is meant to capture the use-case where a habit task being -\"too early\" is less important than it being \"too late\". The -difference between ready and clear states is attenuated by -painting both of them using shades of green. This option thus -highlights the alert and overdue states." - :group 'modus-themes - :package-version '(modus-themes . "1.1.0") - :version "28.1" - :type '(choice - (const :format "[%v] %t\n" :tag "Respect the original design of org-habit (default)" nil) - (const :format "[%v] %t\n" :tag "Like the default, but do not distinguish between present and future variants" simplified) - (const :format "[%v] %t\n" :tag "Like `simplified', but only use red, yellow, green" traffic-light)) - :set #'modus-themes--set-option - :initialize #'custom-initialize-default - :link '(info-link "(modus-themes) Org agenda habits")) - -(make-obsolete 'modus-themes-org-habit 'modus-themes-org-agenda "1.5.0") - (defcustom modus-themes-mode-line nil "Control the overall style of the mode line. @@ -2442,13 +2395,16 @@ the same as the background, effectively creating some padding. The `accented' property ensures that the active mode line uses a colored background instead of the standard shade of gray. -The `padded' property increases the apparent height of the mode -line. 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. +A positive integer (natural number or natnum) applies a padding +effect of NATNUM pixels at the boundaries of the mode lines. The +default value is 1 and does not need to be specified explicitly. +The padding has no effect when the `moody' property is also used, +because Moody already applies its own tweaks. To ensure that the +underline is placed at the bottom of the mode line, set +`x-underline-at-descent-line' to non-nil (this is not needed when +the `borderless' property is also set). For users on Emacs 29, +the `x-use-underline-position-properties' variable must also be +set to nil. Combinations of any of those properties are expressed as a list, like in these examples: @@ -2461,7 +2417,7 @@ The order in which the properties are set is not significant. In user configuration files the form may look like this: - (setq modus-themes-mode-line '(borderless accented)) + (setq modus-themes-mode-line (quote (borderless accented))) Note that Moody does not expose any faces that the themes could style directly. Instead it re-purposes existing ones to render @@ -2485,7 +2441,7 @@ default colors (which have been carefully designed to be highly accessible). Furthermore, because Moody expects an underline and overline -instead of a box style, it is advised to set +instead of a box style, it is strongly advised to set `x-underline-at-descent-line' to a non-nil value." :group 'modus-themes :package-version '(modus-themes . "1.6.0") @@ -2497,17 +2453,29 @@ instead of a box style, it is advised to set (const :tag "No box effects (Moody-compatible)" moody)) (const :tag "Colored background" accented) (const :tag "Without border color" borderless) - (const :tag "With extra padding" padded)) + (natnum :tag "With extra padding" :value 6)) + :set #'modus-themes--set-option + :initialize #'custom-initialize-default + :link '(info-link "(modus-themes) Mode line")) + +(defcustom modus-themes-mode-line-padding 6 + "DEPRECATED: Set natural number in `modus-themes-mode-line'." + :group 'modus-themes + :package-version '(modus-themes . "1.7.0") + :version "29.1" + :type 'natnum :set #'modus-themes--set-option :initialize #'custom-initialize-default :link '(info-link "(modus-themes) Mode line")) +(make-obsolete 'modus-themes-mode-line-padding 'modus-themes-mode-line "2.0.0") + (defcustom modus-themes-diffs nil "Adjust the overall style of diffs. The default (nil) uses fairly intense color combinations for diffs, by applying prominently colored backgrounds, with -appropriate foregrounds. +appropriately tinted foregrounds. Option `desaturated' follows the same principles as with the default (nil), though it tones down all relevant colors. @@ -2515,36 +2483,19 @@ default (nil), though it tones down all relevant colors. Option `bg-only' applies a background but does not override the text's foreground. This makes it suitable for a non-nil value passed to `diff-font-lock-syntax' (note: Magit does not support -syntax highlighting in diffs---last checked on 2021-04-21). - -Option `deuteranopia' is like the default (nil) in terms of using -prominently colored backgrounds, except that it also accounts for -red-green color defficiency by replacing all instances of green -with colors on the blue side of the spectrum. Other stylistic -changes are made in the interest of optimizing for such a -use-case. - -Option `fg-only-deuteranopia' removes all colored backgrounds, -except from word-wise or refined changes. Instead, it only uses -color-coded foreground values to differentiate between added, -removed, and changed lines. If a background is necessary to -denote context, a subtle grayscale value is applied. The color -used for added lines is a variant of blue to account for -red-green color defficiency but also because green text alone is -hard to discern in the diff's context (hard for our accessibility -purposes). The `fg-only' option that existed in older versions -of the themes is now an alias of `fg-only-deuteranopia', in the -interest of backward compatibility." +syntax highlighting in diffs---last checked on 2021-12-02). + +When the user option `modus-themes-deuteranopia' is non-nil, all +diffs will use a red/blue color-coding system instead of the +standard red/green. Other stylistic changes are made in the +interest of optimizing for such a use-case." :group 'modus-themes - :package-version '(modus-themes . "1.4.0") - :version "28.1" + :package-version '(modus-themes . "2.0.0") + :version "29.1" :type '(choice (const :format "[%v] %t\n" :tag "Intensely colored backgrounds (default)" nil) (const :format "[%v] %t\n" :tag "Slightly accented backgrounds with tinted text" desaturated) - (const :format "[%v] %t\n" :tag "Apply color-coded backgrounds; keep syntax colors intact" bg-only) - (const :format "[%v] %t\n" :tag "Like the default (nil), though optimized for red-green color defficiency" deuteranopia) - (const :format "[%v] %t\n" :tag "No backgrounds, except for refined diffs" fg-only-deuteranopia) - (const :format "[%v] %t\n" :tag "Alias of `fg-only-deuteranopia' for backward compatibility" fg-only)) + (const :format "[%v] %t\n" :tag "Apply color-coded backgrounds; keep syntax colors intact" bg-only)) :set #'modus-themes--set-option :initialize #'custom-initialize-default :link '(info-link "(modus-themes) Diffs")) @@ -2559,8 +2510,7 @@ only or mostly use foreground colors for their interaction model, and (ii) those that combine background and foreground values for some of their metaphors. The former category encompasses Icomplete, Ido, Selectrum, Vertico, as well as pattern matching -styles like Orderless and Flx. The latter covers Helm, Ivy, and -Sallet. +styles like Orderless and Flx. The latter covers Helm and Ivy. A value of nil (the default) will simply respect the metaphors of each completion framework. @@ -2629,7 +2579,7 @@ The order in which the properties are set is not significant. In user configuration files the form may look like this: - (setq modus-themes-prompts '(background gray))" + (setq modus-themes-prompts (quote (background gray)))" :group 'modus-themes :package-version '(modus-themes . "1.5.0") :version "28.1" @@ -2643,18 +2593,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 "Control the current line highlight of HL-line mode. @@ -2683,7 +2621,7 @@ The order in which the properties are set is not significant. In user configuration files the form may look like this: - (setq modus-themes-hl-line '(underline accented)) + (setq modus-themes-hl-line (quote (underline accented))) Set `x-underline-at-descent-line' to a non-nil value for better results with underlines." @@ -2708,6 +2646,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. @@ -2735,7 +2689,7 @@ The order in which the properties are set is not significant. In user configuration files the form may look like this: - (setq modus-themes-paren-match '(bold intense))" + (setq modus-themes-paren-match (quote (bold intense)))" :group 'modus-themes :package-version '(modus-themes . "1.5.0") :version "28.1" @@ -2783,7 +2737,7 @@ The order in which the properties are set is not significant. In user configuration files the form may look like this: - (setq modus-themes-syntax '(faint alt-syntax)) + (setq modus-themes-syntax (quote (faint alt-syntax))) Independent of this variable, users may also control the use of a bold weight or italic text: `modus-themes-bold-constructs' and @@ -2842,7 +2796,7 @@ The order in which the properties are set is not significant. In user configuration files the form may look like this: - (setq modus-themes-links '(neutral-underline background)) + (setq modus-themes-links (quote (neutral-underline background))) The placement of the underline, meaning its proximity to the text, is controlled by `x-use-underline-position-properties', @@ -2896,7 +2850,7 @@ The order in which the properties are set is not significant. In user configuration files the form may look like this: - (setq modus-themes-region '(bg-only no-extend))" + (setq modus-themes-region (quote (bg-only no-extend)))" :group 'modus-themes :package-version '(modus-themes . "1.5.0") :version "28.1" @@ -2908,24 +2862,37 @@ In user configuration files the form may look like this: :initialize #'custom-initialize-default :link '(info-link "(modus-themes) Active region")) -(defcustom modus-themes-success-deuteranopia nil - "Color-code 'success' or 'done' as blue instead of green. - -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. - -Diffs, which have a red/green dichotomy by default, can also be -configured to conform with deuteranopia: `modus-themes-diffs'." +(define-obsolete-variable-alias + 'modus-themes-success-deuteranopia + 'modus-themes-deuteranopia + "2.0.0") + +(defcustom modus-themes-deuteranopia nil + "When non-nil use red/blue color-coding instead of red/green. + +This is to account for red-green color deficiency, also know as +deuteranopia and variants. It applies to all contexts where +there can be a color-coded distinction between failure or +success, a to-do or done state, a mark for deletion versus a mark +for selection (e.g. in Dired), current and lazily highlighted +search matches, removed lines in diffs as opposed to added ones, +and so on. + +Note that this does not change all colors throughout the active +theme, but only applies to cases that have color-coding +significance. For example, regular code syntax highlighting is +not affected. There is no such need because of the themes' +overarching commitment to the highest legibility standard, which +ensures that text is readable regardless of hue, as well as the +predominance of colors on the blue-cyan-magenta-purple side of +the spectrum." :group 'modus-themes - :package-version '(modus-themes . "1.4.0") - :version "28.1" + :package-version '(modus-themes . "2.0.0") + :version "29.1" :type 'boolean :set #'modus-themes--set-option :initialize #'custom-initialize-default - :link '(info-link "(modus-themes) Success' color-code")) + :link '(info-link "(modus-themes) Deuteranopia style")) (defcustom modus-themes-mail-citations nil "Control the color of citations in messages or email clients. @@ -3024,14 +2991,9 @@ 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 () - "Conditional use of `variable-pitch' in headings." - (when modus-themes-variable-pitch-headings - (list :inherit 'variable-pitch))) - (defun modus-themes--variable-pitch-ui () "Conditional use of `variable-pitch' in UI elements." (when modus-themes-variable-pitch-ui @@ -3054,14 +3016,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,29 +3045,38 @@ 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) ((memq 'background modus-themes-lang-checkers) - subtlebg)) + subtlebg) + ('unspecified)) :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) ((memq 'intense modus-themes-lang-checkers) intensefg) ((memq 'text-also modus-themes-lang-checkers) - subtlefg))))) + subtlefg) + ('unspecified))))) (defun modus-themes--prompt (mainfg intensefg grayfg subtlebg intensebg intensebg-fg subtlebggray intensebggray) - "Conditional use of colors for prompts. + "Conditional use of colors for text prompt faces. MAINFG is the prompt's standard foreground. INTENSEFG is a more prominent alternative to the main foreground, while GRAYFG is a less luminant shade of gray. @@ -3110,7 +3090,7 @@ should be combinable with INTENSEBG-FG. SUBTLEBGGRAY and INTENSEBGGRAY are background values. The former can be combined with GRAYFG, while the latter only works with the theme's fallback text color." - (let ((modus-themes-prompts + (let ((properties (if (listp modus-themes-prompts) modus-themes-prompts ;; translation layer for legacy values @@ -3125,40 +3105,40 @@ theme's fallback text color." ('intense-gray '(background intense gray)))))) (list :foreground (cond - ((and (memq 'gray modus-themes-prompts) - (memq 'intense modus-themes-prompts)) + ((and (memq 'gray properties) + (memq 'intense properties)) 'unspecified) - ((memq 'gray modus-themes-prompts) + ((memq 'gray properties) grayfg) - ((and (memq 'background modus-themes-prompts) - (memq 'intense modus-themes-prompts)) + ((and (memq 'background properties) + (memq 'intense properties)) intensebg-fg) - ((memq 'intense modus-themes-prompts) + ((memq 'intense properties) intensefg) (mainfg)) :background (cond - ((and (memq 'gray modus-themes-prompts) - (memq 'background modus-themes-prompts) - (memq 'intense modus-themes-prompts)) + ((and (memq 'gray properties) + (memq 'background properties) + (memq 'intense properties)) intensebggray) - ((and (memq 'gray modus-themes-prompts) - (memq 'background modus-themes-prompts)) + ((and (memq 'gray properties) + (memq 'background properties)) subtlebggray) - ((and (memq 'background modus-themes-prompts) - (memq 'intense modus-themes-prompts)) + ((and (memq 'background properties) + (memq 'intense properties)) intensebg) - ((memq 'background modus-themes-prompts) + ((memq 'background properties) subtlebg) ('unspecified)) :inherit (cond - ((and (memq 'bold modus-themes-prompts) - (memq 'italic modus-themes-prompts)) + ((and (memq 'bold properties) + (memq 'italic properties)) 'bold-italic) - ((memq 'italic modus-themes-prompts) + ((memq 'italic properties) 'italic) - ((memq 'bold modus-themes-prompts) + ((memq 'bold properties) 'bold) ('unspecified))))) @@ -3168,7 +3148,7 @@ NORMALBG should be the special palette color 'bg-paren-match' or something similar. INTENSEBG must be easier to discern next to other backgrounds, such as the special palette color 'bg-paren-match-intense'." - (let ((modus-themes-paren-match + (let ((properties (if (listp modus-themes-paren-match) modus-themes-paren-match ;; translation layer for legacy values @@ -3179,15 +3159,15 @@ other backgrounds, such as the special palette color ('subtle-bold '(bold)) ('intense '(intense)))))) (list :inherit - (if (memq 'bold modus-themes-paren-match) + (if (memq 'bold properties) 'bold 'unspecified) :background - (if (memq 'intense modus-themes-paren-match) + (if (memq 'intense properties) intensebg normalbg) :underline - (if (memq 'underline modus-themes-paren-match) + (if (memq 'underline properties) t nil)))) @@ -3195,7 +3175,7 @@ other backgrounds, such as the special palette color "Apply foreground value to code syntax. FG is the default. FAINT is typically the same color in its desaturated version." - (let ((modus-themes-syntax + (let ((properties (if (listp modus-themes-syntax) modus-themes-syntax ;; translation layer for legacy values @@ -3209,7 +3189,7 @@ desaturated version." ('alt-syntax-yellow-comments '(alt-syntax yellow-comments)))))) (list :foreground (cond - ((memq 'faint modus-themes-syntax) + ((memq 'faint properties) faint) (fg))))) @@ -3218,7 +3198,7 @@ desaturated version." FG is the default. FAINT is typically the same color in its desaturated version. ALT is another hue while optional FAINT-ALT is its subtle alternative." - (let ((modus-themes-syntax + (let ((properties (if (listp modus-themes-syntax) modus-themes-syntax ;; translation layer for legacy values @@ -3232,12 +3212,12 @@ is its subtle alternative." ('alt-syntax-yellow-comments '(alt-syntax yellow-comments)))))) (list :foreground (cond - ((and (memq 'alt-syntax modus-themes-syntax) - (memq 'faint modus-themes-syntax)) + ((and (memq 'alt-syntax properties) + (memq 'faint properties)) (or faint-alt alt)) - ((memq 'faint modus-themes-syntax) + ((memq 'faint properties) faint) - ((memq 'alt-syntax modus-themes-syntax) + ((memq 'alt-syntax properties) alt) (fg))))) @@ -3248,7 +3228,7 @@ desaturated version. GREEN is a color variant in that side of the spectrum. ALT is another hue. Optional FAINT-GREEN is a subtle alternative to GREEN. Optional FAINT-ALT is a subtle alternative to ALT." - (let ((modus-themes-syntax + (let ((properties (if (listp modus-themes-syntax) modus-themes-syntax ;; translation layer for legacy values @@ -3262,17 +3242,17 @@ alternative to ALT." ('alt-syntax-yellow-comments '(alt-syntax yellow-comments)))))) (list :foreground (cond - ((and (memq 'faint modus-themes-syntax) - (memq 'green-strings modus-themes-syntax)) + ((and (memq 'faint properties) + (memq 'green-strings properties)) (or faint-green green)) - ((and (memq 'alt-syntax modus-themes-syntax) - (memq 'faint modus-themes-syntax)) + ((and (memq 'alt-syntax properties) + (memq 'faint properties)) (or faint-alt faint)) - ((memq 'faint modus-themes-syntax) + ((memq 'faint properties) faint) - ((memq 'green-strings modus-themes-syntax) + ((memq 'green-strings properties) green) - ((memq 'alt-syntax modus-themes-syntax) + ((memq 'alt-syntax properties) alt) (fg))))) @@ -3281,7 +3261,7 @@ alternative to ALT." FG is the default. YELLOW is a color variant of that name while optional FAINT-YELLOW is its subtle variant. Optional FAINT is an alternative to the default value." - (let ((modus-themes-syntax + (let ((properties (if (listp modus-themes-syntax) modus-themes-syntax ;; translation layer for legacy values @@ -3295,16 +3275,16 @@ an alternative to the default value." ('alt-syntax-yellow-comments '(alt-syntax yellow-comments)))))) (list :foreground (cond - ((and (memq 'faint modus-themes-syntax) - (memq 'yellow-comments modus-themes-syntax)) + ((and (memq 'faint properties) + (memq 'yellow-comments properties)) (or faint-yellow yellow)) - ((and (memq 'alt-syntax modus-themes-syntax) - (memq 'yellow-comments modus-themes-syntax) - (not (memq 'green-strings modus-themes-syntax))) + ((and (memq 'alt-syntax properties) + (memq 'yellow-comments properties) + (not (memq 'green-strings properties))) (or faint-yellow yellow)) - ((memq 'yellow-comments modus-themes-syntax) + ((memq 'yellow-comments properties) yellow) - ((memq 'faint modus-themes-syntax) + ((memq 'faint properties) (or faint fg)) (fg))))) @@ -3312,6 +3292,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 +3315,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))) - (modus-themes-headings - (if (listp style) + (style-listp (listp style)) + (properties + (if style-listp style ;; translation layer for legacy values (pcase style @@ -3345,34 +3338,39 @@ 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 (memq 'variable-pitch properties) '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 properties)) var) (varbold)) :background (cond - ((and (memq 'monochrome modus-themes-headings) - (memq 'background modus-themes-headings)) + ((and (memq 'monochrome properties) + (memq 'background properties)) bg-gray) - ((memq 'background modus-themes-headings) + ((memq 'background properties) bg) ('unspecified)) :foreground (cond - ((memq 'monochrome modus-themes-headings) + ((memq 'monochrome properties) 'unspecified) - ((memq 'rainbow modus-themes-headings) + ((memq 'rainbow properties) fg-alt) (fg)) + :height + (seq-find #'floatp properties 'unspecified) + :weight + (or weight 'unspecified) :overline - (if (memq 'overline modus-themes-headings) + (if (memq 'overline properties) border 'unspecified)))) @@ -3380,16 +3378,20 @@ that combines well with the background and foreground." "Control the style of the Org agenda structure. FG is the foreground color to use." (let* ((properties (modus-themes--key-cdr 'header-block modus-themes-org-agenda)) - (inherit (cond ((memq 'variable-pitch properties) - (list 'bold 'variable-pitch)) - ('bold))) - (height (cond ((memq 'no-scale properties) - 1.0) - ((memq 'scale-title properties) - modus-themes-scale-title) - (1.15)))) - (list :inherit inherit - :height height + (weight (modus-themes--heading-weight properties))) + (list :inherit + (cond + ((and weight (memq 'variable-pitch properties)) + 'variable-pitch) + (weight 'unspecified) + ((memq 'variable-pitch properties) + (list 'bold 'variable-pitch)) + ('bold)) + :weight + (or weight 'unspecified) + :height + (cond ((memq 'no-scale properties) 'unspecified) + ((seq-find #'floatp properties 1.15))) :foreground fg))) (defun modus-themes--agenda-date (defaultfg grayscalefg &optional workaholicfg grayscaleworkaholicfg bg bold ul) @@ -3408,8 +3410,10 @@ weight. Optional UL applies an underline." (t 'unspecified)) :background - (unless (memq 'underline-today properties) - bg) + (cond + ((memq 'underline-today properties) + 'unspecified) + ((or bg 'unspecified))) :foreground (cond ((and (memq 'grayscale properties) @@ -3422,32 +3426,44 @@ weight. Optional UL applies an underline." (t defaultfg)) :height - (if (memq 'scale-heading properties) - modus-themes-scale-1 - 'unspecified) + (seq-find #'floatp properties 'unspecified) :underline (if (and ul (memq 'underline-today properties)) 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 + (list :foreground + (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))))) @@ -3469,11 +3485,12 @@ DEFAULT is the original foregrounc color. TRAFFIC is to be used when the 'traffic-light' style is applied, while SIMPLE corresponds to the 'simplified style'. Optional TRAFFIC-DEUTERAN is an alternative to TRAFFIC, meant for deuteranopia." - (pcase (modus-themes--key-cdr 'habit modus-themes-org-agenda) - ('traffic-light (list :background traffic)) - ('traffic-light-deuteranopia (list :background (or traffic-deuteran traffic))) - ('simplified (list :background simple)) - (_ (list :background default)))) + (if modus-themes-deuteranopia + (list :background (or traffic-deuteran traffic)) + (pcase (modus-themes--key-cdr 'habit modus-themes-org-agenda) + ('traffic-light (list :background traffic)) + ('simplified (list :background simple)) + (_ (list :background default))))) (defun modus-themes--org-block (bgblk fgdefault &optional fgblk) "Conditionally set the background of Org blocks. @@ -3509,8 +3526,8 @@ set to `rainbow'." ('gray-background (list :background bg :foreground fg :extend t)) ('grayscale (list :background bg :foreground fg :extend t)) ('greyscale (list :background bg :foreground fg :extend t)) - ('rainbow (list :background bgaccent :foreground fgaccent)) - (_ (list :background bg :foreground fg)))) + ('rainbow (list :background bgaccent :foreground fgaccent :extend nil)) + (_ (list :background bg :foreground fg :extend nil)))) (defun modus-themes--mode-line-attrs (fg bg fg-alt bg-alt fg-accent bg-accent border border-3d &optional alt-style fg-distant) @@ -3528,87 +3545,85 @@ 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 - (if (listp modus-themes-mode-line) - modus-themes-mode-line - ;; translation layer for legacy values - (alist-get modus-themes-mode-line - '((3d . (3d)) - (moody . (moody)) - (borderless . (borderless)) - (borderless-3d . (borderless 3d)) - (borderless-moody . (borderless moody)) - (accented . (accented)) - (accented-3d . (accented 3d)) - (accented-moody . (accented moody)) - (borderless-accented . (borderless accented)) - (borderless-accented-3d . (borderless accented 3d)) - (borderless-accented-moody . (borderless accented moody))))))) - (let ((base (cond ((memq 'accented modus-themes-mode-line) - (cons fg-accent bg-accent)) - ((and (or (memq 'moody modus-themes-mode-line) - (memq '3d modus-themes-mode-line)) - (not (memq 'borderless modus-themes-mode-line))) - (cons fg-alt bg-alt)) - ((cons fg bg)))) - (box (cond ((memq 'moody modus-themes-mode-line) - nil) - ((and (memq '3d modus-themes-mode-line) - (memq 'padded modus-themes-mode-line)) - (list :line-width 4 - :color - (cond ((and (memq 'accented modus-themes-mode-line) - (memq 'borderless modus-themes-mode-line)) - bg-accent) - ((or (memq 'accented modus-themes-mode-line) - (memq 'borderless modus-themes-mode-line)) - bg) - (bg-alt)) - :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)) - ((memq 'padded modus-themes-mode-line) - (list :line-width 6 :color bg)) - ((memq '3d modus-themes-mode-line) - (list :line-width 1 - :color - (cond ((and (memq 'accented modus-themes-mode-line) - (memq 'borderless modus-themes-mode-line)) - bg-accent) - ((memq 'borderless modus-themes-mode-line) bg) - (border-3d)) - :style (when alt-style 'released-button))) - ((memq 'borderless modus-themes-mode-line) + (let* ((properties + (if (listp modus-themes-mode-line) + modus-themes-mode-line + ;; translation layer for legacy values + (alist-get modus-themes-mode-line + '((3d . (3d)) + (moody . (moody)) + (borderless . (borderless)) + (borderless-3d . (borderless 3d)) + (borderless-moody . (borderless moody)) + (accented . (accented)) + (accented-3d . (accented 3d)) + (accented-moody . (accented moody)) + (borderless-accented . (borderless accented)) + (borderless-accented-3d . (borderless accented 3d)) + (borderless-accented-moody . (borderless accented moody)))))) + (padding (seq-find #'natnump properties 1)) + (padded (> padding 1)) + (base (cond ((memq 'accented properties) + (cons fg-accent bg-accent)) + ((and (or (memq 'moody properties) + (memq '3d properties)) + (not (memq 'borderless properties))) + (cons fg-alt bg-alt)) + ((cons fg bg)))) + (line (cond ((not (or (memq 'moody properties) padded)) + 'unspecified) + ((and (not (memq 'moody properties)) + padded + (memq 'borderless properties)) + 'unspecified) + ((and (memq 'borderless properties) + (memq 'accented properties)) + bg-accent) + ((memq 'borderless properties) bg) - ((memq 'padded modus-themes-mode-line) - (list :line-width 6 :color bg)) - (border))) - (line (cond ((not (or (memq 'moody modus-themes-mode-line) - (memq 'padded modus-themes-mode-line))) - nil) - ((and (memq 'borderless modus-themes-mode-line) - (memq 'accented modus-themes-mode-line)) - bg-accent) - ((memq 'borderless modus-themes-mode-line) - bg) - (border)))) - (list :foreground (car base) - :background (cdr base) - :box box - :overline line - :underline line - :distant-foreground - (when (memq 'moody modus-themes-mode-line) - fg-distant))))) - -(defun modus-themes--diff - (fg-only-bg fg-only-fg mainbg mainfg altbg altfg &optional deuteranbg deuteranfg bg-only-fg) - "Color combinations for `modus-themes-diffs'. + (border)))) + (list :foreground (car base) + :background (cdr base) + :box + (cond ((memq 'moody properties) + 'unspecified) + ((and (memq '3d properties) padded) + (list :line-width padding + :color + (cond ((and (memq 'accented properties) + (memq 'borderless properties)) + bg-accent) + ((or (memq 'accented properties) + (memq 'borderless properties)) + bg) + (bg-alt)) + :style (when alt-style 'released-button))) + ((and (memq 'accented properties) padded) + (list :line-width padding :color bg-accent)) + ((memq '3d properties) + (list :line-width padding + :color + (cond ((and (memq 'accented properties) + (memq 'borderless properties)) + bg-accent) + ((memq 'borderless properties) bg) + (border-3d)) + :style (when alt-style 'released-button))) + ((and (memq 'accented properties) + (memq 'borderless properties)) + (list :line-width padding :color bg-accent)) + ((or (memq 'borderless properties) padded) + (list :line-width padding :color bg)) + (border)) + :overline line + :underline line + :distant-foreground + (if (memq 'moody properties) + fg-distant + 'unspecified)))) -FG-ONLY-BG should be similar or the same as the main background. -FG-ONLY-FG should be a saturated accent value that can be -combined with the former. +(defun modus-themes--diff (mainbg mainfg altbg altfg &optional deuteranbg deuteranfg bg-only-fg) + "Color combinations for `modus-themes-diffs'. MAINBG must be one of the dedicated backgrounds for diffs while MAINFG must be the same for the foreground. @@ -3622,27 +3637,16 @@ for red-green color defficiency (deuteranopia). Optional BG-ONLY-FG applies ALTFG else leaves the foreground unspecified." - (pcase modus-themes-diffs - ('fg-only (list :background fg-only-bg :foreground fg-only-fg)) - ('fg-only-deuteranopia (list :background fg-only-bg :foreground fg-only-fg)) - ('desaturated (list :background altbg :foreground altfg)) - ('deuteranopia (list :background (or deuteranbg mainbg) :foreground (or deuteranfg mainfg))) - ('bg-only (list :background altbg :foreground (if bg-only-fg altfg 'unspecified))) - (_ (list :background mainbg :foreground mainfg)))) - -(defun modus-themes--diff-deuteran (deuteran main) - "Determine whether the DEUTERAN or MAIN color should be used. -This is based on whether `modus-themes-diffs' has the value -`deuteranopia'." - (if (or (eq modus-themes-diffs 'deuteranopia) - (eq modus-themes-diffs 'fg-only-deuteranopia) - (eq modus-themes-diffs 'fg-only)) - (list deuteran) - (list main))) - -(defun modus-themes--success-deuteran (deuteran main) + (if modus-themes-deuteranopia + (list :background (or deuteranbg mainbg) :foreground (or deuteranfg mainfg)) + (pcase modus-themes-diffs + ('desaturated (list :background altbg :foreground altfg)) + ('bg-only (list :background altbg :foreground (if bg-only-fg altfg 'unspecified))) + (_ (list :background mainbg :foreground mainfg))))) + +(defun modus-themes--deuteran (deuteran main) "Determine whether to color-code success as DEUTERAN or MAIN." - (if modus-themes-success-deuteranopia + (if modus-themes-deuteranopia (list deuteran) (list main))) @@ -3686,7 +3690,7 @@ FG is the link's default color for its text and underline property. FGFAINT is a desaturated color for the text and underline. UNDERLINE is a gray color only for the undeline. BG is a background color and BGNEUTRAL is its fallback value." - (let ((modus-themes-links + (let ((properties (if (listp modus-themes-links) modus-themes-links ;; translation layer for legacy values @@ -3699,42 +3703,42 @@ is a background color and BGNEUTRAL is its fallback value." ('neutral-underline-only '(no-color neutral-underline)))))) (list :inherit (cond - ((and (memq 'bold modus-themes-links) - (memq 'italic modus-themes-links)) + ((and (memq 'bold properties) + (memq 'italic properties)) 'bold-italic) - ((memq 'italic modus-themes-links) + ((memq 'italic properties) 'italic) - ((memq 'bold modus-themes-links) + ((memq 'bold properties) 'bold) ('unspecified)) :background (cond - ((and (memq 'no-color modus-themes-links) - (memq 'no-underline modus-themes-links)) + ((and (memq 'no-color properties) + (memq 'no-underline properties)) bgneutral) - ((memq 'background modus-themes-links) + ((memq 'background properties) bg) ('unspecified)) :foreground (cond - ((memq 'no-color modus-themes-links) + ((memq 'no-color properties) 'unspecified) - ((memq 'faint modus-themes-links) + ((memq 'faint properties) fgfaint) (fg)) :underline (cond - ((memq 'no-underline modus-themes-links) + ((memq 'no-underline properties) 'unspecified) - ((memq 'neutral-underline modus-themes-links) + ((memq 'neutral-underline properties) underline) (t))))) (defun modus-themes--link-color (fg fgfaint &optional neutralfg) - "Extends `modus-themes--link'. + "Extend `modus-themes--link'. FG is the main accented foreground. FGFAINT is also accented, yet desaturated. Optional NEUTRALFG is a gray value." - (let ((modus-themes-links + (let ((properties (if (listp modus-themes-links) modus-themes-links ;; translation layer for legacy values @@ -3747,25 +3751,19 @@ yet desaturated. Optional NEUTRALFG is a gray value." ('neutral-underline-only '(no-color neutral-underline)))))) (list :foreground (cond - ((memq 'no-color modus-themes-links) + ((memq 'no-color properties) (or neutralfg 'unspecified)) - ((memq 'faint modus-themes-links) + ((memq 'faint properties) fgfaint) (fg)) :underline (cond - ((memq 'no-underline modus-themes-links) + ((memq 'no-underline properties) 'unspecified) - ((memq 'neutral-underline modus-themes-links) + ((memq 'neutral-underline properties) (or neutralfg 'unspecified)) (t))))) -(defun modus-themes--scale (amount) - "Scale heading by AMOUNT. -AMOUNT is a customization option." - (when modus-themes-scale-headings - (list :height amount))) - (defun modus-themes--region (bg fg bgsubtle bgaccent bgaccentsubtle) "Apply `modus-themes-region' styles. @@ -3774,7 +3772,7 @@ is a subtle background value that can be combined with all colors used to fontify text and code syntax. BGACCENT is a colored background that combines well with FG. BGACCENTSUBTLE can be combined with all colors used to fontify text." - (let ((modus-themes-region + (let ((properties (if (listp modus-themes-region) modus-themes-region ;; translation layer for legacy values @@ -3786,25 +3784,25 @@ combined with all colors used to fontify text." ('no-extend '(no-extend)))))) (list :background (cond - ((and (memq 'accented modus-themes-region) - (memq 'bg-only modus-themes-region)) + ((and (memq 'accented properties) + (memq 'bg-only properties)) bgaccentsubtle) - ((memq 'accented modus-themes-region) + ((memq 'accented properties) bgaccent) - ((memq 'bg-only modus-themes-region) + ((memq 'bg-only properties) bgsubtle) (bg)) :foreground (cond - ((and (memq 'accented modus-themes-region) - (memq 'bg-only modus-themes-region)) + ((and (memq 'accented properties) + (memq 'bg-only properties)) 'unspecified) - ((memq 'bg-only modus-themes-region) + ((memq 'bg-only properties) 'unspecified) (fg)) :extend (cond - ((memq 'no-extend modus-themes-region) + ((memq 'no-extend properties) nil) (t))))) @@ -3819,7 +3817,7 @@ LINEACCENT are color values that can remain distinct against the buffer's possible backgrounds: the former is neutral, the latter is accented. LINENEUTRALINTENSE and LINEACCENTINTENSE are their more prominent alternatives." - (let ((modus-themes-hl-line + (let ((properties (if (listp modus-themes-hl-line) modus-themes-hl-line ;; translation layer for legacy values @@ -3832,28 +3830,28 @@ more prominent alternatives." ('underline-only-accented '(underline accented)))))) (list :background (cond - ((and (memq 'intense modus-themes-hl-line) - (memq 'accented modus-themes-hl-line)) + ((and (memq 'intense properties) + (memq 'accented properties)) bgaccent) - ((memq 'accented modus-themes-hl-line) + ((memq 'accented properties) bgaccentsubtle) - ((memq 'intense modus-themes-hl-line) + ((memq 'intense properties) bgintense) (bgdefault)) :underline (cond - ((and (memq 'intense modus-themes-hl-line) - (memq 'accented modus-themes-hl-line) - (memq 'underline modus-themes-hl-line)) + ((and (memq 'intense properties) + (memq 'accented properties) + (memq 'underline properties)) lineaccentintense) - ((and (memq 'accented modus-themes-hl-line) - (memq 'underline modus-themes-hl-line)) + ((and (memq 'accented properties) + (memq 'underline properties)) lineaccent) - ((and (memq 'intense modus-themes-hl-line) - (memq 'underline modus-themes-hl-line)) + ((and (memq 'intense properties) + (memq 'underline properties)) lineneutralintense) - ((or (memq 'no-background modus-themes-hl-line) - (memq 'underline modus-themes-hl-line)) + ((or (memq 'no-background properties) + (memq 'underline properties)) lineneutral) ('unspecified))))) @@ -4007,6 +4005,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 +4014,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)) @@ -4111,88 +4111,94 @@ by virtue of calling either of `modus-themes-load-operandi' and ;; intended for `diff-mode' or equivalent `(modus-themes-diff-added ((,class ,@(modus-themes--diff - bg-main blue-alt-other bg-diff-focus-added fg-diff-focus-added green-nuanced-bg fg-diff-added bg-diff-focus-added-deuteran fg-diff-focus-added-deuteran)))) `(modus-themes-diff-changed ((,class ,@(modus-themes--diff - bg-main yellow bg-diff-focus-changed fg-diff-focus-changed yellow-nuanced-bg fg-diff-changed)))) `(modus-themes-diff-removed ((,class ,@(modus-themes--diff - bg-main red bg-diff-focus-removed fg-diff-focus-removed red-nuanced-bg fg-diff-removed)))) `(modus-themes-diff-refine-added ((,class ,@(modus-themes--diff - bg-diff-added-deuteran fg-diff-added-deuteran bg-diff-refine-added fg-diff-refine-added bg-diff-focus-added fg-diff-focus-added bg-diff-refine-added-deuteran fg-diff-refine-added-deuteran)))) `(modus-themes-diff-refine-changed ((,class ,@(modus-themes--diff - bg-diff-changed fg-diff-changed bg-diff-refine-changed fg-diff-refine-changed bg-diff-focus-changed fg-diff-focus-changed)))) `(modus-themes-diff-refine-removed ((,class ,@(modus-themes--diff - bg-diff-removed fg-diff-removed bg-diff-refine-removed fg-diff-refine-removed bg-diff-focus-removed fg-diff-focus-removed)))) `(modus-themes-diff-focus-added ((,class ,@(modus-themes--diff - bg-dim blue-alt-other bg-diff-focus-added fg-diff-focus-added bg-diff-added fg-diff-added bg-diff-focus-added-deuteran fg-diff-focus-added-deuteran)))) `(modus-themes-diff-focus-changed ((,class ,@(modus-themes--diff - bg-dim yellow bg-diff-focus-changed fg-diff-focus-changed bg-diff-changed fg-diff-changed)))) `(modus-themes-diff-focus-removed ((,class ,@(modus-themes--diff - bg-dim red bg-diff-focus-removed fg-diff-focus-removed bg-diff-removed fg-diff-removed)))) `(modus-themes-diff-heading ((,class ,@(modus-themes--diff - bg-alt fg-main bg-diff-heading fg-diff-heading cyan-nuanced-bg cyan-nuanced-fg bg-header fg-main t)))) +;;;;; deuteranopia-specific + `(modus-themes-grue ((,class :foreground ,@(modus-themes--deuteran blue green)))) + `(modus-themes-grue-active ((,class :foreground ,@(modus-themes--deuteran blue-active green-active)))) + `(modus-themes-grue-nuanced ((,class :foreground ,@(modus-themes--deuteran blue-nuanced-fg green-nuanced-fg)))) + `(modus-themes-grue-background-active ((,class :inherit ,@(modus-themes--deuteran + 'modus-themes-fringe-blue + 'modus-themes-fringe-green)))) + `(modus-themes-grue-background-intense ((,class :inherit ,@(modus-themes--deuteran + 'modus-themes-intense-blue + 'modus-themes-intense-green)))) + `(modus-themes-grue-background-subtle ((,class :inherit ,@(modus-themes--deuteran + 'modus-themes-subtle-blue + 'modus-themes-subtle-green)))) + `(modus-themes-grue-background-subtle ((,class :inherit ,@(modus-themes--deuteran + 'modus-themes-refine-blue + 'modus-themes-refine-green)))) ;;;;; mark indicators ;; color combinations intended for Dired, Ibuffer, or equivalent `(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--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. `(modus-themes-heading-1 ((,class ,@(modus-themes--heading 1 fg-main magenta-alt-other - magenta-nuanced-bg bg-alt bg-region) - ,@(modus-themes--scale modus-themes-scale-4)))) + magenta-nuanced-bg bg-alt bg-region)))) `(modus-themes-heading-2 ((,class ,@(modus-themes--heading 2 fg-special-warm magenta-alt - red-nuanced-bg bg-alt bg-region) - ,@(modus-themes--scale modus-themes-scale-3)))) + red-nuanced-bg bg-alt bg-region)))) `(modus-themes-heading-3 ((,class ,@(modus-themes--heading 3 fg-special-cold blue - blue-nuanced-bg bg-alt bg-region) - ,@(modus-themes--scale modus-themes-scale-2)))) + blue-nuanced-bg bg-alt bg-region)))) `(modus-themes-heading-4 ((,class ,@(modus-themes--heading 4 fg-special-mild cyan - cyan-nuanced-bg bg-alt bg-region) - ,@(modus-themes--scale modus-themes-scale-1)))) + cyan-nuanced-bg bg-alt bg-region)))) `(modus-themes-heading-5 ((,class ,@(modus-themes--heading 5 fg-special-calm green-alt-other @@ -4225,13 +4231,20 @@ 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)))) +;;;;; links + `(modus-themes-link-broken ((,class :inherit button ,@(modus-themes--link-color red red-faint)))) + `(modus-themes-link-symlink ((,class :inherit button ,@(modus-themes--link-color cyan cyan-faint)))) +;;;;; tabs + `(modus-themes-tab-active ((,class ,@(modus-themes--tab bg-tab-active nil nil nil t t)))) + `(modus-themes-tab-backdrop ((,class ,@(modus-themes--tab bg-active bg-active-accent nil nil nil nil t)))) + `(modus-themes-tab-inactive ((,class ,@(modus-themes--tab bg-tab-inactive bg-tab-inactive-accent fg-dim nil t)))) ;;;;; other custom faces `(modus-themes-bold ((,class ,@(modus-themes--bold-weight)))) `(modus-themes-hl-line ((,class ,@(modus-themes--hl-line @@ -4251,18 +4264,21 @@ by virtue of calling either of `modus-themes-load-operandi' and `(modus-themes-reset-soft ((,class :background ,bg-main :foreground ,fg-main :weight normal :slant normal :strike-through nil :box nil :underline nil :overline nil :extend nil))) - `(modus-themes-search-success ((,class :inherit ,@(modus-themes--success-deuteran + `(modus-themes-search-success ((,class :inherit ,@(modus-themes--deuteran 'modus-themes-intense-blue 'modus-themes-intense-green)))) - `(modus-themes-search-success-lazy ((,class :inherit ,@(modus-themes--success-deuteran + `(modus-themes-search-success-lazy ((,class :inherit ,@(modus-themes--deuteran 'modus-themes-special-mild 'modus-themes-refine-cyan)))) - `(modus-themes-search-success-modeline ((,class :foreground ,@(modus-themes--success-deuteran + `(modus-themes-search-success-modeline ((,class :foreground ,@(modus-themes--deuteran blue-active green-active)))) `(modus-themes-slant ((,class :inherit italic :slant ,@(modus-themes--slant)))) - `(modus-themes-variable-pitch ((,class ,@(modus-themes--variable-pitch)))) + `(modus-themes-ui-variable-pitch ((,class ,@(modus-themes--variable-pitch-ui)))) `(modus-themes-fixed-pitch ((,class ,@(modus-themes--fixed-pitch)))) + `(modus-themes-markup-verbatim ((,class :inherit modus-themes-fixed-pitch + ,@(modus-themes--markup fg-special-calm magenta-alt + bg-alt magenta-nuanced-bg)))) ;;;; standard faces ;;;;; absolute essentials `(default ((,class :background ,bg-main :foreground ,fg-main))) @@ -4276,15 +4292,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))) - `(header-line ((,class ,@(modus-themes--variable-pitch-ui) + `(file-name-shadow ((,class :inherit (shadow italic)))) + `(header-line ((,class :inherit modus-themes-ui-variable-pitch :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))) @@ -4300,7 +4317,7 @@ by virtue of calling either of `modus-themes-load-operandi' and bg-region-accent-subtle)))) `(secondary-selection ((,class :inherit modus-themes-special-cold))) `(shadow ((,class :foreground ,fg-alt))) - `(success ((,class :inherit bold :foreground ,@(modus-themes--success-deuteran blue green)))) + `(success ((,class :inherit (bold modus-themes-grue)))) `(trailing-whitespace ((,class :background ,red-intense-bg))) `(warning ((,class :inherit bold :foreground ,yellow))) ;;;;; buttons, links, widgets @@ -4316,11 +4333,8 @@ 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))) - `(ag-match-face ((,class :inherit modus-themes-special-calm))) ;;;;; alert `(alert-high-face ((,class :inherit bold :foreground ,red-alt))) `(alert-low-face ((,class :foreground ,fg-special-mild))) @@ -4396,62 +4410,45 @@ by virtue of calling either of `modus-themes-load-operandi' and `(anzu-replace-highlight ((,class :inherit modus-themes-refine-yellow :underline t))) `(anzu-replace-to ((,class :inherit (modus-themes-search-success bold)))) ;;;;; apropos - `(apropos-button ((,class :inherit button - ,@(modus-themes--link-color - magenta-alt-other magenta-alt-other-faint)))) - `(apropos-function-button ((,class :inherit button - ,@(modus-themes--link-color - magenta magenta-faint)))) + `(apropos-button ((,class :foreground ,magenta-alt-other))) + `(apropos-function-button ((,class :foreground ,magenta))) `(apropos-keybinding ((,class :inherit modus-themes-key-binding))) - `(apropos-misc-button ((,class :inherit button - ,@(modus-themes--link-color - green-alt-other green-alt-other-faint)))) + `(apropos-misc-button ((,class :foreground ,green-alt-other))) `(apropos-property ((,class :inherit modus-themes-bold :foreground ,magenta-alt))) `(apropos-symbol ((,class :inherit modus-themes-pseudo-header))) - `(apropos-user-option-button ((,class :inherit button - ,@(modus-themes--link-color - cyan cyan-faint)))) - `(apropos-variable-button ((,class :inherit button - ,@(modus-themes--link-color - blue-alt blue-alt-faint)))) -;;;;; apt-sources-list - `(apt-sources-list-components ((,class :foreground ,cyan))) - `(apt-sources-list-options ((,class :foreground ,yellow))) - `(apt-sources-list-suite ((,class :foreground ,green))) - `(apt-sources-list-type ((,class :foreground ,magenta))) - `(apt-sources-list-uri ((,class :foreground ,blue))) + `(apropos-user-option-button ((,class :foreground ,cyan))) + `(apropos-variable-button ((,class :foreground ,blue-alt))) ;;;;; artbollocks-mode `(artbollocks-face ((,class :inherit modus-themes-lang-note))) `(artbollocks-lexical-illusions-face ((,class :background ,bg-alt :foreground ,red-alt :underline t))) `(artbollocks-passive-voice-face ((,class :inherit modus-themes-lang-warning))) `(artbollocks-weasel-words-face ((,class :inherit modus-themes-lang-error))) ;;;;; auctex and Tex - `(font-latex-bold-face ((,class :inherit bold :foreground ,fg-special-calm))) - `(font-latex-doctex-documentation-face ((,class :inherit modus-themes-slant :foreground ,fg-special-cold))) - `(font-latex-doctex-preprocessor-face ((,class :inherit modus-themes-bold :foreground ,red-alt-other))) + `(font-latex-bold-face ((,class :inherit bold))) + `(font-latex-doctex-documentation-face ((,class :inherit font-lock-doc-face))) + `(font-latex-doctex-preprocessor-face ((,class :inherit font-lock-preprocessor-face))) `(font-latex-italic-face ((,class :inherit italic))) - `(font-latex-math-face ((,class :foreground ,cyan-alt-other))) - `(font-latex-script-char-face ((,class :foreground ,cyan-alt-other))) - `(font-latex-sectioning-0-face ((,class :inherit modus-themes-variable-pitch :foreground ,blue-nuanced-fg))) - `(font-latex-sectioning-1-face ((,class :inherit (bold modus-themes-variable-pitch) :foreground ,blue-nuanced-fg))) - `(font-latex-sectioning-2-face ((,class :inherit (bold modus-themes-variable-pitch) :foreground ,blue-nuanced-fg))) - `(font-latex-sectioning-3-face ((,class :inherit (bold modus-themes-variable-pitch) :foreground ,blue-nuanced-fg))) - `(font-latex-sectioning-4-face ((,class :inherit (bold modus-themes-variable-pitch) :foreground ,blue-nuanced-fg))) - `(font-latex-sectioning-5-face ((,class :inherit modus-themes-variable-pitch :foreground ,blue-nuanced-fg))) - `(font-latex-sedate-face ((,class :inherit modus-themes-bold :foreground ,magenta-alt-other))) - `(font-latex-slide-title-face ((,class :inherit (bold modus-themes-variable-pitch) :foreground ,cyan-nuanced-fg - ,@(modus-themes--scale modus-themes-scale-4)))) + `(font-latex-math-face ((,class :inherit font-lock-constant-face))) + `(font-latex-script-char-face ((,class :inherit font-lock-builtin-face))) + `(font-latex-sectioning-0-face ((,class :inherit modus-themes-heading-1))) + `(font-latex-sectioning-1-face ((,class :inherit modus-themes-heading-2))) + `(font-latex-sectioning-2-face ((,class :inherit modus-themes-heading-3))) + `(font-latex-sectioning-3-face ((,class :inherit modus-themes-heading-4))) + `(font-latex-sectioning-4-face ((,class :inherit modus-themes-heading-5))) + `(font-latex-sectioning-5-face ((,class :inherit modus-themes-heading-6))) + `(font-latex-sedate-face ((,class :inherit font-lock-keyword-face))) + `(font-latex-slide-title-face ((,class :inherit modus-themes-heading-1))) `(font-latex-string-face ((,class :inherit font-lock-string-face))) `(font-latex-subscript-face ((,class :height 0.95))) `(font-latex-superscript-face ((,class :height 0.95))) `(font-latex-verbatim-face ((,class :background ,bg-dim :foreground ,fg-special-mild))) `(font-latex-warning-face ((,class :inherit font-lock-warning-face))) `(tex-match ((,class :foreground ,blue-alt-other))) - `(tex-verbatim ((,class :background ,bg-dim :foreground ,fg-special-mild))) + `(tex-verbatim ((,class :inherit modus-themes-markup-verbatim))) `(texinfo-heading ((,class :foreground ,magenta))) `(TeX-error-description-error ((,class :inherit error))) - `(TeX-error-description-help ((,class :foreground ,blue))) - `(TeX-error-description-tex-said ((,class :foreground ,blue))) + `(TeX-error-description-help ((,class :inherit success))) + `(TeX-error-description-tex-said ((,class :inherit success))) `(TeX-error-description-warning ((,class :inherit warning))) ;;;;; auto-dim-other-buffers `(auto-dim-other-buffers-face ((,class :background ,bg-alt))) @@ -4505,7 +4502,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 @@ -4519,10 +4516,6 @@ by virtue of calling either of `modus-themes-load-operandi' and ;;;;; breakpoint (built-in gdb-mi.el) `(breakpoint-disabled ((,class :inherit shadow))) `(breakpoint-enabled ((,class :inherit bold :foreground ,red))) -;;;;; buffer-expose - `(buffer-expose-ace-char-face ((,class :inherit bold :foreground ,red-active))) - `(buffer-expose-mode-line-face ((,class :foreground ,cyan-active))) - `(buffer-expose-selected-face ((,class :inherit modus-themes-special-mild))) ;;;;; calendar and diary `(calendar-month-header ((,class :inherit modus-themes-pseudo-header))) `(calendar-today ((,class :inherit bold :underline t))) @@ -4545,9 +4538,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(cfw:face-saturday ((,class :inherit bold :foreground ,cyan-alt-other))) `(cfw:face-select ((,class :inherit modus-themes-intense-blue))) `(cfw:face-sunday ((,class :inherit bold :foreground ,cyan-alt-other))) - `(cfw:face-title ((,class :inherit modus-themes-variable-pitch - :foreground ,fg-special-cold - ,@(modus-themes--scale modus-themes-scale-title)))) + `(cfw:face-title ((,class :inherit modus-themes-heading-1 :background ,bg-main :overline nil :foreground ,fg-special-cold))) `(cfw:face-today ((,class :background ,bg-inactive))) `(cfw:face-today-title ((,class :background ,bg-active))) `(cfw:face-toolbar ((,class :background ,bg-alt :foreground ,bg-alt))) @@ -4562,14 +4553,14 @@ by virtue of calling either of `modus-themes-load-operandi' and `(centaur-tabs-modified-marker-selected ((,class :inherit centaur-tabs-selected))) `(centaur-tabs-modified-marker-unselected ((,class :inherit centaur-tabs-unselected))) `(centaur-tabs-default (( ))) - `(centaur-tabs-selected ((,class ,@(modus-themes--tab bg-tab-active nil nil nil t t)))) + `(centaur-tabs-selected ((,class :inherit modus-themes-tab-active))) `(centaur-tabs-selected-modified ((,class :inherit (italic centaur-tabs-selected)))) - `(centaur-tabs-unselected ((,class ,@(modus-themes--tab bg-tab-inactive bg-tab-inactive-accent fg-dim nil t)))) + `(centaur-tabs-unselected ((,class :inherit modus-themes-tab-inactive))) `(centaur-tabs-unselected-modified ((,class :inherit (italic centaur-tabs-unselected)))) ;;;;; 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,15 +4600,13 @@ 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))) `(cider-test-error-face ((,class :inherit modus-themes-subtle-red))) `(cider-test-failure-face ((,class :inherit (modus-themes-intense-red bold)))) - `(cider-test-success-face ((,class :inherit ,@(modus-themes--success-deuteran - 'modus-themes-intense-blue - 'modus-themes-intense-green)))) + `(cider-test-success-face ((,class :inherit modus-themes-grue-background-intense))) `(cider-traced-face ((,class :box (:line-width -1 :color ,cyan :style nil) :background ,bg-dim))) `(cider-warning-highlight-face ((,class :foreground ,yellow :underline t))) ;;;;; circe (and lui) @@ -4650,15 +4639,16 @@ by virtue of calling either of `modus-themes-load-operandi' and `(company-preview ((,class :background ,bg-dim :foreground ,fg-dim))) `(company-preview-common ((,class :foreground ,blue-alt))) `(company-preview-search ((,class :inherit modus-themes-special-calm))) - `(company-scrollbar-bg ((,class :background ,bg-active))) - `(company-scrollbar-fg ((,class :background ,fg-active))) `(company-template-field ((,class :inherit modus-themes-intense-magenta))) `(company-tooltip ((,class :background ,bg-alt :foreground ,fg-alt))) `(company-tooltip-annotation ((,class :inherit modus-themes-slant :foreground ,fg-special-cold))) `(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-scrollbar-thumb ((,class :background ,fg-active))) + `(company-tooltip-scrollbar-track ((,class :background ,bg-active))) `(company-tooltip-search ((,class :inherit (modus-themes-search-success-lazy bold)))) `(company-tooltip-search-selection ((,class :inherit (modus-themes-search-success bold) :underline t))) `(company-tooltip-selection ((,class :inherit (modus-themes-subtle-cyan bold)))) @@ -4698,10 +4688,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))) @@ -4723,8 +4713,6 @@ by virtue of calling either of `modus-themes-load-operandi' and `(counsel-css-selector-depth-face-4 ((,class :foreground ,yellow))) `(counsel-css-selector-depth-face-5 ((,class :foreground ,magenta))) `(counsel-css-selector-depth-face-6 ((,class :foreground ,red))) -;;;;; counsel-org-capture-string - `(counsel-org-capture-string-template-body-face ((,class :foreground ,fg-special-cold))) ;;;;; cov `(cov-coverage-not-run-face ((,class :foreground ,red-intense))) `(cov-coverage-run-face ((,class :foreground ,green-intense))) @@ -4758,7 +4746,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))) @@ -4806,15 +4794,12 @@ by virtue of calling either of `modus-themes-load-operandi' and `(debbugs-gnu-stale-4 ((,class :foreground ,yellow-alt-other))) `(debbugs-gnu-stale-5 ((,class :foreground ,red-alt))) `(debbugs-gnu-tagged ((,class :foreground ,magenta-alt))) -;;;;; define-word - `(define-word-face-1 ((,class :foreground ,yellow))) - `(define-word-face-2 ((,class :foreground ,fg-main))) ;;;;; deft `(deft-filter-string-error-face ((,class :inherit modus-themes-refine-red))) `(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 @@ -4830,9 +4815,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(diff-hl-dired-ignored ((,class :inherit dired-ignored))) `(diff-hl-dired-insert ((,class :inherit diff-hl-insert))) `(diff-hl-dired-unknown ((,class :inherit dired-ignored))) - `(diff-hl-insert ((,class :inherit ,@(modus-themes--diff-deuteran - 'modus-themes-fringe-blue - 'modus-themes-fringe-green)))) + `(diff-hl-insert ((,class :inherit modus-themes-grue-background-active))) `(diff-hl-reverted-hunk-highlight ((,class :background ,fg-main :foreground ,bg-main))) ;;;;; diff-mode `(diff-added ((,class :inherit modus-themes-diff-added))) @@ -4844,8 +4827,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(diff-header ((,class :foreground ,fg-main))) `(diff-hunk-header ((,class :inherit (bold modus-themes-diff-heading)))) `(diff-index ((,class :inherit bold :foreground ,blue-alt))) - `(diff-indicator-added ((,class :inherit (diff-added bold) - :foreground ,@(modus-themes--diff-deuteran blue green)))) + `(diff-indicator-added ((,class :inherit (modus-themes-grue diff-added bold)))) `(diff-indicator-changed ((,class :inherit (diff-changed bold) :foreground ,yellow))) `(diff-indicator-removed ((,class :inherit (diff-removed bold) :foreground ,red))) `(diff-nonexistent ((,class :inherit (modus-themes-neutral bold)))) @@ -4862,7 +4844,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))) @@ -4873,13 +4855,11 @@ by virtue of calling either of `modus-themes-load-operandi' and `(dir-treeview-indent-face ((,class :inherit shadow))) `(dir-treeview-label-mouse-face ((,class :inherit highlight))) `(dir-treeview-start-dir-face ((,class :inherit modus-themes-pseudo-header))) - `(dir-treeview-symlink-face ((,class :inherit button - ,@(modus-themes--link-color - cyan cyan-faint)))) + `(dir-treeview-symlink-face ((,class :inherit modus-themes-link-symlink))) `(dir-treeview-video-face ((,class :foreground ,magenta-alt-other))) `(dir-treeview-video-icon-face ((,class :inherit dir-treeview-default-icon-face :foreground ,magenta-alt-other))) ;;;;; dired - `(dired-broken-symlink ((,class :inherit button :foreground ,red))) + `(dired-broken-symlink ((,class :inherit modus-themes-link-broken))) `(dired-directory ((,class :foreground ,blue))) `(dired-flagged ((,class :inherit modus-themes-mark-del))) `(dired-header ((,class :inherit modus-themes-pseudo-header))) @@ -4887,9 +4867,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(dired-mark ((,class :inherit modus-themes-mark-symbol))) `(dired-marked ((,class :inherit modus-themes-mark-sel))) `(dired-perm-write ((,class :foreground ,fg-special-warm))) - `(dired-symlink ((,class :inherit button - ,@(modus-themes--link-color - cyan-alt cyan-alt-faint)))) + `(dired-symlink ((,class :inherit modus-themes-link-symlink))) `(dired-warning ((,class :inherit bold :foreground ,yellow))) ;;;;; dired-async `(dired-async-failures ((,class :inherit bold :foreground ,red-active))) @@ -4913,11 +4891,6 @@ by virtue of calling either of `modus-themes-load-operandi' and `(dired-subtree-depth-4-face (())) `(dired-subtree-depth-5-face (())) `(dired-subtree-depth-6-face (())) -;;;;; diredc - `(diredc-face-chmod-font-lock-dir ((,class :foreground ,blue-alt))) - `(diredc-face-chmod-font-lock-exec ((,class :foreground ,magenta))) - `(diredc-face-chmod-font-lock-read ((,class :foreground ,fg-main))) - `(diredc-face-chmod-font-lock-write ((,class :foreground ,cyan))) ;;;;; diredfl `(diredfl-autofile-name ((,class :inherit modus-themes-special-cold))) `(diredfl-compressed-file-name ((,class :foreground ,fg-special-warm))) @@ -4973,13 +4946,6 @@ by virtue of calling either of `modus-themes-load-operandi' and `(diredp-symlink ((,class :inherit dired-symlink))) `(diredp-tagged-autofile-name ((,class :inherit modus-themes-refine-magenta))) `(diredp-write-priv ((,class :foreground ,cyan))) -;;;;; disk-usage - `(disk-usage-children ((,class :foreground ,yellow))) - `(disk-usage-inaccessible ((,class :inherit bold :foreground ,red))) - `(disk-usage-percent ((,class :foreground ,green))) - `(disk-usage-size ((,class :foreground ,cyan))) - `(disk-usage-symlink ((,class :inherit button))) - `(disk-usage-symlink-directory ((,class :inherit bold :foreground ,blue-alt))) ;;;;; display-fill-column-indicator-mode `(fill-column-indicator ((,class :foreground ,bg-active))) ;;;;; doom-modeline @@ -5010,9 +4976,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(doom-modeline-host ((,class :inherit italic))) `(doom-modeline-info ((,class :foreground ,green-active))) `(doom-modeline-lsp-error ((,class :inherit bold :foreground ,red-active))) - `(doom-modeline-lsp-success ((,class :inherit bold :foreground ,@(modus-themes--success-deuteran - blue-active - green-active)))) + `(doom-modeline-lsp-success ((,class :inherit (bold modus-themes-grue-active)))) `(doom-modeline-lsp-warning ((,class :inherit bold :foreground ,yellow-active))) `(doom-modeline-panel ((,class :inherit modus-themes-active-blue))) `(doom-modeline-persp-buffer-not-in-persp ((,class :inherit italic :foreground ,yellow-active))) @@ -5028,9 +4992,6 @@ by virtue of calling either of `modus-themes-load-operandi' and `(dynamic-ruler-positive-face ((,class :inherit modus-themes-intense-yellow))) ;;;;; easy-jekyll `(easy-jekyll-help-face ((,class :background ,bg-dim :foreground ,cyan-alt-other))) -;;;;; easy-kill - `(easy-kill-origin ((,class :inherit modus-themes-subtle-red))) - `(easy-kill-selection ((,class :inherit modus-themes-subtle-yellow))) ;;;;; ebdb `(ebdb-address-default ((,class :foreground ,fg-special-calm))) `(ebdb-defunct ((,class :inherit shadow))) @@ -5046,7 +5007,6 @@ by virtue of calling either of `modus-themes-load-operandi' and ;;;;; ediff `(ediff-current-diff-A ((,class :inherit modus-themes-diff-removed))) `(ediff-current-diff-Ancestor ((,class ,@(modus-themes--diff - bg-alt fg-special-cold bg-special-cold fg-special-cold blue-nuanced-bg blue)))) `(ediff-current-diff-B ((,class :inherit modus-themes-diff-added))) @@ -5103,12 +5063,12 @@ by virtue of calling either of `modus-themes-load-operandi' and ;;;;; embark `(embark-keybinding ((,class :inherit modus-themes-key-binding))) ;;;;; emms - `(emms-browser-album-face ((,class :foreground ,magenta-alt-other ,@(modus-themes--scale modus-themes-scale-2)))) - `(emms-browser-artist-face ((,class :foreground ,cyan ,@(modus-themes--scale modus-themes-scale-3)))) - `(emms-browser-composer-face ((,class :foreground ,magenta-alt ,@(modus-themes--scale modus-themes-scale-3)))) + `(emms-browser-album-face ((,class :foreground ,magenta-alt-other))) + `(emms-browser-artist-face ((,class :foreground ,cyan))) + `(emms-browser-composer-face ((,class :foreground ,magenta-alt))) `(emms-browser-performer-face ((,class :inherit emms-browser-artist-face))) `(emms-browser-track-face ((,class :inherit emms-playlist-track-face))) - `(emms-browser-year/genre-face ((,class :foreground ,cyan-alt-other ,@(modus-themes--scale modus-themes-scale-4)))) + `(emms-browser-year/genre-face ((,class :foreground ,cyan-alt-other))) `(emms-playlist-track-face ((,class :foreground ,blue-alt))) `(emms-playlist-selected-face ((,class :inherit bold :foreground ,blue-alt-other))) `(emms-metaplaylist-mode-current-face ((,class :inherit emms-playlist-selected-face))) @@ -5140,28 +5100,28 @@ by virtue of calling either of `modus-themes-load-operandi' and `(equake-tab-active ((,class :background ,fg-alt :foreground ,bg-alt))) `(equake-tab-inactive ((,class :foreground ,fg-inactive))) ;;;;; erc - `(erc-action-face ((,class :inherit bold :foreground ,cyan))) + `(erc-action-face ((,class :foreground ,cyan-alt-other))) `(erc-bold-face ((,class :inherit bold))) `(erc-button ((,class :inherit button))) `(erc-command-indicator-face ((,class :inherit bold :foreground ,cyan-alt))) - `(erc-current-nick-face ((,class :foreground ,magenta-alt-other))) + `(erc-current-nick-face ((,class :inherit bold :foreground ,red-alt))) `(erc-dangerous-host-face ((,class :inherit modus-themes-intense-red))) - `(erc-direct-msg-face ((,class :foreground ,magenta))) + `(erc-direct-msg-face ((,class :foreground ,fg-special-warm))) `(erc-error-face ((,class :inherit bold :foreground ,red))) - `(erc-fool-face ((,class :foreground ,fg-inactive))) + `(erc-fool-face ((,class :inherit shadow))) `(erc-header-line ((,class :background ,bg-header :foreground ,fg-header))) - `(erc-input-face ((,class :foreground ,fg-special-calm))) + `(erc-input-face ((,class :foreground ,magenta))) `(erc-inverse-face ((,class :inherit erc-default-face :inverse-video t))) - `(erc-keyword-face ((,class :inherit bold :foreground ,magenta-alt))) + `(erc-keyword-face ((,class :inherit bold :foreground ,magenta-alt-other))) `(erc-my-nick-face ((,class :inherit bold :foreground ,magenta))) `(erc-my-nick-prefix-face ((,class :inherit erc-my-nick-face))) `(erc-nick-default-face ((,class :inherit bold :foreground ,blue))) - `(erc-nick-msg-face ((,class :inherit bold :foreground ,green))) + `(erc-nick-msg-face ((,class :inherit warning))) `(erc-nick-prefix-face ((,class :inherit erc-nick-default-face))) - `(erc-notice-face ((,class :foreground ,fg-unfocused))) - `(erc-pal-face ((,class :inherit bold :foreground ,red-alt))) + `(erc-notice-face ((,class :inherit font-lock-comment-face))) + `(erc-pal-face ((,class :inherit bold :foreground ,magenta-alt))) `(erc-prompt-face ((,class :inherit modus-themes-prompt))) - `(erc-timestamp-face ((,class :foreground ,blue-nuanced-fg))) + `(erc-timestamp-face ((,class :foreground ,cyan))) `(erc-underline-face ((,class :underline t))) `(bg:erc-color-face0 ((,class :background "white"))) `(bg:erc-color-face1 ((,class :background "black"))) @@ -5211,7 +5171,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(eshell-ls-product ((,class :inherit shadow))) `(eshell-ls-readonly ((,class :foreground ,yellow-faint))) `(eshell-ls-special ((,class :foreground ,magenta))) - `(eshell-ls-symlink ((,class :foreground ,cyan))) + `(eshell-ls-symlink ((,class :inherit modus-themes-link-symlink))) `(eshell-ls-unreadable ((,class :background ,bg-inactive :foreground ,fg-inactive))) `(eshell-prompt ((,class :inherit modus-themes-prompt))) ;;;;; eshell-fringe-status @@ -5317,10 +5277,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(flycheck-indicator-error ((,class :inherit modus-themes-bold :foreground ,red-active))) `(flycheck-indicator-info ((,class :inherit modus-themes-bold :foreground ,blue-active))) `(flycheck-indicator-running ((,class :inherit modus-themes-bold :foreground ,magenta-active))) - `(flycheck-indicator-success ((,class :inherit modus-themes-bold - :foreground ,@(modus-themes--success-deuteran - blue-active - green-active)))) + `(flycheck-indicator-success ((,class :inherit (modus-themes-bold modus-themes-grue-active)))) `(flycheck-indicator-warning ((,class :inherit modus-themes-bold :foreground ,yellow-active))) ;;;;; flycheck-posframe `(flycheck-posframe-background-face ((,class :background ,bg-alt))) @@ -5336,8 +5293,6 @@ by virtue of calling either of `modus-themes-load-operandi' and ;;;;; flyspell `(flyspell-duplicate ((,class :inherit modus-themes-lang-warning))) `(flyspell-incorrect ((,class :inherit modus-themes-lang-error))) -;;;;; flyspell-correct - `(flyspell-correct-highlight-face ((,class :inherit modus-themes-refine-green))) ;;;;; flx `(flx-highlight-face ((,class ,@(modus-themes--extra-completions 'modus-themes-subtle-magenta @@ -5456,66 +5411,33 @@ by virtue of calling either of `modus-themes-load-operandi' and `(git-commit-comment-branch-local ((,class :inherit modus-themes-slant :foreground ,blue-alt))) `(git-commit-comment-branch-remote ((,class :inherit modus-themes-slant :foreground ,magenta-alt))) `(git-commit-comment-detached ((,class :inherit modus-themes-slant :foreground ,cyan-alt))) - `(git-commit-comment-file ((,class :inherit modus-themes-slant - ,@(modus-themes--syntax-comment - fg-special-cold red-nuanced-fg)))) - `(git-commit-comment-heading ((,class :inherit (bold modus-themes-slant) - ,@(modus-themes--syntax-comment - fg-dim fg-special-warm)))) + `(git-commit-comment-file ((,class :inherit modus-themes-slant :foreground ,cyan))) + `(git-commit-comment-heading ((,class :inherit (bold modus-themes-slant)))) `(git-commit-keyword ((,class :foreground ,magenta))) `(git-commit-known-pseudo-header ((,class :foreground ,cyan-alt-other))) - `(git-commit-nonempty-second-line ((,class :inherit modus-themes-refine-yellow))) - `(git-commit-overlong-summary ((,class :inherit modus-themes-refine-yellow))) + `(git-commit-nonempty-second-line ((,class :inherit error))) + `(git-commit-overlong-summary ((,class :inherit warning))) `(git-commit-pseudo-header ((,class :foreground ,blue))) - `(git-commit-summary ((,class :inherit bold :foreground ,cyan))) + `(git-commit-summary ((,class :inherit bold :foreground ,blue))) ;;;;; git-gutter - `(git-gutter:added ((,class :inherit ,@(modus-themes--diff-deuteran - 'modus-themes-fringe-blue - 'modus-themes-fringe-green)))) + `(git-gutter:added ((,class :inherit modus-themes-grue-background-active))) `(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))) `(git-gutter:unchanged ((,class :inherit modus-themes-fringe-magenta))) ;;;;; git-gutter-fr - `(git-gutter-fr:added ((,class :inherit ,@(modus-themes--diff-deuteran - 'modus-themes-fringe-blue - 'modus-themes-fringe-green)))) + `(git-gutter-fr:added ((,class :inherit modus-themes-grue-background-active))) `(git-gutter-fr:deleted ((,class :inherit modus-themes-fringe-red))) `(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)))) - `(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))) - `(git-gutter+-unchanged ((,class :inherit modus-themes-fringe-magenta))) - `(git-gutter-fr+-added ((,class :inherit modus-themes-fringe-green))) - `(git-gutter-fr+-deleted ((,class :inherit modus-themes-fringe-red))) - `(git-gutter-fr+-modified ((,class :inherit modus-themes-fringe-yellow))) -;;;;; git-lens - `(git-lens-added ((,class :inherit bold :foreground ,@(modus-themes--diff-deuteran blue green)))) - `(git-lens-deleted ((,class :inherit bold :foreground ,red))) - `(git-lens-header ((,class :inherit bold :height 1.1 :foreground ,cyan))) - `(git-lens-modified ((,class :inherit bold :foreground ,yellow))) - `(git-lens-renamed ((,class :inherit bold :foreground ,magenta))) ;;;;; git-rebase - `(git-rebase-comment-hash ((,class :inherit modus-themes-slant - ,@(modus-themes--syntax-comment - fg-special-cold red-nuanced-fg)))) - `(git-rebase-comment-heading ((,class :inherit (bold modus-themes-slant) - ,@(modus-themes--syntax-comment - fg-dim fg-special-warm)))) + `(git-rebase-comment-hash ((,class :inherit modus-themes-slant :foreground ,cyan))) + `(git-rebase-comment-heading ((,class :inherit (bold modus-themes-slant)))) `(git-rebase-description ((,class :foreground ,fg-main))) `(git-rebase-hash ((,class :foreground ,cyan-alt-other))) ;;;;; git-timemachine `(git-timemachine-commit ((,class :inherit bold :foreground ,yellow-active))) `(git-timemachine-minibuffer-author-face ((,class :foreground ,fg-special-warm))) `(git-timemachine-minibuffer-detail-face ((,class :foreground ,red-alt))) -;;;;; git-walktree - `(git-walktree-commit-face ((,class :foreground ,yellow))) - `(git-walktree-symlink-face ((,class :inherit button))) - `(git-walktree-tree-face ((,class :foreground ,magenta))) ;;;;; gnus `(gnus-button ((,class :inherit button))) `(gnus-cite-1 ((,class :inherit message-cited-text-1))) @@ -5639,9 +5561,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(helm-ff-executable ((,class :foreground ,magenta-alt))) `(helm-ff-file ((,class :foreground ,fg-main))) `(helm-ff-file-extension ((,class :foreground ,fg-special-warm))) - `(helm-ff-invalid-symlink ((,class :inherit button - ,@(modus-themes--link-color - red red-faint)))) + `(helm-ff-invalid-symlink ((,class :inherit modus-themes-link-broken))) `(helm-ff-pipe ((,class ,@(modus-themes--extra-completions 'modus-themes-refine-magenta 'modus-themes-subtle-magenta @@ -5658,9 +5578,7 @@ by virtue of calling either of `modus-themes-load-operandi' and 'modus-themes-refine-red 'modus-themes-nuanced-yellow red-alt)))) - `(helm-ff-symlink ((,class :inherit button - ,@(modus-themes--link-color - cyan cyan-faint)))) + `(helm-ff-symlink ((,class :inherit modus-themes-link-symlink))) `(helm-ff-truename ((,class :foreground ,blue-alt-other))) `(helm-fd-finish ((,class :foreground ,green-active))) `(helm-grep-cmd-line ((,class :foreground ,yellow-alt-other))) @@ -5697,9 +5615,7 @@ by virtue of calling either of `modus-themes-load-operandi' and 'modus-themes-nuanced-cyan cyan-alt-other)))) `(helm-minibuffer-prompt ((,class :inherit modus-themes-prompt))) - `(helm-moccur-buffer ((,class :inherit button - ,@(modus-themes--link-color - cyan-alt-other cyan-alt-other-faint)))) + `(helm-moccur-buffer ((,class :inherit button :foreground ,cyan-alt-other))) `(helm-mode-prefix ((,class ,@(modus-themes--extra-completions 'modus-themes-subtle-magenta 'modus-themes-intense-magenta @@ -5723,8 +5639,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(helm-separator ((,class :foreground ,fg-special-mild))) `(helm-time-zone-current ((,class :foreground ,green))) `(helm-time-zone-home ((,class :foreground ,magenta))) - `(helm-source-header ((,class :inherit bold :foreground ,red-alt - ,@(modus-themes--scale modus-themes-scale-4)))) + `(helm-source-header ((,class :inherit modus-themes-pseudo-header :foreground ,fg-special-cold))) `(helm-top-columns ((,class :inherit helm-header))) `(helm-ucs-char ((,class :foreground ,yellow-alt-other))) `(helm-visible-mark ((,class :inherit modus-themes-subtle-cyan))) @@ -5768,33 +5683,11 @@ by virtue of calling either of `modus-themes-load-operandi' and `(highlight-changes-delete ((,class :background ,red-nuanced-bg :foreground ,red :underline t))) `(hl-line ((,class :inherit modus-themes-hl-line))) -;;;;; highlight-blocks - `(highlight-blocks-depth-1-face ((,class :background ,bg-dim :foreground ,fg-main))) - `(highlight-blocks-depth-2-face ((,class :background ,bg-alt :foreground ,fg-main))) - `(highlight-blocks-depth-3-face ((,class :background ,bg-special-cold :foreground ,fg-main))) - `(highlight-blocks-depth-4-face ((,class :background ,bg-special-calm :foreground ,fg-main))) - `(highlight-blocks-depth-5-face ((,class :background ,bg-special-warm :foreground ,fg-main))) - `(highlight-blocks-depth-6-face ((,class :background ,bg-special-mild :foreground ,fg-main))) - `(highlight-blocks-depth-7-face ((,class :background ,bg-inactive :foreground ,fg-main))) - `(highlight-blocks-depth-8-face ((,class :background ,bg-active :foreground ,fg-main))) - `(highlight-blocks-depth-9-face ((,class :background ,cyan-subtle-bg :foreground ,fg-main))) -;;;;; highlight-defined - `(highlight-defined-builtin-function-name-face ((,class :foreground ,magenta))) - `(highlight-defined-face-name-face ((,class :foreground ,fg-main))) - `(highlight-defined-function-name-face ((,class :foreground ,magenta))) - `(highlight-defined-macro-name-face ((,class :foreground ,magenta-alt))) - `(highlight-defined-special-form-name-face ((,class :foreground ,magenta-alt-other))) - `(highlight-defined-variable-name-face ((,class :foreground ,cyan))) -;;;;; highlight-escape-sequences (`hes-mode') - `(hes-escape-backslash-face ((,class :inherit font-lock-regexp-grouping-construct))) - `(hes-escape-sequence-face ((,class :inherit font-lock-regexp-grouping-backslash))) ;;;;; highlight-indentation `(highlight-indentation-face ((,class :inherit modus-themes-hl-line))) `(highlight-indentation-current-column-face ((,class :background ,bg-active))) ;;;;; highlight-numbers `(highlight-numbers-number ((,class :foreground ,blue-alt-other))) -;;;;; highlight-symbol - `(highlight-symbol-face ((,class :inherit modus-themes-special-mild))) ;;;;; highlight-thing `(highlight-thing ((,class :background ,bg-alt :foreground ,cyan))) ;;;;; hl-defined @@ -5811,16 +5704,6 @@ by virtue of calling either of `modus-themes-load-operandi' and `(hydra-face-pink ((,class :inherit bold :foreground ,magenta-alt-faint))) `(hydra-face-red ((,class :inherit bold :foreground ,red-faint))) `(hydra-face-teal ((,class :inherit bold :foreground ,cyan-alt-other))) -;;;;; hyperlist - `(hyperlist-condition ((,class :foreground ,green))) - `(hyperlist-hashtag ((,class :foreground ,yellow))) - `(hyperlist-operator ((,class :foreground ,blue-alt))) - `(hyperlist-paren ((,class :foreground ,cyan-alt-other))) - `(hyperlist-quote ((,class :foreground ,cyan-alt))) - `(hyperlist-ref ((,class :foreground ,magenta-alt-other))) - `(hyperlist-stars ((,class :inherit shadow))) - `(hyperlist-tag ((,class :foreground ,red))) - `(hyperlist-toplevel ((,class :inherit bold :foreground ,fg-main))) ;;;;; icomplete `(icomplete-first-match ((,class :inherit bold ,@(modus-themes--standard-completions @@ -5851,6 +5734,9 @@ 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 :inherit modus-themes-grue-background-intense))) ;;;;; imenu-list `(imenu-list-entry-face-0 ((,class :foreground ,cyan))) `(imenu-list-entry-face-1 ((,class :foreground ,blue))) @@ -5862,16 +5748,15 @@ 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))) `(indium-repl-prompt-face ((,class :inherit modus-themes-prompt))) `(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))) + `(Info-quoted ((,class :inherit modus-themes-markup-verbatim))) ; the capitalization is canonical + `(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 +5767,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))) @@ -5908,8 +5793,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(ioccur-num-line-face ((,class :foreground ,fg-special-warm))) `(ioccur-overlay-face ((,class :inherit modus-themes-refine-blue :extend t))) `(ioccur-regexp-face ((,class :inherit (modus-themes-intense-magenta bold)))) - `(ioccur-title-face ((,class :inherit bold :foreground ,red-alt - ,@(modus-themes--scale modus-themes-scale-4)))) + `(ioccur-title-face ((,class :inherit modus-themes-pseudo-header :foreground ,fg-special-cold))) ;;;;; isearch, occur, and the like `(isearch ((,class :inherit (modus-themes-search-success bold)))) `(isearch-fail ((,class :inherit modus-themes-refine-red))) @@ -5918,14 +5802,6 @@ by virtue of calling either of `modus-themes-load-operandi' and `(lazy-highlight ((,class :inherit modus-themes-search-success-lazy))) `(match ((,class :inherit modus-themes-special-calm))) `(query-replace ((,class :inherit (modus-themes-intense-yellow bold)))) -;;;;; isl (isearch-light) - `(isl-line ((,class :inherit ,@(modus-themes--success-deuteran - 'modus-themes-subtle-blue - 'modus-themes-subtle-green)))) - `(isl-match ((,class :inherit modus-themes-search-success-lazy))) - `(isl-number ((,class :inherit (modus-themes-bold modus-themes-search-success-modeline)))) - `(isl-on ((,class :inherit (bold modus-themes-search-success)))) - `(isl-string ((,class :inherit modus-themes-bold :foreground ,cyan-active))) ;;;;; ivy `(ivy-action ((,class :inherit bold :foreground ,red-alt))) `(ivy-completions-annotations ((,class :inherit completions-annotations))) @@ -6089,7 +5965,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))) @@ -6127,11 +6003,17 @@ by virtue of calling either of `modus-themes-load-operandi' and `(magit-blame-margin ((,class :inherit (magit-blame-highlight modus-themes-reset-hard)))) `(magit-blame-name ((,class :foreground ,magenta-alt-other))) `(magit-blame-summary ((,class :foreground ,cyan-alt-other))) - `(magit-branch-current ((,class :foreground ,blue-alt-other :box t))) + ;; ;; NOTE 2021-11-23: we do not set the `magit-branch-current' + ;; ;; because its definition checks if the :box attribute can be set + ;; ;; and if not, it uses :inverse-video. Useful for terminal + ;; ;; emulators. + ;; + ;; `(magit-branch-current ((,class :foreground ,blue-alt-other :box t))) `(magit-branch-local ((,class :foreground ,blue-alt))) `(magit-branch-remote ((,class :foreground ,magenta-alt))) `(magit-branch-remote-head ((,class :foreground ,magenta-alt-other :box t))) `(magit-branch-upstream ((,class :inherit italic))) + `(magit-branch-warning ((,class :inherit warning))) `(magit-cherry-equivalent ((,class :background ,bg-main :foreground ,magenta-intense))) `(magit-cherry-unmatched ((,class :background ,bg-main :foreground ,cyan-intense))) ;; NOTE: here we break from the pattern of inheriting from the @@ -6139,19 +6021,16 @@ by virtue of calling either of `modus-themes-load-operandi' and ;; not the highlighted ones. This is because Magit's interaction ;; model relies on highlighting the current diff hunk. `(magit-diff-added ((,class ,@(modus-themes--diff - bg-main blue-alt-other bg-diff-added fg-diff-added green-nuanced-bg fg-diff-added bg-diff-added-deuteran fg-diff-added-deuteran)))) `(magit-diff-added-highlight ((,class :inherit modus-themes-diff-focus-added))) `(magit-diff-base ((,class ,@(modus-themes--diff - bg-main yellow bg-diff-changed fg-diff-changed yellow-nuanced-bg fg-diff-changed)))) `(magit-diff-base-highlight ((,class :inherit modus-themes-diff-focus-changed))) `(magit-diff-context ((,class ,@(unless (eq modus-themes-diffs 'bg-only) (list :foreground fg-unfocused))))) `(magit-diff-context-highlight ((,class ,@(modus-themes--diff - bg-dim fg-dim bg-inactive fg-inactive bg-dim fg-alt bg-dim fg-alt)))) @@ -6162,25 +6041,25 @@ by virtue of calling either of `modus-themes-load-operandi' and ;; modus-themes-diff-* faces. `(magit-diff-hunk-heading ((,class :inherit bold ,@(modus-themes--diff - bg-alt fg-alt bg-active fg-inactive bg-inactive fg-inactive bg-inactive fg-inactive t)))) + ;; NOTE: we do not follow the pattern of inheriting from + ;; modus-themes-grue-* faces, as this is a special case. `(magit-diff-hunk-heading-highlight ((,class :inherit bold - :background ,@(modus-themes--diff-deuteran bg-active bg-diff-heading) - :foreground ,@(modus-themes--diff-deuteran fg-main fg-diff-heading)))) + :background ,@(modus-themes--deuteran bg-active bg-diff-heading) + :foreground ,@(modus-themes--deuteran fg-main fg-diff-heading)))) `(magit-diff-hunk-heading-selection ((,class :inherit modus-themes-refine-blue))) `(magit-diff-hunk-region ((,class :inherit bold))) `(magit-diff-lines-boundary ((,class :background ,fg-main))) `(magit-diff-lines-heading ((,class :inherit modus-themes-refine-magenta))) `(magit-diff-removed ((,class ,@(modus-themes--diff - bg-main red bg-diff-removed fg-diff-removed red-nuanced-bg fg-diff-removed)))) `(magit-diff-removed-highlight ((,class :inherit modus-themes-diff-focus-removed))) - `(magit-diffstat-added ((,class :foreground ,@(modus-themes--diff-deuteran blue green)))) + `(magit-diffstat-added ((,class :inherit modus-themes-grue))) `(magit-diffstat-removed ((,class :foreground ,red))) `(magit-dimmed ((,class :foreground ,fg-unfocused))) `(magit-filename ((,class :foreground ,fg-special-cold))) @@ -6215,9 +6094,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(magit-section-heading ((,class :inherit bold :foreground ,cyan))) `(magit-section-heading-selection ((,class :inherit (modus-themes-refine-cyan bold)))) `(magit-section-highlight ((,class :background ,bg-alt))) - `(magit-sequence-done ((,class :foreground ,@(modus-themes--success-deuteran - blue - green)))) + `(magit-sequence-done ((,class :inherit modus-themes-grue))) `(magit-sequence-drop ((,class :foreground ,red-alt))) `(magit-sequence-exec ((,class :foreground ,magenta-alt))) `(magit-sequence-head ((,class :foreground ,cyan-alt))) @@ -6229,9 +6106,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(magit-signature-error ((,class :foreground ,red-alt))) `(magit-signature-expired ((,class :foreground ,yellow))) `(magit-signature-expired-key ((,class :foreground ,yellow))) - `(magit-signature-good ((,class :foreground ,@(modus-themes--success-deuteran - blue - green)))) + `(magit-signature-good ((,class :inherit modus-themes-grue))) `(magit-signature-revoked ((,class :foreground ,magenta))) `(magit-signature-untrusted ((,class :foreground ,cyan))) `(magit-tag ((,class :foreground ,yellow-alt-other))) @@ -6308,8 +6183,7 @@ by virtue of calling either of `modus-themes-load-operandi' and :foreground ,fg-special-mild))) `(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))) + `(markdown-inline-code-face ((,class :inherit modus-themes-markup-verbatim))) `(markdown-italic-face ((,class :inherit italic))) `(markdown-language-info-face ((,class :inherit modus-themes-fixed-pitch :foreground ,fg-special-cold))) @@ -6337,19 +6211,17 @@ by virtue of calling either of `modus-themes-load-operandi' and `(markup-bold-face ((,class :inherit bold :foreground ,red-nuanced-fg))) `(markup-code-face ((,class :foreground ,magenta))) `(markup-comment-face ((,class :inherit font-lock-comment-face))) - `(markup-complex-replacement-face ((,class :background ,magenta-nuanced-bg - :foreground ,magenta-alt-other - :underline ,magenta-alt-other))) + `(markup-complex-replacement-face ((,class :background ,magenta-nuanced-bg :foreground ,magenta-alt-other))) `(markup-emphasis-face ((,class :inherit markup-italic-face))) `(markup-error-face ((,class :inherit error))) `(markup-gen-face ((,class :foreground ,magenta-alt))) - `(markup-internal-reference-face ((,class :foreground ,fg-alt :underline ,bg-region))) + `(markup-internal-reference-face ((,class :inherit modus-themes-slant :foreground ,fg-alt))) `(markup-italic-face ((,class :inherit italic))) `(markup-list-face ((,class :inherit modus-themes-special-cold))) - `(markup-meta-face ((,class :inherit shadow))) + `(markup-meta-face ((,class :inherit (modus-themes-fixed-pitch 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-reference-face ((,class :inherit modus-themes-slant :foreground ,blue-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))) @@ -6358,24 +6230,13 @@ by virtue of calling either of `modus-themes-load-operandi' and `(markup-table-cell-face ((,class :inherit modus-themes-subtle-neutral))) `(markup-table-face ((,class :inherit modus-themes-subtle-neutral))) `(markup-table-row-face ((,class :inherit modus-themes-special-cold))) - `(markup-title-0-face ((,class :inherit (bold modus-themes-variable-pitch) - :foreground ,blue-nuanced-fg - ,@(modus-themes--scale modus-themes-scale-title)))) - `(markup-title-1-face ((,class :inherit (bold modus-themes-variable-pitch) - :foreground ,blue-nuanced-fg - ,@(modus-themes--scale modus-themes-scale-1)))) - `(markup-title-2-face ((,class :inherit (bold modus-themes-variable-pitch) - :foreground ,blue-nuanced-fg - ,@(modus-themes--scale modus-themes-scale-2)))) - `(markup-title-3-face ((,class :inherit (bold modus-themes-variable-pitch) - :foreground ,blue-nuanced-fg - ,@(modus-themes--scale modus-themes-scale-3)))) - `(markup-title-4-face ((,class :inherit (bold modus-themes-variable-pitch) - :foreground ,blue-nuanced-fg - ,@(modus-themes--scale modus-themes-scale-4)))) - `(markup-title-5-face ((,class :inherit (bold modus-themes-variable-pitch) - :foreground ,blue-nuanced-fg))) - `(markup-verbatim-face ((,class :background ,bg-alt))) + `(markup-title-0-face ((,class :inherit modus-themes-heading-1))) + `(markup-title-1-face ((,class :inherit modus-themes-heading-2))) + `(markup-title-2-face ((,class :inherit modus-themes-heading-3))) + `(markup-title-3-face ((,class :inherit modus-themes-heading-4))) + `(markup-title-4-face ((,class :inherit modus-themes-heading-5))) + `(markup-title-5-face ((,class :inherit modus-themes-heading-6))) + `(markup-verbatim-face ((,class :inherit modus-themes-fixed-pitch :background ,bg-alt))) ;;;;; mentor `(mentor-download-message ((,class :foreground ,fg-special-warm))) `(mentor-download-name ((,class :foreground ,fg-special-cold))) @@ -6400,8 +6261,6 @@ by virtue of calling either of `modus-themes-load-operandi' and `(message-header-xheader ((,class :foreground ,blue-alt))) `(message-mml ((,class :foreground ,cyan-alt-other))) `(message-separator ((,class :inherit modus-themes-intense-neutral))) -;;;;; minibuffer-line - `(minibuffer-line ((,class :foreground ,fg-main))) ;;;;; minimap `(minimap-active-region-background ((,class :background ,bg-active))) `(minimap-current-line-face ((,class :background ,cyan-intense-bg :foreground ,fg-main))) @@ -6415,17 +6274,18 @@ by virtue of calling either of `modus-themes-load-operandi' and `(mmm-output-submode-face ((,class :background ,red-nuanced-bg))) `(mmm-special-submode-face ((,class :background ,green-nuanced-bg))) ;;;;; mode-line - `(mode-line ((,class ,@(modus-themes--variable-pitch-ui) + `(mode-line ((,class :inherit modus-themes-ui-variable-pitch ,@(modus-themes--mode-line-attrs fg-active bg-active fg-dim bg-active fg-main bg-active-accent fg-alt bg-active 'alt-style bg-main)))) + `(mode-line-active ((,class :inherit mode-line))) `(mode-line-buffer-id ((,class :inherit bold))) `(mode-line-emphasis ((,class :inherit bold :foreground ,blue-active))) `(mode-line-highlight ((,class :inherit modus-themes-active-blue :box (:line-width -1 :style pressed-button)))) - `(mode-line-inactive ((,class ,@(modus-themes--variable-pitch-ui) + `(mode-line-inactive ((,class :inherit modus-themes-ui-variable-pitch ,@(modus-themes--mode-line-attrs fg-inactive bg-inactive fg-alt bg-dim @@ -6436,9 +6296,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(mood-line-status-error ((,class :inherit bold :foreground ,red-active))) `(mood-line-status-info ((,class :foreground ,cyan-active))) `(mood-line-status-neutral ((,class :foreground ,blue-active))) - `(mood-line-status-success ((,class :foreground ,@(modus-themes--success-deuteran - blue-active - green-active)))) + `(mood-line-status-success ((,class :inherit modus-themes-grue-active))) `(mood-line-status-warning ((,class :inherit bold :foreground ,yellow-active))) `(mood-line-unimportant ((,class :foreground ,fg-inactive))) ;;;;; mpdel @@ -6479,25 +6337,24 @@ 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 - `(mu4e-conversation-header ((,class :inherit modus-themes-special-cold))) - `(mu4e-conversation-sender-1 ((,class :foreground ,fg-special-warm))) - `(mu4e-conversation-sender-2 ((,class :foreground ,fg-special-cold))) - `(mu4e-conversation-sender-3 ((,class :foreground ,fg-special-mild))) - `(mu4e-conversation-sender-4 ((,class :inherit shadow))) - `(mu4e-conversation-sender-5 ((,class :foreground ,yellow-refine-fg))) - `(mu4e-conversation-sender-6 ((,class :foreground ,cyan-refine-fg))) - `(mu4e-conversation-sender-7 ((,class :foreground ,green-refine-fg))) - `(mu4e-conversation-sender-8 ((,class :foreground ,blue-refine-fg))) - `(mu4e-conversation-sender-me ((,class :foreground ,fg-main))) - `(mu4e-conversation-unread ((,class :inherit bold))) ;;;;; multiple-cursors `(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))) @@ -6506,8 +6363,8 @@ by virtue of calling either of `modus-themes-load-operandi' and `(neo-file-link-face ((,class :foreground ,fg-main))) `(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-added-face ((,class :inherit modus-themes-grue))) + `(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))) @@ -6518,8 +6375,6 @@ by virtue of calling either of `modus-themes-load-operandi' and `(neo-vc-unlocked-changes-face ((,class :inherit modus-themes-refine-blue))) `(neo-vc-up-to-date-face ((,class :inherit shadow))) `(neo-vc-user-face ((,class :foreground ,magenta))) -;;;;; no-emoji - `(no-emoji ((,class :foreground ,cyan))) ;;;;; notmuch `(notmuch-crypto-decryption ((,class :inherit (shadow bold)))) `(notmuch-crypto-part-header ((,class :foreground ,magenta-alt-other))) @@ -6578,10 +6433,6 @@ by virtue of calling either of `modus-themes-load-operandi' and `(nxml-prolog-keyword ((,class :inherit font-lock-keyword-face))) `(nxml-ref ((,class :inherit modus-themes-bold :foreground ,fg-special-mild))) `(rng-error ((,class :inherit error))) -;;;;; objed - `(objed-hl ((,class :background ,(if modus-themes-hl-line bg-hl-alt-intense bg-hl-alt)))) - `(objed-mark ((,class :background ,bg-active))) - `(objed-mode-line ((,class :foreground ,cyan-active))) ;;;;; orderless `(orderless-match-face-0 ((,class :inherit bold ,@(modus-themes--standard-completions @@ -6601,27 +6452,30 @@ 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 - green-nuanced-fg)))) + `(org-agenda-done ((,class :inherit modus-themes-grue-nuanced))) `(org-agenda-filter-category ((,class :inherit bold :foreground ,cyan-active))) `(org-agenda-filter-effort ((,class :inherit bold :foreground ,cyan-active))) `(org-agenda-filter-regexp ((,class :inherit bold :foreground ,cyan-active))) `(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 +6490,23 @@ 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)) - ,@(modus-themes--link-color - cyan cyan-faint)))) - `(org-date-selected ((,class :inherit bold :foreground ,blue-alt :inverse-video t))) + `(org-column ((,class :inherit (modus-themes-fixed-pitch default) + :background ,bg-alt))) + `(org-column-title ((,class :inherit (bold modus-themes-fixed-pitch default) + :underline t :background ,bg-alt))) + `(org-date ((,class :inherit ,(if modus-themes-mixed-fonts + '(fixed-pitch modus-themes-link-symlink) + 'modus-themes-link-symlink)))) + `(org-date-selected ((,class :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-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-document-info-keyword ((,class :inherit (shadow modus-themes-fixed-pitch)))) + `(org-document-title ((,class :inherit modus-themes-heading-1 :background ,bg-main :overline nil :foreground ,fg-special-cold))) + `(org-done ((,class :inherit modus-themes-grue))) + `(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 @@ -6694,13 +6548,11 @@ by virtue of calling either of `modus-themes-load-operandi' and green-graph-0-bg green-graph-1-bg blue-graph-0-bg)))) - `(org-headline-done ((,class :inherit modus-themes-variable-pitch - :foreground ,@(modus-themes--success-deuteran - blue-nuanced-fg - green-nuanced-fg)))) + `(org-headline-done ((,class :inherit (modus-themes-variable-pitch modus-themes-grue-nuanced)))) `(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 +6565,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))) @@ -6723,19 +6576,18 @@ by virtue of calling either of `modus-themes-load-operandi' and `(org-scheduled ((,class ,@(modus-themes--agenda-scheduled yellow-faint fg-special-warm magenta-alt)))) `(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-sexp-date ((,class :foreground ,cyan-alt-other))) + `(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-table-header ((,class :inherit (fixed-pitch modus-themes-special-cold)))) `(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))) + `(org-verbatim ((,class :inherit modus-themes-markup-verbatim))) `(org-verse ((,class :inherit org-quote))) `(org-warning ((,class :inherit bold :foreground ,red-alt-other))) ;;;;; org-journal @@ -6752,29 +6604,21 @@ by virtue of calling either of `modus-themes-load-operandi' and ;;;;; org-recur `(org-recur ((,class :foreground ,magenta-active))) ;;;;; org-roam - `(org-roam-link ((,class :inherit button - ,@(modus-themes--link-color - green green-faint)))) - `(org-roam-link-current ((,class :inherit button - ,@(modus-themes--link-color - green-alt green-alt-faint)))) - `(org-roam-link-invalid ((,class :inherit button - ,@(modus-themes--link-color - red red-faint)))) - `(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-dim ((,class :foreground "gray50"))) + `(org-roam-header-line ((,class :inherit bold :foreground ,magenta-active))) + `(org-roam-olp ((,class :inherit shadow))) + `(org-roam-preview-heading ((,class :inherit modus-themes-subtle-neutral))) + `(org-roam-preview-heading-highlight ((,class :inherit modus-themes-intense-neutral))) + `(org-roam-preview-heading-selection ((,class :inherit modus-themes-special-cold))) + `(org-roam-preview-region ((,class :inherit bold))) + `(org-roam-title ((,class :inherit modus-themes-pseudo-header))) ;;;;; org-superstar `(org-superstar-item ((,class :foreground ,fg-main))) `(org-superstar-leading ((,class :foreground ,fg-whitespace))) ;;;;; org-table-sticky-header - `(org-table-sticky-header-face ((,class :inherit modus-themes-intense-neutral))) + `(org-table-sticky-header-face ((,class :inherit modus-themes-special-cold))) ;;;;; org-tree-slide - `(org-tree-slide-header-overlay-face - ((,class :inherit (bold modus-themes-variable-pitch) :background ,bg-main - :foreground ,fg-special-cold :overline nil - ,@(modus-themes--scale modus-themes-scale-title)))) + `(org-tree-slide-header-overlay-face ((,class :inherit org-document-title))) ;;;;; org-treescope `(org-treescope-faces--markerinternal-midday ((,class :inherit modus-themes-intense-blue))) `(org-treescope-faces--markerinternal-range ((,class :inherit modus-themes-special-mild))) @@ -6830,8 +6674,6 @@ by virtue of calling either of `modus-themes-load-operandi' and `(paradox-starred-face ((,class :foreground ,magenta-alt))) ;;;;; paren-face `(parenthesis ((,class :foreground ,fg-unfocused))) -;;;;; parrot - `(parrot-rotate-rotation-highlight-face ((,class :inherit modus-themes-refine-magenta))) ;;;;; pass `(pass-mode-directory-face ((,class :inherit bold :foreground ,fg-special-cold))) `(pass-mode-entry-face ((,class :background ,bg-main :foreground ,fg-main))) @@ -6847,26 +6689,16 @@ by virtue of calling either of `modus-themes-load-operandi' and ;;;;; perspective `(persp-selected-face ((,class :inherit bold :foreground ,blue-active))) ;;;;; phi-grep - `(phi-grep-heading-face ((,class :inherit bold :foreground ,red-alt - ,@(modus-themes--scale modus-themes-scale-4)))) + `(phi-grep-heading-face ((,class :inherit modus-themes-pseudo-header :foreground ,fg-special-cold))) `(phi-grep-line-number-face ((,class :foreground ,fg-special-warm))) `(phi-grep-match-face ((,class :inherit modus-themes-special-calm))) `(phi-grep-modified-face ((,class :inherit modus-themes-refine-yellow))) `(phi-grep-overlay-face ((,class :inherit modus-themes-refine-blue))) -;;;;; phi-search - `(phi-replace-preview-face ((,class :inherit modus-themes-intense-magenta))) - `(phi-search-failpart-face ((,class :inherit modus-themes-refine-red))) - `(phi-search-match-face ((,class :inherit modus-themes-search-success-lazy))) - `(phi-search-selection-face ((,class :inherit (modus-themes-search-success bold)))) -;;;;; pkgbuild-mode - `(pkgbuild-error-face ((,class :inherit modus-themes-lang-error))) ;;;;; 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-work-face ((,class :foreground ,@(modus-themes--success-deuteran - blue-alt - green-alt-other)))) + `(pomidor-skip-face ((,class :inherit (shadow modus-themes-slant)))) + `(pomidor-work-face ((,class :inherit modus-themes-grue))) ;;;;; popup `(popup-face ((,class :background ,bg-alt :foreground ,fg-main))) `(popup-isearch-match ((,class :inherit (modus-themes-refine-cyan bold)))) @@ -6914,7 +6746,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))) @@ -6931,22 +6763,6 @@ by virtue of calling either of `modus-themes-load-operandi' and `(rainbow-blocks-depth-8-face ((,class :foreground ,cyan-alt))) `(rainbow-blocks-depth-9-face ((,class :foreground ,red-alt))) `(rainbow-blocks-unmatched-face ((,class :foreground ,red))) -;;;;; rainbow-identifiers - `(rainbow-identifiers-identifier-1 ((,class :foreground ,green-alt-other))) - `(rainbow-identifiers-identifier-2 ((,class :foreground ,magenta-alt-other))) - `(rainbow-identifiers-identifier-3 ((,class :foreground ,cyan-alt-other))) - `(rainbow-identifiers-identifier-4 ((,class :foreground ,yellow-alt-other))) - `(rainbow-identifiers-identifier-5 ((,class :foreground ,blue-alt-other))) - `(rainbow-identifiers-identifier-6 ((,class :foreground ,green-alt))) - `(rainbow-identifiers-identifier-7 ((,class :foreground ,magenta-alt))) - `(rainbow-identifiers-identifier-8 ((,class :foreground ,cyan-alt))) - `(rainbow-identifiers-identifier-9 ((,class :foreground ,yellow-alt))) - `(rainbow-identifiers-identifier-10 ((,class :foreground ,green))) - `(rainbow-identifiers-identifier-11 ((,class :foreground ,magenta))) - `(rainbow-identifiers-identifier-12 ((,class :foreground ,cyan))) - `(rainbow-identifiers-identifier-13 ((,class :foreground ,yellow))) - `(rainbow-identifiers-identifier-14 ((,class :foreground ,blue-alt))) - `(rainbow-identifiers-identifier-15 ((,class :foreground ,red-alt))) ;;;;; rainbow-delimiters `(rainbow-delimiters-base-error-face ((,class :background ,red-subtle-bg :foreground ,fg-main))) `(rainbow-delimiters-base-face ((,class :foreground ,fg-main))) @@ -6962,16 +6778,19 @@ by virtue of calling either of `modus-themes-load-operandi' and `(rainbow-delimiters-mismatched-face ((,class :inherit (bold modus-themes-refine-yellow)))) `(rainbow-delimiters-unmatched-face ((,class :inherit (bold modus-themes-refine-red)))) ;;;;; rcirc - `(rcirc-bright-nick ((,class :inherit bold :foreground ,magenta-alt))) + `(rcirc-bright-nick ((,class :inherit bold :foreground ,magenta-intense))) `(rcirc-dim-nick ((,class :inherit shadow))) + `(rcirc-monospace-text ((,class :inherit fixed-pitch))) `(rcirc-my-nick ((,class :inherit bold :foreground ,magenta))) - `(rcirc-nick-in-message ((,class :foreground ,magenta-alt-other))) - `(rcirc-nick-in-message-full-line ((,class :inherit bold :foreground ,fg-special-mild))) - `(rcirc-other-nick ((,class :inherit bold :foreground ,fg-special-cold))) + `(rcirc-nick-in-message ((,class :inherit bold :foreground ,red-alt))) + `(rcirc-nick-in-message-full-line ((,class :inherit bold :foreground ,cyan-alt-other))) + `(rcirc-other-nick ((,class :inherit bold :foreground ,blue))) `(rcirc-prompt ((,class :inherit modus-themes-prompt))) - `(rcirc-server ((,class :foreground ,fg-unfocused))) - `(rcirc-timestamp ((,class :foreground ,blue-nuanced-fg))) - `(rcirc-url ((,class :foreground ,blue :underline t))) + `(rcirc-server ((,class :inherit shadow))) + `(rcirc-timestamp ((,class :foreground ,cyan))) + `(rcirc-track-keyword ((,class :inherit bold))) + `(rcirc-track-nick ((,class :inherit bold :foreground ,red-active))) + `(rcirc-url ((,class :inherit link))) ;;;;; recursion-indicator `(recursion-indicator-general ((,class :foreground ,blue-active))) `(recursion-indicator-minibuffer ((,class :foreground ,red-active))) @@ -7014,57 +6833,13 @@ by virtue of calling either of `modus-themes-load-operandi' and `(ruler-mode-margins ((,class :inherit ruler-mode-default :foreground ,bg-main))) `(ruler-mode-pad ((,class :inherit ruler-mode-default :background ,bg-active :foreground ,fg-inactive))) `(ruler-mode-tab-stop ((,class :inherit ruler-mode-default :foreground ,fg-special-warm))) -;;;;; sallet - `(sallet-buffer-compressed ((,class :inherit italic :foreground ,yellow-nuanced-fg))) - `(sallet-buffer-default-directory ((,class :foreground ,cyan-nuanced-fg))) - `(sallet-buffer-directory ((,class :foreground ,blue-nuanced-fg))) - `(sallet-buffer-help ((,class :foreground ,fg-special-cold))) - `(sallet-buffer-modified ((,class :inherit italic :foreground ,yellow-alt-other))) - `(sallet-buffer-ordinary ((,class :foreground ,fg-main))) - `(sallet-buffer-read-only ((,class :foreground ,yellow-alt))) - `(sallet-buffer-size ((,class :foreground ,fg-special-calm))) - `(sallet-buffer-special ((,class :foreground ,magenta-alt-other))) - `(sallet-flx-match ((,class ,@(modus-themes--extra-completions - 'modus-themes-subtle-cyan - 'modus-themes-refine-cyan - 'modus-themes-nuanced-cyan - cyan-alt-other)))) - `(sallet-recentf-buffer-name ((,class :foreground ,blue-nuanced-fg))) - `(sallet-recentf-file-path ((,class :foreground ,fg-special-mild))) - `(sallet-regexp-match ((,class ,@(modus-themes--extra-completions - 'modus-themes-subtle-magenta - 'modus-themes-refine-magenta - 'modus-themes-nuanced-magenta - magenta-alt-other)))) - `(sallet-source-header ((,class :inherit bold :foreground ,red-alt - ,@(modus-themes--scale modus-themes-scale-4)))) - `(sallet-substring-match ((,class ,@(modus-themes--extra-completions - 'modus-themes-subtle-blue - 'modus-themes-refine-blue - 'modus-themes-nuanced-blue - blue-alt-other)))) ;;;;; selectrum - ;; NOTE 2021-02-22: The `selectrum-primary-highlight' and - ;; `selectrum-secondary-highlight' are deprecated upstream in favour - ;; of their selectrum-prescient counterparts. We shall remove those - ;; faces from the themes once we are certain that they are no longer - ;; relevant. `(selectrum-current-candidate ((,class :inherit bold :foreground ,fg-main :background ,@(pcase modus-themes-completions ('opinionated (list bg-active)) (_ (list bg-inactive)))))) `(selectrum-mouse-highlight ((,class :inherit highlight))) - `(selectrum-primary-highlight - ((,class :inherit bold - ,@(modus-themes--standard-completions - magenta-alt magenta-nuanced-bg - magenta-refine-bg magenta-refine-fg)))) - `(selectrum-secondary-highlight - ((,class :inherit bold - ,@(modus-themes--standard-completions - cyan-alt-other cyan-nuanced-bg - cyan-refine-bg cyan-refine-fg)))) `(selectrum-quick-keys-highlight ((,class :inherit modus-themes-refine-red))) `(selectrum-quick-keys-match @@ -7201,14 +6976,9 @@ by virtue of calling either of `modus-themes-load-operandi' and `(speedbar-selected-face ((,class :inherit bold :foreground ,cyan))) `(speedbar-separator-face ((,class :inherit modus-themes-intense-neutral))) `(speedbar-tag-face ((,class :foreground ,yellow-alt-other))) -;;;;; spell-fu - `(spell-fu-incorrect-face ((,class :inherit modus-themes-lang-error))) -;;;;; spray - `(spray-accent-face ((,class :foreground ,red-intense))) - `(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))) @@ -7223,14 +6993,6 @@ by virtue of calling either of `modus-themes-load-operandi' and `(swiper-match-face-2 ((,class :inherit (bold modus-themes-intense-green)))) `(swiper-match-face-3 ((,class :inherit (bold modus-themes-intense-blue)))) `(swiper-match-face-4 ((,class :inherit (bold modus-themes-intense-red)))) -;;;;; swoop - `(swoop-face-header-format-line ((,class :inherit bold :foreground ,red-alt - ,@(modus-themes--scale modus-themes-scale-3)))) - `(swoop-face-line-buffer-name ((,class :inherit bold :foreground ,blue-alt - ,@(modus-themes--scale modus-themes-scale-4)))) - `(swoop-face-line-number ((,class :foreground ,fg-special-warm))) - `(swoop-face-target-line ((,class :inherit modus-themes-intense-blue :extend t))) - `(swoop-face-target-words ((,class :inherit modus-themes-refine-cyan))) ;;;;; sx `(sx-inbox-item-type ((,class :foreground ,magenta-alt-other))) `(sx-inbox-item-type-unread ((,class :inherit (sx-inbox-item-type bold)))) @@ -7255,7 +7017,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))) @@ -7280,30 +7042,29 @@ by virtue of calling either of `modus-themes-load-operandi' and `(syslog-su ((,class :inherit bold :foreground ,red-alt))) `(syslog-warn ((,class :inherit bold :foreground ,yellow))) ;;;;; tab-bar-groups - `(tab-bar-groups-tab-1 ((,class ,@(modus-themes--variable-pitch-ui) :foreground ,blue-tab))) - `(tab-bar-groups-tab-2 ((,class ,@(modus-themes--variable-pitch-ui) :foreground ,red-tab))) - `(tab-bar-groups-tab-3 ((,class ,@(modus-themes--variable-pitch-ui) :foreground ,green-tab))) - `(tab-bar-groups-tab-4 ((,class ,@(modus-themes--variable-pitch-ui) :foreground ,orange-tab))) - `(tab-bar-groups-tab-5 ((,class ,@(modus-themes--variable-pitch-ui) :foreground ,purple-tab))) - `(tab-bar-groups-tab-6 ((,class ,@(modus-themes--variable-pitch-ui) :foreground ,cyan-tab))) - `(tab-bar-groups-tab-7 ((,class ,@(modus-themes--variable-pitch-ui) :foreground ,yellow-tab))) - `(tab-bar-groups-tab-8 ((,class ,@(modus-themes--variable-pitch-ui) :foreground ,magenta-tab))) + `(tab-bar-groups-tab-1 ((,class :inherit modus-themes-ui-variable-pitch :foreground ,blue-tab))) + `(tab-bar-groups-tab-2 ((,class :inherit modus-themes-ui-variable-pitch :foreground ,red-tab))) + `(tab-bar-groups-tab-3 ((,class :inherit modus-themes-ui-variable-pitch :foreground ,green-tab))) + `(tab-bar-groups-tab-4 ((,class :inherit modus-themes-ui-variable-pitch :foreground ,orange-tab))) + `(tab-bar-groups-tab-5 ((,class :inherit modus-themes-ui-variable-pitch :foreground ,purple-tab))) + `(tab-bar-groups-tab-6 ((,class :inherit modus-themes-ui-variable-pitch :foreground ,cyan-tab))) + `(tab-bar-groups-tab-7 ((,class :inherit modus-themes-ui-variable-pitch :foreground ,yellow-tab))) + `(tab-bar-groups-tab-8 ((,class :inherit modus-themes-ui-variable-pitch :foreground ,magenta-tab))) ;;;;; tab-bar-mode - `(tab-bar ((,class ,@(modus-themes--tab bg-active bg-active-accent nil nil nil nil t)))) + `(tab-bar ((,class :inherit modus-themes-tab-backdrop))) `(tab-bar-tab-group-current ((,class ,@(modus-themes--tab bg-tab-active) :box (:line-width (2 . -2) :color "gray50")))) `(tab-bar-tab-group-inactive ((,class ,@(modus-themes--tab bg-tab-inactive bg-tab-inactive-accent fg-dim) :box (:line-width (2 . -2) :color "gray50")))) - `(tab-bar-tab ((,class ,@(modus-themes--tab bg-tab-active nil nil nil t t)))) - `(tab-bar-tab-inactive ((,class ,@(modus-themes--tab bg-tab-inactive bg-tab-inactive-accent fg-dim nil t)))) + `(tab-bar-tab ((,class :inherit modus-themes-tab-active))) + `(tab-bar-tab-inactive ((,class :inherit modus-themes-tab-inactive))) ;;;;; tab-line-mode - `(tab-line ((,class ,@(modus-themes--tab bg-active bg-active-accent nil nil nil nil t) - :height 0.95))) + `(tab-line ((,class :inherit modus-themes-tab-backdrop :height 0.95))) `(tab-line-close-highlight ((,class :foreground ,red))) `(tab-line-highlight ((,class :inherit modus-themes-active-blue))) - `(tab-line-tab ((,class ,@(modus-themes--tab bg-tab-active nil nil nil t t)))) + `(tab-line-tab ((,class :inherit modus-themes-tab-active))) `(tab-line-tab-current ((,class :inherit tab-line-tab))) - `(tab-line-tab-inactive ((,class ,@(modus-themes--tab bg-tab-inactive bg-tab-inactive-accent fg-dim nil t)))) + `(tab-line-tab-inactive ((,class :inherit modus-themes-tab-inactive))) `(tab-line-tab-inactive-alternate ((,class ,@(modus-themes--tab bg-tab-inactive-alt bg-tab-inactive-alt-accent fg-main nil t)))) `(tab-line-tab-modified ((,class :foreground ,red-alt-other-faint))) @@ -7318,9 +7079,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 +7090,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))) @@ -7377,16 +7138,11 @@ by virtue of calling either of `modus-themes-load-operandi' and `(transient-argument ((,class :inherit bold :foreground ,green))) `(transient-blue ((,class :inherit bold :foreground ,blue))) `(transient-disabled-suffix ((,class :inherit modus-themes-intense-red))) - `(transient-enabled-suffix ((,class :inherit ,@(modus-themes--success-deuteran - 'modus-themes-subtle-blue - 'modus-themes-subtle-green)))) + `(transient-enabled-suffix ((,class :inherit modus-themes-grue-background-subtle))) `(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))) @@ -7401,34 +7157,29 @@ by virtue of calling either of `modus-themes-load-operandi' and `(trashed-mark ((,class :inherit modus-themes-mark-symbol))) `(trashed-marked ((,class :inherit modus-themes-mark-alt))) `(trashed-restored ((,class :inherit modus-themes-mark-sel))) - `(trashed-symlink ((,class :inherit button - ,@(modus-themes--link-color - cyan-alt cyan-alt-faint)))) + `(trashed-symlink ((,class :inherit modus-themes-link-symlink))) ;;;;; treemacs `(treemacs-directory-collapsed-face ((,class :foreground ,magenta-alt))) `(treemacs-directory-face ((,class :inherit dired-directory))) `(treemacs-file-face ((,class :foreground ,fg-main))) `(treemacs-fringe-indicator-face ((,class :foreground ,fg-main))) - `(treemacs-git-added-face ((,class :foreground ,green-intense))) - `(treemacs-git-conflict-face ((,class :inherit (modus-themes-intense-red bold)))) + `(treemacs-git-added-face ((,class :inherit success))) + `(treemacs-git-conflict-face ((,class :inherit error))) `(treemacs-git-ignored-face ((,class :inherit shadow))) - `(treemacs-git-modified-face ((,class :foreground ,yellow-alt-other))) - `(treemacs-git-renamed-face ((,class :foreground ,cyan-alt-other))) + `(treemacs-git-modified-face ((,class :inherit warning))) + `(treemacs-git-renamed-face ((,class :inherit italic))) `(treemacs-git-unmodified-face ((,class :foreground ,fg-main))) - `(treemacs-git-untracked-face ((,class :foreground ,red-alt-other))) + `(treemacs-git-untracked-face ((,class :inherit shadow))) `(treemacs-help-column-face ((,class :inherit modus-themes-bold :foreground ,magenta-alt-other :underline t))) `(treemacs-help-title-face ((,class :foreground ,blue-alt-other))) `(treemacs-on-failure-pulse-face ((,class :inherit modus-themes-intense-red))) - `(treemacs-on-success-pulse-face ((,class :inherit ,@(modus-themes--success-deuteran - 'modus-themes-intense-blue - 'modus-themes-intense-green)))) + `(treemacs-on-success-pulse-face ((,class :inherit modus-themes-grue-background-intense))) `(treemacs-root-face ((,class :inherit bold :foreground ,blue-alt-other :height 1.2 :underline t))) `(treemacs-root-remote-disconnected-face ((,class :inherit treemacs-root-remote-face :foreground ,yellow))) `(treemacs-root-remote-face ((,class :inherit treemacs-root-face :foreground ,magenta))) `(treemacs-root-remote-unreadable-face ((,class :inherit treemacs-root-unreadable-face))) `(treemacs-root-unreadable-face ((,class :inherit treemacs-root-face :strike-through t))) `(treemacs-tags-face ((,class :foreground ,blue-alt))) - `(treemacs-tags-face ((,class :foreground ,magenta-alt))) ;;;;; tty-menu `(tty-menu-disabled-face ((,class :background ,bg-alt :foreground ,fg-alt))) `(tty-menu-enabled-face ((,class :inherit bold :background ,bg-alt :foreground ,fg-main))) @@ -7473,10 +7224,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))) @@ -7485,19 +7236,14 @@ by virtue of calling either of `modus-themes-load-operandi' and `(vc-removed-state ((,class :foreground ,red-active))) `(vc-state-base ((,class :foreground ,fg-active))) `(vc-up-to-date-state ((,class :foreground ,fg-special-cold))) -;;;;; vdiff - `(vdiff-addition-face ((,class :inherit modus-themes-diff-added))) - `(vdiff-change-face ((,class :inherit modus-themes-diff-changed))) - `(vdiff-closed-fold-face ((,class :inherit modus-themes-diff-heading))) - `(vdiff-refine-added ((,class :inherit modus-themes-diff-refine-added))) - `(vdiff-refine-changed ((,class :inherit modus-themes-diff-refine-changed))) - `(vdiff-subtraction-face ((,class :inherit modus-themes-diff-removed))) - `(vdiff-target-face ((,class :inherit modus-themes-intense-blue))) ;;;;; vertico `(vertico-current ((,class :inherit bold :foreground ,fg-main :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))) @@ -7515,8 +7261,6 @@ by virtue of calling either of `modus-themes-load-operandi' and `(vr/match-0 ((,class :inherit modus-themes-refine-yellow))) `(vr/match-1 ((,class :inherit modus-themes-refine-yellow))) `(vr/match-separator-face ((,class :inherit (modus-themes-intense-neutral bold)))) -;;;;; volatile-highlights - `(vhl/default-face ((,class :background ,bg-alt :foreground ,blue-nuanced-fg :extend t))) ;;;;; vterm `(vterm-color-black ((,class :background "gray35" :foreground "gray35"))) `(vterm-color-blue ((,class :background ,blue :foreground ,blue))) @@ -7606,11 +7350,11 @@ by virtue of calling either of `modus-themes-load-operandi' and `(web-mode-warning-face ((,class :inherit font-lock-warning-face))) `(web-mode-whitespace-face ((,class :background ,bg-whitespace :foreground ,fg-whitespace))) ;;;;; wgrep - `(wgrep-delete-face ((,class :inherit modus-themes-refine-yellow))) - `(wgrep-done-face ((,class :inherit modus-themes-refine-blue))) - `(wgrep-face ((,class :inherit modus-themes-refine-green))) + `(wgrep-delete-face ((,class :inherit warning))) + `(wgrep-done-face ((,class :inherit success))) + `(wgrep-face ((,class :inherit bold))) `(wgrep-file-face ((,class :foreground ,fg-special-warm))) - `(wgrep-reject-face ((,class :inherit (modus-themes-intense-red bold)))) + `(wgrep-reject-face ((,class :inherit error))) ;;;;; which-function-mode `(which-func ((,class :foreground ,magenta-active))) ;;;;; which-key @@ -7666,7 +7410,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(ztreep-arrow-face ((,class :foreground ,fg-inactive))) `(ztreep-diff-header-face ((,class :inherit bold :height 1.2 :foreground ,fg-special-cold))) `(ztreep-diff-header-small-face ((,class :foreground ,fg-main))) - `(ztreep-diff-model-add-face ((,class :foreground ,@(modus-themes--diff-deuteran blue green)))) + `(ztreep-diff-model-add-face ((,class :inherit modus-themes-grue))) `(ztreep-diff-model-diff-face ((,class :foreground ,red))) `(ztreep-diff-model-ignored-face ((,class :inherit shadow :strike-through t))) `(ztreep-diff-model-normal-face ((,class :inherit shadow))) @@ -7696,10 +7440,6 @@ by virtue of calling either of `modus-themes-load-operandi' and `(ibuffer-filter-group-name-face 'modus-themes-pseudo-header) `(ibuffer-marked-face 'modus-themes-mark-sel) `(ibuffer-title-face 'default) -;;;; highlight-tail - `(highlight-tail-colors - '((,green-subtle-bg . 0) - (,cyan-subtle-bg . 20))) ;;;; hl-todo `(hl-todo-keyword-faces '(("HOLD" . ,yellow-alt) diff --git a/etc/themes/modus-vivendi-theme.el b/etc/themes/modus-vivendi-theme.el index 919009278b1..1c05c53185f 100644 --- a/etc/themes/modus-vivendi-theme.el +++ b/etc/themes/modus-vivendi-theme.el @@ -4,24 +4,24 @@ ;; Author: Protesilaos Stavrou <info@protesilaos.com> ;; URL: https://gitlab.com/protesilaos/modus-themes -;; Version: 1.6.0 -;; Package-Requires: ((emacs "26.1")) +;; Version: 2.0.0 +;; Package-Requires: ((emacs "27.1")) ;; Keywords: faces, theme, accessibility ;; This file is part of GNU Emacs. -;; This program is free software; you can redistribute it and/or modify +;; 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. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: ;; diff --git a/etc/themes/whiteboard-theme.el b/etc/themes/whiteboard-theme.el index 729c082a331..9cf8e7dfc93 100644 --- a/etc/themes/whiteboard-theme.el +++ b/etc/themes/whiteboard-theme.el @@ -63,6 +63,8 @@ `(ido-first-match ((,class (:weight normal :foreground "DarkOrange3")))) `(ido-only-match ((,class (:foreground "SeaGreen4")))) `(ido-subdir ((,class (:foreground nil :inherit font-lock-keyword-face)))) + `(image-dired-thumb-flagged ((,class :background "Red1"))) + `(image-dired-thumb-mark ((,class :background "dodgerblue3"))) `(info-header-node ((,class (:foreground "DeepSkyBlue1")))) `(info-header-xref ((,class (:foreground "SeaGreen2")))) `(info-menu-header ((,class (:family "helv" :weight bold)))) diff --git a/etc/tutorials/TUTORIAL b/etc/tutorials/TUTORIAL index dcdb61f23ec..c5f2e684c42 100644 --- a/etc/tutorials/TUTORIAL +++ b/etc/tutorials/TUTORIAL @@ -304,8 +304,8 @@ position, type <DEL>. This is the key on the keyboard usually labeled "Backspace"--the same one you normally use, outside Emacs, to delete the last character typed. -There may also be another key on your keyboard labeled <Delete>, but -that's not the one we refer to as <DEL>. +There is usually another key on your keyboard labeled <Delete>, but +that's not the one we refer to as <DEL> in Emacs. >> Do this now--type a few characters, then delete them by typing <DEL> a few times. Don't worry about this file @@ -1099,6 +1099,20 @@ manual in the node called "Dired". The manual also describes many other Emacs features. +* INSTALLING PACKAGES +--------------------- + +There's a rich set of packages for Emacs written by the community, +which extend Emacs' capabilities. These packages include support for +new languages, additional themes, plugins for integrating with +external applications, and much, much more. + +To see a list of all available packages, type M-x list-packages. In +the display this shows, you can install or uninstall packages, as well +as read packages' descriptions. For more information about package +management, consult the manual. + + * CONCLUSION ------------ diff --git a/etc/tutorials/TUTORIAL.he b/etc/tutorials/TUTORIAL.he index 2ee4f74c324..fc4b769599e 100644 --- a/etc/tutorials/TUTORIAL.he +++ b/etc/tutorials/TUTORIAL.he @@ -1,4 +1,4 @@ -שיעור ראשון בשימוש ב־Emacs. זכויות שימוש ראה בסוף המסמך. +שיעור ראשון בשימוש ב־Emacs. זכויות שימוש ראה בסוף המסמך. פקודות רבות של Emacs משתמשות במקש CONTROL (בדרך־כלל מסומן ב־CTRL) או במקש META (בדרך־כלל מסומן ALT). במקום לציין את כל השמות האפשריים @@ -24,7 +24,7 @@ שימו לב לחפיפה של שתי שורות כאשר אתם עוברים ממסך למסך, מה שמבטיח רציפות מסוימת בעת קריאת הטקסט. -הטקסט שלפניכם הינו עותק של שיעור בשימוש ב־Emacs שהותאם קלות עבורכם. +הטקסט שלפניכם הינו עותק של שיעור בשימוש ב־Emacs שהותאם קלות עבורכם. בהמשך תקבלו הוראות לנסות פקודות שונות כדי לבצע שינויים בטקסט הזה. אם במקרה תשנו את הטקסט לפני שנבקש, אל דאגה: זוהי "עריכה" שהיא יעודו של Emacs. @@ -985,6 +985,17 @@ find-file. בנוסף, מדריך למשתמש מתאר עוד הרבה מאד תכונות של Emacs. +* התקנת חבילות הרחבה +-------------------- +קיימות לא מעט חבילות תוכנה עבור Emacs אשר מרחיבות את היכולות שלו. חבילות +הרחבה אלו נכתבו ע״י קהילת משתמשי Emacs והן מהוות אוסף עשיר של תכונות +התומכות בשפות תכנות נוספות, ערכות נושא נוספות, תוספים לשילוב יישומים +חיצוניים, ועוד ועוד. + +לצפיה ברשימת חבילות ההרחבה הזמינות, יש להקיש M-x list-packages. בתצוגה +שתיפתח בעקבות זאת תוכלו לעיין בתיאור של חבילות, לבחור חבילות להתקנה במחשב +שלכם, להסיר חבילות, ועוד. פרטים נוספים לגבי ניהול חבילות הרחבה ניתן למצוא +במדריך למשתמש. * לסיום ------- diff --git a/etc/tutorials/TUTORIAL.it b/etc/tutorials/TUTORIAL.it index cd5c6de9db5..aa2fb4560a7 100644 --- a/etc/tutorials/TUTORIAL.it +++ b/etc/tutorials/TUTORIAL.it @@ -1178,6 +1178,19 @@ quei file. Dired è descritta nel manuale Emacs nel nodo chiamato Il manuale descrive molte altre funzionalità di Emacs. +* INSTALLAZIONE DI ULTERIORI PACCHETTI + +Ci sono tantissimi pacchetti che estendono le funzionalità di Emacs, +scritti dalla comunità. Questi pacchetti includono il supporto a +nuovi linguaggi, aggiungono temi addizionali, rendono possibile +interoperare con applicazioni esterne e molto, molto altro. + +Per vedere una lista di tutti i pacchetti disponibili, inserisci +M-x list-packages. Nell'elenco che viene mostrato, puoi installare o +disinstallare pacchetti, o leggerne la descrizione. Consulta il +manuale per ulteriori informazioni sulla gestione dei pacchetti. + + * CONCLUSIONI ------------- diff --git a/etc/tutorials/TUTORIAL.sv b/etc/tutorials/TUTORIAL.sv index dacc66d916f..5c9703f8066 100644 --- a/etc/tutorials/TUTORIAL.sv +++ b/etc/tutorials/TUTORIAL.sv @@ -1119,6 +1119,20 @@ Emacs-manualen i noden "Dired". Manualen beskriver även många andra funktioner i Emacs. +* INSTALLERA PAKET +------------------ + +Det finns en stor mängd paket för Emacs skrivna av användare, som +utökar Emacs funktionalitet. Detta kan innefatta stöd för nya språk, +fler teman, insticksmoduler för integration med externa program och +mycket, mycket annat. + +Skriv M-x list-packages för att se en lista över alla tillgängliga +paket. I detta läge kan du installera eller avinstallera paket samt +läsa mer om olika paket. Se användarmanualen för mer information om +pakethantering. + + * SLUTORD --------- diff --git a/leim/SKK-DIC/SKK-JISYO.L b/leim/SKK-DIC/SKK-JISYO.L index f1e06ccfca1..2d4f6198984 100644 --- a/leim/SKK-DIC/SKK-JISYO.L +++ b/leim/SKK-DIC/SKK-JISYO.L @@ -143454,7 +143454,7 @@ zyklus /륹/ĥ륹/ Ϥä /ȯDz/ Ϥä /ȯ/ Ϥä /ȯϩ/ -Ϥä /ȯΩ/ +Ϥä /ȯΨ/ Ϥä /ȯս/ Ϥä /ȯֳ/ Ϥä /ȯ/ diff --git a/lib-src/Makefile.in b/lib-src/Makefile.in index f5d9db932ab..835b6016541 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. @@ -232,6 +243,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 \ @@ -240,6 +255,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 @@ -279,8 +297,8 @@ maybe-blessmail: $(BLESSMAIL_TARGET) ## up if chown or chgrp fails, as the package responsible for ## installing Emacs can fix this problem later. $(DESTDIR)${archlibdir}: all - @echo - @echo "Installing utilities run internally by Emacs." + $(info $ ) + $(info Installing utilities run internally by Emacs.) umask 022 && ${MKDIR_P} "$(DESTDIR)${archlibdir}" exp_archlibdir=`cd "$(DESTDIR)${archlibdir}" && /bin/pwd` && \ if [ "$$exp_archlibdir" != "`/bin/pwd`" ]; then \ @@ -321,8 +339,8 @@ $(DESTDIR)${archlibdir}: all .PHONY: bootstrap-clean check tags install: $(DESTDIR)${archlibdir} - @echo - @echo "Installing utilities for users to run." + $(info $ ) + $(info Installing utilities for users to run.) umask 022 && ${MKDIR_P} "$(DESTDIR)${bindir}" for file in ${INSTALLABLES} ; do \ $(INSTALL_PROGRAM) $(INSTALL_STRIP) $${file} \ @@ -357,7 +375,7 @@ bootstrap-clean maintainer-clean: distclean ## Test the contents of the directory. check: - @echo "We don't have any tests for the lib-src/ directory yet." + $(info We don't have any tests for the lib-src/ directory yet.) tagsfiles = $(wildcard ${srcdir}/*.[ch]) @@ -409,6 +427,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 <https://www.gnu.org/licenses/>. */ + +#include <config.h> + +#include <cstdio> +#include <cstring> +#include <cstdlib> + +#include <SupportDefs.h> +#include <Path.h> +#include <AppFileInfo.h> +#include <TranslationUtils.h> +#include <Application.h> +#include <Catalog.h> +#include <Roster.h> + +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 d11fd88c45e..7769e015edc 100644 --- a/lib-src/emacsclient.c +++ b/lib-src/emacsclient.c @@ -116,6 +116,9 @@ static bool eval; /* True means open a new frame. --create-frame etc. */ static bool create_frame; +/* True means reuse a frame if it already exists. */ +static bool reuse_frame; + /* The display on which Emacs should work. --display. */ static char const *display; @@ -165,6 +168,7 @@ static struct option const longopts[] = { "tty", no_argument, NULL, 't' }, { "nw", no_argument, NULL, 't' }, { "create-frame", no_argument, NULL, 'c' }, + { "reuse-frame", no_argument, NULL, 'r' }, { "alternate-editor", required_argument, NULL, 'a' }, { "frame-parameters", required_argument, NULL, 'F' }, #ifdef SOCKETS_IN_FILE_SYSTEM @@ -551,6 +555,11 @@ decode_options (int argc, char **argv) create_frame = true; break; + case 'r': + create_frame = true; + reuse_frame = true; + break; + case 'p': parent_id = optarg; create_frame = true; @@ -594,9 +603,16 @@ 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 + display = egetenv ("WAYLAND_DISPLAY"); + alt_display = egetenv ("DISPLAY"); +#else display = egetenv ("DISPLAY"); +#endif } if (!display) @@ -647,6 +663,8 @@ The following OPTIONS are accepted:\n\ -nw, -t, --tty Open a new Emacs frame on the current terminal\n\ -c, --create-frame Create a new frame instead of trying to\n\ use the current Emacs frame\n\ +-r, --reuse-frame Create a new frame if none exists, otherwise\n\ + use the current Emacs frame\n\ ", "\ -F ALIST, --frame-parameters=ALIST\n\ Set the parameters of a new frame\n\ @@ -1744,8 +1762,9 @@ start_daemon_and_retry_set_socket (void) } /* Try connecting, the daemon should have started by now. */ - message (true, - "Emacs daemon should have started, trying to connect again\n"); + if (!quiet) + message (true, + "Emacs daemon should have started, trying to connect again\n"); } else if (dpid < 0) { @@ -1836,7 +1855,7 @@ start_daemon_and_retry_set_socket (void) /* Try connecting, the daemon should have started by now. */ /* It's just a progress message, so don't pop a dialog if this is emacsclientw. */ - if (!w32_window_app ()) + if (!quiet && !w32_window_app ()) message (true, "Emacs daemon should have started, trying to connect again\n"); #endif /* WINDOWSNT */ @@ -1940,7 +1959,7 @@ main (int argc, char **argv) if (nowait) send_to_emacs (emacs_socket, "-nowait "); - if (!create_frame) + if (!create_frame || reuse_frame) send_to_emacs (emacs_socket, "-current-frame "); if (display) diff --git a/lib-src/etags.c b/lib-src/etags.c index bd4d4fcf53a..71f3464661c 100644 --- a/lib-src/etags.c +++ b/lib-src/etags.c @@ -5773,7 +5773,7 @@ static void TEX_decode_env (const char *evarname, const char *defenv) { const char *env, *p; - ptrdiff_t len; + ptrdiff_t len = 1; /* Append default string to environment. */ env = getenv (evarname); @@ -5782,8 +5782,13 @@ TEX_decode_env (const char *evarname, const char *defenv) else env = concat (env, defenv, ""); + /* If the environment variable doesn't start with a colon, increase + the length of the token table. */ + if (*env != ':') + len++; + /* Allocate a token table */ - for (len = 1, p = env; (p = strchr (p, ':')); ) + for (p = env; (p = strchr (p, ':')); ) if (*++p) len++; TEX_toktab = xnew (len, linebuffer); diff --git a/lib-src/make-docfile.c b/lib-src/make-docfile.c index d17c28be90b..913aa69aacc 100644 --- a/lib-src/make-docfile.c +++ b/lib-src/make-docfile.c @@ -19,8 +19,8 @@ You should have received a copy of the GNU General Public License along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ -/* The arguments given to this program are all the C and Lisp source files - of GNU Emacs. .elc and .el and .c files are allowed. +/* The arguments given to this program are all the C files + of GNU Emacs. .c files are allowed. A .o file can also be specified; the .c file it was made from is used. This helps the makefile pass the correct list of files. Option -d DIR means change to DIR before looking for files. @@ -62,13 +62,9 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ Similarly, msdos defines this as sys_chdir, but we're not linking with the file where that function is defined. */ #undef chdir -#define IS_SLASH(c) ((c) == '/' || (c) == '\\' || (c) == ':') -#else /* not DOS_NT */ -#define IS_SLASH(c) ((c) == '/') #endif /* not DOS_NT */ static void scan_file (char *filename); -static void scan_lisp_file (const char *filename, const char *mode); static void scan_c_file (char *filename, const char *mode); static void scan_c_stream (FILE *infile); static void start_globals (void); @@ -238,16 +234,9 @@ put_filename (char *filename) static void scan_file (char *filename) { - ptrdiff_t len = strlen (filename); - if (!generate_globals) put_filename (filename); - if (len > 4 && !strcmp (filename + len - 4, ".elc")) - scan_lisp_file (filename, "rb"); - else if (len > 3 && !strcmp (filename + len - 3, ".el")) - scan_lisp_file (filename, "r"); - else - scan_c_file (filename, "r"); + scan_c_file (filename, "r"); } static void @@ -1225,453 +1214,4 @@ scan_c_stream (FILE *infile) fatal ("read error"); } -/* Read a file of Lisp code, compiled or interpreted. - Looks for - (defun NAME ARGS DOCSTRING ...) - (defmacro NAME ARGS DOCSTRING ...) - (defsubst NAME ARGS DOCSTRING ...) - (autoload (quote NAME) FILE DOCSTRING ...) - (defvar NAME VALUE DOCSTRING) - (defconst NAME VALUE DOCSTRING) - (fset (quote NAME) (make-byte-code ... DOCSTRING ...)) - (fset (quote NAME) #[... DOCSTRING ...]) - (defalias (quote NAME) #[... DOCSTRING ...]) - (custom-declare-variable (quote NAME) VALUE DOCSTRING ...) - starting in column zero. - (quote NAME) may appear as 'NAME as well. - - We also look for #@LENGTH CONTENTS^_ at the beginning of the line. - When we find that, we save it for the following defining-form, - and we use that instead of reading a doc string within that defining-form. - - For defvar, defconst, and fset we skip to the docstring with a kludgy - formatting convention: all docstrings must appear on the same line as the - initial open-paren (the one in column zero) and must contain a backslash - and a newline immediately after the initial double-quote. No newlines - must appear between the beginning of the form and the first double-quote. - For defun, defmacro, and autoload, we know how to skip over the - arglist, but the doc string must still have a backslash and newline - immediately after the double quote. - The only source files that must follow this convention are preloaded - uncompiled ones like loaddefs.el; aside from that, it is always the .elc - file that we should look at, and they are no problem because byte-compiler - output follows this convention. - The NAME and DOCSTRING are output. - NAME is preceded by `F' for a function or `V' for a variable. - An entry is output only if DOCSTRING has \ newline just after the opening ". - */ - -static void -skip_white (FILE *infile) -{ - int c; - do - c = getc (infile); - while (c_isspace (c)); - - ungetc (c, infile); -} - -static void -read_lisp_symbol (FILE *infile, char *buffer) -{ - int c; - char *fillp = buffer; - - skip_white (infile); - while (true) - { - c = getc (infile); - if (c == '\\') - { - c = getc (infile); - if (c < 0) - return; - *fillp++ = c; - } - else if (c_isspace (c) || c == '(' || c == ')' || c < 0) - { - ungetc (c, infile); - *fillp = 0; - break; - } - else - *fillp++ = c; - } - - if (! buffer[0]) - fprintf (stderr, "## expected a symbol, got '%c'\n", c); - - skip_white (infile); -} - -static bool -search_lisp_doc_at_eol (FILE *infile) -{ - int c = 0, c1 = 0, c2 = 0; - - /* Skip until the end of line; remember two previous chars. */ - while (c != '\n' && c != '\r' && c != EOF) - { - c2 = c1; - c1 = c; - c = getc (infile); - } - - /* If two previous characters were " and \, - this is a doc string. Otherwise, there is none. */ - if (c2 != '"' || c1 != '\\') - { -#ifdef DEBUG - fprintf (stderr, "## non-docstring found\n"); -#endif - ungetc (c, infile); - return false; - } - return true; -} - -#define DEF_ELISP_FILE(fn) { #fn, sizeof(#fn) - 1 } - -static void -scan_lisp_file (const char *filename, const char *mode) -{ - FILE *infile; - int c; - char *saved_string = 0; - /* These are the only files that are loaded uncompiled, and must - follow the conventions of the doc strings expected by this - function. These conventions are automatically followed by the - byte compiler when it produces the .elc files. */ - static struct { - const char *fn; - int fl; - } const uncompiled[] = { - DEF_ELISP_FILE (loaddefs.el), - DEF_ELISP_FILE (loadup.el), - DEF_ELISP_FILE (charprop.el), - DEF_ELISP_FILE (cp51932.el), - DEF_ELISP_FILE (eucjp-ms.el) - }; - int i; - int flen = strlen (filename); - - if (generate_globals) - fatal ("scanning lisp file when -g specified"); - if (flen > 3 && !strcmp (filename + flen - 3, ".el")) - { - bool match = false; - for (i = 0; i < sizeof (uncompiled) / sizeof (uncompiled[0]); i++) - { - if (uncompiled[i].fl <= flen - && !strcmp (filename + flen - uncompiled[i].fl, uncompiled[i].fn) - && (flen == uncompiled[i].fl - || IS_SLASH (filename[flen - uncompiled[i].fl - 1]))) - { - match = true; - break; - } - } - if (!match) - fatal ("uncompiled lisp file %s is not supported", filename); - } - - infile = fopen (filename, mode); - if (infile == NULL) - { - perror (filename); - exit (EXIT_FAILURE); - } - - c = '\n'; - while (!feof (infile)) - { - char buffer[BUFSIZ]; - char type; - - /* If not at end of line, skip till we get to one. */ - if (c != '\n' && c != '\r') - { - c = getc (infile); - continue; - } - /* Skip the line break. */ - while (c == '\n' || c == '\r') - c = getc (infile); - /* Detect a dynamic doc string and save it for the next expression. */ - if (c == '#') - { - c = getc (infile); - if (c == '@') - { - ptrdiff_t length = 0; - ptrdiff_t i; - - /* Read the length. */ - while ((c = getc (infile), - c_isdigit (c))) - { - if (INT_MULTIPLY_WRAPV (length, 10, &length) - || INT_ADD_WRAPV (length, c - '0', &length) - || SIZE_MAX < length) - memory_exhausted (); - } - - if (length <= 1) - fatal ("invalid dynamic doc string length"); - - if (c != ' ') - fatal ("space not found after dynamic doc string length"); - - /* The next character is a space that is counted in the length - but not part of the doc string. - We already read it, so just ignore it. */ - length--; - - /* Read in the contents. */ - free (saved_string); - saved_string = xmalloc (length); - for (i = 0; i < length; i++) - saved_string[i] = getc (infile); - /* The last character is a ^_. - That is needed in the .elc file - but it is redundant in DOC. So get rid of it here. */ - saved_string[length - 1] = 0; - /* Skip the line break. */ - while (c == '\n' || c == '\r') - c = getc (infile); - /* Skip the following line. */ - while (! (c == '\n' || c == '\r' || c < 0)) - c = getc (infile); - } - continue; - } - - if (c != '(') - continue; - - read_lisp_symbol (infile, buffer); - - if (! strcmp (buffer, "defun") - || ! strcmp (buffer, "defmacro") - || ! strcmp (buffer, "defsubst")) - { - type = 'F'; - read_lisp_symbol (infile, buffer); - - /* Skip the arguments: either "nil" or a list in parens. */ - - c = getc (infile); - if (c == 'n') /* nil */ - { - if ((c = getc (infile)) != 'i' - || (c = getc (infile)) != 'l') - { - fprintf (stderr, "## unparsable arglist in %s (%s)\n", - buffer, filename); - continue; - } - } - else if (c != '(') - { - fprintf (stderr, "## unparsable arglist in %s (%s)\n", - buffer, filename); - continue; - } - else - while (! (c == ')' || c < 0)) - c = getc (infile); - skip_white (infile); - - /* If the next three characters aren't `dquote bslash newline' - then we're not reading a docstring. - */ - if ((c = getc (infile)) != '"' - || (c = getc (infile)) != '\\' - || ((c = getc (infile)) != '\n' && c != '\r')) - { -#ifdef DEBUG - fprintf (stderr, "## non-docstring in %s (%s)\n", - buffer, filename); -#endif - continue; - } - } - - /* defcustom can only occur in uncompiled Lisp files. */ - else if (! strcmp (buffer, "defvar") - || ! strcmp (buffer, "defconst") - || ! strcmp (buffer, "defcustom")) - { - type = 'V'; - read_lisp_symbol (infile, buffer); - - if (saved_string == 0) - if (!search_lisp_doc_at_eol (infile)) - continue; - } - - else if (! strcmp (buffer, "custom-declare-variable") - || ! strcmp (buffer, "defvaralias") - ) - { - type = 'V'; - - c = getc (infile); - if (c == '\'') - read_lisp_symbol (infile, buffer); - else - { - if (c != '(') - { - fprintf (stderr, - "## unparsable name in custom-declare-variable in %s\n", - filename); - continue; - } - read_lisp_symbol (infile, buffer); - if (strcmp (buffer, "quote")) - { - fprintf (stderr, - "## unparsable name in custom-declare-variable in %s\n", - filename); - continue; - } - read_lisp_symbol (infile, buffer); - c = getc (infile); - if (c != ')') - { - fprintf (stderr, - "## unparsable quoted name in custom-declare-variable in %s\n", - filename); - continue; - } - } - - if (saved_string == 0) - if (!search_lisp_doc_at_eol (infile)) - continue; - } - - else if (! strcmp (buffer, "fset") || ! strcmp (buffer, "defalias")) - { - type = 'F'; - - c = getc (infile); - if (c == '\'') - read_lisp_symbol (infile, buffer); - else - { - if (c != '(') - { - fprintf (stderr, "## unparsable name in fset in %s\n", - filename); - continue; - } - read_lisp_symbol (infile, buffer); - if (strcmp (buffer, "quote")) - { - fprintf (stderr, "## unparsable name in fset in %s\n", - filename); - continue; - } - read_lisp_symbol (infile, buffer); - c = getc (infile); - if (c != ')') - { - fprintf (stderr, - "## unparsable quoted name in fset in %s\n", - filename); - continue; - } - } - - if (saved_string == 0) - if (!search_lisp_doc_at_eol (infile)) - continue; - } - - else if (! strcmp (buffer, "autoload")) - { - type = 'F'; - c = getc (infile); - if (c == '\'') - read_lisp_symbol (infile, buffer); - else - { - if (c != '(') - { - fprintf (stderr, "## unparsable name in autoload in %s\n", - filename); - continue; - } - read_lisp_symbol (infile, buffer); - if (strcmp (buffer, "quote")) - { - fprintf (stderr, "## unparsable name in autoload in %s\n", - filename); - continue; - } - read_lisp_symbol (infile, buffer); - c = getc (infile); - if (c != ')') - { - fprintf (stderr, - "## unparsable quoted name in autoload in %s\n", - filename); - continue; - } - } - skip_white (infile); - c = getc (infile); - if (c != '\"') - { - fprintf (stderr, "## autoload of %s unparsable (%s)\n", - buffer, filename); - continue; - } - read_c_string_or_comment (infile, 0, false, 0); - - if (saved_string == 0) - if (!search_lisp_doc_at_eol (infile)) - continue; - } - -#ifdef DEBUG - else if (! strcmp (buffer, "if") - || ! strcmp (buffer, "byte-code")) - continue; -#endif - - else - { -#ifdef DEBUG - fprintf (stderr, "## unrecognized top-level form, %s (%s)\n", - buffer, filename); -#endif - continue; - } - - /* At this point, we should either use the previous dynamic doc string in - saved_string or gobble a doc string from the input file. - In the latter case, the opening quote (and leading backslash-newline) - have already been read. */ - - printf ("\037%c%s\n", type, buffer); - if (saved_string) - { - fputs (saved_string, stdout); - /* Don't use one dynamic doc string twice. */ - free (saved_string); - saved_string = 0; - } - else - read_c_string_or_comment (infile, 1, false, 0); - } - free (saved_string); - if (ferror (infile) || fclose (infile) != 0) - fatal ("%s: read error", filename); -} - - /* make-docfile.c ends here */ diff --git a/lib-src/ntlib.c b/lib-src/ntlib.c index ccf827cf526..c8bcf742fea 100644 --- a/lib-src/ntlib.c +++ b/lib-src/ntlib.c @@ -20,14 +20,8 @@ GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ -/* Temporary workaround for compilation problems with MinGW64 GCC 11. - The funky #ifdef's are to avoid warnings about unused macros. */ -#define _GL_ATTRIBUTE_MALLOC -#define _GL_ATTRIBUTE_DEALLOC_FREE -#ifdef _GL_ATTRIBUTE_MALLOC -#endif -#ifdef _GL_ATTRIBUTE_DEALLOC_FREE -#endif +#define DEFER_MS_W32_H +#include <config.h> #include <windows.h> #include <stdlib.h> @@ -296,9 +290,6 @@ is_exec (const char * name) stricmp (p, ".cmd") == 0)); } -/* FIXME? This is in configure.ac now - is this still needed? */ -#define IS_DIRECTORY_SEP(x) ((x) == '/' || (x) == '\\') - /* We need stat/fsfat below because nt/inc/sys/stat.h defines struct stat that is incompatible with the MS run-time libraries. */ int diff --git a/lib/Makefile.in b/lib/Makefile.in index ccb90c3d1b3..7fdbf192687 100644 --- a/lib/Makefile.in +++ b/lib/Makefile.in @@ -88,13 +88,13 @@ e-%.o: %.c all: libgnu.a $(if $(HYBRID_MALLOC),libegnu.a) libgnu.a: $(libgnu_a_OBJECTS) - $(AM_V_at)rm -f $@ - $(AM_V_AR)$(AR) $(ARFLAGS) $@ $(libgnu_a_OBJECTS) + $(AM_V_AR)rm -f $@ + $(AM_V_at)$(AR) $(ARFLAGS) $@ $(libgnu_a_OBJECTS) $(AM_V_at)$(RANLIB) $@ libegnu.a: $(libegnu_a_OBJECTS) - $(AM_V_at)rm -f $@ - $(AM_V_AR)$(AR) $(ARFLAGS) $@ $(libegnu_a_OBJECTS) + $(AM_V_AR)rm -f $@ + $(AM_V_at)$(AR) $(ARFLAGS) $@ $(libegnu_a_OBJECTS) $(AM_V_at)$(RANLIB) $@ ETAGS = ../lib-src/etags$(EXEEXT) diff --git a/lib/cdefs.h b/lib/cdefs.h index 4dac9d264d2..a05b538579b 100644 --- a/lib/cdefs.h +++ b/lib/cdefs.h @@ -1,4 +1,5 @@ /* Copyright (C) 1992-2021 Free Software Foundation, Inc. + Copyright The GNU Toolchain Authors. This file is part of the GNU C Library. The GNU C Library is free software; you can redistribute it and/or @@ -150,6 +151,53 @@ # define __glibc_objsize(__o) __bos (__o) #endif +/* Compile time conditions to choose between the regular, _chk and _chk_warn + variants. These conditions should get evaluated to constant and optimized + away. */ + +#define __glibc_safe_len_cond(__l, __s, __osz) ((__l) <= (__osz) / (__s)) +#define __glibc_unsigned_or_positive(__l) \ + ((__typeof (__l)) 0 < (__typeof (__l)) -1 \ + || (__builtin_constant_p (__l) && (__l) > 0)) + +/* Length is known to be safe at compile time if the __L * __S <= __OBJSZ + condition can be folded to a constant and if it is true. The -1 check is + redundant because since it implies that __glibc_safe_len_cond is true. */ +#define __glibc_safe_or_unknown_len(__l, __s, __osz) \ + (__glibc_unsigned_or_positive (__l) \ + && __builtin_constant_p (__glibc_safe_len_cond ((__SIZE_TYPE__) (__l), \ + __s, __osz)) \ + && __glibc_safe_len_cond ((__SIZE_TYPE__) (__l), __s, __osz)) + +/* Conversely, we know at compile time that the length is unsafe if the + __L * __S <= __OBJSZ condition can be folded to a constant and if it is + false. */ +#define __glibc_unsafe_len(__l, __s, __osz) \ + (__glibc_unsigned_or_positive (__l) \ + && __builtin_constant_p (__glibc_safe_len_cond ((__SIZE_TYPE__) (__l), \ + __s, __osz)) \ + && !__glibc_safe_len_cond ((__SIZE_TYPE__) (__l), __s, __osz)) + +/* Fortify function f. __f_alias, __f_chk and __f_chk_warn must be + declared. */ + +#define __glibc_fortify(f, __l, __s, __osz, ...) \ + (__glibc_safe_or_unknown_len (__l, __s, __osz) \ + ? __ ## f ## _alias (__VA_ARGS__) \ + : (__glibc_unsafe_len (__l, __s, __osz) \ + ? __ ## f ## _chk_warn (__VA_ARGS__, __osz) \ + : __ ## f ## _chk (__VA_ARGS__, __osz))) \ + +/* Fortify function f, where object size argument passed to f is the number of + elements and not total size. */ + +#define __glibc_fortify_n(f, __l, __s, __osz, ...) \ + (__glibc_safe_or_unknown_len (__l, __s, __osz) \ + ? __ ## f ## _alias (__VA_ARGS__) \ + : (__glibc_unsafe_len (__l, __s, __osz) \ + ? __ ## f ## _chk_warn (__VA_ARGS__, (__osz) / (__s)) \ + : __ ## f ## _chk (__VA_ARGS__, (__osz) / (__s)))) \ + #if __GNUC_PREREQ (4,3) # define __warnattr(msg) __attribute__((__warning__ (msg))) # define __errordecl(name, msg) \ @@ -243,6 +291,15 @@ # define __attribute_alloc_size__(params) /* Ignore. */ #endif +/* Tell the compiler which argument to an allocation function + indicates the alignment of the allocation. */ +#if __GNUC_PREREQ (4, 9) || __glibc_has_attribute (__alloc_align__) +# define __attribute_alloc_align__(param) \ + __attribute__ ((__alloc_align__ param)) +#else +# define __attribute_alloc_align__(param) /* Ignore. */ +#endif + /* At some point during the gcc 2.96 development the `pure' attribute for functions was introduced. We don't want to use it unconditionally (although this would be possible) since it generates warnings. */ @@ -605,12 +662,22 @@ _Static_assert (0, "IEEE 128-bits long double requires redirection on this platf size-index is not provided: access (access-mode, <ref-index> [, <size-index>]) */ # define __attr_access(x) __attribute__ ((__access__ x)) +/* For _FORTIFY_SOURCE == 3 we use __builtin_dynamic_object_size, which may + use the access attribute to get object sizes from function definition + arguments, so we can't use them on functions we fortify. Drop the object + size hints for such functions. */ +# if __USE_FORTIFY_LEVEL == 3 +# define __fortified_attr_access(a, o, s) __attribute__ ((__access__ (a, o))) +# else +# define __fortified_attr_access(a, o, s) __attr_access ((a, o, s)) +# endif # if __GNUC_PREREQ (11, 0) # define __attr_access_none(argno) __attribute__ ((__access__ (__none__, argno))) # else # define __attr_access_none(argno) # endif #else +# define __fortified_attr_access(a, o, s) # define __attr_access(x) # define __attr_access_none(argno) #endif diff --git a/lib/gettext.h b/lib/gettext.h index f1c7a240757..a573da35460 100644 --- a/lib/gettext.h +++ b/lib/gettext.h @@ -138,7 +138,7 @@ #define dcnpgettext(Domainname, Msgctxt, Msgid, MsgidPlural, N, Category) \ npgettext_aux (Domainname, Msgctxt GETTEXT_CONTEXT_GLUE Msgid, Msgid, MsgidPlural, N, Category) -#ifdef __GNUC__ +#if defined __GNUC__ || defined __clang__ __inline #else #ifdef __cplusplus @@ -157,7 +157,7 @@ pgettext_aux (const char *domain, return translation; } -#ifdef __GNUC__ +#if defined __GNUC__ || defined __clang__ __inline #else #ifdef __cplusplus @@ -191,9 +191,8 @@ npgettext_aux (const char *domain, or may have security implications due to non-deterministic stack usage. */ #if (!defined GNULIB_NO_VLA \ - && (((__GNUC__ >= 3 || __GNUG__ >= 2) && !defined __STRICT_ANSI__) \ - /* || (__STDC_VERSION__ == 199901L && !defined __HP_cc) - || (__STDC_VERSION__ >= 201112L && !defined __STDC_NO_VLA__) */ )) + && defined __STDC_VERSION__ && 199901L <= __STDC_VERSION__ \ + && !defined __STDC_NO_VLA__) # define _LIBGETTEXT_HAVE_VARIABLE_SIZE_ARRAYS 1 #else # define _LIBGETTEXT_HAVE_VARIABLE_SIZE_ARRAYS 0 @@ -208,7 +207,7 @@ npgettext_aux (const char *domain, #define dpgettext_expr(Domainname, Msgctxt, Msgid) \ dcpgettext_expr (Domainname, Msgctxt, Msgid, LC_MESSAGES) -#ifdef __GNUC__ +#if defined __GNUC__ || defined __clang__ __inline #else #ifdef __cplusplus @@ -255,7 +254,7 @@ dcpgettext_expr (const char *domain, #define dnpgettext_expr(Domainname, Msgctxt, Msgid, MsgidPlural, N) \ dcnpgettext_expr (Domainname, Msgctxt, Msgid, MsgidPlural, N, LC_MESSAGES) -#ifdef __GNUC__ +#if defined __GNUC__ || defined __clang__ __inline #else #ifdef __cplusplus diff --git a/lib/gnulib.mk.in b/lib/gnulib.mk.in index c7c7eb455be..66b733cfe4e 100644 --- a/lib/gnulib.mk.in +++ b/lib/gnulib.mk.in @@ -202,6 +202,9 @@ COM_ERRLIB = @COM_ERRLIB@ CPP = @CPP@ CPPFLAGS = @CPPFLAGS@ CRYPTOLIB = @CRYPTOLIB@ +CXX = @CXX@ +CXXCPP = @CXXCPP@ +CXXFLAGS = @CXXFLAGS@ CYGWIN_OBJ = @CYGWIN_OBJ@ C_SWITCH_MACHINE = @C_SWITCH_MACHINE@ C_SWITCH_SYSTEM = @C_SWITCH_SYSTEM@ @@ -244,18 +247,22 @@ GETOPT_CDEFS_H = @GETOPT_CDEFS_H@ GETOPT_H = @GETOPT_H@ GFILENOTIFY_CFLAGS = @GFILENOTIFY_CFLAGS@ GFILENOTIFY_LIBS = @GFILENOTIFY_LIBS@ -GL_COND_LIBTOOL = @GL_COND_LIBTOOL@ -GL_GENERATE_ALLOCA_H = @GL_GENERATE_ALLOCA_H@ -GL_GENERATE_BYTESWAP_H = @GL_GENERATE_BYTESWAP_H@ -GL_GENERATE_ERRNO_H = @GL_GENERATE_ERRNO_H@ -GL_GENERATE_EXECINFO_H = @GL_GENERATE_EXECINFO_H@ -GL_GENERATE_GMP_GMP_H = @GL_GENERATE_GMP_GMP_H@ -GL_GENERATE_IEEE754_H = @GL_GENERATE_IEEE754_H@ -GL_GENERATE_LIMITS_H = @GL_GENERATE_LIMITS_H@ -GL_GENERATE_MINI_GMP_H = @GL_GENERATE_MINI_GMP_H@ -GL_GENERATE_STDALIGN_H = @GL_GENERATE_STDALIGN_H@ -GL_GENERATE_STDDEF_H = @GL_GENERATE_STDDEF_H@ -GL_GENERATE_STDINT_H = @GL_GENERATE_STDINT_H@ +GLIB_COMPILE_SCHEMAS = @GLIB_COMPILE_SCHEMAS@ +GL_COND_LIBTOOL_CONDITION = @GL_COND_LIBTOOL_CONDITION@ +GL_GENERATE_ALLOCA_H_CONDITION = @GL_GENERATE_ALLOCA_H_CONDITION@ +GL_GENERATE_BYTESWAP_H_CONDITION = @GL_GENERATE_BYTESWAP_H_CONDITION@ +GL_GENERATE_ERRNO_H_CONDITION = @GL_GENERATE_ERRNO_H_CONDITION@ +GL_GENERATE_EXECINFO_H_CONDITION = @GL_GENERATE_EXECINFO_H_CONDITION@ +GL_GENERATE_GETOPT_CDEFS_H_CONDITION = @GL_GENERATE_GETOPT_CDEFS_H_CONDITION@ +GL_GENERATE_GETOPT_H_CONDITION = @GL_GENERATE_GETOPT_H_CONDITION@ +GL_GENERATE_GMP_GMP_H_CONDITION = @GL_GENERATE_GMP_GMP_H_CONDITION@ +GL_GENERATE_GMP_H_CONDITION = @GL_GENERATE_GMP_H_CONDITION@ +GL_GENERATE_IEEE754_H_CONDITION = @GL_GENERATE_IEEE754_H_CONDITION@ +GL_GENERATE_LIMITS_H_CONDITION = @GL_GENERATE_LIMITS_H_CONDITION@ +GL_GENERATE_MINI_GMP_H_CONDITION = @GL_GENERATE_MINI_GMP_H_CONDITION@ +GL_GENERATE_STDALIGN_H_CONDITION = @GL_GENERATE_STDALIGN_H_CONDITION@ +GL_GENERATE_STDDEF_H_CONDITION = @GL_GENERATE_STDDEF_H_CONDITION@ +GL_GENERATE_STDINT_H_CONDITION = @GL_GENERATE_STDINT_H_CONDITION@ GL_GNULIB_ACCESS = @GL_GNULIB_ACCESS@ GL_GNULIB_ALIGNED_ALLOC = @GL_GNULIB_ALIGNED_ALLOC@ GL_GNULIB_ALPHASORT = @GL_GNULIB_ALPHASORT@ @@ -556,17 +563,24 @@ GOBJECT_CFLAGS = @GOBJECT_CFLAGS@ GOBJECT_LIBS = @GOBJECT_LIBS@ GREP = @GREP@ GSETTINGS_CFLAGS = @GSETTINGS_CFLAGS@ +GSETTINGS_DISABLE_SCHEMAS_COMPILE = @GSETTINGS_DISABLE_SCHEMAS_COMPILE@ GSETTINGS_LIBS = @GSETTINGS_LIBS@ +GSETTINGS_RULES = @GSETTINGS_RULES@ GTK_CFLAGS = @GTK_CFLAGS@ GTK_LIBS = @GTK_LIBS@ GTK_OBJ = @GTK_OBJ@ GZIP_PROG = @GZIP_PROG@ +HAIKU_CFLAGS = @HAIKU_CFLAGS@ +HAIKU_CXX_OBJ = @HAIKU_CXX_OBJ@ +HAIKU_LIBS = @HAIKU_LIBS@ +HAIKU_OBJ = @HAIKU_OBJ@ HARFBUZZ_CFLAGS = @HARFBUZZ_CFLAGS@ HARFBUZZ_LIBS = @HARFBUZZ_LIBS@ HAVE_ALIGNED_ALLOC = @HAVE_ALIGNED_ALLOC@ HAVE_ALLOCA_H = @HAVE_ALLOCA_H@ HAVE_ALPHASORT = @HAVE_ALPHASORT@ HAVE_ATOLL = @HAVE_ATOLL@ +HAVE_BE_APP = @HAVE_BE_APP@ HAVE_C99_STDINT_H = @HAVE_C99_STDINT_H@ HAVE_CANONICALIZE_FILE_NAME = @HAVE_CANONICALIZE_FILE_NAME@ HAVE_CHOWN = @HAVE_CHOWN@ @@ -600,6 +614,7 @@ HAVE_DECL_LOCALTIME_R = @HAVE_DECL_LOCALTIME_R@ HAVE_DECL_MEMMEM = @HAVE_DECL_MEMMEM@ HAVE_DECL_MEMRCHR = @HAVE_DECL_MEMRCHR@ HAVE_DECL_OBSTACK_PRINTF = @HAVE_DECL_OBSTACK_PRINTF@ +HAVE_DECL_POSIX_SPAWN_SETSID = @HAVE_DECL_POSIX_SPAWN_SETSID@ HAVE_DECL_SETENV = @HAVE_DECL_SETENV@ HAVE_DECL_SETHOSTNAME = @HAVE_DECL_SETHOSTNAME@ HAVE_DECL_SETSTATE = @HAVE_DECL_SETSTATE@ @@ -690,6 +705,10 @@ HAVE_POPEN = @HAVE_POPEN@ HAVE_POSIX_MEMALIGN = @HAVE_POSIX_MEMALIGN@ HAVE_POSIX_OPENPT = @HAVE_POSIX_OPENPT@ HAVE_POSIX_SIGNALBLOCKING = @HAVE_POSIX_SIGNALBLOCKING@ +HAVE_POSIX_SPAWN = @HAVE_POSIX_SPAWN@ +HAVE_POSIX_SPAWNATTR_SETFLAGS = @HAVE_POSIX_SPAWNATTR_SETFLAGS@ +HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR = @HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR@ +HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR_NP = @HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR_NP@ HAVE_PREAD = @HAVE_PREAD@ HAVE_PSELECT = @HAVE_PSELECT@ HAVE_PTHREAD_SIGMASK = @HAVE_PTHREAD_SIGMASK@ @@ -726,6 +745,7 @@ HAVE_SIGNED_WCHAR_T = @HAVE_SIGNED_WCHAR_T@ HAVE_SIGNED_WINT_T = @HAVE_SIGNED_WINT_T@ HAVE_SIGSET_T = @HAVE_SIGSET_T@ HAVE_SLEEP = @HAVE_SLEEP@ +HAVE_SPAWN_H = @HAVE_SPAWN_H@ HAVE_STDINT_H = @HAVE_STDINT_H@ HAVE_STPCPY = @HAVE_STPCPY@ HAVE_STPNCPY = @HAVE_STPNCPY@ @@ -923,6 +943,8 @@ PATH_SEPARATOR = @PATH_SEPARATOR@ PAXCTL = @PAXCTL@ PAXCTL_dumped = @PAXCTL_dumped@ PAXCTL_notdumped = @PAXCTL_notdumped@ +PGTK_LIBS = @PGTK_LIBS@ +PGTK_OBJ = @PGTK_OBJ@ PKG_CONFIG = @PKG_CONFIG@ PKG_CONFIG_LIBDIR = @PKG_CONFIG_LIBDIR@ PKG_CONFIG_PATH = @PKG_CONFIG_PATH@ @@ -1104,6 +1126,7 @@ SETTINGS_LIBS = @SETTINGS_LIBS@ SHELL = @SHELL@ SIG_ATOMIC_T_SUFFIX = @SIG_ATOMIC_T_SUFFIX@ SIZE_T_SUFFIX = @SIZE_T_SUFFIX@ +SQLITE3_LIBS = @SQLITE3_LIBS@ STDALIGN_H = @STDALIGN_H@ STDDEF_H = @STDDEF_H@ STDINT_H = @STDINT_H@ @@ -1132,6 +1155,8 @@ WARN_CFLAGS = @WARN_CFLAGS@ WCHAR_T_SUFFIX = @WCHAR_T_SUFFIX@ WEBKIT_CFLAGS = @WEBKIT_CFLAGS@ WEBKIT_LIBS = @WEBKIT_LIBS@ +WEBP_CFLAGS = @WEBP_CFLAGS@ +WEBP_LIBS = @WEBP_LIBS@ WERROR_CFLAGS = @WERROR_CFLAGS@ WIDGET_OBJ = @WIDGET_OBJ@ WINDOWS_64_BIT_OFF_T = @WINDOWS_64_BIT_OFF_T@ @@ -1153,6 +1178,8 @@ XFT_LIBS = @XFT_LIBS@ XGSELOBJ = @XGSELOBJ@ XINERAMA_CFLAGS = @XINERAMA_CFLAGS@ XINERAMA_LIBS = @XINERAMA_LIBS@ +XINPUT_CFLAGS = @XINPUT_CFLAGS@ +XINPUT_LIBS = @XINPUT_LIBS@ XMENU_OBJ = @XMENU_OBJ@ XMKMF = @XMKMF@ XOBJ = @XOBJ@ @@ -1162,6 +1189,7 @@ XRENDER_LIBS = @XRENDER_LIBS@ XWIDGETS_OBJ = @XWIDGETS_OBJ@ X_TOOLKIT_TYPE = @X_TOOLKIT_TYPE@ ac_ct_CC = @ac_ct_CC@ +ac_ct_CXX = @ac_ct_CXX@ ac_ct_OBJC = @ac_ct_OBJC@ archlibdir = @archlibdir@ bindir = @bindir@ @@ -1188,34 +1216,35 @@ exec_prefix = @exec_prefix@ gamedir = @gamedir@ gamegroup = @gamegroup@ gameuser = @gameuser@ -gl_GNULIB_ENABLED_03e0aaad4cb89ca757653bd367a6ccb7 = @gl_GNULIB_ENABLED_03e0aaad4cb89ca757653bd367a6ccb7@ -gl_GNULIB_ENABLED_260941c0e5dc67ec9e87d1fb321c300b = @gl_GNULIB_ENABLED_260941c0e5dc67ec9e87d1fb321c300b@ -gl_GNULIB_ENABLED_5264294aa0a5557541b53c8c741f7f31 = @gl_GNULIB_ENABLED_5264294aa0a5557541b53c8c741f7f31@ -gl_GNULIB_ENABLED_6099e9737f757db36c47fa9d9f02e88c = @gl_GNULIB_ENABLED_6099e9737f757db36c47fa9d9f02e88c@ -gl_GNULIB_ENABLED_61bcaca76b3e6f9ae55d57a1c3193bc4 = @gl_GNULIB_ENABLED_61bcaca76b3e6f9ae55d57a1c3193bc4@ -gl_GNULIB_ENABLED_682e609604ccaac6be382e4ee3a4eaec = @gl_GNULIB_ENABLED_682e609604ccaac6be382e4ee3a4eaec@ -gl_GNULIB_ENABLED_925677f0343de64b89a9f0c790b4104c = @gl_GNULIB_ENABLED_925677f0343de64b89a9f0c790b4104c@ -gl_GNULIB_ENABLED_a9786850e999ae65a836a6041e8e5ed1 = @gl_GNULIB_ENABLED_a9786850e999ae65a836a6041e8e5ed1@ -gl_GNULIB_ENABLED_be453cec5eecf5731a274f2de7f2db36 = @gl_GNULIB_ENABLED_be453cec5eecf5731a274f2de7f2db36@ -gl_GNULIB_ENABLED_cloexec = @gl_GNULIB_ENABLED_cloexec@ -gl_GNULIB_ENABLED_d3b2383720ee0e541357aa2aac598e2b = @gl_GNULIB_ENABLED_d3b2383720ee0e541357aa2aac598e2b@ -gl_GNULIB_ENABLED_dirfd = @gl_GNULIB_ENABLED_dirfd@ -gl_GNULIB_ENABLED_dynarray = @gl_GNULIB_ENABLED_dynarray@ -gl_GNULIB_ENABLED_ef455225c00f5049c808c2eda3e76866 = @gl_GNULIB_ENABLED_ef455225c00f5049c808c2eda3e76866@ -gl_GNULIB_ENABLED_euidaccess = @gl_GNULIB_ENABLED_euidaccess@ -gl_GNULIB_ENABLED_getdtablesize = @gl_GNULIB_ENABLED_getdtablesize@ -gl_GNULIB_ENABLED_getgroups = @gl_GNULIB_ENABLED_getgroups@ -gl_GNULIB_ENABLED_lchmod = @gl_GNULIB_ENABLED_lchmod@ -gl_GNULIB_ENABLED_open = @gl_GNULIB_ENABLED_open@ -gl_GNULIB_ENABLED_rawmemchr = @gl_GNULIB_ENABLED_rawmemchr@ -gl_GNULIB_ENABLED_scratch_buffer = @gl_GNULIB_ENABLED_scratch_buffer@ -gl_GNULIB_ENABLED_strtoll = @gl_GNULIB_ENABLED_strtoll@ -gl_GNULIB_ENABLED_utimens = @gl_GNULIB_ENABLED_utimens@ +gl_GNULIB_ENABLED_03e0aaad4cb89ca757653bd367a6ccb7_CONDITION = @gl_GNULIB_ENABLED_03e0aaad4cb89ca757653bd367a6ccb7_CONDITION@ +gl_GNULIB_ENABLED_260941c0e5dc67ec9e87d1fb321c300b_CONDITION = @gl_GNULIB_ENABLED_260941c0e5dc67ec9e87d1fb321c300b_CONDITION@ +gl_GNULIB_ENABLED_5264294aa0a5557541b53c8c741f7f31_CONDITION = @gl_GNULIB_ENABLED_5264294aa0a5557541b53c8c741f7f31_CONDITION@ +gl_GNULIB_ENABLED_6099e9737f757db36c47fa9d9f02e88c_CONDITION = @gl_GNULIB_ENABLED_6099e9737f757db36c47fa9d9f02e88c_CONDITION@ +gl_GNULIB_ENABLED_61bcaca76b3e6f9ae55d57a1c3193bc4_CONDITION = @gl_GNULIB_ENABLED_61bcaca76b3e6f9ae55d57a1c3193bc4_CONDITION@ +gl_GNULIB_ENABLED_682e609604ccaac6be382e4ee3a4eaec_CONDITION = @gl_GNULIB_ENABLED_682e609604ccaac6be382e4ee3a4eaec_CONDITION@ +gl_GNULIB_ENABLED_925677f0343de64b89a9f0c790b4104c_CONDITION = @gl_GNULIB_ENABLED_925677f0343de64b89a9f0c790b4104c_CONDITION@ +gl_GNULIB_ENABLED_a9786850e999ae65a836a6041e8e5ed1_CONDITION = @gl_GNULIB_ENABLED_a9786850e999ae65a836a6041e8e5ed1_CONDITION@ +gl_GNULIB_ENABLED_be453cec5eecf5731a274f2de7f2db36_CONDITION = @gl_GNULIB_ENABLED_be453cec5eecf5731a274f2de7f2db36_CONDITION@ +gl_GNULIB_ENABLED_cloexec_CONDITION = @gl_GNULIB_ENABLED_cloexec_CONDITION@ +gl_GNULIB_ENABLED_d3b2383720ee0e541357aa2aac598e2b_CONDITION = @gl_GNULIB_ENABLED_d3b2383720ee0e541357aa2aac598e2b_CONDITION@ +gl_GNULIB_ENABLED_dirfd_CONDITION = @gl_GNULIB_ENABLED_dirfd_CONDITION@ +gl_GNULIB_ENABLED_dynarray_CONDITION = @gl_GNULIB_ENABLED_dynarray_CONDITION@ +gl_GNULIB_ENABLED_ef455225c00f5049c808c2eda3e76866_CONDITION = @gl_GNULIB_ENABLED_ef455225c00f5049c808c2eda3e76866_CONDITION@ +gl_GNULIB_ENABLED_euidaccess_CONDITION = @gl_GNULIB_ENABLED_euidaccess_CONDITION@ +gl_GNULIB_ENABLED_getdtablesize_CONDITION = @gl_GNULIB_ENABLED_getdtablesize_CONDITION@ +gl_GNULIB_ENABLED_getgroups_CONDITION = @gl_GNULIB_ENABLED_getgroups_CONDITION@ +gl_GNULIB_ENABLED_lchmod_CONDITION = @gl_GNULIB_ENABLED_lchmod_CONDITION@ +gl_GNULIB_ENABLED_open_CONDITION = @gl_GNULIB_ENABLED_open_CONDITION@ +gl_GNULIB_ENABLED_rawmemchr_CONDITION = @gl_GNULIB_ENABLED_rawmemchr_CONDITION@ +gl_GNULIB_ENABLED_scratch_buffer_CONDITION = @gl_GNULIB_ENABLED_scratch_buffer_CONDITION@ +gl_GNULIB_ENABLED_strtoll_CONDITION = @gl_GNULIB_ENABLED_strtoll_CONDITION@ +gl_GNULIB_ENABLED_utimens_CONDITION = @gl_GNULIB_ENABLED_utimens_CONDITION@ gl_LIBOBJS = @gl_LIBOBJS@ gl_LTLIBOBJS = @gl_LTLIBOBJS@ gltests_LIBOBJS = @gltests_LIBOBJS@ gltests_LTLIBOBJS = @gltests_LTLIBOBJS@ gltests_WITNESS = @gltests_WITNESS@ +gsettingsschemadir = @gsettingsschemadir@ host = @host@ host_alias = @host_alias@ host_cpu = @host_cpu@ @@ -1296,7 +1325,7 @@ BUILT_SOURCES += $(ALLOCA_H) # We need the following in order to create <alloca.h> when the system # doesn't have one that works with the given compiler. -ifneq (,$(GL_GENERATE_ALLOCA_H)) +ifneq (,$(GL_GENERATE_ALLOCA_H_CONDITION)) alloca.h: alloca.in.h $(top_builddir)/config.status $(AM_V_GEN)rm -f $@-t $@ && \ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \ @@ -1327,7 +1356,7 @@ endif ## begin gnulib module at-internal ifeq (,$(OMIT_GNULIB_MODULE_at-internal)) -ifneq (,$(gl_GNULIB_ENABLED_260941c0e5dc67ec9e87d1fb321c300b)) +ifneq (,$(gl_GNULIB_ENABLED_260941c0e5dc67ec9e87d1fb321c300b_CONDITION)) libgnu_a_SOURCES += openat-priv.h openat-proc.c endif @@ -1358,7 +1387,7 @@ BUILT_SOURCES += $(BYTESWAP_H) # We need the following in order to create <byteswap.h> when the system # doesn't have one. -ifneq (,$(GL_GENERATE_BYTESWAP_H)) +ifneq (,$(GL_GENERATE_BYTESWAP_H_CONDITION)) byteswap.h: byteswap.in.h $(top_builddir)/config.status $(AM_V_GEN)rm -f $@-t $@ && \ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \ @@ -1416,7 +1445,7 @@ endif ## begin gnulib module cloexec ifeq (,$(OMIT_GNULIB_MODULE_cloexec)) -ifneq (,$(gl_GNULIB_ENABLED_cloexec)) +ifneq (,$(gl_GNULIB_ENABLED_cloexec_CONDITION)) libgnu_a_SOURCES += cloexec.c endif @@ -1585,7 +1614,7 @@ endif ## begin gnulib module dirfd ifeq (,$(OMIT_GNULIB_MODULE_dirfd)) -ifneq (,$(gl_GNULIB_ENABLED_dirfd)) +ifneq (,$(gl_GNULIB_ENABLED_dirfd_CONDITION)) endif EXTRA_DIST += dirfd.c @@ -1629,12 +1658,12 @@ endif ## begin gnulib module dynarray ifeq (,$(OMIT_GNULIB_MODULE_dynarray)) -ifneq (,$(gl_GNULIB_ENABLED_dynarray)) +ifneq (,$(gl_GNULIB_ENABLED_dynarray_CONDITION)) BUILT_SOURCES += malloc/dynarray.gl.h malloc/dynarray-skeleton.gl.h malloc/dynarray.gl.h: malloc/dynarray.h - $(AM_V_at)$(MKDIR_P) malloc - $(AM_V_GEN)rm -f $@-t $@ && \ + $(AM_V_GEN)$(MKDIR_P) 'malloc' + $(AM_V_at)rm -f $@-t $@ && \ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \ sed -e '/libc_hidden_proto/d' < $(srcdir)/malloc/dynarray.h; \ } > $@-t && \ @@ -1642,8 +1671,8 @@ malloc/dynarray.gl.h: malloc/dynarray.h MOSTLYCLEANFILES += malloc/dynarray.gl.h malloc/dynarray.gl.h-t malloc/dynarray-skeleton.gl.h: malloc/dynarray-skeleton.c - $(AM_V_at)$(MKDIR_P) malloc - $(AM_V_GEN)rm -f $@-t $@ && \ + $(AM_V_GEN)$(MKDIR_P) 'malloc' + $(AM_V_at)rm -f $@-t $@ && \ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \ sed -e 's|<malloc/dynarray\.h>|<malloc/dynarray.gl.h>|g' \ -e 's|__attribute_maybe_unused__|_GL_ATTRIBUTE_MAYBE_UNUSED|g' \ @@ -1669,7 +1698,7 @@ endif ## begin gnulib module eloop-threshold ifeq (,$(OMIT_GNULIB_MODULE_eloop-threshold)) -ifneq (,$(gl_GNULIB_ENABLED_925677f0343de64b89a9f0c790b4104c)) +ifneq (,$(gl_GNULIB_ENABLED_925677f0343de64b89a9f0c790b4104c_CONDITION)) endif EXTRA_DIST += eloop-threshold.h @@ -1684,7 +1713,7 @@ BUILT_SOURCES += $(ERRNO_H) # We need the following in order to create <errno.h> when the system # doesn't have one that is POSIX compliant. -ifneq (,$(GL_GENERATE_ERRNO_H)) +ifneq (,$(GL_GENERATE_ERRNO_H_CONDITION)) errno.h: errno.in.h $(top_builddir)/config.status $(AM_V_GEN)rm -f $@-t $@ && \ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \ @@ -1716,7 +1745,7 @@ endif ## begin gnulib module euidaccess ifeq (,$(OMIT_GNULIB_MODULE_euidaccess)) -ifneq (,$(gl_GNULIB_ENABLED_euidaccess)) +ifneq (,$(gl_GNULIB_ENABLED_euidaccess_CONDITION)) endif EXTRA_DIST += euidaccess.c @@ -1733,7 +1762,7 @@ BUILT_SOURCES += $(EXECINFO_H) # We need the following in order to create <execinfo.h> when the system # doesn't have one that works. -ifneq (,$(GL_GENERATE_EXECINFO_H)) +ifneq (,$(GL_GENERATE_EXECINFO_H_CONDITION)) execinfo.h: execinfo.in.h $(top_builddir)/config.status $(AM_V_GEN)rm -f $@-t $@ && \ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \ @@ -1966,7 +1995,7 @@ endif ## begin gnulib module getdtablesize ifeq (,$(OMIT_GNULIB_MODULE_getdtablesize)) -ifneq (,$(gl_GNULIB_ENABLED_getdtablesize)) +ifneq (,$(gl_GNULIB_ENABLED_getdtablesize_CONDITION)) endif EXTRA_DIST += getdtablesize.c @@ -1979,7 +2008,7 @@ endif ## begin gnulib module getgroups ifeq (,$(OMIT_GNULIB_MODULE_getgroups)) -ifneq (,$(gl_GNULIB_ENABLED_getgroups)) +ifneq (,$(gl_GNULIB_ENABLED_getgroups_CONDITION)) endif EXTRA_DIST += getgroups.c @@ -2007,6 +2036,7 @@ BUILT_SOURCES += $(GETOPT_H) $(GETOPT_CDEFS_H) # We need the following in order to create <getopt.h> when the system # doesn't have one that works with the given compiler. +ifneq (,$(GL_GENERATE_GETOPT_H_CONDITION)) getopt.h: getopt.in.h $(top_builddir)/config.status $(ARG_NONNULL_H) $(AM_V_GEN)rm -f $@-t $@ && \ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \ @@ -2020,7 +2050,12 @@ getopt.h: getopt.in.h $(top_builddir)/config.status $(ARG_NONNULL_H) < $(srcdir)/getopt.in.h; \ } > $@-t && \ mv -f $@-t $@ +else +getopt.h: $(top_builddir)/config.status + rm -f $@ +endif +ifneq (,$(GL_GENERATE_GETOPT_CDEFS_H_CONDITION)) getopt-cdefs.h: getopt-cdefs.in.h $(top_builddir)/config.status $(AM_V_GEN)rm -f $@-t $@ && \ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \ @@ -2028,6 +2063,10 @@ getopt-cdefs.h: getopt-cdefs.in.h $(top_builddir)/config.status < $(srcdir)/getopt-cdefs.in.h; \ } > $@-t && \ mv -f $@-t $@ +else +getopt-cdefs.h: $(top_builddir)/config.status + rm -f $@ +endif MOSTLYCLEANFILES += getopt.h getopt.h-t getopt-cdefs.h getopt-cdefs.h-t @@ -2052,7 +2091,7 @@ endif ## begin gnulib module gettext-h ifeq (,$(OMIT_GNULIB_MODULE_gettext-h)) -ifneq (,$(gl_GNULIB_ENABLED_be453cec5eecf5731a274f2de7f2db36)) +ifneq (,$(gl_GNULIB_ENABLED_be453cec5eecf5731a274f2de7f2db36_CONDITION)) libgnu_a_SOURCES += gettext.h endif @@ -2090,7 +2129,7 @@ endif ## begin gnulib module group-member ifeq (,$(OMIT_GNULIB_MODULE_group-member)) -ifneq (,$(gl_GNULIB_ENABLED_a9786850e999ae65a836a6041e8e5ed1)) +ifneq (,$(gl_GNULIB_ENABLED_a9786850e999ae65a836a6041e8e5ed1_CONDITION)) endif EXTRA_DIST += group-member.c @@ -2115,7 +2154,7 @@ BUILT_SOURCES += $(IEEE754_H) # We need the following in order to create <ieee754.h> when the system # doesn't have one that works with the given compiler. -ifneq (,$(GL_GENERATE_IEEE754_H)) +ifneq (,$(GL_GENERATE_IEEE754_H_CONDITION)) ieee754.h: ieee754.in.h $(top_builddir)/config.status $(AM_V_GEN)rm -f $@-t && \ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \ @@ -2200,7 +2239,7 @@ endif ## begin gnulib module lchmod ifeq (,$(OMIT_GNULIB_MODULE_lchmod)) -ifneq (,$(gl_GNULIB_ENABLED_lchmod)) +ifneq (,$(gl_GNULIB_ENABLED_lchmod_CONDITION)) endif EXTRA_DIST += lchmod.c @@ -2224,22 +2263,25 @@ ifeq (,$(OMIT_GNULIB_MODULE_libgmp)) BUILT_SOURCES += $(GMP_H) -ifneq (,$(GL_GENERATE_MINI_GMP_H)) +ifneq (,$(GL_GENERATE_GMP_H_CONDITION)) +ifneq (,$(GL_GENERATE_MINI_GMP_H_CONDITION)) # Build gmp.h as a wrapper for mini-gmp.h when using mini-gmp. gmp.h: $(top_builddir)/config.status - echo '#include "mini-gmp.h"' >$@-t + $(MKDIR_P) '.' + echo '#include "mini-gmp.h"' > $@-t mv $@-t $@ -else -ifneq (,$(GL_GENERATE_GMP_GMP_H)) +endif +ifneq (,$(GL_GENERATE_GMP_GMP_H_CONDITION)) # Build gmp.h as a wrapper for gmp/gmp.h. gmp.h: $(top_builddir)/config.status - echo '#include <gmp/gmp.h>' >$@-t + $(MKDIR_P) '.' + echo '#include <gmp/gmp.h>' > $@-t mv $@-t $@ +endif else gmp.h: $(top_builddir)/config.status rm -f $@ endif -endif MOSTLYCLEANFILES += gmp.h gmp.h-t EXTRA_DIST += mini-gmp-gnulib.c mini-gmp.c mini-gmp.h @@ -2256,7 +2298,7 @@ BUILT_SOURCES += $(LIMITS_H) # We need the following in order to create <limits.h> when the system # doesn't have one that is compatible with GNU. -ifneq (,$(GL_GENERATE_LIMITS_H)) +ifneq (,$(GL_GENERATE_LIMITS_H_CONDITION)) limits.h: limits.in.h $(top_builddir)/config.status $(AM_V_GEN)rm -f $@-t $@ && \ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \ @@ -2293,7 +2335,7 @@ endif ## begin gnulib module malloc-posix ifeq (,$(OMIT_GNULIB_MODULE_malloc-posix)) -ifneq (,$(gl_GNULIB_ENABLED_ef455225c00f5049c808c2eda3e76866)) +ifneq (,$(gl_GNULIB_ENABLED_ef455225c00f5049c808c2eda3e76866_CONDITION)) endif EXTRA_DIST += malloc.c @@ -2369,7 +2411,7 @@ endif ## begin gnulib module mktime-internal ifeq (,$(OMIT_GNULIB_MODULE_mktime-internal)) -ifneq (,$(gl_GNULIB_ENABLED_5264294aa0a5557541b53c8c741f7f31)) +ifneq (,$(gl_GNULIB_ENABLED_5264294aa0a5557541b53c8c741f7f31_CONDITION)) endif EXTRA_DIST += mktime-internal.h mktime.c @@ -2402,7 +2444,7 @@ endif ## begin gnulib module open ifeq (,$(OMIT_GNULIB_MODULE_open)) -ifneq (,$(gl_GNULIB_ENABLED_open)) +ifneq (,$(gl_GNULIB_ENABLED_open_CONDITION)) endif EXTRA_DIST += open.c @@ -2415,7 +2457,7 @@ endif ## begin gnulib module openat-h ifeq (,$(OMIT_GNULIB_MODULE_openat-h)) -ifneq (,$(gl_GNULIB_ENABLED_03e0aaad4cb89ca757653bd367a6ccb7)) +ifneq (,$(gl_GNULIB_ENABLED_03e0aaad4cb89ca757653bd367a6ccb7_CONDITION)) endif EXTRA_DIST += openat.h @@ -2473,7 +2515,7 @@ endif ## begin gnulib module rawmemchr ifeq (,$(OMIT_GNULIB_MODULE_rawmemchr)) -ifneq (,$(gl_GNULIB_ENABLED_rawmemchr)) +ifneq (,$(gl_GNULIB_ENABLED_rawmemchr_CONDITION)) endif EXTRA_DIST += rawmemchr.c rawmemchr.valgrind @@ -2508,7 +2550,7 @@ endif ## begin gnulib module realloc-gnu ifeq (,$(OMIT_GNULIB_MODULE_realloc-gnu)) -ifneq (,$(gl_GNULIB_ENABLED_d3b2383720ee0e541357aa2aac598e2b)) +ifneq (,$(gl_GNULIB_ENABLED_d3b2383720ee0e541357aa2aac598e2b_CONDITION)) endif EXTRA_DIST += realloc.c @@ -2521,7 +2563,7 @@ endif ## begin gnulib module realloc-posix ifeq (,$(OMIT_GNULIB_MODULE_realloc-posix)) -ifneq (,$(gl_GNULIB_ENABLED_61bcaca76b3e6f9ae55d57a1c3193bc4)) +ifneq (,$(gl_GNULIB_ENABLED_61bcaca76b3e6f9ae55d57a1c3193bc4_CONDITION)) endif EXTRA_DIST += realloc.c @@ -2545,7 +2587,7 @@ endif ## begin gnulib module root-uid ifeq (,$(OMIT_GNULIB_MODULE_root-uid)) -ifneq (,$(gl_GNULIB_ENABLED_6099e9737f757db36c47fa9d9f02e88c)) +ifneq (,$(gl_GNULIB_ENABLED_6099e9737f757db36c47fa9d9f02e88c_CONDITION)) endif EXTRA_DIST += root-uid.h @@ -2556,12 +2598,12 @@ endif ## begin gnulib module scratch_buffer ifeq (,$(OMIT_GNULIB_MODULE_scratch_buffer)) -ifneq (,$(gl_GNULIB_ENABLED_scratch_buffer)) +ifneq (,$(gl_GNULIB_ENABLED_scratch_buffer_CONDITION)) BUILT_SOURCES += malloc/scratch_buffer.gl.h malloc/scratch_buffer.gl.h: malloc/scratch_buffer.h - $(AM_V_at)$(MKDIR_P) malloc - $(AM_V_GEN)rm -f $@-t $@ && \ + $(AM_V_GEN)$(MKDIR_P) 'malloc' + $(AM_V_at)rm -f $@-t $@ && \ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \ sed -e 's|__always_inline|inline _GL_ATTRIBUTE_ALWAYS_INLINE|g' \ -e 's|__glibc_likely|_GL_LIKELY|g' \ @@ -2719,7 +2761,7 @@ BUILT_SOURCES += $(STDALIGN_H) # We need the following in order to create <stdalign.h> when the system # doesn't have one that works. -ifneq (,$(GL_GENERATE_STDALIGN_H)) +ifneq (,$(GL_GENERATE_STDALIGN_H_CONDITION)) stdalign.h: stdalign.in.h $(top_builddir)/config.status $(AM_V_GEN)rm -f $@-t $@ && \ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \ @@ -2744,7 +2786,7 @@ BUILT_SOURCES += $(STDDEF_H) # We need the following in order to create <stddef.h> when the system # doesn't have one that works with the given compiler. -ifneq (,$(GL_GENERATE_STDDEF_H)) +ifneq (,$(GL_GENERATE_STDDEF_H_CONDITION)) stddef.h: stddef.in.h $(top_builddir)/config.status $(AM_V_GEN)rm -f $@-t $@ && \ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \ @@ -2777,7 +2819,7 @@ BUILT_SOURCES += $(STDINT_H) # We need the following in order to create <stdint.h> when the system # doesn't have one that works with the given compiler. -ifneq (,$(GL_GENERATE_STDINT_H)) +ifneq (,$(GL_GENERATE_STDINT_H_CONDITION)) stdint.h: stdint.in.h $(top_builddir)/config.status $(AM_V_GEN)rm -f $@-t $@ && \ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \ @@ -3256,7 +3298,7 @@ endif ## begin gnulib module strtoll ifeq (,$(OMIT_GNULIB_MODULE_strtoll)) -ifneq (,$(gl_GNULIB_ENABLED_strtoll)) +ifneq (,$(gl_GNULIB_ENABLED_strtoll_CONDITION)) endif EXTRA_DIST += strtol.c strtoll.c @@ -3285,8 +3327,8 @@ BUILT_SOURCES += sys/random.h # We need the following in order to create <sys/random.h> when the system # doesn't have one. sys/random.h: sys_random.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $(WARN_ON_USE_H) - $(AM_V_at)$(MKDIR_P) sys - $(AM_V_GEN)rm -f $@-t $@ && \ + $(AM_V_GEN)$(MKDIR_P) 'sys' + $(AM_V_at)rm -f $@-t $@ && \ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \ sed -e 's|@''GUARD_PREFIX''@|GL|g' \ -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \ @@ -3319,8 +3361,8 @@ BUILT_SOURCES += sys/select.h # We need the following in order to create <sys/select.h> when the system # doesn't have one that works with the given compiler. sys/select.h: sys_select.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(WARN_ON_USE_H) - $(AM_V_at)$(MKDIR_P) sys - $(AM_V_GEN)rm -f $@-t $@ && \ + $(AM_V_GEN)$(MKDIR_P) 'sys' + $(AM_V_at)rm -f $@-t $@ && \ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \ sed -e 's|@''GUARD_PREFIX''@|GL|g' \ -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \ @@ -3355,8 +3397,8 @@ BUILT_SOURCES += sys/stat.h # We need the following in order to create <sys/stat.h> when the system # has one that is incomplete. sys/stat.h: sys_stat.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $(WARN_ON_USE_H) - $(AM_V_at)$(MKDIR_P) sys - $(AM_V_GEN)rm -f $@-t $@ && \ + $(AM_V_GEN)$(MKDIR_P) 'sys' + $(AM_V_at)rm -f $@-t $@ && \ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \ sed -e 's|@''GUARD_PREFIX''@|GL|g' \ -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \ @@ -3430,8 +3472,8 @@ BUILT_SOURCES += sys/time.h # We need the following in order to create <sys/time.h> when the system # doesn't have one that works with the given compiler. sys/time.h: sys_time.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $(WARN_ON_USE_H) - $(AM_V_at)$(MKDIR_P) sys - $(AM_V_GEN)rm -f $@-t $@ && \ + $(AM_V_GEN)$(MKDIR_P) 'sys' + $(AM_V_at)rm -f $@-t $@ && \ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \ sed -e 's|@''GUARD_PREFIX''@|GL|g' \ -e 's/@''HAVE_SYS_TIME_H''@/$(HAVE_SYS_TIME_H)/g' \ @@ -3466,8 +3508,8 @@ BUILT_SOURCES += sys/types.h # We need the following in order to create <sys/types.h> when the system # doesn't have one that works with the given compiler. sys/types.h: sys_types.in.h $(top_builddir)/config.status - $(AM_V_at)$(MKDIR_P) sys - $(AM_V_GEN)rm -f $@-t $@ && \ + $(AM_V_GEN)$(MKDIR_P) 'sys' + $(AM_V_at)rm -f $@-t $@ && \ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \ sed -e 's|@''GUARD_PREFIX''@|GL|g' \ -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \ @@ -3853,7 +3895,7 @@ endif ## begin gnulib module utimens ifeq (,$(OMIT_GNULIB_MODULE_utimens)) -ifneq (,$(gl_GNULIB_ENABLED_utimens)) +ifneq (,$(gl_GNULIB_ENABLED_utimens_CONDITION)) libgnu_a_SOURCES += utimens.c endif @@ -3894,7 +3936,7 @@ endif ## begin gnulib module xalloc-oversized ifeq (,$(OMIT_GNULIB_MODULE_xalloc-oversized)) -ifneq (,$(gl_GNULIB_ENABLED_682e609604ccaac6be382e4ee3a4eaec)) +ifneq (,$(gl_GNULIB_ENABLED_682e609604ccaac6be382e4ee3a4eaec_CONDITION)) endif EXTRA_DIST += xalloc-oversized.h diff --git a/lib/intprops.h b/lib/intprops.h index 3fe64e82e9f..a10d793e0ae 100644 --- a/lib/intprops.h +++ b/lib/intprops.h @@ -229,18 +229,18 @@ /* True if __builtin_add_overflow (A, B, P) and __builtin_sub_overflow (A, B, P) work when P is non-null. */ +#if defined __has_builtin +# define _GL_HAS_BUILTIN_ADD_OVERFLOW __has_builtin (__builtin_add_overflow) /* __builtin_{add,sub}_overflow exists but is not reliable in GCC 5.x and 6.x, see <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=98269>. */ -#if 7 <= __GNUC__ && !defined __ICC +#elif 7 <= __GNUC__ && !defined __EDG__ # define _GL_HAS_BUILTIN_ADD_OVERFLOW 1 -#elif defined __has_builtin -# define _GL_HAS_BUILTIN_ADD_OVERFLOW __has_builtin (__builtin_add_overflow) #else # define _GL_HAS_BUILTIN_ADD_OVERFLOW 0 #endif /* True if __builtin_mul_overflow (A, B, P) works when P is non-null. */ -#ifdef __clang__ +#if defined __clang_major__ && __clang_major__ < 14 /* Work around Clang bug <https://bugs.llvm.org/show_bug.cgi?id=16404>. */ # define _GL_HAS_BUILTIN_MUL_OVERFLOW 0 #else @@ -249,9 +249,8 @@ /* True if __builtin_add_overflow_p (A, B, C) works, and similarly for __builtin_sub_overflow_p and __builtin_mul_overflow_p. */ -#if defined __clang__ || defined __ICC -/* Clang 11 lacks __builtin_mul_overflow_p, and even if it did it - would presumably run afoul of Clang bug 16404. ICC 2021.1's +#ifdef __EDG__ +/* In EDG-based compilers like ICC 2021.3 and earlier, __builtin_add_overflow_p etc. are not treated as integral constant expressions even when all arguments are. */ # define _GL_HAS_BUILTIN_OVERFLOW_P 0 @@ -400,7 +399,7 @@ #if _GL_HAS_BUILTIN_MUL_OVERFLOW # if ((9 < __GNUC__ + (3 <= __GNUC_MINOR__) \ || (__GNUC__ == 8 && 4 <= __GNUC_MINOR__)) \ - && !defined __ICC) + && !defined __EDG__) # define INT_MULTIPLY_WRAPV(a, b, r) __builtin_mul_overflow (a, b, r) # else /* Work around GCC bug 91450. */ diff --git a/lib/nproc.c b/lib/nproc.c index a9e369dd3f7..1af989d6dd0 100644 --- a/lib/nproc.c +++ b/lib/nproc.c @@ -307,10 +307,11 @@ num_processors_ignoring_omp (enum nproc_query query) NPROC_CURRENT and NPROC_ALL. */ #if HAVE_SYSCTL && ! defined __GLIBC__ && defined HW_NCPU - { /* This works on Mac OS X, FreeBSD, NetBSD, OpenBSD. */ + { /* This works on macOS, FreeBSD, NetBSD, OpenBSD. + macOS 10.14 does not allow mib to be const. */ int nprocs; size_t len = sizeof (nprocs); - static int const mib[][2] = { + static int mib[][2] = { # ifdef HW_NCPUONLINE { CTL_HW, HW_NCPUONLINE }, # endif diff --git a/lib/nstrftime.c b/lib/nstrftime.c index 7f258e8727f..25baf76c60f 100644 --- a/lib/nstrftime.c +++ b/lib/nstrftime.c @@ -22,7 +22,7 @@ # define HAVE_TZNAME 1 # include "../locale/localeinfo.h" #else -# include <config.h> +# include <libc-config.h> # if FPRINTFTIME # include "fprintftime.h" # else @@ -367,10 +367,7 @@ tm_diff (const struct tm *a, const struct tm *b) #define ISO_WEEK1_WDAY 4 /* Thursday */ #define YDAY_MINIMUM (-366) static int iso_week_days (int, int); -#if defined __GNUC__ || defined __clang__ -__inline__ -#endif -static int +static __inline int iso_week_days (int yday, int wday) { /* Add enough to the first operand of % to make it nonnegative. */ @@ -428,9 +425,7 @@ my_strftime (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize) return __strftime_internal (s, STRFTIME_ARG (maxsize) format, tp, false, 0, -1, &tzset_called extra_args LOCALE_ARG); } -#if defined _LIBC && ! FPRINTFTIME libc_hidden_def (my_strftime) -#endif /* Just like my_strftime, above, but with more parameters. UPCASE indicates that the result should be converted to upper case. diff --git a/lib/regcomp.c b/lib/regcomp.c index 887e5b50684..6a97fdee478 100644 --- a/lib/regcomp.c +++ b/lib/regcomp.c @@ -27,14 +27,10 @@ static void re_compile_fastmap_iter (regex_t *bufp, const re_dfastate_t *init_state, char *fastmap); static reg_errcode_t init_dfa (re_dfa_t *dfa, size_t pat_len); -#ifdef RE_ENABLE_I18N static void free_charset (re_charset_t *cset); -#endif /* RE_ENABLE_I18N */ static void free_workarea_compile (regex_t *preg); static reg_errcode_t create_initial_state (re_dfa_t *dfa); -#ifdef RE_ENABLE_I18N static void optimize_utf8 (re_dfa_t *dfa); -#endif static reg_errcode_t analyze (regex_t *preg); static reg_errcode_t preorder (bin_tree_t *root, reg_errcode_t (fn (void *, bin_tree_t *)), @@ -89,7 +85,6 @@ static reg_errcode_t parse_bracket_element (bracket_elem_t *elem, static reg_errcode_t parse_bracket_symbol (bracket_elem_t *elem, re_string_t *regexp, re_token_t *token); -#ifdef RE_ENABLE_I18N static reg_errcode_t build_equiv_class (bitset_t sbcset, re_charset_t *mbcset, Idx *equiv_class_alloc, @@ -100,14 +95,6 @@ static reg_errcode_t build_charclass (RE_TRANSLATE_TYPE trans, Idx *char_class_alloc, const char *class_name, reg_syntax_t syntax); -#else /* not RE_ENABLE_I18N */ -static reg_errcode_t build_equiv_class (bitset_t sbcset, - const unsigned char *name); -static reg_errcode_t build_charclass (RE_TRANSLATE_TYPE trans, - bitset_t sbcset, - const char *class_name, - reg_syntax_t syntax); -#endif /* not RE_ENABLE_I18N */ static bin_tree_t *build_charclass_op (re_dfa_t *dfa, RE_TRANSLATE_TYPE trans, const char *class_name, @@ -279,8 +266,7 @@ re_compile_fastmap (struct re_pattern_buffer *bufp) } weak_alias (__re_compile_fastmap, re_compile_fastmap) -static inline void -__attribute__ ((always_inline)) +static __always_inline void re_set_fastmap (char *fastmap, bool icase, int ch) { fastmap[ch] = 1; @@ -306,7 +292,6 @@ re_compile_fastmap_iter (regex_t *bufp, const re_dfastate_t *init_state, if (type == CHARACTER) { re_set_fastmap (fastmap, icase, dfa->nodes[node].opr.c); -#ifdef RE_ENABLE_I18N if ((bufp->syntax & RE_ICASE) && dfa->mb_cur_max > 1) { unsigned char buf[MB_LEN_MAX]; @@ -327,7 +312,6 @@ re_compile_fastmap_iter (regex_t *bufp, const re_dfastate_t *init_state, != (size_t) -1)) re_set_fastmap (fastmap, false, buf[0]); } -#endif } else if (type == SIMPLE_BRACKET) { @@ -341,13 +325,12 @@ re_compile_fastmap_iter (regex_t *bufp, const re_dfastate_t *init_state, re_set_fastmap (fastmap, icase, ch); } } -#ifdef RE_ENABLE_I18N else if (type == COMPLEX_BRACKET) { re_charset_t *cset = dfa->nodes[node].opr.mbcset; Idx i; -# ifdef _LIBC +#ifdef _LIBC /* See if we have to try all bytes which start multiple collation elements. e.g. In da_DK, we want to catch 'a' since "aa" is a valid @@ -363,7 +346,7 @@ re_compile_fastmap_iter (regex_t *bufp, const re_dfastate_t *init_state, if (table[i] < 0) re_set_fastmap (fastmap, icase, i); } -# endif /* _LIBC */ +#endif /* _LIBC */ /* See if we have to start the match at all multibyte characters, i.e. where we would not find an invalid sequence. This only @@ -371,9 +354,9 @@ re_compile_fastmap_iter (regex_t *bufp, const re_dfastate_t *init_state, sets, the SIMPLE_BRACKET again suffices. */ if (dfa->mb_cur_max > 1 && (cset->nchar_classes || cset->non_match || cset->nranges -# ifdef _LIBC +#ifdef _LIBC || cset->nequiv_classes -# endif /* _LIBC */ +#endif /* _LIBC */ )) { unsigned char c = 0; @@ -406,12 +389,7 @@ re_compile_fastmap_iter (regex_t *bufp, const re_dfastate_t *init_state, } } } -#endif /* RE_ENABLE_I18N */ - else if (type == OP_PERIOD -#ifdef RE_ENABLE_I18N - || type == OP_UTF8_PERIOD -#endif /* RE_ENABLE_I18N */ - || type == END_OF_RE) + else if (type == OP_PERIOD || type == OP_UTF8_PERIOD || type == END_OF_RE) { memset (fastmap, '\1', sizeof (char) * SBC_MAX); if (type == END_OF_RE) @@ -550,7 +528,6 @@ regerror (int errcode, const regex_t *__restrict preg, char *__restrict errbuf, weak_alias (__regerror, regerror) -#ifdef RE_ENABLE_I18N /* This static array is used for the map to single-byte characters when UTF-8 is used. Otherwise we would allocate memory just to initialize it the same all the time. UTF-8 is the preferred encoding so this is @@ -558,25 +535,24 @@ weak_alias (__regerror, regerror) static const bitset_t utf8_sb_map = { /* Set the first 128 bits. */ -# if (defined __GNUC__ || __clang_major__ >= 4) && !defined __STRICT_ANSI__ +#if (defined __GNUC__ || __clang_major__ >= 4) && !defined __STRICT_ANSI__ [0 ... 0x80 / BITSET_WORD_BITS - 1] = BITSET_WORD_MAX -# else -# if 4 * BITSET_WORD_BITS < ASCII_CHARS -# error "bitset_word_t is narrower than 32 bits" -# elif 3 * BITSET_WORD_BITS < ASCII_CHARS +#else +# if 4 * BITSET_WORD_BITS < ASCII_CHARS +# error "bitset_word_t is narrower than 32 bits" +# elif 3 * BITSET_WORD_BITS < ASCII_CHARS BITSET_WORD_MAX, BITSET_WORD_MAX, BITSET_WORD_MAX, -# elif 2 * BITSET_WORD_BITS < ASCII_CHARS +# elif 2 * BITSET_WORD_BITS < ASCII_CHARS BITSET_WORD_MAX, BITSET_WORD_MAX, -# elif 1 * BITSET_WORD_BITS < ASCII_CHARS +# elif 1 * BITSET_WORD_BITS < ASCII_CHARS BITSET_WORD_MAX, -# endif +# endif (BITSET_WORD_MAX >> (SBC_MAX % BITSET_WORD_BITS == 0 ? 0 : BITSET_WORD_BITS - SBC_MAX % BITSET_WORD_BITS)) -# endif -}; #endif +}; static void @@ -614,10 +590,8 @@ free_dfa_content (re_dfa_t *dfa) re_free (entry->array); } re_free (dfa->state_table); -#ifdef RE_ENABLE_I18N if (dfa->sb_char != utf8_sb_map) re_free (dfa->sb_char); -#endif re_free (dfa->subexp_map); #ifdef DEBUG re_free (dfa->re_str); @@ -796,11 +770,9 @@ re_compile_internal (regex_t *preg, const char * pattern, size_t length, if (__glibc_unlikely (err != REG_NOERROR)) goto re_compile_internal_free_return; -#ifdef RE_ENABLE_I18N /* If possible, do searching in single byte encoding to speed things up. */ if (dfa->is_utf8 && !(syntax & RE_ICASE) && preg->translate == NULL) optimize_utf8 (dfa); -#endif /* Then create the initial state of the dfa. */ err = create_initial_state (dfa); @@ -830,11 +802,7 @@ init_dfa (re_dfa_t *dfa, size_t pat_len) #ifndef _LIBC const char *codeset_name; #endif -#ifdef RE_ENABLE_I18N size_t max_i18n_object_size = MAX (sizeof (wchar_t), sizeof (wctype_t)); -#else - size_t max_i18n_object_size = 0; -#endif size_t max_object_size = MAX (sizeof (struct re_state_table_entry), MAX (sizeof (re_token_t), @@ -886,7 +854,6 @@ init_dfa (re_dfa_t *dfa, size_t pat_len) dfa->map_notascii = 0; #endif -#ifdef RE_ENABLE_I18N if (dfa->mb_cur_max > 1) { if (dfa->is_utf8) @@ -906,14 +873,13 @@ init_dfa (re_dfa_t *dfa, size_t pat_len) wint_t wch = __btowc (ch); if (wch != WEOF) dfa->sb_char[i] |= (bitset_word_t) 1 << j; -# ifndef _LIBC +#ifndef _LIBC if (isascii (ch) && wch != ch) dfa->map_notascii = 1; -# endif +#endif } } } -#endif if (__glibc_unlikely (dfa->nodes == NULL || dfa->state_table == NULL)) return REG_ESPACE; @@ -933,8 +899,6 @@ init_word_char (re_dfa_t *dfa) dfa->word_ops_used = 1; if (__glibc_likely (dfa->map_notascii == 0)) { - /* Avoid uint32_t and uint64_t as some non-GCC platforms lack - them, an issue when this code is used in Gnulib. */ bitset_word_t bits0 = 0x00000000; bitset_word_t bits1 = 0x03ff0000; bitset_word_t bits2 = 0x87fffffe; @@ -1074,7 +1038,6 @@ create_initial_state (re_dfa_t *dfa) return REG_NOERROR; } -#ifdef RE_ENABLE_I18N /* If it is possible to do searching in single byte encoding instead of UTF-8 to speed things up, set dfa->mb_cur_max to 1, clear is_utf8 and change DFA nodes where needed. */ @@ -1154,7 +1117,6 @@ optimize_utf8 (re_dfa_t *dfa) dfa->is_utf8 = 0; dfa->has_mb_node = dfa->nbackref > 0 || has_period; } -#endif /* Analyze the structure tree, and calculate "first", "next", "edest", "eclosure", and "inveclosure". */ @@ -1792,7 +1754,6 @@ peek_token (re_token_t *token, re_string_t *input, reg_syntax_t syntax) token->opr.c = c; token->word_char = 0; -#ifdef RE_ENABLE_I18N token->mb_partial = 0; if (input->mb_cur_max > 1 && !re_string_first_byte (input, re_string_cur_idx (input))) @@ -1801,7 +1762,6 @@ peek_token (re_token_t *token, re_string_t *input, reg_syntax_t syntax) token->mb_partial = 1; return 1; } -#endif if (c == '\\') { unsigned char c2; @@ -1814,7 +1774,6 @@ peek_token (re_token_t *token, re_string_t *input, reg_syntax_t syntax) c2 = re_string_peek_byte_case (input, 1); token->opr.c = c2; token->type = CHARACTER; -#ifdef RE_ENABLE_I18N if (input->mb_cur_max > 1) { wint_t wc = re_string_wchar_at (input, @@ -1822,7 +1781,6 @@ peek_token (re_token_t *token, re_string_t *input, reg_syntax_t syntax) token->word_char = IS_WIDE_WORD_CHAR (wc) != 0; } else -#endif token->word_char = IS_WORD_CHAR (c2) != 0; switch (c2) @@ -1928,14 +1886,12 @@ peek_token (re_token_t *token, re_string_t *input, reg_syntax_t syntax) } token->type = CHARACTER; -#ifdef RE_ENABLE_I18N if (input->mb_cur_max > 1) { wint_t wc = re_string_wchar_at (input, re_string_cur_idx (input)); token->word_char = IS_WIDE_WORD_CHAR (wc) != 0; } else -#endif token->word_char = IS_WORD_CHAR (token->opr.c); switch (c) @@ -2027,14 +1983,12 @@ peek_token_bracket (re_token_t *token, re_string_t *input, reg_syntax_t syntax) c = re_string_peek_byte (input, 0); token->opr.c = c; -#ifdef RE_ENABLE_I18N if (input->mb_cur_max > 1 && !re_string_first_byte (input, re_string_cur_idx (input))) { token->type = CHARACTER; return 1; } -#endif /* RE_ENABLE_I18N */ if (c == '\\' && (syntax & RE_BACKSLASH_ESCAPE_IN_LISTS) && re_string_cur_idx (input) + 1 < re_string_length (input)) @@ -2256,7 +2210,6 @@ parse_expression (re_string_t *regexp, regex_t *preg, re_token_t *token, *err = REG_ESPACE; return NULL; } -#ifdef RE_ENABLE_I18N if (dfa->mb_cur_max > 1) { while (!re_string_eoi (regexp) @@ -2273,7 +2226,6 @@ parse_expression (re_string_t *regexp, regex_t *preg, re_token_t *token, } } } -#endif break; case OP_OPEN_SUBEXP: @@ -2666,40 +2618,30 @@ parse_dup_op (bin_tree_t *elem, re_string_t *regexp, re_dfa_t *dfa, #ifndef _LIBC -# ifdef RE_ENABLE_I18N /* Convert the byte B to the corresponding wide character. In a unibyte locale, treat B as itself. In a multibyte locale, return WEOF if B is an encoding error. */ static wint_t -parse_byte (unsigned char b, re_charset_t *mbcset) +parse_byte (unsigned char b, re_dfa_t const *dfa) { - return mbcset == NULL ? b : __btowc (b); + return dfa->mb_cur_max > 1 ? __btowc (b) : b; } -# endif - /* Local function for parse_bracket_exp only used in case of NOT _LIBC. - Build the range expression which starts from START_ELEM, and ends - at END_ELEM. The result are written to MBCSET and SBCSET. - RANGE_ALLOC is the allocated size of mbcset->range_starts, and - mbcset->range_ends, is a pointer argument since we may - update it. */ +/* Local function for parse_bracket_exp used in _LIBC environment. + Build the range expression which starts from START_ELEM, and ends + at END_ELEM. The result are written to MBCSET and SBCSET. + RANGE_ALLOC is the allocated size of mbcset->range_starts, and + mbcset->range_ends, is a pointer argument since we may + update it. */ static reg_errcode_t -# ifdef RE_ENABLE_I18N -build_range_exp (const reg_syntax_t syntax, - bitset_t sbcset, - re_charset_t *mbcset, - Idx *range_alloc, - const bracket_elem_t *start_elem, - const bracket_elem_t *end_elem) -# else /* not RE_ENABLE_I18N */ -build_range_exp (const reg_syntax_t syntax, - bitset_t sbcset, - const bracket_elem_t *start_elem, - const bracket_elem_t *end_elem) -# endif /* not RE_ENABLE_I18N */ +build_range_exp (bitset_t sbcset, re_charset_t *mbcset, Idx *range_alloc, + bracket_elem_t *start_elem, bracket_elem_t *end_elem, + re_dfa_t *dfa, reg_syntax_t syntax, uint_fast32_t nrules, + const unsigned char *collseqmb, const char *collseqwc, + int_fast32_t table_size, const void *symb_table, + const unsigned char *extra) { - unsigned int start_ch, end_ch; /* Equivalence Classes and Character Classes can't be a range start/end. */ if (__glibc_unlikely (start_elem->type == EQUIV_CLASS || start_elem->type == CHAR_CLASS @@ -2715,110 +2657,88 @@ build_range_exp (const reg_syntax_t syntax, && strlen ((char *) end_elem->opr.name) > 1))) return REG_ECOLLATE; -# ifdef RE_ENABLE_I18N - { - wchar_t wc; - wint_t start_wc; - wint_t end_wc; - + unsigned int start_ch = ((start_elem->type == SB_CHAR) ? start_elem->opr.ch : ((start_elem->type == COLL_SYM) ? start_elem->opr.name[0] - : 0)); + : 0)), end_ch = ((end_elem->type == SB_CHAR) ? end_elem->opr.ch : ((end_elem->type == COLL_SYM) ? end_elem->opr.name[0] : 0)); + wint_t start_wc = ((start_elem->type == SB_CHAR || start_elem->type == COLL_SYM) - ? parse_byte (start_ch, mbcset) : start_elem->opr.wch); + ? parse_byte (start_ch, dfa) : start_elem->opr.wch), end_wc = ((end_elem->type == SB_CHAR || end_elem->type == COLL_SYM) - ? parse_byte (end_ch, mbcset) : end_elem->opr.wch); - if (start_wc == WEOF || end_wc == WEOF) - return REG_ECOLLATE; - else if (__glibc_unlikely ((syntax & RE_NO_EMPTY_RANGES) - && start_wc > end_wc)) - return REG_ERANGE; - - /* Got valid collation sequence values, add them as a new entry. - However, for !_LIBC we have no collation elements: if the - character set is single byte, the single byte character set - that we build below suffices. parse_bracket_exp passes - no MBCSET if dfa->mb_cur_max == 1. */ - if (mbcset) - { - /* Check the space of the arrays. */ - if (__glibc_unlikely (*range_alloc == mbcset->nranges)) - { - /* There is not enough space, need realloc. */ - wchar_t *new_array_start, *new_array_end; - Idx new_nranges; - - /* +1 in case of mbcset->nranges is 0. */ - new_nranges = 2 * mbcset->nranges + 1; - /* Use realloc since mbcset->range_starts and mbcset->range_ends - are NULL if *range_alloc == 0. */ - new_array_start = re_realloc (mbcset->range_starts, wchar_t, - new_nranges); - new_array_end = re_realloc (mbcset->range_ends, wchar_t, - new_nranges); + ? parse_byte (end_ch, dfa) : end_elem->opr.wch); - if (__glibc_unlikely (new_array_start == NULL - || new_array_end == NULL)) - { - re_free (new_array_start); - re_free (new_array_end); - return REG_ESPACE; - } + if (start_wc == WEOF || end_wc == WEOF) + return REG_ECOLLATE; + else if (__glibc_unlikely ((syntax & RE_NO_EMPTY_RANGES) + && start_wc > end_wc)) + return REG_ERANGE; - mbcset->range_starts = new_array_start; - mbcset->range_ends = new_array_end; - *range_alloc = new_nranges; - } + /* Got valid collation sequence values, add them as a new entry. + However, for !_LIBC we have no collation elements: if the + character set is single byte, the single byte character set + that we build below suffices. parse_bracket_exp passes + no MBCSET if dfa->mb_cur_max == 1. */ + if (dfa->mb_cur_max > 1) + { + /* Check the space of the arrays. */ + if (__glibc_unlikely (*range_alloc == mbcset->nranges)) + { + /* There is not enough space, need realloc. */ + wchar_t *new_array_start, *new_array_end; + Idx new_nranges; - mbcset->range_starts[mbcset->nranges] = start_wc; - mbcset->range_ends[mbcset->nranges++] = end_wc; - } + /* +1 in case of mbcset->nranges is 0. */ + new_nranges = 2 * mbcset->nranges + 1; + /* Use realloc since mbcset->range_starts and mbcset->range_ends + are NULL if *range_alloc == 0. */ + new_array_start = re_realloc (mbcset->range_starts, wchar_t, + new_nranges); + new_array_end = re_realloc (mbcset->range_ends, wchar_t, + new_nranges); + + if (__glibc_unlikely (new_array_start == NULL + || new_array_end == NULL)) + { + re_free (new_array_start); + re_free (new_array_end); + return REG_ESPACE; + } + + mbcset->range_starts = new_array_start; + mbcset->range_ends = new_array_end; + *range_alloc = new_nranges; + } + + mbcset->range_starts[mbcset->nranges] = start_wc; + mbcset->range_ends[mbcset->nranges++] = end_wc; + } + + /* Build the table for single byte characters. */ + for (wchar_t wc = 0; wc < SBC_MAX; ++wc) + { + if (start_wc <= wc && wc <= end_wc) + bitset_set (sbcset, wc); + } - /* Build the table for single byte characters. */ - for (wc = 0; wc < SBC_MAX; ++wc) - { - if (start_wc <= wc && wc <= end_wc) - bitset_set (sbcset, wc); - } - } -# else /* not RE_ENABLE_I18N */ - { - unsigned int ch; - start_ch = ((start_elem->type == SB_CHAR ) ? start_elem->opr.ch - : ((start_elem->type == COLL_SYM) ? start_elem->opr.name[0] - : 0)); - end_ch = ((end_elem->type == SB_CHAR ) ? end_elem->opr.ch - : ((end_elem->type == COLL_SYM) ? end_elem->opr.name[0] - : 0)); - if (start_ch > end_ch) - return REG_ERANGE; - /* Build the table for single byte characters. */ - for (ch = 0; ch < SBC_MAX; ++ch) - if (start_ch <= ch && ch <= end_ch) - bitset_set (sbcset, ch); - } -# endif /* not RE_ENABLE_I18N */ return REG_NOERROR; } #endif /* not _LIBC */ #ifndef _LIBC -/* Helper function for parse_bracket_exp only used in case of NOT _LIBC.. +/* Helper function for parse_bracket_exp only used in case of NOT _LIBC. Build the collating element which is represented by NAME. The result are written to MBCSET and SBCSET. COLL_SYM_ALLOC is the allocated size of mbcset->coll_sym, is a pointer argument since we may update it. */ static reg_errcode_t -# ifdef RE_ENABLE_I18N build_collating_symbol (bitset_t sbcset, re_charset_t *mbcset, - Idx *coll_sym_alloc, const unsigned char *name) -# else /* not RE_ENABLE_I18N */ -build_collating_symbol (bitset_t sbcset, const unsigned char *name) -# endif /* not RE_ENABLE_I18N */ + Idx *coll_sym_alloc, const unsigned char *name, + uint_fast32_t nrules, int_fast32_t table_size, + const void *symb_table, const unsigned char *extra) { size_t name_len = strlen ((const char *) name); if (__glibc_unlikely (name_len != 1)) @@ -2831,271 +2751,280 @@ build_collating_symbol (bitset_t sbcset, const unsigned char *name) } #endif /* not _LIBC */ -/* This function parse bracket expression like "[abc]", "[a-c]", - "[[.a-a.]]" etc. */ - -static bin_tree_t * -parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa, re_token_t *token, - reg_syntax_t syntax, reg_errcode_t *err) -{ #ifdef _LIBC - const unsigned char *collseqmb; - const char *collseqwc; - uint32_t nrules; - int32_t table_size; - const int32_t *symb_table; - const unsigned char *extra; - - /* Local function for parse_bracket_exp used in _LIBC environment. - Seek the collating symbol entry corresponding to NAME. - Return the index of the symbol in the SYMB_TABLE, - or -1 if not found. */ - - auto inline int32_t - __attribute__ ((always_inline)) - seek_collating_symbol_entry (const unsigned char *name, size_t name_len) - { - int32_t elem; - - for (elem = 0; elem < table_size; elem++) - if (symb_table[2 * elem] != 0) - { - int32_t idx = symb_table[2 * elem + 1]; - /* Skip the name of collating element name. */ - idx += 1 + extra[idx]; - if (/* Compare the length of the name. */ - name_len == extra[idx] - /* Compare the name. */ - && memcmp (name, &extra[idx + 1], name_len) == 0) - /* Yep, this is the entry. */ - return elem; - } - return -1; - } +/* Local function for parse_bracket_exp used in _LIBC environment. + Seek the collating symbol entry corresponding to NAME. + Return the index of the symbol in the SYMB_TABLE, + or -1 if not found. */ + +static __always_inline int32_t +seek_collating_symbol_entry (const unsigned char *name, size_t name_len, + const int32_t *symb_table, + int_fast32_t table_size, + const unsigned char *extra) +{ + int_fast32_t elem; - /* Local function for parse_bracket_exp used in _LIBC environment. - Look up the collation sequence value of BR_ELEM. - Return the value if succeeded, UINT_MAX otherwise. */ + for (elem = 0; elem < table_size; elem++) + if (symb_table[2 * elem] != 0) + { + int32_t idx = symb_table[2 * elem + 1]; + /* Skip the name of collating element name. */ + idx += 1 + extra[idx]; + if (/* Compare the length of the name. */ + name_len == extra[idx] + /* Compare the name. */ + && memcmp (name, &extra[idx + 1], name_len) == 0) + /* Yep, this is the entry. */ + return elem; + } + return -1; +} - auto inline unsigned int - __attribute__ ((always_inline)) - lookup_collation_sequence_value (bracket_elem_t *br_elem) +/* Local function for parse_bracket_exp used in _LIBC environment. + Look up the collation sequence value of BR_ELEM. + Return the value if succeeded, UINT_MAX otherwise. */ + +static __always_inline unsigned int +lookup_collation_sequence_value (bracket_elem_t *br_elem, uint32_t nrules, + const unsigned char *collseqmb, + const char *collseqwc, + int_fast32_t table_size, + const int32_t *symb_table, + const unsigned char *extra) +{ + if (br_elem->type == SB_CHAR) { - if (br_elem->type == SB_CHAR) - { - /* - if (MB_CUR_MAX == 1) - */ - if (nrules == 0) - return collseqmb[br_elem->opr.ch]; - else - { - wint_t wc = __btowc (br_elem->opr.ch); - return __collseq_table_lookup (collseqwc, wc); - } - } - else if (br_elem->type == MB_CHAR) + /* if (MB_CUR_MAX == 1) */ + if (nrules == 0) + return collseqmb[br_elem->opr.ch]; + else { - if (nrules != 0) - return __collseq_table_lookup (collseqwc, br_elem->opr.wch); + wint_t wc = __btowc (br_elem->opr.ch); + return __collseq_table_lookup (collseqwc, wc); } - else if (br_elem->type == COLL_SYM) + } + else if (br_elem->type == MB_CHAR) + { + if (nrules != 0) + return __collseq_table_lookup (collseqwc, br_elem->opr.wch); + } + else if (br_elem->type == COLL_SYM) + { + size_t sym_name_len = strlen ((char *) br_elem->opr.name); + if (nrules != 0) { - size_t sym_name_len = strlen ((char *) br_elem->opr.name); - if (nrules != 0) + int32_t elem, idx; + elem = seek_collating_symbol_entry (br_elem->opr.name, + sym_name_len, + symb_table, table_size, + extra); + if (elem != -1) { - int32_t elem, idx; - elem = seek_collating_symbol_entry (br_elem->opr.name, - sym_name_len); - if (elem != -1) - { - /* We found the entry. */ - idx = symb_table[2 * elem + 1]; - /* Skip the name of collating element name. */ - idx += 1 + extra[idx]; - /* Skip the byte sequence of the collating element. */ - idx += 1 + extra[idx]; - /* Adjust for the alignment. */ - idx = (idx + 3) & ~3; - /* Skip the multibyte collation sequence value. */ - idx += sizeof (unsigned int); - /* Skip the wide char sequence of the collating element. */ - idx += sizeof (unsigned int) * - (1 + *(unsigned int *) (extra + idx)); - /* Return the collation sequence value. */ - return *(unsigned int *) (extra + idx); - } - else if (sym_name_len == 1) - { - /* No valid character. Match it as a single byte - character. */ - return collseqmb[br_elem->opr.name[0]]; - } + /* We found the entry. */ + idx = symb_table[2 * elem + 1]; + /* Skip the name of collating element name. */ + idx += 1 + extra[idx]; + /* Skip the byte sequence of the collating element. */ + idx += 1 + extra[idx]; + /* Adjust for the alignment. */ + idx = (idx + 3) & ~3; + /* Skip the multibyte collation sequence value. */ + idx += sizeof (unsigned int); + /* Skip the wide char sequence of the collating element. */ + idx += sizeof (unsigned int) * + (1 + *(unsigned int *) (extra + idx)); + /* Return the collation sequence value. */ + return *(unsigned int *) (extra + idx); } else if (sym_name_len == 1) - return collseqmb[br_elem->opr.name[0]]; + { + /* No valid character. Match it as a single byte + character. */ + return collseqmb[br_elem->opr.name[0]]; + } } - return UINT_MAX; + else if (sym_name_len == 1) + return collseqmb[br_elem->opr.name[0]]; } + return UINT_MAX; +} - /* Local function for parse_bracket_exp used in _LIBC environment. - Build the range expression which starts from START_ELEM, and ends - at END_ELEM. The result are written to MBCSET and SBCSET. - RANGE_ALLOC is the allocated size of mbcset->range_starts, and - mbcset->range_ends, is a pointer argument since we may - update it. */ +/* Local function for parse_bracket_exp used in _LIBC environment. + Build the range expression which starts from START_ELEM, and ends + at END_ELEM. The result are written to MBCSET and SBCSET. + RANGE_ALLOC is the allocated size of mbcset->range_starts, and + mbcset->range_ends, is a pointer argument since we may + update it. */ + +static __always_inline reg_errcode_t +build_range_exp (bitset_t sbcset, re_charset_t *mbcset, Idx *range_alloc, + bracket_elem_t *start_elem, bracket_elem_t *end_elem, + re_dfa_t *dfa, reg_syntax_t syntax, uint32_t nrules, + const unsigned char *collseqmb, const char *collseqwc, + int_fast32_t table_size, const int32_t *symb_table, + const unsigned char *extra) +{ + unsigned int ch; + uint32_t start_collseq; + uint32_t end_collseq; - auto inline reg_errcode_t - __attribute__ ((always_inline)) - build_range_exp (bitset_t sbcset, re_charset_t *mbcset, int *range_alloc, - bracket_elem_t *start_elem, bracket_elem_t *end_elem) - { - unsigned int ch; - uint32_t start_collseq; - uint32_t end_collseq; - - /* Equivalence Classes and Character Classes can't be a range - start/end. */ - if (__glibc_unlikely (start_elem->type == EQUIV_CLASS - || start_elem->type == CHAR_CLASS - || end_elem->type == EQUIV_CLASS - || end_elem->type == CHAR_CLASS)) - return REG_ERANGE; + /* Equivalence Classes and Character Classes can't be a range + start/end. */ + if (__glibc_unlikely (start_elem->type == EQUIV_CLASS + || start_elem->type == CHAR_CLASS + || end_elem->type == EQUIV_CLASS + || end_elem->type == CHAR_CLASS)) + return REG_ERANGE; - /* FIXME: Implement rational ranges here, too. */ - start_collseq = lookup_collation_sequence_value (start_elem); - end_collseq = lookup_collation_sequence_value (end_elem); - /* Check start/end collation sequence values. */ - if (__glibc_unlikely (start_collseq == UINT_MAX - || end_collseq == UINT_MAX)) - return REG_ECOLLATE; - if (__glibc_unlikely ((syntax & RE_NO_EMPTY_RANGES) - && start_collseq > end_collseq)) - return REG_ERANGE; + /* FIXME: Implement rational ranges here, too. */ + start_collseq = lookup_collation_sequence_value (start_elem, nrules, collseqmb, collseqwc, + table_size, symb_table, extra); + end_collseq = lookup_collation_sequence_value (end_elem, nrules, collseqmb, collseqwc, + table_size, symb_table, extra); + /* Check start/end collation sequence values. */ + if (__glibc_unlikely (start_collseq == UINT_MAX + || end_collseq == UINT_MAX)) + return REG_ECOLLATE; + if (__glibc_unlikely ((syntax & RE_NO_EMPTY_RANGES) + && start_collseq > end_collseq)) + return REG_ERANGE; - /* Got valid collation sequence values, add them as a new entry. - However, if we have no collation elements, and the character set - is single byte, the single byte character set that we - build below suffices. */ - if (nrules > 0 || dfa->mb_cur_max > 1) + /* Got valid collation sequence values, add them as a new entry. + However, if we have no collation elements, and the character set + is single byte, the single byte character set that we + build below suffices. */ + if (nrules > 0 || dfa->mb_cur_max > 1) + { + /* Check the space of the arrays. */ + if (__glibc_unlikely (*range_alloc == mbcset->nranges)) { - /* Check the space of the arrays. */ - if (__glibc_unlikely (*range_alloc == mbcset->nranges)) - { - /* There is not enough space, need realloc. */ - uint32_t *new_array_start; - uint32_t *new_array_end; - Idx new_nranges; - - /* +1 in case of mbcset->nranges is 0. */ - new_nranges = 2 * mbcset->nranges + 1; - new_array_start = re_realloc (mbcset->range_starts, uint32_t, - new_nranges); - new_array_end = re_realloc (mbcset->range_ends, uint32_t, - new_nranges); - - if (__glibc_unlikely (new_array_start == NULL - || new_array_end == NULL)) - return REG_ESPACE; + /* There is not enough space, need realloc. */ + uint32_t *new_array_start; + uint32_t *new_array_end; + int new_nranges; - mbcset->range_starts = new_array_start; - mbcset->range_ends = new_array_end; - *range_alloc = new_nranges; - } + /* +1 in case of mbcset->nranges is 0. */ + new_nranges = 2 * mbcset->nranges + 1; + new_array_start = re_realloc (mbcset->range_starts, uint32_t, + new_nranges); + new_array_end = re_realloc (mbcset->range_ends, uint32_t, + new_nranges); - mbcset->range_starts[mbcset->nranges] = start_collseq; - mbcset->range_ends[mbcset->nranges++] = end_collseq; - } + if (__glibc_unlikely (new_array_start == NULL + || new_array_end == NULL)) + return REG_ESPACE; - /* Build the table for single byte characters. */ - for (ch = 0; ch < SBC_MAX; ch++) - { - uint32_t ch_collseq; - /* - if (MB_CUR_MAX == 1) - */ - if (nrules == 0) - ch_collseq = collseqmb[ch]; - else - ch_collseq = __collseq_table_lookup (collseqwc, __btowc (ch)); - if (start_collseq <= ch_collseq && ch_collseq <= end_collseq) - bitset_set (sbcset, ch); + mbcset->range_starts = new_array_start; + mbcset->range_ends = new_array_end; + *range_alloc = new_nranges; } - return REG_NOERROR; + + mbcset->range_starts[mbcset->nranges] = start_collseq; + mbcset->range_ends[mbcset->nranges++] = end_collseq; } - /* Local function for parse_bracket_exp used in _LIBC environment. - Build the collating element which is represented by NAME. - The result are written to MBCSET and SBCSET. - COLL_SYM_ALLOC is the allocated size of mbcset->coll_sym, is a - pointer argument since we may update it. */ + /* Build the table for single byte characters. */ + for (ch = 0; ch < SBC_MAX; ch++) + { + uint32_t ch_collseq; + /* if (MB_CUR_MAX == 1) */ + if (nrules == 0) + ch_collseq = collseqmb[ch]; + else + ch_collseq = __collseq_table_lookup (collseqwc, __btowc (ch)); + if (start_collseq <= ch_collseq && ch_collseq <= end_collseq) + bitset_set (sbcset, ch); + } + return REG_NOERROR; +} - auto inline reg_errcode_t - __attribute__ ((always_inline)) - build_collating_symbol (bitset_t sbcset, re_charset_t *mbcset, - Idx *coll_sym_alloc, const unsigned char *name) +/* Local function for parse_bracket_exp used in _LIBC environment. + Build the collating element which is represented by NAME. + The result are written to MBCSET and SBCSET. + COLL_SYM_ALLOC is the allocated size of mbcset->coll_sym, is a + pointer argument since we may update it. */ + +static __always_inline reg_errcode_t +build_collating_symbol (bitset_t sbcset, re_charset_t *mbcset, + Idx *coll_sym_alloc, const unsigned char *name, + uint_fast32_t nrules, int_fast32_t table_size, + const int32_t *symb_table, const unsigned char *extra) +{ + int32_t elem, idx; + size_t name_len = strlen ((const char *) name); + if (nrules != 0) { - int32_t elem, idx; - size_t name_len = strlen ((const char *) name); - if (nrules != 0) + elem = seek_collating_symbol_entry (name, name_len, symb_table, + table_size, extra); + if (elem != -1) { - elem = seek_collating_symbol_entry (name, name_len); - if (elem != -1) - { - /* We found the entry. */ - idx = symb_table[2 * elem + 1]; - /* Skip the name of collating element name. */ - idx += 1 + extra[idx]; - } - else if (name_len == 1) - { - /* No valid character, treat it as a normal - character. */ - bitset_set (sbcset, name[0]); - return REG_NOERROR; - } - else - return REG_ECOLLATE; - - /* Got valid collation sequence, add it as a new entry. */ - /* Check the space of the arrays. */ - if (__glibc_unlikely (*coll_sym_alloc == mbcset->ncoll_syms)) - { - /* Not enough, realloc it. */ - /* +1 in case of mbcset->ncoll_syms is 0. */ - Idx new_coll_sym_alloc = 2 * mbcset->ncoll_syms + 1; - /* Use realloc since mbcset->coll_syms is NULL - if *alloc == 0. */ - int32_t *new_coll_syms = re_realloc (mbcset->coll_syms, int32_t, - new_coll_sym_alloc); - if (__glibc_unlikely (new_coll_syms == NULL)) - return REG_ESPACE; - mbcset->coll_syms = new_coll_syms; - *coll_sym_alloc = new_coll_sym_alloc; - } - mbcset->coll_syms[mbcset->ncoll_syms++] = idx; + /* We found the entry. */ + idx = symb_table[2 * elem + 1]; + /* Skip the name of collating element name. */ + idx += 1 + extra[idx]; + } + else if (name_len == 1) + { + /* No valid character, treat it as a normal + character. */ + bitset_set (sbcset, name[0]); return REG_NOERROR; } else + return REG_ECOLLATE; + + /* Got valid collation sequence, add it as a new entry. */ + /* Check the space of the arrays. */ + if (__glibc_unlikely (*coll_sym_alloc == mbcset->ncoll_syms)) { - if (__glibc_unlikely (name_len != 1)) - return REG_ECOLLATE; - else - { - bitset_set (sbcset, name[0]); - return REG_NOERROR; - } + /* Not enough, realloc it. */ + /* +1 in case of mbcset->ncoll_syms is 0. */ + int new_coll_sym_alloc = 2 * mbcset->ncoll_syms + 1; + /* Use realloc since mbcset->coll_syms is NULL + if *alloc == 0. */ + int32_t *new_coll_syms = re_realloc (mbcset->coll_syms, int32_t, + new_coll_sym_alloc); + if (__glibc_unlikely (new_coll_syms == NULL)) + return REG_ESPACE; + mbcset->coll_syms = new_coll_syms; + *coll_sym_alloc = new_coll_sym_alloc; } + mbcset->coll_syms[mbcset->ncoll_syms++] = idx; + return REG_NOERROR; } -#endif + else + { + if (__glibc_unlikely (name_len != 1)) + return REG_ECOLLATE; + else + { + bitset_set (sbcset, name[0]); + return REG_NOERROR; + } + } +} +#endif /* _LIBC */ + +/* This function parse bracket expression like "[abc]", "[a-c]", + "[[.a-a.]]" etc. */ + +static bin_tree_t * +parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa, re_token_t *token, + reg_syntax_t syntax, reg_errcode_t *err) +{ + const unsigned char *collseqmb = NULL; + const char *collseqwc = NULL; + uint_fast32_t nrules = 0; + int_fast32_t table_size = 0; + const void *symb_table = NULL; + const unsigned char *extra = NULL; re_token_t br_token; re_bitset_ptr_t sbcset; -#ifdef RE_ENABLE_I18N re_charset_t *mbcset; Idx coll_sym_alloc = 0, range_alloc = 0, mbchar_alloc = 0; Idx equiv_class_alloc = 0, char_class_alloc = 0; -#endif /* not RE_ENABLE_I18N */ bool non_match = false; bin_tree_t *work_tree; int token_len; @@ -3111,26 +3040,17 @@ parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa, re_token_t *token, */ collseqwc = _NL_CURRENT (LC_COLLATE, _NL_COLLATE_COLLSEQWC); table_size = _NL_CURRENT_WORD (LC_COLLATE, _NL_COLLATE_SYMB_HASH_SIZEMB); - symb_table = (const int32_t *) _NL_CURRENT (LC_COLLATE, - _NL_COLLATE_SYMB_TABLEMB); + symb_table = _NL_CURRENT (LC_COLLATE, _NL_COLLATE_SYMB_TABLEMB); extra = (const unsigned char *) _NL_CURRENT (LC_COLLATE, _NL_COLLATE_SYMB_EXTRAMB); } #endif sbcset = (re_bitset_ptr_t) calloc (sizeof (bitset_t), 1); -#ifdef RE_ENABLE_I18N mbcset = (re_charset_t *) calloc (sizeof (re_charset_t), 1); -#endif /* RE_ENABLE_I18N */ -#ifdef RE_ENABLE_I18N if (__glibc_unlikely (sbcset == NULL || mbcset == NULL)) -#else - if (__glibc_unlikely (sbcset == NULL)) -#endif /* RE_ENABLE_I18N */ { re_free (sbcset); -#ifdef RE_ENABLE_I18N re_free (mbcset); -#endif *err = REG_ESPACE; return NULL; } @@ -3143,9 +3063,7 @@ parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa, re_token_t *token, } if (token->type == OP_NON_MATCH_LIST) { -#ifdef RE_ENABLE_I18N mbcset->non_match = 1; -#endif /* not RE_ENABLE_I18N */ non_match = true; if (syntax & RE_HAT_LISTS_NOT_NEWLINE) bitset_set (sbcset, '\n'); @@ -3228,18 +3146,10 @@ parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa, re_token_t *token, token_len = peek_token_bracket (token, regexp, syntax); -#ifdef _LIBC *err = build_range_exp (sbcset, mbcset, &range_alloc, - &start_elem, &end_elem); -#else -# ifdef RE_ENABLE_I18N - *err = build_range_exp (syntax, sbcset, - dfa->mb_cur_max > 1 ? mbcset : NULL, - &range_alloc, &start_elem, &end_elem); -# else - *err = build_range_exp (syntax, sbcset, &start_elem, &end_elem); -# endif -#endif /* RE_ENABLE_I18N */ + &start_elem, &end_elem, + dfa, syntax, nrules, collseqmb, collseqwc, + table_size, symb_table, extra); if (__glibc_unlikely (*err != REG_NOERROR)) goto parse_bracket_exp_free_return; } @@ -3250,7 +3160,6 @@ parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa, re_token_t *token, case SB_CHAR: bitset_set (sbcset, start_elem.opr.ch); break; -#ifdef RE_ENABLE_I18N case MB_CHAR: /* Check whether the array has enough space. */ if (__glibc_unlikely (mbchar_alloc == mbcset->nmbchars)) @@ -3268,30 +3177,24 @@ parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa, re_token_t *token, } mbcset->mbchars[mbcset->nmbchars++] = start_elem.opr.wch; break; -#endif /* RE_ENABLE_I18N */ case EQUIV_CLASS: *err = build_equiv_class (sbcset, -#ifdef RE_ENABLE_I18N mbcset, &equiv_class_alloc, -#endif /* RE_ENABLE_I18N */ start_elem.opr.name); if (__glibc_unlikely (*err != REG_NOERROR)) goto parse_bracket_exp_free_return; break; case COLL_SYM: *err = build_collating_symbol (sbcset, -#ifdef RE_ENABLE_I18N mbcset, &coll_sym_alloc, -#endif /* RE_ENABLE_I18N */ - start_elem.opr.name); + start_elem.opr.name, + nrules, table_size, symb_table, extra); if (__glibc_unlikely (*err != REG_NOERROR)) goto parse_bracket_exp_free_return; break; case CHAR_CLASS: *err = build_charclass (regexp->trans, sbcset, -#ifdef RE_ENABLE_I18N mbcset, &char_class_alloc, -#endif /* RE_ENABLE_I18N */ (const char *) start_elem.opr.name, syntax); if (__glibc_unlikely (*err != REG_NOERROR)) @@ -3317,7 +3220,6 @@ parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa, re_token_t *token, if (non_match) bitset_not (sbcset); -#ifdef RE_ENABLE_I18N /* Ensure only single byte characters are set. */ if (dfa->mb_cur_max > 1) bitset_mask (sbcset, dfa->sb_char); @@ -3361,11 +3263,8 @@ parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa, re_token_t *token, } } else -#endif /* not RE_ENABLE_I18N */ { -#ifdef RE_ENABLE_I18N free_charset (mbcset); -#endif /* Build a tree for simple bracket. */ br_token.type = SIMPLE_BRACKET; br_token.opr.sbcset = sbcset; @@ -3379,9 +3278,7 @@ parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa, re_token_t *token, *err = REG_ESPACE; parse_bracket_exp_free_return: re_free (sbcset); -#ifdef RE_ENABLE_I18N free_charset (mbcset); -#endif /* RE_ENABLE_I18N */ return NULL; } @@ -3392,7 +3289,6 @@ parse_bracket_element (bracket_elem_t *elem, re_string_t *regexp, re_token_t *token, int token_len, re_dfa_t *dfa, reg_syntax_t syntax, bool accept_hyphen) { -#ifdef RE_ENABLE_I18N int cur_char_size; cur_char_size = re_string_char_size_at (regexp, re_string_cur_idx (regexp)); if (cur_char_size > 1) @@ -3402,7 +3298,6 @@ parse_bracket_element (bracket_elem_t *elem, re_string_t *regexp, re_string_skip_bytes (regexp, cur_char_size); return REG_NOERROR; } -#endif /* RE_ENABLE_I18N */ re_string_skip_bytes (regexp, token_len); /* Skip a token. */ if (token->type == OP_OPEN_COLL_ELEM || token->type == OP_OPEN_CHAR_CLASS || token->type == OP_OPEN_EQUIV_CLASS) @@ -3475,12 +3370,8 @@ parse_bracket_symbol (bracket_elem_t *elem, re_string_t *regexp, is a pointer argument since we may update it. */ static reg_errcode_t -#ifdef RE_ENABLE_I18N build_equiv_class (bitset_t sbcset, re_charset_t *mbcset, Idx *equiv_class_alloc, const unsigned char *name) -#else /* not RE_ENABLE_I18N */ -build_equiv_class (bitset_t sbcset, const unsigned char *name) -#endif /* not RE_ENABLE_I18N */ { #ifdef _LIBC uint32_t nrules = _NL_CURRENT_WORD (LC_COLLATE, _NL_COLLATE_NRULES); @@ -3560,14 +3451,9 @@ build_equiv_class (bitset_t sbcset, const unsigned char *name) is a pointer argument since we may update it. */ static reg_errcode_t -#ifdef RE_ENABLE_I18N build_charclass (RE_TRANSLATE_TYPE trans, bitset_t sbcset, re_charset_t *mbcset, Idx *char_class_alloc, const char *class_name, reg_syntax_t syntax) -#else /* not RE_ENABLE_I18N */ -build_charclass (RE_TRANSLATE_TYPE trans, bitset_t sbcset, - const char *class_name, reg_syntax_t syntax) -#endif /* not RE_ENABLE_I18N */ { int i; const char *name = class_name; @@ -3578,7 +3464,6 @@ build_charclass (RE_TRANSLATE_TYPE trans, bitset_t sbcset, && (strcmp (name, "upper") == 0 || strcmp (name, "lower") == 0)) name = "alpha"; -#ifdef RE_ENABLE_I18N /* Check the space of the arrays. */ if (__glibc_unlikely (*char_class_alloc == mbcset->nchar_classes)) { @@ -3594,7 +3479,6 @@ build_charclass (RE_TRANSLATE_TYPE trans, bitset_t sbcset, *char_class_alloc = new_char_class_alloc; } mbcset->char_classes[mbcset->nchar_classes++] = __wctype (name); -#endif /* RE_ENABLE_I18N */ #define BUILD_CHARCLASS_LOOP(ctype_func) \ do { \ @@ -3649,10 +3533,8 @@ build_charclass_op (re_dfa_t *dfa, RE_TRANSLATE_TYPE trans, reg_errcode_t *err) { re_bitset_ptr_t sbcset; -#ifdef RE_ENABLE_I18N re_charset_t *mbcset; Idx alloc = 0; -#endif /* not RE_ENABLE_I18N */ reg_errcode_t ret; bin_tree_t *tree; @@ -3662,7 +3544,6 @@ build_charclass_op (re_dfa_t *dfa, RE_TRANSLATE_TYPE trans, *err = REG_ESPACE; return NULL; } -#ifdef RE_ENABLE_I18N mbcset = (re_charset_t *) calloc (sizeof (re_charset_t), 1); if (__glibc_unlikely (mbcset == NULL)) { @@ -3671,21 +3552,14 @@ build_charclass_op (re_dfa_t *dfa, RE_TRANSLATE_TYPE trans, return NULL; } mbcset->non_match = non_match; -#endif /* RE_ENABLE_I18N */ /* We don't care the syntax in this case. */ - ret = build_charclass (trans, sbcset, -#ifdef RE_ENABLE_I18N - mbcset, &alloc, -#endif /* RE_ENABLE_I18N */ - class_name, 0); + ret = build_charclass (trans, sbcset, mbcset, &alloc, class_name, 0); if (__glibc_unlikely (ret != REG_NOERROR)) { re_free (sbcset); -#ifdef RE_ENABLE_I18N free_charset (mbcset); -#endif /* RE_ENABLE_I18N */ *err = ret; return NULL; } @@ -3697,11 +3571,9 @@ build_charclass_op (re_dfa_t *dfa, RE_TRANSLATE_TYPE trans, if (non_match) bitset_not (sbcset); -#ifdef RE_ENABLE_I18N /* Ensure only single byte characters are set. */ if (dfa->mb_cur_max > 1) bitset_mask (sbcset, dfa->sb_char); -#endif /* Build a tree for simple bracket. */ re_token_t br_token = { .type = SIMPLE_BRACKET, .opr.sbcset = sbcset }; @@ -3709,7 +3581,6 @@ build_charclass_op (re_dfa_t *dfa, RE_TRANSLATE_TYPE trans, if (__glibc_unlikely (tree == NULL)) goto build_word_op_espace; -#ifdef RE_ENABLE_I18N if (dfa->mb_cur_max > 1) { bin_tree_t *mbc_tree; @@ -3730,15 +3601,10 @@ build_charclass_op (re_dfa_t *dfa, RE_TRANSLATE_TYPE trans, free_charset (mbcset); return tree; } -#else /* not RE_ENABLE_I18N */ - return tree; -#endif /* not RE_ENABLE_I18N */ build_word_op_espace: re_free (sbcset); -#ifdef RE_ENABLE_I18N free_charset (mbcset); -#endif /* RE_ENABLE_I18N */ *err = REG_ESPACE; return NULL; } @@ -3771,21 +3637,19 @@ fetch_number (re_string_t *input, re_token_t *token, reg_syntax_t syntax) return num; } -#ifdef RE_ENABLE_I18N static void free_charset (re_charset_t *cset) { re_free (cset->mbchars); -# ifdef _LIBC +#ifdef _LIBC re_free (cset->coll_syms); re_free (cset->equiv_classes); -# endif +#endif re_free (cset->range_starts); re_free (cset->range_ends); re_free (cset->char_classes); re_free (cset); } -#endif /* RE_ENABLE_I18N */ /* Functions for binary tree operation. */ @@ -3851,13 +3715,10 @@ mark_opt_subexp (void *extra, bin_tree_t *node) static void free_token (re_token_t *node) { -#ifdef RE_ENABLE_I18N if (node->type == COMPLEX_BRACKET && node->duplicated == 0) free_charset (node->opr.mbcset); - else -#endif /* RE_ENABLE_I18N */ - if (node->type == SIMPLE_BRACKET && node->duplicated == 0) - re_free (node->opr.sbcset); + else if (node->type == SIMPLE_BRACKET && node->duplicated == 0) + re_free (node->opr.sbcset); } /* Worker function for tree walking. Free the allocated memory inside NODE diff --git a/lib/regex_internal.c b/lib/regex_internal.c index aefcfa2f52e..9767cd0d07f 100644 --- a/lib/regex_internal.c +++ b/lib/regex_internal.c @@ -30,10 +30,8 @@ static re_dfastate_t *create_cd_newstate (const re_dfa_t *dfa, re_hashval_t hash); static reg_errcode_t re_string_realloc_buffers (re_string_t *pstr, Idx new_buf_len); -#ifdef RE_ENABLE_I18N static void build_wcs_buffer (re_string_t *pstr); static reg_errcode_t build_wcs_upper_buffer (re_string_t *pstr); -#endif /* RE_ENABLE_I18N */ static void build_upper_buffer (re_string_t *pstr); static void re_string_translate_buffer (re_string_t *pstr); static unsigned int re_string_context_at (const re_string_t *input, Idx idx, @@ -91,7 +89,6 @@ re_string_construct (re_string_t *pstr, const char *str, Idx len, if (icase) { -#ifdef RE_ENABLE_I18N if (dfa->mb_cur_max > 1) { while (1) @@ -109,16 +106,13 @@ re_string_construct (re_string_t *pstr, const char *str, Idx len, } } else -#endif /* RE_ENABLE_I18N */ build_upper_buffer (pstr); } else { -#ifdef RE_ENABLE_I18N if (dfa->mb_cur_max > 1) build_wcs_buffer (pstr); else -#endif /* RE_ENABLE_I18N */ { if (trans != NULL) re_string_translate_buffer (pstr); @@ -139,7 +133,6 @@ static reg_errcode_t __attribute_warn_unused_result__ re_string_realloc_buffers (re_string_t *pstr, Idx new_buf_len) { -#ifdef RE_ENABLE_I18N if (pstr->mb_cur_max > 1) { wint_t *new_wcs; @@ -162,7 +155,6 @@ re_string_realloc_buffers (re_string_t *pstr, Idx new_buf_len) pstr->offsets = new_offsets; } } -#endif /* RE_ENABLE_I18N */ if (pstr->mbs_allocated) { unsigned char *new_mbs = re_realloc (pstr->mbs, unsigned char, @@ -194,7 +186,6 @@ re_string_construct_common (const char *str, Idx len, re_string_t *pstr, pstr->raw_stop = pstr->stop; } -#ifdef RE_ENABLE_I18N /* Build wide character buffer PSTR->WCS. If the byte sequence of the string are: @@ -530,7 +521,6 @@ re_string_skip_chars (re_string_t *pstr, Idx new_raw_idx, wint_t *last_wc) *last_wc = wc; return rawbuf_idx; } -#endif /* RE_ENABLE_I18N */ /* Build the buffer PSTR->MBS, and apply the translation if we need. This function is used in case of REG_ICASE. */ @@ -585,10 +575,8 @@ re_string_reconstruct (re_string_t *pstr, Idx idx, int eflags) else { /* Reset buffer. */ -#ifdef RE_ENABLE_I18N if (pstr->mb_cur_max > 1) memset (&pstr->cur_state, '\0', sizeof (mbstate_t)); -#endif /* RE_ENABLE_I18N */ pstr->len = pstr->raw_len; pstr->stop = pstr->raw_stop; pstr->valid_len = 0; @@ -608,7 +596,6 @@ re_string_reconstruct (re_string_t *pstr, Idx idx, int eflags) if (__glibc_likely (offset < pstr->valid_raw_len)) { /* Yes, move them to the front of the buffer. */ -#ifdef RE_ENABLE_I18N if (__glibc_unlikely (pstr->offsets_needed)) { Idx low = 0, high = pstr->valid_len, mid; @@ -672,15 +659,12 @@ re_string_reconstruct (re_string_t *pstr, Idx idx, int eflags) } } else -#endif { pstr->tip_context = re_string_context_at (pstr, offset - 1, eflags); -#ifdef RE_ENABLE_I18N if (pstr->mb_cur_max > 1) memmove (pstr->wcs, pstr->wcs + offset, (pstr->valid_len - offset) * sizeof (wint_t)); -#endif /* RE_ENABLE_I18N */ if (__glibc_unlikely (pstr->mbs_allocated)) memmove (pstr->mbs, pstr->mbs + offset, pstr->valid_len - offset); @@ -691,7 +675,6 @@ re_string_reconstruct (re_string_t *pstr, Idx idx, int eflags) } else { -#ifdef RE_ENABLE_I18N /* No, skip all characters until IDX. */ Idx prev_valid_len = pstr->valid_len; @@ -701,9 +684,7 @@ re_string_reconstruct (re_string_t *pstr, Idx idx, int eflags) pstr->stop = pstr->raw_stop - idx + offset; pstr->offsets_needed = 0; } -#endif pstr->valid_len = 0; -#ifdef RE_ENABLE_I18N if (pstr->mb_cur_max > 1) { Idx wcs_idx; @@ -787,7 +768,6 @@ re_string_reconstruct (re_string_t *pstr, Idx idx, int eflags) pstr->valid_raw_len = pstr->valid_len; } else -#endif /* RE_ENABLE_I18N */ { int c = pstr->raw_mbs[pstr->raw_mbs_idx + offset - 1]; pstr->valid_raw_len = 0; @@ -807,7 +787,6 @@ re_string_reconstruct (re_string_t *pstr, Idx idx, int eflags) pstr->stop -= offset; /* Then build the buffers. */ -#ifdef RE_ENABLE_I18N if (pstr->mb_cur_max > 1) { if (pstr->icase) @@ -820,7 +799,6 @@ re_string_reconstruct (re_string_t *pstr, Idx idx, int eflags) build_wcs_buffer (pstr); } else -#endif /* RE_ENABLE_I18N */ if (__glibc_unlikely (pstr->mbs_allocated)) { if (pstr->icase) @@ -846,28 +824,22 @@ re_string_peek_byte_case (const re_string_t *pstr, Idx idx) if (__glibc_likely (!pstr->mbs_allocated)) return re_string_peek_byte (pstr, idx); -#ifdef RE_ENABLE_I18N if (pstr->mb_cur_max > 1 && ! re_string_is_single_byte_char (pstr, pstr->cur_idx + idx)) return re_string_peek_byte (pstr, idx); -#endif off = pstr->cur_idx + idx; -#ifdef RE_ENABLE_I18N if (pstr->offsets_needed) off = pstr->offsets[off]; -#endif ch = pstr->raw_mbs[pstr->raw_mbs_idx + off]; -#ifdef RE_ENABLE_I18N /* Ensure that e.g. for tr_TR.UTF-8 BACKSLASH DOTLESS SMALL LETTER I this function returns CAPITAL LETTER I instead of first byte of DOTLESS SMALL LETTER I. The latter would confuse the parser, since peek_byte_case doesn't advance cur_idx in any way. */ if (pstr->offsets_needed && !isascii (ch)) return re_string_peek_byte (pstr, idx); -#endif return ch; } @@ -878,7 +850,6 @@ re_string_fetch_byte_case (re_string_t *pstr) if (__glibc_likely (!pstr->mbs_allocated)) return re_string_fetch_byte (pstr); -#ifdef RE_ENABLE_I18N if (pstr->offsets_needed) { Idx off; @@ -904,7 +875,6 @@ re_string_fetch_byte_case (re_string_t *pstr) re_string_char_size_at (pstr, pstr->cur_idx)); return ch; } -#endif return pstr->raw_mbs[pstr->raw_mbs_idx + pstr->cur_idx++]; } @@ -912,10 +882,8 @@ re_string_fetch_byte_case (re_string_t *pstr) static void re_string_destruct (re_string_t *pstr) { -#ifdef RE_ENABLE_I18N re_free (pstr->wcs); re_free (pstr->offsets); -#endif /* RE_ENABLE_I18N */ if (pstr->mbs_allocated) re_free (pstr->mbs); } @@ -933,7 +901,6 @@ re_string_context_at (const re_string_t *input, Idx idx, int eflags) if (__glibc_unlikely (idx == input->len)) return ((eflags & REG_NOTEOL) ? CONTEXT_ENDBUF : CONTEXT_NEWLINE | CONTEXT_ENDBUF); -#ifdef RE_ENABLE_I18N if (input->mb_cur_max > 1) { wint_t wc; @@ -953,7 +920,6 @@ re_string_context_at (const re_string_t *input, Idx idx, int eflags) ? CONTEXT_NEWLINE : 0); } else -#endif { c = re_string_byte_at (input, idx); if (bitset_contain (input->word_char, c)) @@ -1451,11 +1417,9 @@ re_dfa_add_node (re_dfa_t *dfa, re_token_t token) } dfa->nodes[dfa->nodes_len] = token; dfa->nodes[dfa->nodes_len].constraint = 0; -#ifdef RE_ENABLE_I18N dfa->nodes[dfa->nodes_len].accept_mb = ((token.type == OP_PERIOD && dfa->mb_cur_max > 1) || token.type == COMPLEX_BRACKET); -#endif dfa->nexts[dfa->nodes_len] = -1; re_node_set_init_empty (dfa->edests + dfa->nodes_len); re_node_set_init_empty (dfa->eclosures + dfa->nodes_len); @@ -1651,9 +1615,7 @@ create_ci_newstate (const re_dfa_t *dfa, const re_node_set *nodes, re_token_type_t type = node->type; if (type == CHARACTER && !node->constraint) continue; -#ifdef RE_ENABLE_I18N newstate->accept_mb |= node->accept_mb; -#endif /* RE_ENABLE_I18N */ /* If the state has the halt node, the state is a halt state. */ if (type == END_OF_RE) @@ -1705,9 +1667,7 @@ create_cd_newstate (const re_dfa_t *dfa, const re_node_set *nodes, if (type == CHARACTER && !constraint) continue; -#ifdef RE_ENABLE_I18N newstate->accept_mb |= node->accept_mb; -#endif /* RE_ENABLE_I18N */ /* If the state has the halt node, the state is a halt state. */ if (type == END_OF_RE) diff --git a/lib/regex_internal.h b/lib/regex_internal.h index 1245e782ffc..8493db2701a 100644 --- a/lib/regex_internal.h +++ b/lib/regex_internal.h @@ -116,10 +116,6 @@ # define gettext_noop(String) String #endif -#if (defined MB_CUR_MAX && HAVE_WCTYPE_H && HAVE_ISWCTYPE) || _LIBC -# define RE_ENABLE_I18N -#endif - /* Number of ASCII characters. */ #define ASCII_CHARS 0x80 @@ -150,6 +146,11 @@ # define __regfree regfree #endif /* not _LIBC */ +/* Types related to integers. Unless protected by #ifdef _LIBC, the + regex code should avoid exact-width types like int32_t and uint64_t + as some non-GCC platforms lack them, an issue when this code is + used in Gnulib. */ + #ifndef SSIZE_MAX # define SSIZE_MAX ((ssize_t) (SIZE_MAX / 2)) #endif @@ -246,10 +247,8 @@ typedef enum SIMPLE_BRACKET = 3, OP_BACK_REF = 4, OP_PERIOD = 5, -#ifdef RE_ENABLE_I18N COMPLEX_BRACKET = 6, OP_UTF8_PERIOD = 7, -#endif /* RE_ENABLE_I18N */ /* We define EPSILON_BIT as a macro so that OP_OPEN_SUBEXP is used when the debugger shows values of this enum type. */ @@ -287,30 +286,29 @@ typedef enum } re_token_type_t; -#ifdef RE_ENABLE_I18N typedef struct { /* Multibyte characters. */ wchar_t *mbchars; +#ifdef _LIBC /* Collating symbols. */ -# ifdef _LIBC int32_t *coll_syms; -# endif +#endif +#ifdef _LIBC /* Equivalence classes. */ -# ifdef _LIBC int32_t *equiv_classes; -# endif +#endif /* Range expressions. */ -# ifdef _LIBC +#ifdef _LIBC uint32_t *range_starts; uint32_t *range_ends; -# else /* not _LIBC */ +#else wchar_t *range_starts; wchar_t *range_ends; -# endif /* not _LIBC */ +#endif /* Character classes. */ wctype_t *char_classes; @@ -333,7 +331,6 @@ typedef struct /* # of character classes. */ Idx nchar_classes; } re_charset_t; -#endif /* RE_ENABLE_I18N */ typedef struct { @@ -341,9 +338,7 @@ typedef struct { unsigned char c; /* for CHARACTER */ re_bitset_ptr_t sbcset; /* for SIMPLE_BRACKET */ -#ifdef RE_ENABLE_I18N re_charset_t *mbcset; /* for COMPLEX_BRACKET */ -#endif /* RE_ENABLE_I18N */ Idx idx; /* for BACK_REF */ re_context_type ctx_type; /* for ANCHOR */ } opr; @@ -355,12 +350,10 @@ typedef struct unsigned int constraint : 10; /* context constraint */ unsigned int duplicated : 1; unsigned int opt_subexp : 1; -#ifdef RE_ENABLE_I18N unsigned int accept_mb : 1; /* These 2 bits can be moved into the union if needed (e.g. if running out of bits; move opr.c to opr.c.c and move the flags to opr.c.flags). */ unsigned int mb_partial : 1; -#endif unsigned int word_char : 1; } re_token_t; @@ -375,12 +368,10 @@ struct re_string_t REG_ICASE, upper cases of the string are stored, otherwise MBS points the same address that RAW_MBS points. */ unsigned char *mbs; -#ifdef RE_ENABLE_I18N /* Store the wide character string which is corresponding to MBS. */ wint_t *wcs; Idx *offsets; mbstate_t cur_state; -#endif /* Index in RAW_MBS. Each character mbs[i] corresponds to raw_mbs[raw_mbs_idx + i]. */ Idx raw_mbs_idx; @@ -779,7 +770,6 @@ bitset_mask (bitset_t dest, const bitset_t src) dest[bitset_i] &= src[bitset_i]; } -#ifdef RE_ENABLE_I18N /* Functions for re_string. */ static int __attribute__ ((pure, unused)) @@ -803,15 +793,15 @@ re_string_wchar_at (const re_string_t *pstr, Idx idx) return (wint_t) pstr->wcs[idx]; } -# ifdef _LIBC -# include <locale/weight.h> -# endif +#ifdef _LIBC +# include <locale/weight.h> +#endif static int __attribute__ ((pure, unused)) re_string_elem_size_at (const re_string_t *pstr, Idx idx) { -# ifdef _LIBC +#ifdef _LIBC const unsigned char *p, *extra; const int32_t *table, *indirect; uint_fast32_t nrules = _NL_CURRENT_WORD (LC_COLLATE, _NL_COLLATE_NRULES); @@ -827,11 +817,10 @@ re_string_elem_size_at (const re_string_t *pstr, Idx idx) findidx (table, indirect, extra, &p, pstr->len - idx); return p - pstr->mbs - idx; } - else -# endif /* _LIBC */ - return 1; +#endif /* _LIBC */ + + return 1; } -#endif /* RE_ENABLE_I18N */ #ifdef _LIBC # if __GNUC__ >= 7 diff --git a/lib/regexec.c b/lib/regexec.c index 83e9aaf8cad..3196708373f 100644 --- a/lib/regexec.c +++ b/lib/regexec.c @@ -67,11 +67,9 @@ static reg_errcode_t set_regs (const regex_t *preg, bool fl_backtrack); static reg_errcode_t free_fail_stack_return (struct re_fail_stack_t *fs); -#ifdef RE_ENABLE_I18N static int sift_states_iter_mb (const re_match_context_t *mctx, re_sift_context_t *sctx, Idx node_idx, Idx str_idx, Idx max_str_idx); -#endif /* RE_ENABLE_I18N */ static reg_errcode_t sift_states_backward (const re_match_context_t *mctx, re_sift_context_t *sctx); static reg_errcode_t build_sifted_states (const re_match_context_t *mctx, @@ -123,10 +121,8 @@ static re_dfastate_t *transit_state_sb (reg_errcode_t *err, re_match_context_t *mctx, re_dfastate_t *pstate); #endif -#ifdef RE_ENABLE_I18N static reg_errcode_t transit_state_mb (re_match_context_t *mctx, re_dfastate_t *pstate); -#endif /* RE_ENABLE_I18N */ static reg_errcode_t transit_state_bkref (re_match_context_t *mctx, const re_node_set *nodes); static reg_errcode_t get_subexp (re_match_context_t *mctx, @@ -156,14 +152,12 @@ static reg_errcode_t expand_bkref_cache (re_match_context_t *mctx, re_node_set *cur_nodes, Idx cur_str, Idx subexp_num, int type); static bool build_trtable (const re_dfa_t *dfa, re_dfastate_t *state); -#ifdef RE_ENABLE_I18N static int check_node_accept_bytes (const re_dfa_t *dfa, Idx node_idx, const re_string_t *input, Idx idx); -# ifdef _LIBC +#ifdef _LIBC static unsigned int find_collation_sequence_value (const unsigned char *mbs, size_t name_len); -# endif /* _LIBC */ -#endif /* RE_ENABLE_I18N */ +#endif static Idx group_nodes_into_DFAstates (const re_dfa_t *dfa, const re_dfastate_t *state, re_node_set *states_node, @@ -758,10 +752,9 @@ re_search_internal (const regex_t *preg, const char *string, Idx length, offset = match_first - mctx.input.raw_mbs_idx; } - /* If MATCH_FIRST is out of the buffer, leave it as '\0'. - Note that MATCH_FIRST must not be smaller than 0. */ - ch = (match_first >= length - ? 0 : re_string_byte_at (&mctx.input, offset)); + /* Use buffer byte if OFFSET is in buffer, otherwise '\0'. */ + ch = (offset < mctx.input.valid_len + ? re_string_byte_at (&mctx.input, offset) : 0); if (fastmap[ch]) break; match_first += incr; @@ -780,12 +773,10 @@ re_search_internal (const regex_t *preg, const char *string, Idx length, if (__glibc_unlikely (err != REG_NOERROR)) goto free_return; -#ifdef RE_ENABLE_I18N - /* Don't consider this char as a possible match start if it part, - yet isn't the head, of a multibyte character. */ + /* Don't consider this char as a possible match start if it part, + yet isn't the head, of a multibyte character. */ if (!sb && !re_string_first_byte (&mctx.input, 0)) continue; -#endif /* It seems to be appropriate one, then use the matcher. */ /* We assume that the matching starts from 0. */ @@ -859,7 +850,6 @@ re_search_internal (const regex_t *preg, const char *string, Idx length, for (reg_idx = 0; reg_idx < nmatch; ++reg_idx) if (pmatch[reg_idx].rm_so != -1) { -#ifdef RE_ENABLE_I18N if (__glibc_unlikely (mctx.input.offsets_needed != 0)) { pmatch[reg_idx].rm_so = @@ -871,9 +861,6 @@ re_search_internal (const regex_t *preg, const char *string, Idx length, ? mctx.input.valid_raw_len : mctx.input.offsets[pmatch[reg_idx].rm_eo]); } -#else - DEBUG_ASSERT (mctx.input.offsets_needed == 0); -#endif pmatch[reg_idx].rm_so += match_first; pmatch[reg_idx].rm_eo += match_first; } @@ -997,8 +984,7 @@ prune_impossible_nodes (re_match_context_t *mctx) We must select appropriate initial state depending on the context, since initial states may have constraints like "\<", "^", etc.. */ -static inline re_dfastate_t * -__attribute__ ((always_inline)) +static __always_inline re_dfastate_t * acquire_init_state_context (reg_errcode_t *err, const re_match_context_t *mctx, Idx idx) { @@ -1262,12 +1248,9 @@ proceed_next_node (const re_match_context_t *mctx, Idx nregs, regmatch_t *regs, Idx naccepted = 0; re_token_type_t type = dfa->nodes[node].type; -#ifdef RE_ENABLE_I18N if (dfa->nodes[node].accept_mb) naccepted = check_node_accept_bytes (dfa, node, &mctx->input, *pidx); - else -#endif /* RE_ENABLE_I18N */ - if (type == OP_BACK_REF) + else if (type == OP_BACK_REF) { Idx subexp_idx = dfa->nodes[node].opr.idx + 1; if (subexp_idx < nregs) @@ -1635,12 +1618,10 @@ build_sifted_states (const re_match_context_t *mctx, re_sift_context_t *sctx, bool ok; DEBUG_ASSERT (!IS_EPSILON_NODE (dfa->nodes[prev_node].type)); -#ifdef RE_ENABLE_I18N /* If the node may accept "multi byte". */ if (dfa->nodes[prev_node].accept_mb) naccepted = sift_states_iter_mb (mctx, sctx, prev_node, str_idx, sctx->last_str_idx); -#endif /* RE_ENABLE_I18N */ /* We don't check backreferences here. See update_cur_sifted_state(). */ @@ -1689,6 +1670,7 @@ clean_state_log_if_needed (re_match_context_t *mctx, Idx next_state_log_idx) if (top < next_state_log_idx) { + DEBUG_ASSERT (mctx->state_log != NULL); memset (mctx->state_log + top + 1, '\0', sizeof (re_dfastate_t *) * (next_state_log_idx - top)); mctx->state_log_top = next_state_log_idx; @@ -2177,7 +2159,6 @@ sift_states_bkref (const re_match_context_t *mctx, re_sift_context_t *sctx, } -#ifdef RE_ENABLE_I18N static int sift_states_iter_mb (const re_match_context_t *mctx, re_sift_context_t *sctx, Idx node_idx, Idx str_idx, Idx max_str_idx) @@ -2197,8 +2178,6 @@ sift_states_iter_mb (const re_match_context_t *mctx, re_sift_context_t *sctx, 'naccepted' bytes input. */ return naccepted; } -#endif /* RE_ENABLE_I18N */ - /* Functions for state transition. */ @@ -2216,7 +2195,6 @@ transit_state (reg_errcode_t *err, re_match_context_t *mctx, re_dfastate_t **trtable; unsigned char ch; -#ifdef RE_ENABLE_I18N /* If the current state can accept multibyte. */ if (__glibc_unlikely (state->accept_mb)) { @@ -2224,7 +2202,6 @@ transit_state (reg_errcode_t *err, re_match_context_t *mctx, if (__glibc_unlikely (*err != REG_NOERROR)) return NULL; } -#endif /* RE_ENABLE_I18N */ /* Then decide the next state with the single byte. */ #if 0 @@ -2445,7 +2422,6 @@ transit_state_sb (reg_errcode_t *err, re_match_context_t *mctx, } #endif -#ifdef RE_ENABLE_I18N static reg_errcode_t transit_state_mb (re_match_context_t *mctx, re_dfastate_t *pstate) { @@ -2513,7 +2489,6 @@ transit_state_mb (re_match_context_t *mctx, re_dfastate_t *pstate) } return REG_NOERROR; } -#endif /* RE_ENABLE_I18N */ static reg_errcode_t transit_state_bkref (re_match_context_t *mctx, const re_node_set *nodes) @@ -3003,9 +2978,7 @@ check_arrival_add_next_nodes (re_match_context_t *mctx, Idx str_idx, const re_dfa_t *const dfa = mctx->dfa; bool ok; Idx cur_idx; -#ifdef RE_ENABLE_I18N reg_errcode_t err = REG_NOERROR; -#endif re_node_set union_set; re_node_set_init_empty (&union_set); for (cur_idx = 0; cur_idx < cur_nodes->nelem; ++cur_idx) @@ -3014,7 +2987,6 @@ check_arrival_add_next_nodes (re_match_context_t *mctx, Idx str_idx, Idx cur_node = cur_nodes->elems[cur_idx]; DEBUG_ASSERT (!IS_EPSILON_NODE (dfa->nodes[cur_node].type)); -#ifdef RE_ENABLE_I18N /* If the node may accept "multi byte". */ if (dfa->nodes[cur_node].accept_mb) { @@ -3052,7 +3024,7 @@ check_arrival_add_next_nodes (re_match_context_t *mctx, Idx str_idx, } } } -#endif /* RE_ENABLE_I18N */ + if (naccepted || check_node_accept (mctx, dfa->nodes + cur_node, str_idx)) { @@ -3476,18 +3448,15 @@ group_nodes_into_DFAstates (const re_dfa_t *dfa, const re_dfastate_t *state, } else if (type == OP_PERIOD) { -#ifdef RE_ENABLE_I18N if (dfa->mb_cur_max > 1) bitset_merge (accepts, dfa->sb_char); else -#endif bitset_set_all (accepts); if (!(dfa->syntax & RE_DOT_NEWLINE)) bitset_clear (accepts, '\n'); if (dfa->syntax & RE_DOT_NOT_NULL) bitset_clear (accepts, '\0'); } -#ifdef RE_ENABLE_I18N else if (type == OP_UTF8_PERIOD) { if (ASCII_CHARS % BITSET_WORD_BITS == 0) @@ -3499,7 +3468,6 @@ group_nodes_into_DFAstates (const re_dfa_t *dfa, const re_dfastate_t *state, if (dfa->syntax & RE_DOT_NOT_NULL) bitset_clear (accepts, '\0'); } -#endif else continue; @@ -3530,12 +3498,10 @@ group_nodes_into_DFAstates (const re_dfa_t *dfa, const re_dfastate_t *state, bitset_empty (accepts); continue; } -#ifdef RE_ENABLE_I18N if (dfa->mb_cur_max > 1) for (j = 0; j < BITSET_WORDS; ++j) any_set |= (accepts[j] &= (dfa->word_char[j] | ~dfa->sb_char[j])); else -#endif for (j = 0; j < BITSET_WORDS; ++j) any_set |= (accepts[j] &= dfa->word_char[j]); if (!any_set) @@ -3549,12 +3515,10 @@ group_nodes_into_DFAstates (const re_dfa_t *dfa, const re_dfastate_t *state, bitset_empty (accepts); continue; } -#ifdef RE_ENABLE_I18N if (dfa->mb_cur_max > 1) for (j = 0; j < BITSET_WORDS; ++j) any_set |= (accepts[j] &= ~(dfa->word_char[j] & dfa->sb_char[j])); else -#endif for (j = 0; j < BITSET_WORDS; ++j) any_set |= (accepts[j] &= ~dfa->word_char[j]); if (!any_set) @@ -3631,7 +3595,6 @@ group_nodes_into_DFAstates (const re_dfa_t *dfa, const re_dfastate_t *state, return -1; } -#ifdef RE_ENABLE_I18N /* Check how many bytes the node 'dfa->nodes[node_idx]' accepts. Return the number of the bytes the node accepts. STR_IDX is the current index of the input string. @@ -3640,9 +3603,9 @@ group_nodes_into_DFAstates (const re_dfa_t *dfa, const re_dfastate_t *state, one collating element like '.', '[a-z]', opposite to the other nodes can only accept one byte. */ -# ifdef _LIBC -# include <locale/weight.h> -# endif +#ifdef _LIBC +# include <locale/weight.h> +#endif static int check_node_accept_bytes (const re_dfa_t *dfa, Idx node_idx, @@ -3726,12 +3689,12 @@ check_node_accept_bytes (const re_dfa_t *dfa, Idx node_idx, if (node->type == COMPLEX_BRACKET) { const re_charset_t *cset = node->opr.mbcset; -# ifdef _LIBC +#ifdef _LIBC const unsigned char *pin = ((const unsigned char *) re_string_get_buffer (input) + str_idx); Idx j; uint32_t nrules; -# endif /* _LIBC */ +#endif int match_len = 0; wchar_t wc = ((cset->nranges || cset->nchar_classes || cset->nmbchars) ? re_string_wchar_at (input, str_idx) : 0); @@ -3754,7 +3717,7 @@ check_node_accept_bytes (const re_dfa_t *dfa, Idx node_idx, } } -# ifdef _LIBC +#ifdef _LIBC nrules = _NL_CURRENT_WORD (LC_COLLATE, _NL_COLLATE_NRULES); if (nrules != 0) { @@ -3843,7 +3806,7 @@ check_node_accept_bytes (const re_dfa_t *dfa, Idx node_idx, } } else -# endif /* _LIBC */ +#endif /* _LIBC */ { /* match with range expression? */ for (i = 0; i < cset->nranges; ++i) @@ -3869,7 +3832,7 @@ check_node_accept_bytes (const re_dfa_t *dfa, Idx node_idx, return 0; } -# ifdef _LIBC +#ifdef _LIBC static unsigned int find_collation_sequence_value (const unsigned char *mbs, size_t mbs_len) { @@ -3927,8 +3890,7 @@ find_collation_sequence_value (const unsigned char *mbs, size_t mbs_len) return UINT_MAX; } } -# endif /* _LIBC */ -#endif /* RE_ENABLE_I18N */ +#endif /* _LIBC */ /* Check whether the node accepts the byte which is IDX-th byte of the INPUT. */ @@ -3951,12 +3913,10 @@ check_node_accept (const re_match_context_t *mctx, const re_token_t *node, return false; break; -#ifdef RE_ENABLE_I18N case OP_UTF8_PERIOD: if (ch >= ASCII_CHARS) return false; FALLTHROUGH; -#endif case OP_PERIOD: if ((ch == '\n' && !(mctx->dfa->syntax & RE_DOT_NEWLINE)) || (ch == '\0' && (mctx->dfa->syntax & RE_DOT_NOT_NULL))) @@ -4017,7 +3977,6 @@ extend_buffers (re_match_context_t *mctx, int min_len) /* Then reconstruct the buffers. */ if (pstr->icase) { -#ifdef RE_ENABLE_I18N if (pstr->mb_cur_max > 1) { ret = build_wcs_upper_buffer (pstr); @@ -4025,16 +3984,13 @@ extend_buffers (re_match_context_t *mctx, int min_len) return ret; } else -#endif /* RE_ENABLE_I18N */ build_upper_buffer (pstr); } else { -#ifdef RE_ENABLE_I18N if (pstr->mb_cur_max > 1) build_wcs_buffer (pstr); else -#endif /* RE_ENABLE_I18N */ { if (pstr->trans != NULL) re_string_translate_buffer (pstr); diff --git a/lib/string.in.h b/lib/string.in.h index 8d77ae38000..afe73508677 100644 --- a/lib/string.in.h +++ b/lib/string.in.h @@ -67,6 +67,35 @@ # include <strings.h> #endif +/* _GL_ATTRIBUTE_DEALLOC (F, I) declares that the function returns pointers + that can be freed by passing them as the Ith argument to the + function F. */ +#ifndef _GL_ATTRIBUTE_DEALLOC +# if __GNUC__ >= 11 +# define _GL_ATTRIBUTE_DEALLOC(f, i) __attribute__ ((__malloc__ (f, i))) +# else +# define _GL_ATTRIBUTE_DEALLOC(f, i) +# endif +#endif + +/* _GL_ATTRIBUTE_DEALLOC_FREE declares that the function returns pointers that + can be freed via 'free'; it can be used only after declaring 'free'. */ +/* Applies to: functions. Cannot be used on inline functions. */ +#ifndef _GL_ATTRIBUTE_DEALLOC_FREE +# define _GL_ATTRIBUTE_DEALLOC_FREE _GL_ATTRIBUTE_DEALLOC (free, 1) +#endif + +/* _GL_ATTRIBUTE_MALLOC declares that the function returns a pointer to freshly + allocated memory. */ +/* Applies to: functions. */ +#ifndef _GL_ATTRIBUTE_MALLOC +# if __GNUC__ >= 3 || defined __clang__ +# define _GL_ATTRIBUTE_MALLOC __attribute__ ((__malloc__)) +# else +# define _GL_ATTRIBUTE_MALLOC +# endif +#endif + /* The __attribute__ feature is available in gcc versions 2.5 and later. The attribute __pure__ was added in gcc 2.96. */ #ifndef _GL_ATTRIBUTE_PURE diff --git a/lib/sys_random.in.h b/lib/sys_random.in.h index 1abd6c544e0..8b4b934a1e7 100644 --- a/lib/sys_random.in.h +++ b/lib/sys_random.in.h @@ -23,8 +23,10 @@ #if @HAVE_SYS_RANDOM_H@ -/* On uClibc, <sys/random.h> assumes prior inclusion of <stddef.h>. */ -# if defined __UCLIBC__ +/* On uClibc < 1.0.35, <sys/random.h> assumes prior inclusion of <stddef.h>. + Do not use __UCLIBC__ here, as it might not be defined yet. + But avoid namespace pollution on glibc systems. */ +# ifndef __GLIBC__ # include <stddef.h> # endif /* On Mac OS X 10.5, <sys/random.h> assumes prior inclusion of <sys/types.h>. diff --git a/lib/warn-on-use.h b/lib/warn-on-use.h index 612937abb02..39842946160 100644 --- a/lib/warn-on-use.h +++ b/lib/warn-on-use.h @@ -84,20 +84,20 @@ # if 4 < __GNUC__ || (__GNUC__ == 4 && 3 <= __GNUC_MINOR__) /* A compiler attribute is available in gcc versions 4.3.0 and later. */ # define _GL_WARN_ON_USE(function, message) \ -extern __typeof__ (function) function __attribute__ ((__warning__ (message))) +_GL_WARN_EXTERN_C __typeof__ (function) function __attribute__ ((__warning__ (message))) # define _GL_WARN_ON_USE_ATTRIBUTE(message) \ __attribute__ ((__warning__ (message))) # elif __clang_major__ >= 4 /* Another compiler attribute is available in clang. */ # define _GL_WARN_ON_USE(function, message) \ -extern __typeof__ (function) function \ +_GL_WARN_EXTERN_C __typeof__ (function) function \ __attribute__ ((__diagnose_if__ (1, message, "warning"))) # define _GL_WARN_ON_USE_ATTRIBUTE(message) \ __attribute__ ((__diagnose_if__ (1, message, "warning"))) # elif __GNUC__ >= 3 && GNULIB_STRICT_CHECKING /* Verify the existence of the function. */ # define _GL_WARN_ON_USE(function, message) \ -extern __typeof__ (function) function +_GL_WARN_EXTERN_C __typeof__ (function) function # define _GL_WARN_ON_USE_ATTRIBUTE(message) # else /* Unsupported. */ # define _GL_WARN_ON_USE(function, message) \ diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 3e764c5a787..0c0c3f12acb 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -60,7 +60,7 @@ BYTE_COMPILE_EXTRA_FLAGS = # The example above is just for developers, it should not be used by default. # Those automatically generated autoload files that need special rules -# to build; ie not including things created via generated-autoload-file +# to build; i.e. not including things created via generated-autoload-file # (eg calc/calc-loaddefs.el). LOADDEFS = $(lisp)/calendar/cal-loaddefs.el \ $(lisp)/calendar/diary-loaddefs.el \ @@ -91,25 +91,14 @@ COMPILE_FIRST = \ $(lisp)/emacs-lisp/byte-opt.elc \ $(lisp)/emacs-lisp/bytecomp.elc ifeq ($(HAVE_NATIVE_COMP),yes) -COMPILE_FIRST += \ - $(lisp)/emacs-lisp/comp.elc \ - $(lisp)/emacs-lisp/comp-cstr.elc \ - $(lisp)/emacs-lisp/cl-macs.elc \ - $(lisp)/emacs-lisp/rx.elc \ - $(lisp)/emacs-lisp/cl-seq.elc \ - $(lisp)/help-mode.elc \ - $(lisp)/emacs-lisp/cl-extra.elc \ - $(lisp)/emacs-lisp/gv.elc \ - $(lisp)/emacs-lisp/seq.elc \ - $(lisp)/emacs-lisp/cl-lib.elc \ - $(lisp)/emacs-lisp/warnings.elc \ - $(lisp)/emacs-lisp/subr-x.elc +COMPILE_FIRST += $(lisp)/emacs-lisp/comp.elc +COMPILE_FIRST += $(lisp)/emacs-lisp/comp-cstr.elc endif COMPILE_FIRST += $(lisp)/emacs-lisp/autoload.elc # Files to compile early in compile-main. Works around bug#25556. MAIN_FIRST = ./emacs-lisp/eieio.el ./emacs-lisp/eieio-base.el \ - ./cedet/semantic/db.el + ./cedet/semantic/db.el ./emacs-lisp/cconv.el # Prevent any settings in the user environment causing problems. unexport EMACSDATA EMACSDOC EMACSPATH @@ -216,6 +205,9 @@ autoloads-force: rm -f $(lisp)/loaddefs.el $(MAKE) autoloads +ldefs-boot.el: autoloads-force + cp $(lisp)/loaddefs.el $(lisp)/ldefs-boot.el + # This is required by the bootstrap-emacs target in ../src/Makefile, so # we know that if we have an emacs executable, we also have a subdirs.el. $(lisp)/subdirs.el: @@ -263,9 +255,9 @@ ${ETAGS}: FORCE ## compile-main. But maybe this is not even necessary any more now ## that this uses relative filenames. TAGS: ${ETAGS} ${tagsfiles} - $(AM_V_at)rm -f $@ + $(AM_V_GEN)rm -f $@ $(AM_V_at)touch $@ - $(AM_V_GEN)ls ${tagsfiles} | xargs $(XARGS_LIMIT) "${ETAGS}" -a -o $@ + $(AM_V_at)ls ${tagsfiles} | xargs $(XARGS_LIMIT) "${ETAGS}" -a -o $@ # The src/Makefile.in has its own set of dependencies and when they decide @@ -346,10 +338,10 @@ endif # Compile all the Elisp files that need it. Beware: it approximates # 'no-byte-compile', so watch out for false-positives! -compile-main: gen-lisp compile-clean +compile-main: gen-lisp compile-clean main-first @(cd $(lisp) && \ els=`echo "${SUBDIRS_REL} " | sed -e 's|/\./|/|g' -e 's|/\. | |g' -e 's| |/*.el |g'`; \ - for el in ${MAIN_FIRST} $$els; do \ + for el in $$els; do \ test -f $$el || continue; \ test ! -f $${el}c && \ GREP_OPTIONS= grep '^;.*[^a-zA-Z]no-byte-compile: *t' $$el > /dev/null && \ @@ -362,6 +354,18 @@ compile-main: gen-lisp compile-clean TARGETS="$$chunk"; \ done +# Compile some important files first. +main-first: + @(cd $(lisp) && \ + for el in ${MAIN_FIRST}; do \ + echo "$${el}c"; \ + done | xargs $(XARGS_LIMIT) echo) | \ + while read chunk; do \ + $(MAKE) compile-targets \ + NATIVE_DISABLED=$(NATIVE_SKIP_NONDUMP) \ + TARGETS="$$chunk"; \ + done + .PHONY: compile-clean # Erase left-over .elc files that do not have a corresponding .el file. compile-clean: diff --git a/lisp/abbrev.el b/lisp/abbrev.el index b0e8a4fa99c..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 @@ -583,6 +583,7 @@ PROPS is a property list. The following properties are special: An obsolete but still supported calling form is: \(define-abbrev TABLE NAME EXPANSION &optional HOOK COUNT SYSTEM)." + (declare (indent defun)) (when (and (consp props) (or (null (car props)) (numberp (car props)))) ;; Old-style calling convention. (setq props `(:count ,(car props) @@ -1139,7 +1140,7 @@ Properties with special meaning: - `:enable-function' can be set to a function of no argument which returns non-nil if and only if the abbrevs in this table should be used for this instance of `expand-abbrev'." - (declare (doc-string 3)) + (declare (doc-string 3) (indent defun)) ;; We used to manually add the docstring, but we also want to record this ;; location as the definition of the variable (in load-history), so we may ;; as well just use `defvar'. diff --git a/lisp/align.el b/lisp/align.el index 7ced7b70445..2fd6dcda6d7 100644 --- a/lisp/align.el +++ b/lisp/align.el @@ -553,8 +553,7 @@ The possible settings for `align-region-separate' are: (modes . align-text-modes) (repeat . t) (run-if . ,(lambda () - (and current-prefix-arg - (not (eq '- current-prefix-arg)))))) + (not (eq '- current-prefix-arg))))) ;; With a negative prefix argument, lists of dollar figures will ;; be aligned. @@ -836,11 +835,22 @@ See the variable `align-exclude-rules-list' for more details.") ;;;###autoload (defun align (beg end &optional separate rules exclude-rules) "Attempt to align a region based on a set of alignment rules. -BEG and END mark the region. If BEG and END are specifically set to -nil (this can only be done programmatically), the beginning and end of -the current alignment section will be calculated based on the location -of point, and the value of `align-region-separate' (or possibly each -rule's `separate' attribute). +Interactively, BEG and END are the mark/point of the current region. + +Many modes define specific alignment rules, and some of these +rules in some modes react to the current prefix argument. For +instance, in `text-mode', `M-x align' will align into columns +based on space delimiters, while `C-u - M-x align' will align +into columns based on the \"$\" character. See the +`align-rules-list' variable definition for the specific rules. + +Also see `align-regexp', which will guide you through various +parameters for aligning text. + +Non-interactively, if BEG and END are nil, the beginning and end +of the current alignment section will be calculated based on the +location of point, and the value of `align-region-separate' (or +possibly each rule's `separate' attribute). If SEPARATE is non-nil, it overrides the value of `align-region-separate' for all rules, except those that have their @@ -889,6 +899,15 @@ on the format of these lists." BEG and END mark the limits of the region. Interactively, this function prompts for the regular expression REGEXP to align with. +Interactively, if you specify a prefix argument, the function +will guide you through entering the full regular expression, and +then prompts for which subexpression parenthesis GROUP (default +1) within REGEXP to modify, the amount of SPACING (default +`align-default-spacing') to use, and whether or not to REPEAT the +rule throughout the line. + +See `align-rules-list' for more information about these options. + For example, let's say you had a list of phone numbers, and wanted to align them so that the opening parentheses would line up: @@ -908,15 +927,8 @@ regular expression after you enter it. Interactively, you only need to supply the characters to be lined up, and any preceding whitespace is replaced. -Non-interactively (or if you specify a prefix argument), you must -enter the full regular expression, including the subexpression. -Interactively, the function also then prompts for which -subexpression parenthesis GROUP (default 1) within REGEXP to -modify, the amount of SPACING (default `align-default-spacing') -to use, and whether or not to REPEAT the rule throughout the -line. - -See `align-rules-list' for more information about these options. +Non-interactively, you must enter the full regular expression, +including the subexpression. The non-interactive form of the previous example would look something like: (align-regexp (point-min) (point-max) \"\\\\(\\\\s-*\\\\)(\") @@ -928,7 +940,7 @@ construct a rule to pass to `align-region', which does the real work." (list (region-beginning) (region-end)) (if current-prefix-arg (list (read-string "Complex align using regexp: " - "\\(\\s-*\\)" 'align-regexp-history) + "\\(\\s-*\\) " 'align-regexp-history) (string-to-number (read-string "Parenthesis group to modify (justify if negative): " "1")) diff --git a/lisp/allout.el b/lisp/allout.el index 5102ee73412..f684751a2a4 100644 --- a/lisp/allout.el +++ b/lisp/allout.el @@ -133,15 +133,10 @@ respective `allout-mode' keybinding variables, `allout-command-prefix', (when (boundp 'allout-unprefixed-keybindings) (dolist (entry allout-unprefixed-keybindings) (define-key map (car (read-from-string (car entry))) (cadr entry)))) - (substitute-key-definition #'beginning-of-line #'allout-beginning-of-line - map global-map) - (substitute-key-definition #'move-beginning-of-line - #'allout-beginning-of-line - map global-map) - (substitute-key-definition #'end-of-line #'allout-end-of-line - map global-map) - (substitute-key-definition #'move-end-of-line #'allout-end-of-line - map global-map) + (define-key map [remap beginning-of-line] #'allout-beginning-of-line) + (define-key map [remap move-beginning-of-line] #'allout-beginning-of-line) + (define-key map [remap end-of-line] #'allout-end-of-line) + (define-key map [remap move-end-of-line] #'allout-end-of-line) (allout-institute-keymap map))) ;;;_ > allout-institute-keymap (map) (defun allout-institute-keymap (map) @@ -3079,6 +3074,8 @@ Move to buffer limit in indicated direction if headings are exhausted." (backward (if (< arg 0) (setq arg (* -1 arg)))) (step (if backward -1 1)) (progress (allout-current-bullet-pos)) + ;; Move to the next physical line. + (line-move-visual nil) prev got) (while (> arg 0) diff --git a/lisp/ansi-color.el b/lisp/ansi-color.el index b1c9cdaeca4..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") @@ -458,11 +458,18 @@ variable, and is meant to be used in `compilation-filter-hook'." ;; Working with strings (defvar-local ansi-color-context nil "Context saved between two calls to `ansi-color-apply'. -This is a list of the form (CODES FRAGMENT) or nil. CODES +This is a list of the form (FACE-VEC FRAGMENT) or nil. FACE-VEC represents the state the last call to `ansi-color-apply' ended -with, currently a list of ansi codes, and FRAGMENT is a string -starting with an escape sequence, possibly the start of a new -escape sequence.") +with, currently a list of the form: + + (BASIC-FACES FG BG) + +BASIC-FACES is a bool-vector that specifies which basic faces +from `ansi-color-basic-faces-vector' to apply. FG and BG are +ANSI color codes for the foreground and background color. + +FRAGMENT is a string starting with an escape sequence, possibly +the start of a new escape sequence.") (defun ansi-color-filter-apply (string) "Filter out all ANSI control sequences from STRING. @@ -473,17 +480,17 @@ will be used for the next call to `ansi-color-apply'. Set `ansi-color-context' to nil if you don't want this. This function can be added to `comint-preoutput-filter-functions'." - (let ((start 0) end result) + (let ((context (ansi-color--ensure-context 'ansi-color-context nil)) + (start 0) end result) ;; if context was saved and is a string, prepend it - (if (cadr ansi-color-context) - (setq string (concat (cadr ansi-color-context) string) - ansi-color-context nil)) + (setq string (concat (cadr context) string)) + (setcar (cdr context) "") ;; find the next escape sequence (while (setq end (string-match ansi-color-control-seq-regexp string start)) (push (substring string start end) result) (setq start (match-end 0))) ;; save context, add the remainder of the string to the result - (let (fragment) + (let ((fragment "")) (push (substring string start (if (string-match "\033" string start) (let ((pos (match-beginning 0))) @@ -491,25 +498,9 @@ This function can be added to `comint-preoutput-filter-functions'." pos) nil)) result) - (setq ansi-color-context (if fragment (list nil fragment)))) + (setcar (cdr context) fragment)) (apply #'concat (nreverse result)))) -(defun ansi-color--find-face (codes) - "Return the face corresponding to CODES." - ;; Sort the codes in ascending order to guarantee that "bold" comes before - ;; any of the colors. This ensures that `ansi-color-bold-is-bright' is - ;; applied correctly. - (let (faces bright (codes (sort (copy-sequence codes) #'<))) - (while codes - (when-let ((face (ansi-color-get-face-1 (pop codes) bright))) - (when (and ansi-color-bold-is-bright (eq face 'ansi-color-bold)) - (setq bright t)) - (push face faces))) - ;; Avoid some long-lived conses in the common case. - (if (cdr faces) - (nreverse faces) - (car faces)))) - (defun ansi-color-apply (string) "Translates SGR control sequences into text properties. Delete all other control sequences without processing them. @@ -524,49 +515,157 @@ This information will be used for the next call to `ansi-color-apply'. Set `ansi-color-context' to nil if you don't want this. This function can be added to `comint-preoutput-filter-functions'." - (let ((codes (car ansi-color-context)) - (start 0) end result) + (let* ((context + (ansi-color--ensure-context 'ansi-color-context nil)) + (face-vec (car context)) + (start 0) + end result) ;; If context was saved and is a string, prepend it. - (if (cadr ansi-color-context) - (setq string (concat (cadr ansi-color-context) string) - ansi-color-context nil)) + (setq string (concat (cadr context) string)) + (setcar (cdr context) "") ;; Find the next escape sequence. (while (setq end (string-match ansi-color-control-seq-regexp string start)) (let ((esc-end (match-end 0))) ;; Colorize the old block from start to end using old face. - (when codes + (when-let ((face (ansi-color--face-vec-face face-vec))) (put-text-property start end 'font-lock-face - (ansi-color--find-face codes) string)) + face string)) (push (substring string start end) result) (setq start (match-end 0)) ;; If this is a color escape sequence, (when (eq (aref string (1- esc-end)) ?m) ;; create a new face from it. - (setq codes (ansi-color-apply-sequence - (substring string end esc-end) codes))))) + (let ((cur-pos end)) + (ansi-color--update-face-vec + face-vec + (lambda () + (when (string-match ansi-color-parameter-regexp + string cur-pos) + (setq cur-pos (match-end 0)) + (when (<= cur-pos esc-end) + (string-to-number (match-string 1 string)))))))))) ;; if the rest of the string should have a face, put it there - (when codes + (when-let ((face (ansi-color--face-vec-face face-vec))) (put-text-property start (length string) - 'font-lock-face (ansi-color--find-face codes) string)) + 'font-lock-face face string)) ;; save context, add the remainder of the string to the result - (let (fragment) - (if (string-match "\033" string start) - (let ((pos (match-beginning 0))) - (setq fragment (substring string pos)) - (push (substring string start pos) result)) - (push (substring string start) result)) - (setq ansi-color-context (if (or codes fragment) (list codes fragment)))) + (if (string-match "\033" string start) + (let ((pos (match-beginning 0))) + (setcar (cdr context) (substring string pos)) + (push (substring string start pos) result)) + (push (substring string start) result)) (apply 'concat (nreverse result)))) +(defun ansi-color--ensure-context (context-sym position) + "Return CONTEXT-SYM's value as a valid context. +If it is nil, set CONTEXT-SYM's value to a new context and return +it. Context is a list of the form as described in +`ansi-color-context' if POSITION is nil, or +`ansi-color-context-region' if POSITION is non-nil. + +If CONTEXT-SYM's value is already non-nil, return it. If its +marker doesn't point anywhere yet, position it before character +number POSITION, if non-nil." + (let ((context (symbol-value context-sym))) + (if context + (if position + (let ((marker (cadr context))) + (unless (marker-position marker) + (set-marker marker position)) + context) + context) + (set context-sym + (list (list (make-bool-vector 8 nil) + nil nil) + (if position + (copy-marker position) + "")))))) + +(defun ansi-color--face-vec-face (face-vec) + "Return the face corresponding to FACE-VEC. +FACE-VEC is a list containing information about the ANSI sequence +code. It is usually stored as the car of the variable +`ansi-color-context-region'." + (let* ((basic-faces (car face-vec)) + (colors (cdr face-vec)) + (bright (and ansi-color-bold-is-bright (aref basic-faces 1))) + (faces nil)) + + (when-let ((fg (car colors))) + (push + `(:foreground + ,(or (ansi-color--code-as-hex fg) + (face-foreground + (aref (if (or bright (>= fg 8)) + ansi-color-bright-colors-vector + ansi-color-normal-colors-vector) + (mod fg 8)) + nil 'default))) + faces)) + (when-let ((bg (cadr colors))) + (push + `(:background + ,(or (ansi-color--code-as-hex bg) + (face-background + (aref (if (or bright (>= bg 8)) + ansi-color-bright-colors-vector + ansi-color-normal-colors-vector) + (mod bg 8)) + nil 'default))) + faces)) + + (let ((i 8)) + (while (> i 0) + (setq i (1- i)) + (when (aref basic-faces i) + (push (aref ansi-color-basic-faces-vector i) faces)))) + ;; Avoid some long-lived conses in the common case. + (if (cdr faces) + faces + (car faces)))) + +(defun ansi-color--code-as-hex (color) + "Convert COLOR to hexadecimal string representation. +COLOR is an ANSI color code. If it is between 16 and 255 +inclusive, it corresponds to a color from an 8-bit color cube. +If it is greater or equal than 256, it is subtracted by 256 to +directly specify a 24-bit color. + +Return a hexadecimal string, specifying the color, or nil, if +COLOR is less than 16." + (cond + ((< color 16) nil) + ((>= color 256) (format "#%06X" (- color 256))) + ((>= color 232) ;; Grayscale + (format "#%06X" (* #x010101 (+ 8 (* 10 (- color 232)))))) + (t ;; 6x6x6 color cube + (setq color (- color 16)) + (let ((res 0) + (frac (* 6 6))) + (while (<= 1 frac) ; Repeat 3 times + (setq res (* res #x000100)) + (let ((color-num (mod (/ color frac) 6))) + (unless (zerop color-num) + (setq res (+ res #x37 (* #x28 color-num))))) + (setq frac (/ frac 6))) + (format "#%06X" res))))) + ;; Working with regions (defvar-local ansi-color-context-region nil "Context saved between two calls to `ansi-color-apply-on-region'. -This is a list of the form (CODES MARKER) or nil. CODES +This is a list of the form (FACE-VEC MARKER) or nil. FACE-VEC represents the state the last call to `ansi-color-apply-on-region' -ended with, currently a list of ansi codes, and MARKER is a -buffer position within an escape sequence or the last position -processed.") +ended with, currently a list of the form: + + (BASIC-FACES FG BG). + +BASIC-FACES is a bool-vector that specifies which basic faces +from `ansi-color-basic-faces-vector' to apply. FG and BG are +ANSI color codes for the foreground and background color. + +MARKER is a buffer position within an escape sequence or the last +position processed.") (defun ansi-color-filter-region (begin end) "Filter out all ANSI control sequences from region BEGIN to END. @@ -576,8 +675,10 @@ Every call to this function will set and use the buffer-local variable used for the next call to `ansi-color-apply-on-region'. Specifically, it will override BEGIN, the start of the region. Set `ansi-color-context-region' to nil if you don't want this." - (let ((end-marker (copy-marker end)) - (start (or (cadr ansi-color-context-region) begin))) + (let* ((end-marker (copy-marker end)) + (context (ansi-color--ensure-context + 'ansi-color-context-region begin)) + (start (cadr context))) (save-excursion (goto-char start) ;; Delete escape sequences. @@ -585,8 +686,8 @@ it will override BEGIN, the start of the region. Set (delete-region (match-beginning 0) (match-end 0))) ;; save context, add the remainder of the string to the result (if (re-search-forward "\033" end-marker t) - (setq ansi-color-context-region (list nil (match-beginning 0))) - (setq ansi-color-context-region nil))))) + (set-marker start (match-beginning 0)) + (set-marker start nil))))) (defun ansi-color-apply-on-region (begin end &optional preserve-sequences) "Translates SGR control sequences into overlays or extents. @@ -608,58 +709,58 @@ this. If PRESERVE-SEQUENCES is t, the sequences are hidden instead of being deleted." - (let ((codes (car ansi-color-context-region)) - (start-marker (or (cadr ansi-color-context-region) - (copy-marker begin))) - (end-marker (copy-marker end))) + (let* ((context (ansi-color--ensure-context + 'ansi-color-context-region begin)) + (face-vec (car context)) + (start-marker (cadr context)) + (end-marker (copy-marker end))) (save-excursion (goto-char start-marker) ;; Find the next escape sequence. (while (re-search-forward ansi-color-control-seq-regexp end-marker t) ;; Extract escape sequence. - (let ((esc-seq (buffer-substring - (match-beginning 0) (point)))) - (if preserve-sequences - ;; Make the escape sequence transparent. - (overlay-put (make-overlay (match-beginning 0) (point)) - 'invisible t) - ;; Otherwise, strip. - (delete-region (match-beginning 0) (point))) - + (let ((esc-beg (match-beginning 0)) + (esc-end (point))) ;; Colorize the old block from start to end using old face. (funcall ansi-color-apply-face-function (prog1 (marker-position start-marker) ;; Store new start position. - (set-marker start-marker (point))) - (match-beginning 0) (ansi-color--find-face codes)) + (set-marker start-marker esc-end)) + esc-beg (ansi-color--face-vec-face face-vec)) ;; If this is a color sequence, - (when (eq (aref esc-seq (1- (length esc-seq))) ?m) - ;; update the list of ansi codes. - (setq codes (ansi-color-apply-sequence esc-seq codes))))) + (when (eq (char-before esc-end) ?m) + (goto-char esc-beg) + (ansi-color--update-face-vec + face-vec (lambda () + (when (re-search-forward ansi-color-parameter-regexp + esc-end t) + (string-to-number (match-string 1)))))) + + (if preserve-sequences + ;; Make the escape sequence transparent. + (overlay-put (make-overlay esc-beg esc-end) 'invisible t) + ;; Otherwise, strip. + (delete-region esc-beg esc-end)))) ;; search for the possible start of a new escape sequence (if (re-search-forward "\033" end-marker t) - (progn - ;; if the rest of the region should have a face, put it there - (funcall ansi-color-apply-face-function - start-marker (point) (ansi-color--find-face codes)) - ;; save codes and point - (setq ansi-color-context-region - (list codes (copy-marker (match-beginning 0))))) - ;; if the rest of the region should have a face, put it there - (funcall ansi-color-apply-face-function - start-marker end-marker (ansi-color--find-face codes)) - ;; Save a restart position when there are codes active. It's - ;; convenient for man.el's process filter to pass `begin' - ;; positions that overlap regions previously colored; these - ;; `codes' should not be applied to that overlap, so we need - ;; to know where they should really start. - (setq ansi-color-context-region - (if codes (list codes (copy-marker (point))))))) - ;; Clean up our temporary markers. - (unless (eq start-marker (cadr ansi-color-context-region)) - (set-marker start-marker nil)) - (unless (eq end-marker (cadr ansi-color-context-region)) - (set-marker end-marker nil)))) + (progn + (while (re-search-forward "\033" end-marker t)) + (backward-char) + (funcall ansi-color-apply-face-function + start-marker (point) + (ansi-color--face-vec-face face-vec)) + (set-marker start-marker (point))) + (let ((faces (ansi-color--face-vec-face face-vec))) + (funcall ansi-color-apply-face-function + start-marker end-marker faces) + ;; Save a restart position when there are codes active. It's + ;; convenient for man.el's process filter to pass `begin' + ;; positions that overlap regions previously colored; these + ;; `codes' should not be applied to that overlap, so we need + ;; to know where they should really start. + (set-marker start-marker (when faces end-marker))))) + ;; Clean up our temporary marker. + (set-marker end-marker nil))) (defun ansi-color-apply-overlay-face (beg end face) "Make an overlay from BEG to END, and apply face FACE. @@ -767,6 +868,7 @@ the foreground color code is replaced or added resp. deleted; if it is 40-47 (or 100-107) resp. 49, the background color code is replaced or added resp. deleted; any other code is discarded together with the old codes. Finally, the so changed list of codes is returned." + (declare (obsolete ansi-color--update-face-vec "29.1")) (let ((new-codes (ansi-color-parse-sequence escape-sequence))) (while new-codes (let* ((new (pop new-codes)) @@ -795,6 +897,72 @@ old codes. Finally, the so changed list of codes is returned." (_ nil))))) codes)) +(defun ansi-color--update-face-vec (face-vec iterator) + "Apply escape sequences to FACE-VEC. + +Destructively modify FACE-VEC, which should be a list containing +face information. It is described in +`ansi-color-context-region'. ITERATOR is a function which is +called repeatedly with zero arguments and should return either +the next ANSI code in the current sequence as a number or nil if +there are no more ANSI codes left. + +For each new code, the following happens: if it is 1-7, set the +corresponding properties; if it is 21-25 or 27, unset appropriate +properties; if it is 30-37 (or 90-97) or resp. 39, set the +foreground color or resp. unset it; if it is 40-47 (or 100-107) +resp. 49, set the background color or resp. unset it; if it is 38 +or 48, the following codes are used to set the foreground or +background color and the correct color mode; any other code will +unset all properties and colors." + (let ((basic-faces (car face-vec)) + (colors (cdr face-vec)) + new q do-clear) + (while (setq new (funcall iterator)) + (setq q (/ new 10)) + (pcase q + (0 (if (memq new '(0 8 9)) + (setq do-clear t) + (aset basic-faces new t))) + (2 (if (memq new '(20 26 28 29)) + (setq do-clear t) + ;; The standard says `21 doubly underlined' while + ;; https://en.wikipedia.org/wiki/ANSI_escape_code claims + ;; `21 Bright/Bold: off or Underline: Double'. + (aset basic-faces (- new 20) nil) + (aset basic-faces (pcase new (22 1) (25 6) (_ 0)) nil))) + ((or 3 4 9 10) + (let ((r (mod new 10)) + (cell (if (memq q '(3 9)) colors (cdr colors)))) + (pcase r + (8 + (pcase (funcall iterator) + (5 (setq new (setcar cell (funcall iterator))) + (setq do-clear (or (null new) (>= new 256)))) + (2 + (let ((red (funcall iterator)) + (green (funcall iterator)) + (blue (funcall iterator))) + (if (and red green blue + (progn + (setq new (+ (* #x010000 red) + (* #x000100 green) + (* #x000001 blue))) + (<= new #xFFFFFF))) + (setcar cell (+ 256 new)) + (setq do-clear t)))) + (_ (setq do-clear t)))) + (9 (setcar cell nil)) + (_ (setcar cell (+ (if (memq q '(3 4)) 0 8) r)))))) + (_ (setq do-clear t))) + + (when do-clear + (setq do-clear nil) + ;; Zero out our bool vector without any allocation. + (bool-vector-intersection basic-faces #&8"\0" basic-faces) + (setcar colors nil) + (setcar (cdr colors) nil))))) + (defun ansi-color-make-color-map () "Create a vector of face definitions and return it. @@ -859,6 +1027,7 @@ This function is obsolete, and no longer needed to use ansi-color." "Get face definition for ANSI-CODE. BRIGHT, if non-nil, requests \"bright\" ANSI colors, even if ANSI-CODE is a normal-intensity color." + (declare (obsolete ansi-color--face-vec-face "29.1")) (when (and bright (<= 30 ansi-code 49)) (setq ansi-code (+ ansi-code 60))) (cond ((<= 0 ansi-code 7) diff --git a/lisp/apropos.el b/lisp/apropos.el index fc15cd3e011..66a594d588d 100644 --- a/lisp/apropos.el +++ b/lisp/apropos.el @@ -515,9 +515,9 @@ variables, not just user options." current-prefix-arg)) (apropos-command pattern nil (if (or do-all apropos-do-all) - #'(lambda (symbol) - (and (boundp symbol) - (get symbol 'variable-documentation))) + (lambda (symbol) + (and (boundp symbol) + (get symbol 'variable-documentation))) #'custom-variable-p))) ;;;###autoload @@ -1322,17 +1322,18 @@ as a heading." (defun apropos-describe-plist (symbol) "Display a pretty listing of SYMBOL's plist." - (help-setup-xref (list 'apropos-describe-plist symbol) - (called-interactively-p 'interactive)) - (with-help-window (help-buffer) - (set-buffer standard-output) - (princ "Symbol ") - (prin1 symbol) - (princ (substitute-command-keys "'s plist is\n (")) - (put-text-property (+ (point-min) 7) (- (point) 14) - 'face 'apropos-symbol) - (insert (apropos-format-plist symbol "\n ")) - (princ ")"))) + (let ((help-buffer-under-preparation t)) + (help-setup-xref (list 'apropos-describe-plist symbol) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) + (set-buffer standard-output) + (princ "Symbol ") + (prin1 symbol) + (princ (substitute-command-keys "'s plist is\n (")) + (put-text-property (+ (point-min) 7) (- (point) 14) + 'face 'apropos-symbol) + (insert (apropos-format-plist symbol "\n ")) + (princ ")")))) (provide 'apropos) diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el index 5576ae35053..ece30fec003 100644 --- a/lisp/arc-mode.el +++ b/lisp/arc-mode.el @@ -431,12 +431,8 @@ be added." ;; Let mouse-1 follow the link. (define-key map [follow-link] 'mouse-face) - (if (fboundp 'command-remapping) - (progn - (define-key map [remap advertised-undo] 'archive-undo) - (define-key map [remap undo] 'archive-undo)) - (substitute-key-definition 'advertised-undo 'archive-undo map global-map) - (substitute-key-definition 'undo 'archive-undo map global-map)) + (define-key map [remap advertised-undo] #'archive-undo) + (define-key map [remap undo] #'archive-undo) (define-key map [mouse-2] 'archive-extract) @@ -621,12 +617,8 @@ OLDMODE will be modified accordingly just like chmod(2) would have done." (defun archive-unixdate (low high) "Stringify Unix (LOW HIGH) date." - (let* ((time (list high low)) - (str (current-time-string time))) - (format "%s-%s-%s" - (substring str 8 10) - (substring str 4 7) - (format-time-string "%Y" time)))) + (let ((system-time-locale "C")) + (format-time-string "%e-%b-%Y" (list high low)))) (defun archive-unixtime (low high) "Stringify Unix (LOW HIGH) time." diff --git a/lisp/auth-source.el b/lisp/auth-source.el index 3c1a6feaeeb..1c58410f029 100644 --- a/lisp/auth-source.el +++ b/lisp/auth-source.el @@ -45,6 +45,9 @@ (require 'cl-lib) (require 'eieio) +(declare-function gnutls-symmetric-decrypt "gnutls.c") +(declare-function gnutls-ciphers "gnutls.c") + (autoload 'secrets-create-item "secrets") (autoload 'secrets-delete-item "secrets") (autoload 'secrets-get-alias "secrets") @@ -253,7 +256,7 @@ can get pretty complex." (choice :tag "Authentication backend choice" (string :tag "Authentication Source (file)") (list - :tag "Secret Service API/KWallet/GNOME Keyring" + :tag "Secret Service API/KWallet/GNOME Keyring/KeyPassXC" (const :format "" :value :secrets) (choice :tag "Collection to use" (string :tag "Collection name") diff --git a/lisp/autoinsert.el b/lisp/autoinsert.el index 063d0a14d63..b448c0f8da9 100644 --- a/lisp/autoinsert.el +++ b/lisp/autoinsert.el @@ -415,6 +415,7 @@ Matches the visited file name against the elements of `auto-insert-alist'." "Associate CONDITION with (additional) ACTION in `auto-insert-alist'. Optional AFTER means to insert action after all existing actions for CONDITION, or if CONDITION had no actions, after all other CONDITIONs." + (declare (indent defun)) (let ((elt (assoc condition auto-insert-alist))) (if elt (setcdr elt diff --git a/lisp/bindings.el b/lisp/bindings.el index 121e484a0ee..98a12a252ad 100644 --- a/lisp/bindings.el +++ b/lisp/bindings.el @@ -288,7 +288,7 @@ mnemonics of the following coding systems: Value is used for `mode-line-frame-identification', which see." (if (or (null window-system) (eq window-system 'pc)) - "-%F " + " %F " " ")) ;; We need to defer the call to mode-line-frame-control to the time @@ -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 " " @@ -1251,6 +1261,8 @@ if `inhibit-field-text-motion' is non-nil." ;; (define-key global-map [kp-9] 'function-key-error) ;; (define-key global-map [kp-equal] 'function-key-error) +(define-key global-map [touch-end] 'ignore) + ;; X11 distinguishes these keys from the non-kp keys. ;; Make them behave like the non-kp keys unless otherwise bound. ;; FIXME: rather than list such mappings for every modifier-combination, diff --git a/lisp/bookmark.el b/lisp/bookmark.el index c5e7f2720d1..0c93cec8096 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) @@ -501,11 +498,8 @@ If DEFAULT is nil then return empty string for empty input." 'string-lessp) (bookmark-all-names))) (let* ((completion-ignore-case bookmark-completion-ignore-case) - (default (unless (equal "" default) default)) - (prompt (concat prompt (if default - (format " (%s): " default) - ": ")))) - (completing-read prompt + (default (unless (equal "" default) default))) + (completing-read (format-prompt prompt default) (lambda (string pred action) (if (eq action 'metadata) '(metadata (category . bookmark)) @@ -516,8 +510,9 @@ If DEFAULT is nil then return empty string for empty input." (defmacro bookmark-maybe-historicize-string (string) "Put STRING into the bookmark prompt history, if caller non-interactive. -We need this because sometimes bookmark functions are invoked from -menus, so `completing-read' never gets a chance to set `bookmark-history'." +We need this because sometimes bookmark functions are invoked +from other commands that pass in the bookmark name, so +`completing-read' never gets a chance to set `bookmark-history'." `(or (called-interactively-p 'interactive) (setq bookmark-history (cons ,string bookmark-history)))) @@ -816,11 +811,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. @@ -924,7 +917,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 @@ -995,12 +988,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." @@ -1703,44 +1694,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 + "<mouse-2>" #'bookmark-bmenu-other-window-with-mouse) (easy-menu-define bookmark-menu bookmark-bmenu-mode-map "Menu for `bookmark-bmenu'." @@ -2320,10 +2309,10 @@ Prompt with completion for the new path." (lambda () (setq timer (run-with-idle-timer bookmark-search-delay 'repeat - #'(lambda (buf) - (with-current-buffer buf - (bookmark-bmenu-filter-alist-by-regexp - (minibuffer-contents)))) + (lambda (buf) + (with-current-buffer buf + (bookmark-bmenu-filter-alist-by-regexp + (minibuffer-contents)))) (current-buffer)))) (read-string "Pattern: ") (when timer (cancel-timer timer) (setq timer nil))) diff --git a/lisp/button.el b/lisp/button.el index aedd07b762d..dd5a71d116a 100644 --- a/lisp/button.el +++ b/lisp/button.el @@ -130,6 +130,7 @@ In addition, the keyword argument :supertype may be used to specify a `button-type' from which NAME inherits its default property values (however, the inheritance happens only when NAME is defined; subsequent changes to a supertype are not reflected in its subtypes)." + (declare (indent defun)) (let ((catsym (make-symbol (concat (symbol-name name) "-button"))) (super-catsym (button-category-symbol @@ -603,7 +604,8 @@ When called from Lisp, pass BUTTON-OR-POS as the button to describe, or a buffer position where a button is present. If BUTTON-OR-POS is nil, the button at point is the button to describe." (interactive "d") - (let* ((button (cond ((integer-or-marker-p button-or-pos) + (let* ((help-buffer-under-preparation t) + (button (cond ((integer-or-marker-p button-or-pos) (button-at button-or-pos)) ((null button-or-pos) (button-at (point))) ((overlayp button-or-pos) button-or-pos))) @@ -615,13 +617,19 @@ button at point is the button to describe." (button--describe props) t))) -(defun button-buttonize (string callback &optional data) +(define-obsolete-function-alias 'button-buttonize #'buttonize "29.1") + +(defun buttonize (string callback &optional data help-echo) "Make STRING into a button and return it. When clicked, CALLBACK will be called with the DATA as the function argument. If DATA isn't present (or is nil), the button -itself will be used instead as the function argument." +itself will be used instead as the function argument. + +If HELP-ECHO, use that as the `help-echo' property." (propertize string 'face 'button + 'mouse-face 'highlight + 'help-echo help-echo 'button t 'follow-link t 'category t diff --git a/lisp/calc/calc-ext.el b/lisp/calc/calc-ext.el index dbe2f689d85..93ba8c4b6bb 100644 --- a/lisp/calc/calc-ext.el +++ b/lisp/calc/calc-ext.el @@ -1266,27 +1266,23 @@ calc-kill calc-kill-region calc-yank)))) (math-normalize val))))) -(defvar calc-help-map nil) - -(if calc-help-map - nil - (setq calc-help-map (make-keymap)) - (define-key calc-help-map "b" 'calc-describe-bindings) - (define-key calc-help-map "c" 'calc-describe-key-briefly) - (define-key calc-help-map "f" 'calc-describe-function) - (define-key calc-help-map "h" 'calc-full-help) - (define-key calc-help-map "i" 'calc-info) - (define-key calc-help-map "k" 'calc-describe-key) - (define-key calc-help-map "n" 'calc-view-news) - (define-key calc-help-map "s" 'calc-info-summary) - (define-key calc-help-map "t" 'calc-tutorial) - (define-key calc-help-map "v" 'calc-describe-variable) - (define-key calc-help-map "\C-c" 'calc-describe-copying) - (define-key calc-help-map "\C-d" 'calc-describe-distribution) - (define-key calc-help-map "\C-n" 'calc-view-news) - (define-key calc-help-map "\C-w" 'calc-describe-no-warranty) - (define-key calc-help-map "?" 'calc-help-for-help) - (define-key calc-help-map "\C-h" 'calc-help-for-help)) +(defvar-keymap calc-help-map + "b" 'calc-describe-bindings + "c" 'calc-describe-key-briefly + "f" 'calc-describe-function + "h" 'calc-full-help + "i" 'calc-info + "k" 'calc-describe-key + "n" 'calc-view-news + "s" 'calc-info-summary + "t" 'calc-tutorial + "v" 'calc-describe-variable + "C-c" 'calc-describe-copying + "C-d" 'calc-describe-distribution + "C-n" 'calc-view-news + "C-w" 'calc-describe-no-warranty + "?" 'calc-help-for-help + "C-h" 'calc-help-for-help) (defvar calc-prefix-help-retry nil) (defvar calc-prefix-help-phase 0) 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 dd5063f27d5..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) @@ -111,9 +111,6 @@ C-w Describe how there is no warranty for Calc." (with-current-buffer "*Help*" (let ((inhibit-read-only t)) (goto-char (point-min)) - (when (search-forward "Major Mode Bindings:" nil t) - (delete-region (point-min) (point)) - (insert "Calc Mode Bindings:")) (when (search-forward "Global bindings:" nil t) (forward-line -1) (delete-region (point) (point-max))) diff --git a/lisp/calc/calc-math.el b/lisp/calc/calc-math.el index 1c2e7bcf2bc..ba2b6b2ca9c 100644 --- a/lisp/calc/calc-math.el +++ b/lisp/calc/calc-math.el @@ -618,8 +618,9 @@ If this can't be done, return NIL." (defun math-nth-root-float (a nrf-n &optional guess) (math-inexact-result) (math-with-extra-prec 1 - (let ((math-nrf-nf (math-float nrf-n)) - (math-nrf-nfm1 (math-float (1- nrf-n)))) + (let ((math-nrf-n nrf-n) + (math-nrf-nf (math-float nrf-n)) + (math-nrf-nfm1 (math-float (1- nrf-n)))) (math-nth-root-float-iter a (or guess (math-make-float 1 (/ (+ (math-numdigs (nth 1 a)) 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-prog.el b/lisp/calc/calc-prog.el index 3492b6d831b..b381f8afcf9 100644 --- a/lisp/calc/calc-prog.el +++ b/lisp/calc/calc-prog.el @@ -205,9 +205,8 @@ (progn (setq cmd-base-default (concat "User-" keyname)) (setq cmd (completing-read - (concat "Define M-x command name (default calc-" - cmd-base-default - "): ") + (format-prompt "Define M-x command name" + (concat "calc-" cmd-base-default)) obarray 'commandp nil (if (and odef (symbolp (cdr odef))) (symbol-name (cdr odef)) @@ -241,8 +240,8 @@ (setq func (concat "calcFunc-" (completing-read - (concat "Define algebraic function name (default " - cmd-base-default "): ") + (format-prompt "Define algebraic function name" + cmd-base-default) (mapcar (lambda (x) (substring x 9)) (all-completions "calcFunc-" obarray)) diff --git a/lisp/calc/calc-store.el b/lisp/calc/calc-store.el index ee29c440fe4..817b50951dd 100644 --- a/lisp/calc/calc-store.el +++ b/lisp/calc/calc-store.el @@ -163,19 +163,19 @@ tag (and (not val) 1)) (message "Variable \"%s\" changed" (calc-var-name var))))))) -(defvar calc-var-name-map nil "Keymap for reading Calc variable names.") -(if calc-var-name-map - () - (setq calc-var-name-map (copy-keymap minibuffer-local-completion-map)) - (define-key calc-var-name-map " " 'self-insert-command) - (mapc (lambda (x) - (define-key calc-var-name-map (char-to-string x) - 'calcVar-digit)) - "0123456789") - (mapc (lambda (x) - (define-key calc-var-name-map (char-to-string x) - 'calcVar-oper)) - "+-*/^|")) +(defvar calc-var-name-map + (let ((map (copy-keymap minibuffer-local-completion-map))) + (define-key map " " #'self-insert-command) + (mapc (lambda (x) + (define-key map (char-to-string x) + #'calcVar-digit)) + "0123456789") + (mapc (lambda (x) + (define-key map (char-to-string x) + #'calcVar-oper)) + "+-*/^|") + map) + "Keymap for reading Calc variable names.") (defvar calc-store-opers) @@ -188,12 +188,15 @@ (let* ((calc-store-opers store-opers) (var (concat "var-" - (let ((minibuffer-completion-table - (mapcar (lambda (x) (substring x 4)) - (all-completions "var-" obarray))) - (minibuffer-completion-predicate - (lambda (x) (boundp (intern (concat "var-" x))))) - (minibuffer-completion-confirm t)) + (minibuffer-with-setup-hook + (lambda () + (setq-local minibuffer-completion-table + (mapcar (lambda (x) (substring x 4)) + (all-completions "var-" obarray))) + (setq-local minibuffer-completion-predicate + (lambda (x) + (boundp (intern (concat "var-" x))))) + (setq-local minibuffer-completion-confirm t)) (read-from-minibuffer prompt nil calc-var-name-map nil 'calc-read-var-name-history))))) @@ -586,7 +589,7 @@ (defun calc-permanent-variable (&optional var) (interactive) (calc-wrapper - (or var (setq var (calc-read-var-name "Save variable (default all): "))) + (or var (setq var (calc-read-var-name (format-prompt "Save variable" "all")))) (let (calc-pv-pos) (and var (or (and (boundp var) (symbol-value var)) (error "No such variable"))) diff --git a/lisp/calc/calc-units.el b/lisp/calc/calc-units.el index fd6f3a7b67b..f6d749db117 100644 --- a/lisp/calc/calc-units.el +++ b/lisp/calc/calc-units.el @@ -486,18 +486,13 @@ If COMP or STD is non-nil, put that in the units table instead." (setq defunits (math-get-default-units expr)) (unless new-units (setq new-units - (read-string (concat + (read-string (format-prompt (if (and uoldname (not nouold)) (concat "Old units: " uoldname ", new units") "New units") - (if defunits - (concat - " (default " - defunits - "): ") - ": ")))) + defunits))) (if (and (string= new-units "") defunits) @@ -533,14 +528,7 @@ If COMP or STD is non-nil, put that in the units table instead." (let* ((old-units (math-extract-units expr)) (defunits (math-get-default-units expr)) units - (new-units - (read-string (concat "New units" - (if defunits - (concat - " (default " - defunits - "): ") - ": "))))) + (new-units (read-string (format-prompt "New units" defunits)))) (if (and (string= new-units "") defunits) @@ -596,19 +584,14 @@ If COMP or STD is non-nil, put that in the units table instead." (setq expr (math-mul expr uold))) (setq defunits (math-get-default-units expr)) (setq unew (or new-units - (completing-read - (concat - (if uoldname - (concat "Old temperature units: " - uoldname - ", new units") - "New temperature units") - (if defunits - (concat " (default " - defunits - "): ") - ": ")) - tempunits))) + (completing-read (format-prompt + (if uoldname + (concat "Old temperature units: " + uoldname + ", new units") + "New temperature units") + defunits) + tempunits))) (setq unew (math-read-expr (if (string= unew "") defunits unew))) (when (eq (car-safe unew) 'error) (error "Bad format in units expression: %s" (nth 2 unew))) diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el index e97315165b3..d426e2829f8 100644 --- a/lisp/calc/calc.el +++ b/lisp/calc/calc.el @@ -494,7 +494,7 @@ This setting only applies to floats in normal display mode.") (defmacro defcalcmodevar (var defval &optional doc) "Declare VAR as a Calc variable, with default value DEFVAL and doc-string DOC. The variable VAR will be added to `calc-mode-var-list'." - (declare (doc-string 3)) + (declare (doc-string 3) (indent defun)) `(progn (defvar ,var ,defval ,doc) (add-to-list 'calc-mode-var-list (list (quote ,var) ,defval)))) @@ -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 @@ -3439,7 +3440,7 @@ The prefix `calcFunc-' is added to the specified name to get the actual Lisp function name. See Info node `(calc)Defining Functions'." - (declare (doc-string 3)) ;; FIXME: Edebug spec? + (declare (doc-string 3) (indent defun)) ;; FIXME: Edebug spec? (require 'calc-ext) (math-do-defmath func args body)) 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-<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) 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 +* \\`<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 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..15778ea14bc 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) + (pcase (aref isodatetimestring 15) + (?Z + (setq source-zone t)) + ((or ?- ?+) + (setq source-zone + (concat "UTC" (substring isodatetimestring 15)))))) ;; shift if necessary (if day-shift (let ((mdy (calendar-gregorian-from-absolute diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index 0aa38166bc1..b36171259c0 100644 --- a/lisp/calendar/time-date.el +++ b/lisp/calendar/time-date.el @@ -69,7 +69,7 @@ list (HIGH LOW MICRO PICO)." (pop elt))) (time-value (car elt)) (gensym (make-symbol "time"))) - `(let* ,(append `((,gensym (or ,time-value (current-time))) + `(let* ,(append `((,gensym (or ,time-value (time-convert nil 'list))) (,gensym (cond ((integerp ,gensym) @@ -154,7 +154,10 @@ it is assumed that PICO was omitted and should be treated as zero." DATE should be in one of the forms recognized by `parse-time-string'. If DATE lacks timezone information, GMT is assumed." (condition-case err - (encode-time (parse-time-string date)) + (let ((parsed (parse-time-string date))) + (when (decoded-time-year parsed) + (decoded-time-set-defaults parsed)) + (encode-time parsed)) (error (let ((overflow-error '(error "Specified time is not representable"))) (if (equal err overflow-error) @@ -406,7 +409,11 @@ entries only for the values that should be altered. For instance, if you want to \"add two months\" to TIME, then leave all other fields but the month field in DELTA nil, and make -the month field 2. The values in DELTA can be negative. +the month field 2. For instance: + + (decoded-time-add (decode-time) (make-decoded-time :month 2)) + +The values in DELTA can be negative. If applying a month/year delta leaves the time spec invalid, it is decreased to be valid (\"add one month\" to January 31st 2019 diff --git a/lisp/cedet/mode-local.el b/lisp/cedet/mode-local.el index 18fb05e7eb4..e0717fbfe5a 100644 --- a/lisp/cedet/mode-local.el +++ b/lisp/cedet/mode-local.el @@ -156,7 +156,7 @@ local variables have been defined." DOCSTRING is optional and not used. To work properly, this should be put after PARENT mode local variables definition." - (declare (obsolete define-derived-mode "27.1")) + (declare (obsolete define-derived-mode "27.1") (indent 2)) `(mode-local--set-parent ',mode ',parent)) (defun mode-local-use-bindings-p (this-mode desired-mode) @@ -567,6 +567,7 @@ appropriate arguments deduced from ARGS. OVERARGS is a list of arguments passed to the override and `NAME-default' function, in place of those deduced from ARGS." (declare (doc-string 3) + (indent defun) (debug (&define name lambda-list stringp def-body))) `(eval-and-compile (defun ,name ,args @@ -595,6 +596,7 @@ DOCSTRING is the documentation string. BODY is the implementation of this function." ;; FIXME: Make this obsolete and use cl-defmethod with &context instead. (declare (doc-string 4) + (indent defun) (debug (&define name symbolp lambda-list stringp def-body))) (let ((newname (intern (format "%s-%s" name mode)))) `(progn diff --git a/lisp/cedet/semantic/bovine/c.el b/lisp/cedet/semantic/bovine/c.el index c7d59def1f1..19e2fee2bac 100644 --- a/lisp/cedet/semantic/bovine/c.el +++ b/lisp/cedet/semantic/bovine/c.el @@ -1466,36 +1466,32 @@ Override function for `semantic-tag-protection'." (prot nil)) ;; Check the modifiers for protection if we are not a child ;; of some class type. - (when (or (not parent) (not (eq (semantic-tag-class parent) 'type))) - (while (and (not prot) mods) - (if (stringp (car mods)) - (let ((s (car mods))) - ;; A few silly defaults to get things started. - (cond ((or (string= s "extern") - (string= s "export")) - 'public) - ((string= s "static") - 'private)))) - (setq mods (cdr mods)))) - ;; If we have a typed parent, look for :public style labels. - (when (and parent (eq (semantic-tag-class parent) 'type)) + (if (not (and parent (eq (semantic-tag-class parent) 'type))) + (while (and (not prot) mods) + (if (stringp (car mods)) + (let ((s (car mods))) + ;; A few silly defaults to get things started. + (setq prot (pcase s + ((or "extern" "export") 'public) + ("static" 'private))))) + (setq mods (cdr mods))) + ;; If we have a typed parent, look for :public style labels. (let ((pp (semantic-tag-type-members parent))) (while (and pp (not (semantic-equivalent-tag-p (car pp) tag))) (when (eq (semantic-tag-class (car pp)) 'label) (setq prot - (cond ((string= (semantic-tag-name (car pp)) "public") - 'public) - ((string= (semantic-tag-name (car pp)) "private") - 'private) - ((string= (semantic-tag-name (car pp)) "protected") - 'protected))) + (pcase (semantic-tag-name (car pp)) + ("public" 'public) + ("private" 'private) + ("protected" 'protected))) ) (setq pp (cdr pp))))) (when (and (not prot) (eq (semantic-tag-class parent) 'type)) (setq prot - (cond ((string= (semantic-tag-type parent) "class") 'private) - ((string= (semantic-tag-type parent) "struct") 'public) - (t 'unknown)))) + (pcase (semantic-tag-type parent) + ("class" 'private) + ("struct" 'public) + (_ 'unknown)))) (or prot (if (and parent (semantic-tag-of-class-p parent 'type)) 'public diff --git a/lisp/cedet/semantic/complete.el b/lisp/cedet/semantic/complete.el index 6cfbdd5f03f..375b97a7a5d 100644 --- a/lisp/cedet/semantic/complete.el +++ b/lisp/cedet/semantic/complete.el @@ -224,11 +224,10 @@ HISTORY is a symbol representing a variable to story the history in." ;; @todo - move from () to into the editable area (if (string-match ":" prompt) - (setq prompt (concat - (substring prompt 0 (match-beginning 0)) - " (default " default-as-string ")" - (substring prompt (match-beginning 0)))) - (setq prompt (concat prompt " (" default-as-string "): ")))) + (setq prompt (format-prompt + (substring prompt 0 (match-beginning 0)) + default-as-string)) + (setq prompt (format-prompt prompt default-as-string)))) ;; ;; Perform the Completion ;; diff --git a/lisp/cedet/semantic/decorate/mode.el b/lisp/cedet/semantic/decorate/mode.el index 6271fb1ced6..0a234b3000d 100644 --- a/lisp/cedet/semantic/decorate/mode.el +++ b/lisp/cedet/semantic/decorate/mode.el @@ -391,6 +391,7 @@ etc., found in the semantic-decorate library. To add other kind of decorations on a tag, `NAME-highlight' must use `semantic-decorate-tag', and other functions of the semantic decoration API found in this library." + (declare (indent 1)) (let ((predicate (semantic-decorate-style-predicate name)) (highlighter (semantic-decorate-style-highlighter name)) (predicatedef (semantic-decorate-style-predicate-default name)) diff --git a/lisp/cedet/semantic/dep.el b/lisp/cedet/semantic/dep.el index 0694b9c2329..cae38e6f111 100644 --- a/lisp/cedet/semantic/dep.el +++ b/lisp/cedet/semantic/dep.el @@ -82,6 +82,7 @@ users will customize. Creates a customizable variable users can customize that will keep semantic data structures up to date." + (declare (indent defun)) `(progn ;; Create a variable users can customize. (defcustom ,name ,value diff --git a/lisp/cedet/semantic/fw.el b/lisp/cedet/semantic/fw.el index 16e8ce8de95..3502cda500e 100644 --- a/lisp/cedet/semantic/fw.el +++ b/lisp/cedet/semantic/fw.el @@ -66,8 +66,6 @@ (defalias 'semantic-mode-line-update #'force-mode-line-update) -;; Since Emacs 22 major mode functions should use `run-mode-hooks' to -;; run major mode hooks. (define-obsolete-function-alias 'semantic-run-mode-hooks #'run-mode-hooks "28.1") ;; Fancy compat usage now handled in cedet-compat diff --git a/lisp/cedet/semantic/grm-wy-boot.el b/lisp/cedet/semantic/grm-wy-boot.el index a6bf211713a..ce63421fb37 100644 --- a/lisp/cedet/semantic/grm-wy-boot.el +++ b/lisp/cedet/semantic/grm-wy-boot.el @@ -149,10 +149,10 @@ ((type_decl)) ((use_macros_decl))) (default_prec_decl - ((DEFAULT-PREC) - `(wisent-raw-tag - (semantic-tag "default-prec" 'assoc :value - '("t"))))) + ((DEFAULT-PREC) + `(wisent-raw-tag + (semantic-tag "default-prec" 'assoc :value + '("t"))))) (no_default_prec_decl ((NO-DEFAULT-PREC) `(wisent-raw-tag diff --git a/lisp/cedet/semantic/lex-spp.el b/lisp/cedet/semantic/lex-spp.el index 8073640a8bd..3297367db90 100644 --- a/lisp/cedet/semantic/lex-spp.el +++ b/lisp/cedet/semantic/lex-spp.el @@ -1165,7 +1165,8 @@ of type `spp-macro-def' is to be created. VALFORM are forms that return the value to be saved for this macro, or nil. When implementing a macro, you can use `semantic-lex-spp-stream-for-macro' to convert text into a lexical stream for storage in the macro." - (declare (debug (&define name stringp stringp form def-body))) + (declare (debug (&define name stringp stringp form def-body)) + (indent 1)) (let ((start (make-symbol "start")) (end (make-symbol "end")) (val (make-symbol "val")) @@ -1199,7 +1200,8 @@ REGEXP is a regular expression for the analyzer to match. See `define-lex-regex-analyzer' for more on regexp. TOKIDX is an index into REGEXP for which a new lexical token of type `spp-macro-undef' is to be created." - (declare (debug (&define name stringp stringp form))) + (declare (debug (&define name stringp stringp form)) + (indent 1)) (let ((start (make-symbol "start")) (end (make-symbol "end"))) `(define-lex-regex-analyzer ,name @@ -1260,7 +1262,8 @@ type of include. The return value should be of the form: (NAME . TYPE) where NAME is the name of the include, and TYPE is the type of the include, where a valid symbol is `system', or nil." - (declare (debug (&define name stringp stringp form def-body))) + (declare (debug (&define name stringp stringp form def-body)) + (indent 1)) (let ((start (make-symbol "start")) (end (make-symbol "end")) (val (make-symbol "val")) diff --git a/lisp/cedet/semantic/lex.el b/lisp/cedet/semantic/lex.el index 69f20deeb76..d524b733db5 100644 --- a/lisp/cedet/semantic/lex.el +++ b/lisp/cedet/semantic/lex.el @@ -760,7 +760,7 @@ If two analyzers can match the same text, it is important to order the analyzers so that the one you want to match first occurs first. For example, it is good to put a number analyzer in front of a symbol analyzer which might mistake a number for a symbol." - (declare (debug (&define name stringp (&rest symbolp)))) + (declare (debug (&define name stringp (&rest symbolp))) (indent 1)) `(defun ,name (start end &optional depth length) ,(concat doc "\nSee `semantic-lex' for more information.") ;; Make sure the state of block parsing starts over. @@ -1096,7 +1096,7 @@ Proper action in FORMS is to move the value of `semantic-lex-end-point' to after the location of the analyzed entry, and to add any discovered tokens at the beginning of `semantic-lex-token-stream'. This can be done by using `semantic-lex-push-token'." - (declare (debug (&define name stringp form def-body))) + (declare (debug (&define name stringp form def-body)) (indent 1)) `(eval-and-compile ;; This is the real info used by `define-lex' (via semantic-lex-one-token). (defconst ,name '(,condition ,@forms) ,doc) @@ -1118,7 +1118,7 @@ This can be done by using `semantic-lex-push-token'." "Create a lexical analyzer with NAME and DOC that will match REGEXP. FORMS are evaluated upon a successful match. See `define-lex-analyzer' for more about analyzers." - (declare (debug (&define name stringp form def-body))) + (declare (debug (&define name stringp form def-body)) (indent 1)) `(define-lex-analyzer ,name ,doc (looking-at ,regexp) @@ -1137,7 +1137,8 @@ FORMS are evaluated upon a successful match BEFORE the new token is created. It is valid to ignore FORMS. See `define-lex-analyzer' for more about analyzers." (declare (debug - (&define name stringp form symbolp [ &optional form ] def-body))) + (&define name stringp form symbolp [ &optional form ] def-body)) + (indent 1)) `(define-lex-analyzer ,name ,doc (looking-at ,regexp) @@ -1162,7 +1163,8 @@ where BLOCK-SYM is the symbol returned in a block token. OPEN-DELIM and CLOSE-DELIM are respectively the open and close delimiters identifying a block. OPEN-SYM and CLOSE-SYM are respectively the symbols returned in open and close tokens." - (declare (debug (&define name stringp form (&rest form)))) + (declare (debug (&define name stringp form (&rest form))) + (indent 1)) (let ((specs (cons spec1 specs)) spec open olist clist) (while specs @@ -1471,6 +1473,7 @@ syntax as specified by the syntax table." (defmacro define-lex-keyword-type-analyzer (name doc syntax) "Define a keyword type analyzer NAME with DOC string. SYNTAX is the regexp that matches a keyword syntactic expression." + (declare (indent 1)) (let ((key (make-symbol "key"))) `(define-lex-analyzer ,name ,doc @@ -1486,6 +1489,7 @@ SYNTAX is the regexp that matches a keyword syntactic expression." "Define a sexp type analyzer NAME with DOC string. SYNTAX is the regexp that matches the beginning of the s-expression. TOKEN is the lexical token returned when SYNTAX matches." + (declare (indent 1)) `(define-lex-regex-analyzer ,name ,doc ,syntax @@ -1504,6 +1508,7 @@ SYNTAX is the regexp that matches a syntactic expression. MATCHES is an alist of lexical elements used to refine the syntactic expression. DEFAULT is the default lexical token returned when no MATCHES." + (declare (indent 1)) (if matches (let* ((val (make-symbol "val")) (lst (make-symbol "lst")) @@ -1536,6 +1541,7 @@ SYNTAX is the regexp that matches a syntactic expression. MATCHES is an alist of lexical elements used to refine the syntactic expression. DEFAULT is the default lexical token returned when no MATCHES." + (declare (indent 1)) (if matches (let* ((val (make-symbol "val")) (lst (make-symbol "lst")) @@ -1633,6 +1639,7 @@ When the lexer encounters the open-paren delimiter \"(\": - If the maximum depth of parenthesis tracking is reached (current depth >= max depth), it returns the whole parenthesis block as a (PAREN_BLOCK start . end) token." + (declare (indent 1)) (let* ((val (make-symbol "val")) (lst (make-symbol "lst")) (elt (make-symbol "elt"))) diff --git a/lisp/cedet/semantic/wisent.el b/lisp/cedet/semantic/wisent.el index f5f381d4079..afcdd142822 100644 --- a/lisp/cedet/semantic/wisent.el +++ b/lisp/cedet/semantic/wisent.el @@ -66,7 +66,7 @@ Returned tokens must have the form: (TOKSYM VALUE START . END) where VALUE is the buffer substring between START and END positions." - (declare (debug (&define name stringp def-body))) + (declare (debug (&define name stringp def-body)) (indent 1)) `(defun ,name () ,doc (cond diff --git a/lisp/char-fold.el b/lisp/char-fold.el index e3ab7d5b64c..b8e3d2f6791 100644 --- a/lisp/char-fold.el +++ b/lisp/char-fold.el @@ -26,6 +26,7 @@ (eval-and-compile (put 'char-fold-table 'char-table-extra-slots 1) + (defconst char-fold--default-override nil) (defconst char-fold--default-include '((?\" """ "“" "”" "”" "„" "⹂" "〞" "‟" "‟" "❞" "❝" "❠" "“" "„" "〝" "〟" "🙷" "🙶" "🙸" "«" "»") (?' "❟" "❛" "❜" "‘" "’" "‚" "‛" "‚" "" "❮" "❯" "‹" "›") @@ -40,7 +41,8 @@ )) (defconst char-fold--default-symmetric nil) (defvar char-fold--previous - (list char-fold--default-include + (list char-fold--default-override + char-fold--default-include char-fold--default-exclude char-fold--default-symmetric))) @@ -67,48 +69,50 @@ ;; - A single char of the decomp might be allowed to match the ;; character. ;; Some examples in the comments below. - (map-char-table - (lambda (char decomp) - (when (consp decomp) - ;; Skip trivial cases like ?a decomposing to (?a). - (unless (and (not (cdr decomp)) - (eq char (car decomp))) - (if (symbolp (car decomp)) - ;; Discard a possible formatting tag. - (setq decomp (cdr decomp)) - ;; If there's no formatting tag, ensure that char matches - ;; its decomp exactly. This is because we want 'ä' to - ;; match 'ä', but we don't want '¹' to match '1'. - (aset equiv char - (cons (apply #'string decomp) - (aref equiv char)))) - - ;; Allow the entire decomp to match char. If decomp has - ;; multiple characters, this is done by adding an entry - ;; to the alist of the first character in decomp. This - ;; allows 'ff' to match 'ff', 'ä' to match 'ä', and '1' to - ;; match '¹'. - (let ((make-decomp-match-char - (lambda (decomp char) - (if (cdr decomp) - (aset equiv-multi (car decomp) - (cons (cons (apply #'string (cdr decomp)) - (regexp-quote (string char))) - (aref equiv-multi (car decomp)))) - (aset equiv (car decomp) - (cons (char-to-string char) - (aref equiv (car decomp)))))))) - (funcall make-decomp-match-char decomp char) - ;; Check to see if the first char of the decomposition - ;; has a further decomposition. If so, add a mapping - ;; back from that second decomposition to the original - ;; character. This allows e.g. 'ι' (GREEK SMALL LETTER - ;; IOTA) to match both the Basic Greek block and - ;; Extended Greek block variants of IOTA + - ;; diacritical(s). Repeat until there are no more - ;; decompositions. - (let ((dec decomp) - next-decomp) + (unless (or (bound-and-true-p char-fold-override) + char-fold--default-override) + (map-char-table + (lambda (char decomp) + (when (consp decomp) + ;; Skip trivial cases like ?a decomposing to (?a). + (unless (and (not (cdr decomp)) + (eq char (car decomp))) + (if (symbolp (car decomp)) + ;; Discard a possible formatting tag. + (setq decomp (cdr decomp)) + ;; If there's no formatting tag, ensure that char matches + ;; its decomp exactly. This is because we want 'ä' to + ;; match 'ä', but we don't want '¹' to match '1'. + (aset equiv char + (cons (apply #'string decomp) + (aref equiv char)))) + + ;; Allow the entire decomp to match char. If decomp has + ;; multiple characters, this is done by adding an entry + ;; to the alist of the first character in decomp. This + ;; allows 'ff' to match 'ff', 'ä' to match 'ä', and '1' to + ;; match '¹'. + (let ((make-decomp-match-char + (lambda (decomp char) + (if (cdr decomp) + (aset equiv-multi (car decomp) + (cons (cons (apply #'string (cdr decomp)) + (regexp-quote (string char))) + (aref equiv-multi (car decomp)))) + (aset equiv (car decomp) + (cons (char-to-string char) + (aref equiv (car decomp)))))))) + (funcall make-decomp-match-char decomp char) + ;; Check to see if the first char of the decomposition + ;; has a further decomposition. If so, add a mapping + ;; back from that second decomposition to the original + ;; character. This allows e.g. 'ι' (GREEK SMALL LETTER + ;; IOTA) to match both the Basic Greek block and + ;; Extended Greek block variants of IOTA + + ;; diacritical(s). Repeat until there are no more + ;; decompositions. + (let ((dec decomp) + next-decomp) (while dec (setq next-decomp (char-table-range table (car dec))) (when (consp next-decomp) @@ -118,24 +122,24 @@ (car next-decomp))) (funcall make-decomp-match-char (list (car next-decomp)) char))) (setq dec next-decomp))) - ;; Do it again, without the non-spacing characters. - ;; This allows 'a' to match 'ä'. - (let ((simpler-decomp nil) - (found-one nil)) - (dolist (c decomp) - (if (> (get-char-code-property c 'canonical-combining-class) 0) - (setq found-one t) - (push c simpler-decomp))) - (when (and simpler-decomp found-one) - (funcall make-decomp-match-char simpler-decomp char) - ;; Finally, if the decomp only had one spacing - ;; character, we allow this character to match the - ;; decomp. This is to let 'a' match 'ä'. - (unless (cdr simpler-decomp) - (aset equiv (car simpler-decomp) - (cons (apply #'string decomp) - (aref equiv (car simpler-decomp))))))))))) - table) + ;; Do it again, without the non-spacing characters. + ;; This allows 'a' to match 'ä'. + (let ((simpler-decomp nil) + (found-one nil)) + (dolist (c decomp) + (if (> (get-char-code-property c 'canonical-combining-class) 0) + (setq found-one t) + (push c simpler-decomp))) + (when (and simpler-decomp found-one) + (funcall make-decomp-match-char simpler-decomp char) + ;; Finally, if the decomp only had one spacing + ;; character, we allow this character to match the + ;; decomp. This is to let 'a' match 'ä'. + (unless (cdr simpler-decomp) + (aset equiv (car simpler-decomp) + (cons (apply #'string decomp) + (aref equiv (car simpler-decomp))))))))))) + table)) ;; Add some entries to default decomposition (dolist (it (or (bound-and-true-p char-fold-include) @@ -232,7 +236,9 @@ Exceptionally for the space character (32), ALIST is ignored.") (defun char-fold-update-table () "Update char-fold-table only when one of the options changes its value." - (let ((new (list (or (bound-and-true-p char-fold-include) + (let ((new (list (or (bound-and-true-p char-fold-override) + char-fold--default-override) + (or (bound-and-true-p char-fold-include) char-fold--default-include) (or (bound-and-true-p char-fold-exclude) char-fold--default-exclude) @@ -242,6 +248,22 @@ Exceptionally for the space character (32), ALIST is ignored.") (setq char-fold-table (char-fold--make-table) char-fold--previous new)))) +(defcustom char-fold-override char-fold--default-override + "Non-nil means to override the default definitions of equivalent characters. +When nil (the default), the table of character equivalences used +for character-folding is populated with the default set of equivalent +characters; customize `char-fold-exclude' to remove unneeded equivalences, +and `char-fold-include' to add your own. +When this variable is non-nil, the table of equivalences starts empty, +and you can add your own equivalences by customizing `char-fold-include'." + :type 'boolean + :initialize #'custom-initialize-default + :set (lambda (sym val) + (custom-set-default sym val) + (char-fold-update-table)) + :group 'isearch + :version "29.1") + (defcustom char-fold-include char-fold--default-include "Additional character foldings to include. Each entry is a list of a character and the strings that fold into it." diff --git a/lisp/cmuscheme.el b/lisp/cmuscheme.el index e197069d6b8..acc08889076 100644 --- a/lisp/cmuscheme.el +++ b/lisp/cmuscheme.el @@ -237,7 +237,7 @@ is run). (inferior-scheme-mode))) (setq scheme-program-name cmd) (setq scheme-buffer "*scheme*") - (pop-to-buffer-same-window "*scheme*")) + (pop-to-buffer "*scheme*" display-comint-buffer-action)) (defun scheme-start-file (prog) "Return the name of the start file corresponding to PROG. @@ -245,7 +245,8 @@ Search in the directories \"~\" and `user-emacs-directory', in this order. Return nil if no start file found." (let* ((progname (file-name-nondirectory prog)) (start-file (concat "~/.emacs_" progname)) - (alt-start-file (concat user-emacs-directory "init_" progname ".scm"))) + (alt-start-file (locate-user-emacs-file + (concat "init_" progname ".scm")))) (if (file-exists-p start-file) start-file (and (file-exists-p alt-start-file) alt-start-file)))) @@ -356,7 +357,7 @@ With argument, position cursor at end of buffer." (interactive "P") (if (or (and scheme-buffer (get-buffer scheme-buffer)) (scheme-interactively-start-process)) - (pop-to-buffer-same-window scheme-buffer) + (pop-to-buffer scheme-buffer display-comint-buffer-action) (error "No current process buffer. See variable `scheme-buffer'")) (when eob-p (push-mark) diff --git a/lisp/comint.el b/lisp/comint.el index a0873c0b6a1..3decb80ff0b 100644 --- a/lisp/comint.el +++ b/lisp/comint.el @@ -385,10 +385,12 @@ This variable is buffer-local." "\\(?: [[:alpha:]]+ .+\\)?[[:blank:]]*[::៖][[:space:]]*\\'" ;; The ccrypt encryption dialogue doesn't end with a colon, so ;; treat it specially. - "\\|^Enter encryption key: (repeat) *\\'") + "\\|^Enter encryption key: (repeat) *\\'" + ;; openssh-8.6p1 format: "(user@host) Password:". + "\\|^([^)@ \t\n]+@[^)@ \t\n]+) Password: *\\'") "Regexp matching prompts for passwords in the inferior process. This is used by `comint-watch-for-password-prompt'." - :version "28.1" + :version "29.1" :type 'regexp :group 'comint) @@ -728,6 +730,8 @@ Entry to this mode runs the hooks on `comint-mode-hook'." (or (file-remote-p default-directory) "")) (setq-local comint-accum-marker (make-marker)) (setq-local font-lock-defaults '(nil t)) + (add-function :filter-return (local 'filter-buffer-substring-function) + #'comint--unmark-string-as-output) (add-hook 'change-major-mode-hook 'font-lock-defontify nil t) (add-hook 'isearch-mode-hook 'comint-history-isearch-setup nil t) (add-hook 'completion-at-point-functions 'comint-completion-at-point nil t) @@ -889,12 +893,13 @@ series of processes in the same Comint buffer. The hook ;; and there is no way for us to define it here. ;; Some programs that use terminfo get very confused ;; if TERM is not a valid terminal type. - (if (and (boundp 'system-uses-terminfo) system-uses-terminfo) - (list (format "TERM=%s" comint-terminfo-terminal) - "TERMCAP=" - (format "COLUMNS=%d" (window-width))) - (list "TERM=emacs" - (format "TERMCAP=emacs:co#%d:tc=unknown:" (window-width))))) + (with-connection-local-variables + (if system-uses-terminfo + (list (format "TERM=%s" comint-terminfo-terminal) + "TERMCAP=" + (format "COLUMNS=%d" (window-width))) + (list "TERM=emacs" + (format "TERMCAP=emacs:co#%d:tc=unknown:" (window-width)))))) (defun comint-nonblank-p (str) "Return non-nil if STR contains non-whitespace syntax." @@ -1812,7 +1817,8 @@ Ignore duplicates if `comint-input-ignoredups' is non-nil." (ring-insert comint-input-ring cmd))) (defconst comint--prompt-rear-nonsticky - '(field inhibit-line-move-field-capture read-only font-lock-face) + '( field inhibit-line-move-field-capture read-only font-lock-face + insert-in-front-hooks) "Text properties we set on the prompt and don't want to leak past it.") (defun comint-send-input (&optional no-newline artificial) @@ -1904,6 +1910,14 @@ Similarly for Soar, Scheme, etc." (delete-region pmark start) copy)))) + ;; Delete and reinsert input. This seems like a no-op, except + ;; for the resulting entries in the undo list: undoing this + ;; insertion will delete the region, moving the process mark + ;; back to its original position. + (let ((inhibit-read-only t)) + (delete-region pmark (point)) + (insert input)) + (unless no-newline (insert ?\n)) @@ -1947,7 +1961,7 @@ Similarly for Soar, Scheme, etc." ;; in case we get output amidst sending the input. (set-marker comint-last-input-start pmark) (set-marker comint-last-input-end (point)) - (set-marker (process-mark proc) (point)) + (set-marker pmark (point)) ;; clear the "accumulation" marker (set-marker comint-accum-marker nil) (let ((comint-input-sender-no-newline no-newline)) @@ -2022,7 +2036,7 @@ the start, the cdr to the end of the last prompt recognized.") Freezes the `font-lock-face' text property in place." (when comint-last-prompt (with-silent-modifications - (font-lock-prepend-text-property + (font-lock-append-text-property (car comint-last-prompt) (cdr comint-last-prompt) 'font-lock-face 'comint-highlight-prompt)) @@ -2141,14 +2155,7 @@ Make backspaces delete the previous character." (goto-char (process-mark process)) ; In case a filter moved it. (unless comint-use-prompt-regexp - (with-silent-modifications - (add-text-properties comint-last-output-start (point) - `(rear-nonsticky - ,comint--prompt-rear-nonsticky - front-sticky - (field inhibit-line-move-field-capture) - field output - inhibit-line-move-field-capture t)))) + (comint--mark-as-output comint-last-output-start (point))) ;; Highlight the prompt, where we define `prompt' to mean ;; the most recent output that doesn't end with a newline. @@ -2180,6 +2187,46 @@ Make backspaces delete the previous character." ,comint--prompt-rear-nonsticky))) (goto-char saved-point))))))) +(defun comint--mark-as-output (beg end) + (with-silent-modifications + (add-text-properties + beg end + `(rear-nonsticky + ,comint--prompt-rear-nonsticky + front-sticky + (field inhibit-line-move-field-capture) + field output + inhibit-line-move-field-capture t + ;; Text inserted by a user in the middle of process output + ;; should be marked as output. This is needed for commands + ;; such as `yank' or `just-one-space' which don't use + ;; `insert-and-inherit' and thus bypass default text property + ;; inheritance. + insert-in-front-hooks + (,#'comint--mark-as-output ,#'comint--mark-yanked-as-output))))) + +(defun comint--mark-yanked-as-output (beg end) + ;; `yank' removes the field text property from the text it inserts + ;; due to `yank-excluded-properties', so arrange for this text + ;; property to be reapplied in the `after-change-functions'. + (let (fun) + (setq + fun + (lambda (beg1 end1 _len1) + (remove-hook 'after-change-functions fun t) + (when (and (= beg beg1) + (= end end1)) + (comint--mark-as-output beg1 end1)))) + (add-hook 'after-change-functions fun nil t))) + +(defun comint--unmark-string-as-output (string) + (remove-list-of-text-properties + 0 (length string) + '( rear-nonsticky front-sticky field + inhibit-line-move-field-capture insert-in-front-hooks) + string) + string) + (defun comint-preinput-scroll-to-bottom () "Go to the end of buffer in all windows showing it. Movement occurs if point in the selected window is not after the process mark, @@ -2455,11 +2502,19 @@ This function could be in the list `comint-output-filter-functions'." (when (let ((case-fold-search t)) (string-match comint-password-prompt-regexp (string-replace "\r" "" string))) - (let ((comint--prompt-recursion-depth (1+ comint--prompt-recursion-depth))) - (if (> comint--prompt-recursion-depth 10) - (message "Password prompt recursion too deep") - (comint-send-invisible - (string-trim string "[ \n\r\t\v\f\b\a]+" "\n+")))))) + ;; Use `run-at-time' in order not to pause execution of the + ;; process filter with a minibuffer + (run-at-time + 0 nil + (lambda (current-buf) + (with-current-buffer current-buf + (let ((comint--prompt-recursion-depth + (1+ comint--prompt-recursion-depth))) + (if (> comint--prompt-recursion-depth 10) + (message "Password prompt recursion too deep") + (comint-send-invisible + (string-trim string "[ \n\r\t\v\f\b\a]+" "\n+")))))) + (current-buffer)))) ;; Low-level process communication @@ -3509,6 +3564,20 @@ to send all the accumulated input, at once. The entire accumulated text becomes one item in the input history when you send it." (interactive) + (when-let* ((proc (get-buffer-process (current-buffer))) + (pmark (process-mark proc)) + ((or (marker-position comint-accum-marker) + (set-marker comint-accum-marker pmark) + t)) + ((>= (point) comint-accum-marker pmark))) + ;; Delete and reinsert input. This seems like a no-op, except for + ;; the resulting entries in the undo list: undoing this insertion + ;; will delete the region, moving the accumulation marker back to + ;; its original position. + (let ((text (buffer-substring comint-accum-marker (point))) + (inhibit-read-only t)) + (delete-region comint-accum-marker (point)) + (insert text))) (insert "\n") (set-marker comint-accum-marker (point)) (if comint-input-ring-index diff --git a/lisp/completion.el b/lisp/completion.el index 643f2da0d21..a77cccde643 100644 --- a/lisp/completion.el +++ b/lisp/completion.el @@ -492,7 +492,7 @@ Used to decide whether to save completions.") table)) ;; Old name, non-namespace-clean. -(defvaralias 'cmpl-syntax-table 'completion-syntax-table) +(define-obsolete-variable-alias 'cmpl-syntax-table 'completion-syntax-table "29.1") (defvar-local completion-syntax-table completion-standard-syntax-table "This variable holds the current completion syntax table.") @@ -2220,7 +2220,7 @@ TYPE is the type of the wrapper to be added. Can be :before or :under." (completion-def-wrapper 'delete-backward-char-untabify :backward) ;; Old name, non-namespace-clean. -(defalias 'initialize-completions #'completion-initialize) +(define-obsolete-function-alias 'initialize-completions #'completion-initialize "29.1") (provide 'completion) diff --git a/lisp/composite.el b/lisp/composite.el index 99f528a0779..c2289e8998f 100644 --- a/lisp/composite.el +++ b/lisp/composite.el @@ -901,6 +901,4 @@ For more information on Auto Composition mode, see (provide 'composite) - - ;;; composite.el ends here diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index 5c4448ae71a..ae71140e262 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -1133,7 +1133,7 @@ for the MODE to customize." (defun customize-read-group () (let ((completion-ignore-case t)) - (completing-read "Customize group (default emacs): " + (completing-read (format-prompt "Customize group" "emacs") obarray (lambda (symbol) (or (and (get symbol 'custom-loads) @@ -1205,7 +1205,7 @@ Show the buffer in another window, but don't select it." (unless (eq symbol basevar) (message "`%s' is an alias for `%s'" symbol basevar)))) -(defvar customize-changed-options-previous-release "27.2" +(defvar customize-changed-options-previous-release "28.1" "Version for `customize-changed' to refer back to by default.") ;; Packages will update this variable, so make it available. @@ -2176,7 +2176,7 @@ and `face'." ;;; The `custom' Widget. (defface custom-button - '((((type x w32 ns) (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) (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) (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)) @@ -3458,6 +3458,10 @@ MS Windows.") :sibling-args (:help-echo "\ GNUstep or Macintosh OS Cocoa interface.") ns) + (const :format "PGTK " + :sibling-args (:help-echo "\ +Pure-GTK interface.") + ns) (const :format "DOS " :sibling-args (:help-echo "\ Plain MS-DOS.") diff --git a/lisp/cus-face.el b/lisp/cus-face.el index 6c0052bf860..c78a327fdfa 100644 --- a/lisp/cus-face.el +++ b/lisp/cus-face.el @@ -31,6 +31,9 @@ (defun custom-declare-face (face spec doc &rest args) "Like `defface', but with FACE evaluated as a normal argument." + (when (and doc + (not (stringp doc))) + (error "Invalid (or missing) doc string %S" doc)) (unless (get face 'face-defface-spec) (face-spec-set face (purecopy spec) 'face-defface-spec) (push (cons 'defface face) current-load-list) @@ -51,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." @@ -60,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 @@ -82,22 +92,32 @@ (choice :tag "Weight" :help-echo "Font weight." :value normal ; default + (const :tag "thin" thin) (const :tag "ultralight" ultra-light) - (const :tag "extralight" extra-light) + (const :tag "ultra-light" ultra-light) + (const :tag "extralight" ultra-light) + (const :tag "extra-light" ultra-light) (const :tag "light" light) - (const :tag "thin" thin) (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 1a3e5682bba..579beae123f 100644 --- a/lisp/cus-start.el +++ b/lisp/cus-start.el @@ -386,7 +386,7 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of (const :tag "When sent SIGUSR1" sigusr1) (const :tag "When sent SIGUSR2" sigusr2)) "24.1") - + (translate-upper-case-key-bindings keyboard boolean "29.1") ;; This is not good news because it will use the wrong ;; version-specific directories when you upgrade. We need ;; customization of the front of the list, maintaining the @@ -572,8 +572,10 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of (ns-use-native-fullscreen ns boolean "24.4") (ns-use-fullscreen-animation ns boolean "25.1") (ns-use-srgb-colorspace ns boolean "24.4") + (ns-scroll-event-delta-factor ns float "29.1") ;; process.c (delete-exited-processes processes-basics boolean) + (process-error-pause-time processes-basics integer "29.1") ;; syntax.c (parse-sexp-ignore-comments editing-basics boolean) (words-include-escapes editing-basics boolean) @@ -826,10 +828,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 +853,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 +884,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/cus-theme.el b/lisp/cus-theme.el index 07881e9b74e..f618e3341cb 100644 --- a/lisp/cus-theme.el +++ b/lisp/cus-theme.el @@ -627,22 +627,24 @@ Theme files are named *-theme.el in `")) (let ((help-echo "mouse-2: Enable this theme for this session") widget) (dolist (theme (custom-available-themes)) - (setq widget (widget-create 'checkbox - :value (custom-theme-enabled-p theme) - :theme-name theme - :help-echo help-echo - :action #'custom-theme-checkbox-toggle)) - (push (cons theme widget) custom--listed-themes) - (widget-create-child-and-convert widget 'push-button - :button-face-get 'ignore - :mouse-face-get 'ignore - :value (format " %s" theme) - :action #'widget-parent-action - :help-echo help-echo) - (widget-insert " -- " - (propertize (custom-theme-summary theme) - 'face 'shadow) - ?\n))) + ;; Don't list obsolete themes. + (unless (get theme 'byte-obsolete-info) + (setq widget (widget-create 'checkbox + :value (custom-theme-enabled-p theme) + :theme-name theme + :help-echo help-echo + :action #'custom-theme-checkbox-toggle)) + (push (cons theme widget) custom--listed-themes) + (widget-create-child-and-convert widget 'push-button + :button-face-get 'ignore + :mouse-face-get 'ignore + :value (format " %s" theme) + :action #'widget-parent-action + :help-echo help-echo) + (widget-insert " -- " + (propertize (custom-theme-summary theme) + 'face 'shadow) + ?\n)))) (goto-char (point-min)) (widget-setup)) diff --git a/lisp/custom.el b/lisp/custom.el index cc817403871..9252e80411f 100644 --- a/lisp/custom.el +++ b/lisp/custom.el @@ -364,7 +364,8 @@ call that function directly. See Info node `(elisp) Customization' in the Emacs Lisp manual for more information." - (declare (doc-string 3) (debug (name body))) + (declare (doc-string 3) (debug (name body)) + (indent defun)) ;; It is better not to use backquote in this file, ;; because that makes a bootstrapping problem ;; if you need to recompile all the Lisp files using interpreted code. @@ -447,7 +448,7 @@ In the ATTS property list, possible attributes are `:family', See Info node `(elisp) Faces' in the Emacs Lisp manual for more information." - (declare (doc-string 3)) + (declare (doc-string 3) (indent defun)) ;; It is better not to use backquote in this file, ;; because that makes a bootstrapping problem ;; if you need to recompile all the Lisp files using interpreted code. @@ -515,7 +516,7 @@ non-nil. See Info node `(elisp) Customization' in the Emacs Lisp manual for more information." - (declare (doc-string 3)) + (declare (doc-string 3) (indent defun)) ;; It is better not to use backquote in this file, ;; because that makes a bootstrapping problem ;; if you need to recompile all the Lisp files using interpreted code. @@ -1135,29 +1136,24 @@ list, in which A occurs before B if B was defined with a ;; (provide-theme 'THEME) -;; The IGNORED arguments to deftheme come from the XEmacs theme code, where -;; they were used to supply keyword-value pairs like `:immediate', -;; `:variable-reset-string', etc. We don't use any of these, so ignore them. - -(defmacro deftheme (theme &optional doc &rest _ignored) +(defmacro deftheme (theme &optional doc) "Declare THEME to be a Custom theme. The optional argument DOC is a doc string describing the theme. Any theme `foo' should be defined in a file called `foo-theme.el'; see `custom-make-theme-feature' for more information." (declare (doc-string 2) - (advertised-calling-convention (theme &optional doc) "22.1")) + (indent 1)) (let ((feature (custom-make-theme-feature theme))) ;; It is better not to use backquote in this file, ;; because that makes a bootstrapping problem ;; if you need to recompile all the Lisp files using interpreted code. (list 'custom-declare-theme (list 'quote theme) (list 'quote feature) doc))) -(defun custom-declare-theme (theme feature &optional doc &rest _ignored) +(defun custom-declare-theme (theme feature &optional doc) "Like `deftheme', but THEME is evaluated as a normal argument. FEATURE is the feature this theme provides. Normally, this is a symbol created from THEME by `custom-make-theme-feature'." - (declare (advertised-calling-convention (theme feature &optional doc) "22.1")) (unless (custom-theme-name-valid-p theme) (error "Custom theme cannot be named %S" theme)) (unless (memq theme custom-known-themes) @@ -1335,6 +1331,13 @@ Return t if THEME was successfully loaded, nil otherwise." t)))) (t (error "Unable to load theme `%s'" theme)))) + (when-let ((obs (get theme 'byte-obsolete-info))) + (display-warning 'initialization + (format "The `%s' theme is obsolete%s" + theme + (if (nth 2 obs) + (format " since Emacs %s" (nth 2 obs)) + "")))) ;; Optimization: if the theme changes the `default' face, put that ;; entry first. This avoids some `frame-set-background-mode' rigmarole ;; by assigning the new background immediately. diff --git a/lisp/descr-text.el b/lisp/descr-text.el index 98871164f2a..2a239f81002 100644 --- a/lisp/descr-text.el +++ b/lisp/descr-text.el @@ -417,6 +417,7 @@ The character information includes: (display-table (or (window-display-table) buffer-display-table standard-display-table)) + (composition-string nil) (disp-vector (and display-table (aref display-table char))) (multibyte-p enable-multibyte-characters) (overlays (mapcar (lambda (o) (overlay-properties o)) @@ -538,7 +539,8 @@ The character information includes: (setcar composition nil))) (setcar (cdr composition) (format "composed to form \"%s\" (see below)" - (buffer-substring from to))))) + (setq composition-string + (buffer-substring from to)))))) (setq composition nil))) (setq item-list @@ -682,6 +684,11 @@ The character information includes: (if display (format "terminal code %s" display) "not encodable for terminal")))))) + ,@(when-let ((composition-name + (and composition-string + (eq (aref char-script-table char) 'emoji) + (emoji-describe composition-string)))) + (list (list "composition name" composition-name))) ,@(let ((face (if (not (or disp-vector composition)) (cond diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index 8adda9a2727..5301a3a27ff 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -444,10 +444,10 @@ List has a form of (file-name full-file-name (attribute-list))." ((eq op-symbol 'chgrp) (file-attribute-group-id (file-attributes default-file 'string)))))) - (prompt (concat "Change " attribute-name " of %s to" - (if (eq op-symbol 'touch) - " (default now): " - ": "))) + (prompt (format-prompt "Change %s of %%s to" + (when (eq op-symbol 'touch) + "now") + attribute-name)) (new-attribute (dired-mark-read-string prompt nil op-symbol arg files default (cond ((eq op-symbol 'chown) @@ -1009,6 +1009,7 @@ the offending ARGUMENTS or PROGRAM if no ARGUMENTS were provided." (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")) @@ -1034,6 +1035,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)))) @@ -1282,9 +1284,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))) @@ -1295,10 +1297,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. @@ -1316,7 +1318,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)) @@ -1346,9 +1349,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)) @@ -1363,7 +1367,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")))))))) @@ -1784,13 +1789,46 @@ Special value `always' suppresses confirmation." "Whether Dired should create destination dirs when copying/removing files. If nil, don't create them. If `always', create them without asking. -If `ask', ask for user confirmation." +If `ask', ask for user confirmation. + +Also see `dired-create-destination-dirs-on-trailing-dirsep'." :type '(choice (const :tag "Never create non-existent dirs" nil) (const :tag "Always create non-existent dirs" always) (const :tag "Ask for user confirmation" ask)) :group 'dired :version "27.1") +(defcustom dired-create-destination-dirs-on-trailing-dirsep nil + "If non-nil, treat a trailing slash at queried destination dir specially. + +If this variable is non-nil and a single destination filename is +queried which ends in a directory separator (/), it will be +treated as a non-existent directory and acted on according to +`dired-create-destination-dirs'. + +This option is only relevant if `dired-create-destination-dirs' +is non-nil, too. + +For example, if both `dired-create-destination-dirs' and this +option are non-nil, renaming a directory named `old_name' to +`new_name/' (note the trailing directory separator) where +`new_name' does not exists already, it will be created and +`old_name' be moved into it. If only `new_name' (without the +trailing /) is given or this option or +`dired-create-destination-dirs' is `nil', `old_name' will be +renamed to `new_name'." + :type '(choice + (const :tag + (concat "Do not treat destination dirs with a " + "trailing directory separator specially") + nil) + (const :tag + (concat "Treat destination dirs with trailing " + "directory separator specially") + t)) + :group 'dired + :version "29.1") + (defun dired-maybe-create-dirs (dir) "Create DIR if doesn't exist according to `dired-create-destination-dirs'." (when (and dired-create-destination-dirs (not (file-exists-p dir))) @@ -1986,11 +2024,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 @@ -2159,7 +2198,12 @@ Optional arg HOW-TO determines how to treat the target. target-dir op-symbol arg rfn-list default)))) (into-dir (progn - (unless dired-one-file (dired-maybe-create-dirs target)) + (when + (or + (not dired-one-file) + (and dired-create-destination-dirs-on-trailing-dirsep + (directory-name-p target))) + (dired-maybe-create-dirs target)) (cond ((null how-to) ;; Allow users to change the letter case of ;; a directory on a case-insensitive @@ -2483,11 +2527,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 @@ -2608,11 +2653,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) @@ -2862,8 +2908,8 @@ of marked files. If KILL-ROOT is non-nil, kill DIRNAME as well." ;; if dired-actual-switches contained t. (setq dir1 (file-name-as-directory dir1) dir2 (file-name-as-directory dir2)) - (let ((components-1 (dired-split "/" dir1)) - (components-2 (dired-split "/" dir2))) + (let ((components-1 (split-string dir1 "/")) + (components-2 (split-string dir2 "/"))) (while (and components-1 components-2 (equal (car components-1) (car components-2))) @@ -2882,7 +2928,6 @@ of marked files. If KILL-ROOT is non-nil, kill DIRNAME as well." nil) (t (error "This can't happen")))))) -;; There should be a builtin split function - inverse to mapconcat. (defun dired-split (pat str &optional limit) "Splitting on regexp PAT, turn string STR into a list of substrings. Optional third arg LIMIT (>= 1) is a limit to the length of the @@ -2892,6 +2937,7 @@ Thus, if SEP is a regexp that only matches itself, (mapconcat #'identity (dired-split SEP STRING) SEP) is always equal to STRING." + (declare (obsolete split-string "29.1")) (let* ((start (string-match pat str)) (result (list (substring str 0 start))) (count 1) diff --git a/lisp/dired-x.el b/lisp/dired-x.el index 7c6f49f2ae4..38d8a954a83 100644 --- a/lisp/dired-x.el +++ b/lisp/dired-x.el @@ -554,7 +554,7 @@ If the region is active in Transient Mark mode, operate only on files in the active region if `dired-mark-region' is non-nil." (interactive (list (read-regexp - "Mark unmarked files matching regexp (default all): " + (format-prompt "Mark unmarked files matching regexp" "all") nil 'dired-regexp-history) nil current-prefix-arg nil)) (let ((dired-marker-char (if unflag-p ?\s dired-marker-char))) @@ -580,23 +580,24 @@ files in the active region if `dired-mark-region' is non-nil." (defalias 'virtual-dired 'dired-virtual) (defun dired-virtual (dirname &optional switches) - "Put this Dired buffer into Virtual Dired mode. + "Treat the current buffer as a Dired buffer showing directory DIRNAME. +Interactively, prompt for DIRNAME. -In Virtual Dired mode, all commands that do not actually consult the -filesystem will work. +This command is rarely useful, but may be convenient if you want +to peruse and move around in the output you got from \"ls +-lR\" (or something similar), without having access to the actual +file system. -This is useful if you want to peruse and move around in an ls -lR -output file, for example one you got from an ftp server. With -ange-ftp, you can even Dired a directory containing an ls-lR file, -visit that file and turn on Virtual Dired mode. But don't try to save -this file, as `dired-virtual' indents the listing and thus changes the -buffer. +Most Dired commands that don't consult the file system will work +as advertised, but commands that try to alter the file system +will usually fail. (However, if the output is from the current +system, most of those commands will work fine.) If you have saved a Dired buffer in a file you can use \\[dired-virtual] to resume it in a later session. Type \\<dired-mode-map>\\[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]." @@ -1264,13 +1265,21 @@ sure that a trailing letter in STR is one of BKkMGTPEZY." (let* ((val (string-to-number str)) (u (unless (zerop val) (aref str (1- (length str)))))) - (when (and u (> u ?9)) - (when (= u ?k) - (setq u ?K)) - (let ((units '(?B ?K ?M ?G ?T ?P ?E ?Z ?Y))) - (while (and units (/= (pop units) u)) - (setq val (* 1024.0 val))))) - val)) + ;; If we don't have a unit at the end, but we have some + ;; non-numeric strings in the string, then the string may be + ;; something like "4.134" or "4,134" meant to represent 4134 + ;; (seen in some locales). + (if (and u + (<= ?0 u ?9) + (string-match-p "[^0-9]" str)) + (string-to-number (replace-regexp-in-string "[^0-9]+" "" str)) + (when (and u (> u ?9)) + (when (= u ?k) + (setq u ?K)) + (let ((units '(?B ?K ?M ?G ?T ?P ?E ?Z ?Y))) + (while (and units (/= (pop units) u)) + (setq val (* 1024.0 val))))) + val))) (defun dired-mark-sexp (predicate &optional unflag-p) "Mark files for which PREDICATE returns non-nil. @@ -1478,12 +1487,12 @@ a prefix argument, when it offers the filename near point as a default." ;;; Internal functions -;; Fixme: This should probably use `thing-at-point'. -- fx (define-obsolete-function-alias 'dired-filename-at-point #'dired-x-guess-file-name-at-point "28.1") (defun dired-x-guess-file-name-at-point () "Return the filename closest to point, expanded. Point should be in or after a filename." + (declare (obsolete "use (thing-at-point 'filename) instead." "29.1")) (save-excursion ;; First see if just past a filename. (or (eobp) ; why? @@ -1515,7 +1524,7 @@ Point should be in or after a filename." "Return filename prompting with PROMPT with completion. If `current-prefix-arg' is non-nil, uses name at point as guess." (if current-prefix-arg - (let ((guess (dired-x-guess-file-name-at-point))) + (let ((guess (thing-at-point 'filename))) (read-file-name prompt (file-name-directory guess) guess diff --git a/lisp/dired.el b/lisp/dired.el index 46525891224..a8841214156 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -35,6 +35,7 @@ ;;; Code: (eval-when-compile (require 'subr-x)) +(eval-when-compile (require 'cl-lib)) ;; When bootstrapping dired-loaddefs has not been generated. (require 'dired-loaddefs nil t) @@ -208,6 +209,18 @@ If a character, new links are unconditionally marked with that character." (character :tag "Mark")) :group 'dired-mark) +(defcustom dired-free-space 'first + "Whether and how to display the amount of free disk space in Dired buffers. +If nil, don't display. +If `separate', display on a separate line (along with used count). +If `first', display only the free disk space on the first line, +following the directory name." + :type '(choice (const :tag "On a separate line" separate) + (const :tag "On the first line, after directory name" first) + (const :tag "Don't display" nil)) + :version "29.1" + :group 'dired) + (defcustom dired-dwim-target nil "If non-nil, Dired tries to guess a default target directory. This means: if there is a Dired buffer displayed in some window, @@ -281,6 +294,11 @@ with the buffer narrowed to the listing." ;; Note this can't simply be run inside function `dired-ls' as the hook ;; functions probably depend on the dired-subdir-alist to be OK. +(defcustom dired-make-directory-clickable t + "When non-nil, make the directory at the start of the dired buffer clickable." + :version "29.1" + :type 'boolean) + (defcustom dired-initial-position-hook nil "This hook is used to position the point. It is run by the function `dired-initial-position'." @@ -339,11 +357,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-<down> 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 @@ -1247,8 +1265,7 @@ The return value is the target column for the file names." ;; Don't try to find a wildcard as a subdirectory. (string-equal dirname (file-name-directory dirname))) (let* ((cur-buf (current-buffer)) - (buffers (nreverse - (dired-buffers-for-dir (expand-file-name dirname)))) + (buffers (nreverse (dired-buffers-for-dir dirname))) (cur-buf-matches (and (memq cur-buf buffers) ;; Wildcards must match, too: (equal dired-directory dirname)))) @@ -1326,6 +1343,8 @@ wildcards, erases the buffer, and builds the subdir-alist anew (set-visited-file-modtime (file-attribute-modification-time attributes)))) (set-buffer-modified-p nil) + (when dired-make-directory-clickable + (dired--make-directory-clickable)) ;; No need to narrow since the whole buffer contains just ;; dired-readin's output, nothing else. The hook can ;; successfully use dired functions (e.g. dired-get-filename) @@ -1606,15 +1625,55 @@ see `dired-use-ls-dired' for more details.") ;; by its expansion, so it does not matter whether what we insert ;; here is fully expanded, but it should be absolute. (insert " " (or (car-safe (insert-directory-wildcard-in-dir-p dir)) - (directory-file-name (file-name-directory dir))) ":\n") + (directory-file-name (file-name-directory dir))) + ":\n") (setq content-point (point))) (when wildcard ;; Insert "wildcard" line where "total" line would be for a full dir. (insert " wildcard " (or (cdr-safe (insert-directory-wildcard-in-dir-p dir)) (file-name-nondirectory dir)) - "\n"))) + "\n")) + (setq content-point (dired--insert-disk-space opoint dir))) (dired-insert-set-properties content-point (point))))) +(defun dired--insert-disk-space (beg file) + ;; Try to insert the amount of free space. + (save-excursion + (goto-char beg) + ;; First find the line to put it on. + (if (not (re-search-forward "^ *\\(total\\)" nil t)) + beg + (if (or (not dired-free-space) + (eq dired-free-space 'first)) + (delete-region (match-beginning 0) (line-beginning-position 2)) + ;; Replace "total" with "total used in directory" to + ;; avoid confusion. + (replace-match "total used in directory" nil nil nil 1)) + (if-let ((available (get-free-disk-space file))) + (cond + ((eq dired-free-space 'separate) + (end-of-line) + (insert " available " available) + (forward-line 1) + (point)) + ((eq dired-free-space 'first) + (goto-char beg) + (when (and (looking-at + (if (memq system-type '(windows-nt ms-dos)) + " *[A-Za-z]:/" + " */")) + (progn + (end-of-line) + (eq (char-after (1- (point))) ?:))) + (put-text-property (1- (point)) (point) + 'display + (concat ": (" available " available)"))) + (forward-line 1) + (point)) + (t + beg)) + beg)))) + (defun dired-insert-set-properties (beg end) "Add various text properties to the lines in the region, from BEG to END." (save-excursion @@ -1643,6 +1702,32 @@ see `dired-use-ls-dired' for more details.") 'invisible 'dired-hide-details-link)))) (forward-line 1)))) +(defun dired--make-directory-clickable () + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "^ /" nil t 1) + (let ((bound (line-end-position)) + (segment-start (point)) + (inhibit-read-only t) + (dir "/")) + (while (search-forward "/" bound t 1) + (setq dir (concat dir (buffer-substring segment-start (point)))) + (add-text-properties + segment-start (1- (point)) + `( mouse-face highlight + help-echo "mouse-1: goto this directory" + keymap ,(let* ((current-dir dir) + (click (lambda () + (interactive) + (if (assoc current-dir dired-subdir-alist) + (dired-goto-subdir current-dir) + (dired current-dir))))) + (define-keymap + "<mouse-2>" click + "<follow-link>" 'mouse-face + "RET" click)))) + (setq segment-start (point))))))) + ;;; Reverting a dired buffer @@ -1835,160 +1920,152 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST." ;;; Dired mode key bindings and menus -(defvar dired-mode-map +(defvar-keymap dired-mode-map + :doc "Local keymap for Dired mode buffers." + :full t + :parent special-mode-map ;; This looks ugly when substitute-command-keys uses C-d instead d: - ;; (define-key dired-mode-map "\C-d" 'dired-flag-file-deletion) - (let ((map (make-keymap))) - (set-keymap-parent map special-mode-map) - (define-key map [mouse-2] 'dired-mouse-find-file-other-window) - (define-key map [follow-link] 'mouse-face) - ;; Commands to mark or flag certain categories of files - (define-key map "#" 'dired-flag-auto-save-files) - (define-key map "." 'dired-clean-directory) - (define-key map "~" 'dired-flag-backup-files) - ;; Upper case keys (except !) for operating on the marked files - (define-key map "A" 'dired-do-find-regexp) - (define-key map "C" 'dired-do-copy) - (define-key map "B" 'dired-do-byte-compile) - (define-key map "D" 'dired-do-delete) - (define-key map "G" 'dired-do-chgrp) - (define-key map "H" 'dired-do-hardlink) - (define-key map "L" 'dired-do-load) - (define-key map "M" 'dired-do-chmod) - (define-key map "O" 'dired-do-chown) - (define-key map "P" 'dired-do-print) - (define-key map "Q" 'dired-do-find-regexp-and-replace) - (define-key map "R" 'dired-do-rename) - (define-key map "S" 'dired-do-symlink) - (define-key map "T" 'dired-do-touch) - (define-key map "X" 'dired-do-shell-command) - (define-key map "Z" 'dired-do-compress) - (define-key map "c" 'dired-do-compress-to) - (define-key map "!" 'dired-do-shell-command) - (define-key map "&" 'dired-do-async-shell-command) - ;; Comparison commands - (define-key map "=" 'dired-diff) - ;; Tree Dired commands - (define-key map "\M-\C-?" 'dired-unmark-all-files) - (define-key map "\M-\C-d" 'dired-tree-down) - (define-key map "\M-\C-u" 'dired-tree-up) - (define-key map "\M-\C-n" 'dired-next-subdir) - (define-key map "\M-\C-p" 'dired-prev-subdir) - ;; move to marked files - (define-key map "\M-{" 'dired-prev-marked-file) - (define-key map "\M-}" 'dired-next-marked-file) - ;; Make all regexp commands share a `%' prefix: - ;; We used to get to the submap via a symbol dired-regexp-prefix, - ;; but that seems to serve little purpose, and copy-keymap - ;; does a better job without it. - (define-key map "%" nil) - (define-key map "%u" 'dired-upcase) - (define-key map "%l" 'dired-downcase) - (define-key map "%d" 'dired-flag-files-regexp) - (define-key map "%g" 'dired-mark-files-containing-regexp) - (define-key map "%m" 'dired-mark-files-regexp) - (define-key map "%r" 'dired-do-rename-regexp) - (define-key map "%C" 'dired-do-copy-regexp) - (define-key map "%H" 'dired-do-hardlink-regexp) - (define-key map "%R" 'dired-do-rename-regexp) - (define-key map "%S" 'dired-do-symlink-regexp) - (define-key map "%&" 'dired-flag-garbage-files) - ;; Commands for marking and unmarking. - (define-key map "*" nil) - (define-key map "**" 'dired-mark-executables) - (define-key map "*/" 'dired-mark-directories) - (define-key map "*@" 'dired-mark-symlinks) - (define-key map "*%" 'dired-mark-files-regexp) - (define-key map "*N" 'dired-number-of-marked-files) - (define-key map "*c" 'dired-change-marks) - (define-key map "*s" 'dired-mark-subdir-files) - (define-key map "*m" 'dired-mark) - (define-key map "*u" 'dired-unmark) - (define-key map "*?" 'dired-unmark-all-files) - (define-key map "*!" 'dired-unmark-all-marks) - (define-key map "U" 'dired-unmark-all-marks) - (define-key map "*\177" 'dired-unmark-backward) - (define-key map "*\C-n" 'dired-next-marked-file) - (define-key map "*\C-p" 'dired-prev-marked-file) - (define-key map "*t" 'dired-toggle-marks) - ;; Lower keys for commands not operating on all the marked files - (define-key map "a" 'dired-find-alternate-file) - (define-key map "d" 'dired-flag-file-deletion) - (define-key map "e" 'dired-find-file) - (define-key map "f" 'dired-find-file) - (define-key map "\C-m" 'dired-find-file) - (put 'dired-find-file :advertised-binding "\C-m") - (define-key map "g" 'revert-buffer) - (define-key map "i" 'dired-maybe-insert-subdir) - (define-key map "j" 'dired-goto-file) - (define-key map "k" 'dired-do-kill-lines) - (define-key map "l" 'dired-do-redisplay) - (define-key map "m" 'dired-mark) - (define-key map "n" 'dired-next-line) - (define-key map "o" 'dired-find-file-other-window) - (define-key map "\C-o" 'dired-display-file) - (define-key map "p" 'dired-previous-line) - (define-key map "s" 'dired-sort-toggle-or-edit) - (define-key map "t" 'dired-toggle-marks) - (define-key map "u" 'dired-unmark) - (define-key map "v" 'dired-view-file) - (define-key map "w" 'dired-copy-filename-as-kill) - (define-key map "W" 'browse-url-of-dired-file) - (define-key map "x" 'dired-do-flagged-delete) - (define-key map "y" 'dired-show-file-type) - (define-key map "+" 'dired-create-directory) - ;; moving - (define-key map "<" 'dired-prev-dirline) - (define-key map ">" 'dired-next-dirline) - (define-key map "^" 'dired-up-directory) - (define-key map " " 'dired-next-line) - (define-key map [?\S-\ ] 'dired-previous-line) - (define-key map [remap next-line] 'dired-next-line) - (define-key map [remap previous-line] 'dired-previous-line) - ;; hiding - (define-key map "$" 'dired-hide-subdir) - (define-key map "\M-$" 'dired-hide-all) - (define-key map "(" 'dired-hide-details-mode) - ;; isearch - (define-key map (kbd "M-s a C-s") 'dired-do-isearch) - (define-key map (kbd "M-s a M-C-s") 'dired-do-isearch-regexp) - (define-key map (kbd "M-s f C-s") 'dired-isearch-filenames) - (define-key map (kbd "M-s f M-C-s") 'dired-isearch-filenames-regexp) - ;; misc - (define-key map [remap read-only-mode] 'dired-toggle-read-only) - ;; `toggle-read-only' is an obsolete alias for `read-only-mode' - (define-key map [remap toggle-read-only] 'dired-toggle-read-only) - (define-key map "?" 'dired-summary) - (define-key map "\177" 'dired-unmark-backward) - (define-key map [remap undo] 'dired-undo) - (define-key map [remap advertised-undo] 'dired-undo) - (define-key map [remap vc-next-action] 'dired-vc-next-action) - ;; thumbnail manipulation (image-dired) - (define-key map "\C-td" 'image-dired-display-thumbs) - (define-key map "\C-tt" 'image-dired-tag-files) - (define-key map "\C-tr" 'image-dired-delete-tag) - (define-key map "\C-tj" 'image-dired-jump-thumbnail-buffer) - (define-key map "\C-ti" 'image-dired-dired-display-image) - (define-key map "\C-tx" 'image-dired-dired-display-external) - (define-key map "\C-ta" 'image-dired-display-thumbs-append) - (define-key map "\C-t." 'image-dired-display-thumb) - (define-key map "\C-tc" 'image-dired-dired-comment-files) - (define-key map "\C-tf" 'image-dired-mark-tagged-files) - (define-key map "\C-t\C-t" 'image-dired-dired-toggle-marked-thumbs) - (define-key map "\C-te" 'image-dired-dired-edit-comment-and-tags) - ;; encryption and decryption (epa-dired) - (define-key map ":d" 'epa-dired-do-decrypt) - (define-key map ":v" 'epa-dired-do-verify) - (define-key map ":s" 'epa-dired-do-sign) - (define-key map ":e" 'epa-dired-do-encrypt) - - ;; No need to do this, now that top-level items are fewer. - ;;;; - ;; Get rid of the Edit menu bar item to save space. - ;;(define-key map [menu-bar edit] 'undefined) - - map) - "Local keymap for Dired mode buffers.") + ;; "C-d" #'dired-flag-file-deletion + "<mouse-2>" #'dired-mouse-find-file-other-window + "<follow-link>" 'mouse-face + ;; Commands to mark or flag certain categories of files + "#" #'dired-flag-auto-save-files + "." #'dired-clean-directory + "~" #'dired-flag-backup-files + ;; Upper case keys (except !) for operating on the marked files + "A" #'dired-do-find-regexp + "C" #'dired-do-copy + "B" #'dired-do-byte-compile + "D" #'dired-do-delete + "G" #'dired-do-chgrp + "H" #'dired-do-hardlink + "L" #'dired-do-load + "M" #'dired-do-chmod + "O" #'dired-do-chown + "P" #'dired-do-print + "Q" #'dired-do-find-regexp-and-replace + "R" #'dired-do-rename + "S" #'dired-do-symlink + "T" #'dired-do-touch + "X" #'dired-do-shell-command + "Z" #'dired-do-compress + "c" #'dired-do-compress-to + "!" #'dired-do-shell-command + "&" #'dired-do-async-shell-command + ;; Comparison commands + "=" #'dired-diff + ;; Tree Dired commands + "M-DEL" #'dired-unmark-all-files + "C-M-d" #'dired-tree-down + "C-M-u" #'dired-tree-up + "C-M-n" #'dired-next-subdir + "C-M-p" #'dired-prev-subdir + ;; move to marked files + "M-{" #'dired-prev-marked-file + "M-}" #'dired-next-marked-file + ;; Make all regexp commands share a `%' prefix: + ;; We used to get to the submap via a symbol dired-regexp-prefix, + ;; but that seems to serve little purpose, and copy-keymap + ;; does a better job without it. + "% u" #'dired-upcase + "% l" #'dired-downcase + "% d" #'dired-flag-files-regexp + "% g" #'dired-mark-files-containing-regexp + "% m" #'dired-mark-files-regexp + "% r" #'dired-do-rename-regexp + "% C" #'dired-do-copy-regexp + "% H" #'dired-do-hardlink-regexp + "% R" #'dired-do-rename-regexp + "% S" #'dired-do-symlink-regexp + "% &" #'dired-flag-garbage-files + ;; Commands for marking and unmarking. + "* *" #'dired-mark-executables + "* /" #'dired-mark-directories + "* @" #'dired-mark-symlinks + "* %" #'dired-mark-files-regexp + "* N" #'dired-number-of-marked-files + "* c" #'dired-change-marks + "* s" #'dired-mark-subdir-files + "* m" #'dired-mark + "* u" #'dired-unmark + "* ?" #'dired-unmark-all-files + "* !" #'dired-unmark-all-marks + "U" #'dired-unmark-all-marks + "* DEL" #'dired-unmark-backward + "* C-n" #'dired-next-marked-file + "* C-p" #'dired-prev-marked-file + "* t" #'dired-toggle-marks + ;; Lower keys for commands not operating on all the marked files + "a" #'dired-find-alternate-file + "d" #'dired-flag-file-deletion + "e" #'dired-find-file + "f" #'dired-find-file + "C-m" #'dired-find-file + "g" #'revert-buffer + "i" #'dired-maybe-insert-subdir + "j" #'dired-goto-file + "k" #'dired-do-kill-lines + "l" #'dired-do-redisplay + "m" #'dired-mark + "n" #'dired-next-line + "o" #'dired-find-file-other-window + "C-o" #'dired-display-file + "p" #'dired-previous-line + "s" #'dired-sort-toggle-or-edit + "t" #'dired-toggle-marks + "u" #'dired-unmark + "v" #'dired-view-file + "w" #'dired-copy-filename-as-kill + "W" #'browse-url-of-dired-file + "x" #'dired-do-flagged-delete + "y" #'dired-show-file-type + "+" #'dired-create-directory + ;; moving + "<" #'dired-prev-dirline + ">" #'dired-next-dirline + "^" #'dired-up-directory + "SPC" #'dired-next-line + "S-SPC" #'dired-previous-line + "<remap> <next-line>" #'dired-next-line + "<remap> <previous-line>" #'dired-previous-line + ;; hiding + "$" #'dired-hide-subdir + "M-$" #'dired-hide-all + "(" #'dired-hide-details-mode + ;; isearch + "M-s a C-s" #'dired-do-isearch + "M-s a C-M-s" #'dired-do-isearch-regexp + "M-s f C-s" #'dired-isearch-filenames + "M-s f C-M-s" #'dired-isearch-filenames-regexp + ;; misc + "<remap> <read-only-mode>" #'dired-toggle-read-only + ;; `toggle-read-only' is an obsolete alias for `read-only-mode' + "<remap> <toggle-read-only>" #'dired-toggle-read-only + "?" #'dired-summary + "DEL" #'dired-unmark-backward + "<remap> <undo>" #'dired-undo + "<remap> <advertised-undo>" #'dired-undo + "<remap> <vc-next-action>" #'dired-vc-next-action + ;; thumbnail manipulation (image-dired) + "C-t d" #'image-dired-display-thumbs + "C-t t" #'image-dired-tag-files + "C-t r" #'image-dired-delete-tag + "C-t j" #'image-dired-jump-thumbnail-buffer + "C-t i" #'image-dired-dired-display-image + "C-t x" #'image-dired-dired-display-external + "C-t a" #'image-dired-display-thumbs-append + "C-t ." #'image-dired-display-thumb + "C-t c" #'image-dired-dired-comment-files + "C-t f" #'image-dired-mark-tagged-files + "C-t C-t" #'image-dired-dired-toggle-marked-thumbs + "C-t e" #'image-dired-dired-edit-comment-and-tags + ;; encryption and decryption (epa-dired) + ": d" #'epa-dired-do-decrypt + ": v" #'epa-dired-do-verify + ": s" #'epa-dired-do-sign + ": e" #'epa-dired-do-encrypt) + +(put 'dired-find-file :advertised-binding (kbd "RET")) (easy-menu-define dired-mode-subdir-menu dired-mode-map "Subdir menu for Dired mode." @@ -2415,7 +2492,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 \\<dired-mode-map>" + "\\[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 @@ -2879,7 +2958,7 @@ directories below DIR. The list is in reverse order of buffer creation, most recent last. As a side effect, killed dired buffers for DIR are removed from `dired-buffers'." - (setq dir (file-name-as-directory dir)) + (setq dir (file-name-as-directory (expand-file-name dir))) (let (result buf) (dolist (elt dired-buffers) (setq buf (cdr elt)) @@ -3430,7 +3509,7 @@ If the buffer has a wildcard pattern, check that it matches FILE. FILE may be nil, in which case ignore it. Return list of buffers where FUN succeeded (i.e., returned non-nil)." (let (success-list) - (dolist (buf (dired-buffers-for-dir (expand-file-name directory) file)) + (dolist (buf (dired-buffers-for-dir directory file)) (with-current-buffer buf (when (apply fun args) (push (buffer-name buf) success-list)))) @@ -3479,8 +3558,7 @@ confirmation. To disable the confirmation, see (file-name-nondirectory fn)))) (not dired-clean-confirm-killing-deleted-buffers)) (kill-buffer buf))) - (let ((buf-list (dired-buffers-for-dir (expand-file-name fn) - nil 'subdirs))) + (let ((buf-list (dired-buffers-for-dir fn nil 'subdirs))) (and buf-list (or (and dired-clean-confirm-killing-deleted-buffers (y-or-n-p @@ -4066,9 +4144,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..11559bf2f50 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" + ["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"] + "---" + ["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)] + :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)] + :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) t] + ["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 @@ -756,9 +811,10 @@ OpenDocument format)." (and doc-view-dvipdfm-program (executable-find doc-view-dvipdfm-program))))) ((memq type '(postscript ps eps pdf)) - ;; FIXME: allow mupdf here - (and doc-view-ghostscript-program - (executable-find doc-view-ghostscript-program))) + (or (and doc-view-ghostscript-program + (executable-find doc-view-ghostscript-program)) + (and doc-view-pdfdraw-program + (executable-find doc-view-pdfdraw-program)))) ((eq type 'odf) (and doc-view-odf->pdf-converter-program (executable-find doc-view-odf->pdf-converter-program) @@ -1530,16 +1586,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")))) +\\<doc-view-mode-map> +\\[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 42c164a0881..29900a9595c 100644 --- a/lisp/edmacro.el +++ b/lisp/edmacro.el @@ -610,6 +610,12 @@ This function assumes that the events can be stored in a string." (defun edmacro-fix-menu-commands (macro &optional noerror) (if (vectorp macro) (let (result) + ;; Not preloaded in without-x builds. + (require 'mwheel) + (defvar mouse-wheel-down-event) + (defvar mouse-wheel-left-event) + (defvar mouse-wheel-right-event) + (defvar mouse-wheel-up-event) ;; Make a list of the elements. (setq macro (append macro nil)) (dolist (ev macro) @@ -640,101 +646,10 @@ This function assumes that the events can be stored in a string." ;;; Parsing a human-readable keyboard macro. (defun edmacro-parse-keys (string &optional need-vector) - (let ((case-fold-search nil) - (len (length string)) ; We won't alter string in the loop below. - (pos 0) - (res [])) - (while (and (< pos len) - (string-match "[^ \t\n\f]+" string pos)) - (let* ((word-beg (match-beginning 0)) - (word-end (match-end 0)) - (word (substring string word-beg len)) - (times 1) - key) - ;; Try to catch events of the form "<as df>". - (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 string 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 "$" string pos))) - (t - (let ((orig-word word) (prefix 0) (bits 0)) - (while (string-match "^[ACHMsS]-." word) - (cl-incf bits (cdr (assq (aref word 0) - '((?A . ?\A-\^@) (?C . ?\C-\^@) - (?H . ?\H-\^@) (?M . ?\M-\^@) - (?s . ?\s-\^@) (?S . ?\S-\^@))))) - (cl-incf prefix 2) - (cl-callf substring word 2)) - (when (string-match "^\\^.$" word) - (cl-incf bits ?\C-\^@) - (cl-incf prefix) - (cl-callf 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) - (cl-loop for ch across word - for n = 0 then (+ (* n 8) ch -48) - finally do (setq word (vector n)))) - (cond ((= bits 0) - (setq key word)) - ((and (= bits ?\M-\^@) (stringp word) - (string-match "^-?[0-9]+$" word)) - (setq key (cl-loop for x across word - collect (+ x bits)))) - ((/= (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 - (cl-loop repeat times do (cl-callf 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 (cl-subseq res 2 -2))) - (if (and (not need-vector) - (cl-loop for ch across res - always (and (characterp ch) - (let ((ch2 (logand ch (lognot ?\M-\^@)))) - (and (>= ch2 0) (<= ch2 127)))))) - (concat (cl-loop for ch across res - collect (if (= (logand ch ?\M-\^@) 0) - ch (+ ch 128)))) - res))) + (let ((result (kbd string))) + (if (and need-vector (stringp result)) + (seq-into result 'vector) + result))) (provide 'edmacro) diff --git a/lisp/elec-pair.el b/lisp/elec-pair.el index ba88c819133..f907bba4c6e 100644 --- a/lisp/elec-pair.el +++ b/lisp/elec-pair.el @@ -308,51 +308,51 @@ If point is not enclosed by any lists, return ((t) . (t))." ;; called when `scan-sexps' ran perfectly, when it found ;; a parenthesis pointing in the direction of travel. ;; Also when travel started inside a comment and exited it. - #'(lambda () - (setq outermost (list t)) - (unless innermost - (setq innermost (list t))))) + (lambda () + (setq outermost (list t)) + (unless innermost + (setq innermost (list t))))) (ended-prematurely-fn ;; called when `scan-sexps' crashed against a parenthesis ;; pointing opposite the direction of travel. After ;; traversing that character, the idea is to travel one sexp ;; in the opposite direction looking for a matching ;; delimiter. - #'(lambda () - (let* ((pos (point)) - (matched - (save-excursion - (cond ((< direction 0) - (condition-case nil - (eq (char-after pos) - (electric-pair--with-uncached-syntax - (table) - (matching-paren - (char-before - (scan-sexps (point) 1))))) - (scan-error nil))) - (t - ;; In this case, no need to use - ;; `scan-sexps', we can use some - ;; `electric-pair--syntax-ppss' in this - ;; case (which uses the quicker - ;; `syntax-ppss' in some cases) - (let* ((ppss (electric-pair--syntax-ppss - (1- (point)))) - (start (car (last (nth 9 ppss)))) - (opener (char-after start))) - (and start - (eq (char-before pos) - (or (with-syntax-table table - (matching-paren opener)) - opener)))))))) - (actual-pair (if (> direction 0) - (char-before (point)) - (char-after (point))))) - (unless innermost - (setq innermost (cons matched actual-pair))) - (unless matched - (setq outermost (cons matched actual-pair))))))) + (lambda () + (let* ((pos (point)) + (matched + (save-excursion + (cond ((< direction 0) + (condition-case nil + (eq (char-after pos) + (electric-pair--with-uncached-syntax + (table) + (matching-paren + (char-before + (scan-sexps (point) 1))))) + (scan-error nil))) + (t + ;; In this case, no need to use + ;; `scan-sexps', we can use some + ;; `electric-pair--syntax-ppss' in this + ;; case (which uses the quicker + ;; `syntax-ppss' in some cases) + (let* ((ppss (electric-pair--syntax-ppss + (1- (point)))) + (start (car (last (nth 9 ppss)))) + (opener (char-after start))) + (and start + (eq (char-before pos) + (or (with-syntax-table table + (matching-paren opener)) + opener)))))))) + (actual-pair (if (> direction 0) + (char-before (point)) + (char-after (point))))) + (unless innermost + (setq innermost (cons matched actual-pair))) + (unless matched + (setq outermost (cons matched actual-pair))))))) (save-excursion (while (not outermost) (condition-case err diff --git a/lisp/electric.el b/lisp/electric.el index 4394fae4366..a2f24ca05c6 100644 --- a/lisp/electric.el +++ b/lisp/electric.el @@ -506,11 +506,11 @@ This list's members correspond to left single quote, right single quote, left double quote, and right double quote, respectively." :version "26.1" :type '(list character character character character) - :safe #'(lambda (x) - (pcase x - (`(,(pred characterp) ,(pred characterp) - ,(pred characterp) ,(pred characterp)) - t))) + :safe (lambda (x) + (pcase x + (`(,(pred characterp) ,(pred characterp) + ,(pred characterp) ,(pred characterp)) + t))) :group 'electricity) (defcustom electric-quote-paragraph t diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index aaacba2c8e5..d8b4c1f8850 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -32,7 +32,7 @@ (require 'lisp-mode) ;for `doc-string-elt' properties. (require 'lisp-mnt) -(eval-when-compile (require 'cl-lib)) +(require 'cl-lib) (defvar generated-autoload-file nil "File into which to write autoload definitions. @@ -393,6 +393,8 @@ FILE's name." (concat ";;; " basename " --- automatically extracted " (or type "autoloads") " -*- lexical-binding: t -*-\n" + (when (string-match "/lisp/loaddefs\\.el\\'" file) + ";; This file will be copied to ldefs-boot.el and checked in periodically.\n") ";;\n" ";;; Code:\n\n" (if lp @@ -1194,9 +1196,17 @@ directory or directories specified." (goto-char (point-max)) (search-backward "\f" nil t) (autoload-insert-section-header - (current-buffer) nil nil no-autoloads (if autoload-timestamps - no-autoloads-time - autoload--non-timestamp)) + (current-buffer) nil nil + ;; Filter out the other loaddefs files, because it makes + ;; the list unstable (and leads to spurious changes in + ;; ldefs-boot.el) since the loaddef files can be created in + ;; any order. + (seq-filter (lambda (file) + (not (string-match-p "[/-]loaddefs.el" file))) + no-autoloads) + (if autoload-timestamps + no-autoloads-time + autoload--non-timestamp)) (insert generate-autoload-section-trailer))) ;; Don't modify the file if its content has not been changed, so `make' 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 c8990f23531..66ac67a8144 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -342,8 +342,12 @@ for speeding up processing.") (numberp expr) (stringp expr) (and (consp expr) - (memq (car expr) '(quote function)) - (symbolp (cadr expr))) + (or (and (memq (car expr) '(quote function)) + (symbolp (cadr expr))) + ;; (internal-get-closed-var N) can be considered constant for + ;; const-prop purposes. + (and (eq (car expr) 'internal-get-closed-var) + (integerp (cadr expr))))) (keywordp expr))) (defmacro byte-optimize--pcase (exp &rest cases) @@ -1261,7 +1265,7 @@ See Info node `(elisp) Integer Basics'." (list 'or (car (car clauses)) (byte-optimize-cond (cons (car form) (cdr (cdr form))))) - form)) + (and clauses form))) form)) (defun byte-optimize-if (form) @@ -1460,6 +1464,7 @@ See Info node `(elisp) Integer Basics'." (let ((side-effect-free-fns '(% * + - / /= 1+ 1- < <= = > >= abs acos append aref ash asin atan assq + base64-decode-string base64-encode-string base64url-encode-string bool-vector-count-consecutive bool-vector-count-population bool-vector-subsetp boundp buffer-file-name buffer-local-variables buffer-modified-p @@ -1616,6 +1621,7 @@ See Info node `(elisp) Integer Basics'." assq rassq rassoc plist-get lax-plist-get plist-member aref elt + base64-decode-string base64-encode-string base64url-encode-string bool-vector-subsetp bool-vector-count-population bool-vector-count-consecutive ))) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index da86fa5cecf..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 @@ -380,7 +381,7 @@ You don't need this. (See bytecomp.el commentary for more details.) "Define an inline function. The syntax is just like that of `defun'. \(fn NAME ARGLIST &optional DOCSTRING DECL &rest BODY)" - (declare (debug defun) (doc-string 3)) + (declare (debug defun) (doc-string 3) (indent 2)) (or (memq (get name 'byte-optimizer) '(nil byte-compile-inline-expand)) (error "`%s' is a primitive" name)) @@ -434,7 +435,7 @@ WHEN should be a string indicating when the function was first made obsolete, for example a date or a release number. See the docstrings of `defalias' and `make-obsolete' for more details." - (declare (doc-string 4)) + (declare (doc-string 4) (indent defun)) `(progn (defalias ,obsolete-name ,current-name ,docstring) (make-obsolete ,obsolete-name ,current-name ,when))) @@ -483,7 +484,7 @@ For the benefit of Customize, if OBSOLETE-NAME has any of the following properties, they are copied to CURRENT-NAME, if it does not already have them: `saved-value', `saved-variable-comment'." - (declare (doc-string 4)) + (declare (doc-string 4) (indent defun)) `(progn (defvaralias ,obsolete-name ,current-name ,docstring) ;; See Bug#4706. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 3f050d1b799..a64af022d4f 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -299,7 +299,7 @@ The information is logged to `byte-compile-log-buffer'." '(redefine callargs free-vars unresolved obsolete noruntime interactive-only make-local mapcar constants suspicious lexical lexical-dynamic - docstrings) + docstrings not-unused) "The list of warning types used when `byte-compile-warnings' is t.") (defcustom byte-compile-warnings t "List of warnings that the byte-compiler should issue (t for all). @@ -321,6 +321,7 @@ Elements of the list may be: lexically bound variable declared dynamic elsewhere make-local calls to `make-variable-buffer-local' that may be incorrect. mapcar mapcar called for effect. + not-unused warning about using variables with symbol names starting with _. constants let-binding of, or assignment to, constants/nonvariables. docstrings docstrings that are too wide (longer than `byte-compile-docstring-max-column' or @@ -343,6 +344,7 @@ suppress. For example, (not mapcar) will suppress warnings about mapcar." (or (symbolp v) (null (delq nil (mapcar (lambda (x) (not (symbolp x))) v)))))) +;;;###autoload (defun byte-compile-warning-enabled-p (warning &optional symbol) "Return non-nil if WARNING is enabled, according to `byte-compile-warnings'." (let ((suppress nil)) @@ -508,7 +510,7 @@ Return the compile-time value of FORM." ;; whether to compile as byte-compile-form ;; or byte-compile-file-form. (let ((expanded - (macroexpand-all + (macroexpand--all-toplevel form macroexpand-all-environment))) (eval expanded lexical-binding) @@ -1671,9 +1673,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. @@ -1705,10 +1712,10 @@ It is too wide if it has any lines longer than the largest of (nth 2 form))))) (when (and (consp name) (eq (car name) 'quote)) (setq name (cadr name))) - (setq name (if name (format " `%s'" name) "")) + (setq name (if name (format " `%s' " name) "")) (when (and kind docs (stringp docs) (byte-compile--wide-docstring-p docs col)) - (byte-compile-warn "%s%s docstring wider than %s characters" + (byte-compile-warn "%s%sdocstring wider than %s characters" kind name col)))) form) @@ -2223,8 +2230,7 @@ With argument ARG, insert value in current buffer after the form." (byte-compile-depth 0) (byte-compile-maxdepth 0) (byte-compile-output nil) - ;; This allows us to get the positions of symbols read; it's - ;; new in Emacs 22.1. + ;; This allows us to get the positions of symbols read. (read-with-symbol-positions inbuffer) (read-symbol-positions-list nil) ;; #### This is bound in b-c-close-variables. @@ -2671,15 +2677,6 @@ list that represents a doc string reference. (prog1 (byte-compile-keep-pending form) (apply 'make-obsolete (mapcar 'eval (cdr form))))) -;; This handler is not necessary, but it makes the output from dont-compile -;; and similar macros cleaner. -(put 'eval 'byte-hunk-handler 'byte-compile-file-form-eval) -(defun byte-compile-file-form-eval (form) - (if (and (eq (car-safe (nth 1 form)) 'quote) - (equal (nth 2 form) lexical-binding)) - (nth 1 (nth 1 form)) - (byte-compile-keep-pending form))) - (defun byte-compile-file-form-defmumble (name macro arglist body rest) "Process a `defalias' for NAME. If MACRO is non-nil, the definition is known to be a macro. @@ -4929,13 +4926,13 @@ binding slots have been popped." ;; if it weren't for the fact that we need to figure out when a defalias ;; defines a macro, so as to add it to byte-compile-macro-environment. ;; - ;; FIXME: we also use this hunk-handler to implement the function's dynamic - ;; docstring feature. We could actually implement it more elegantly in - ;; byte-compile-lambda so it applies to all lambdas, but the problem is that - ;; the resulting .elc format will not be recognized by make-docfile, so - ;; either we stop using DOC for the docstrings of preloaded elc files (at the - ;; cost of around 24KB on 32bit hosts, double on 64bit hosts) or we need to - ;; build DOC in a more clever way (e.g. handle anonymous elements). + ;; FIXME: we also use this hunk-handler to implement the function's + ;; dynamic docstring feature (via byte-compile-file-form-defmumble). + ;; We should actually implement it (more elegantly) in + ;; byte-compile-lambda so it applies to all lambdas. We did it here + ;; so the resulting .elc format was recognizable by make-docfile, + ;; but since then we stopped using DOC for the docstrings of + ;; preloaded elc files so that obstacle is gone. (let ((byte-compile-free-references nil) (byte-compile-free-assignments nil)) (pcase form @@ -5042,6 +5039,8 @@ binding slots have been popped." nil)) (_ (byte-compile-keep-pending form)))) + + ;;; tags diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 0a6b04b4c1f..d8f463e9d6a 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -293,17 +293,31 @@ of converted forms." (cconv-convert form env nil)) funcbody)) (if wrappers - (let ((special-forms '())) - ;; Keep special forms at the beginning of the body. - (while (or (and (cdr funcbody) (stringp (car funcbody))) ;docstring. - (memq (car-safe (car funcbody)) - '(interactive declare :documentation))) - (push (pop funcbody) special-forms)) - (let ((body (macroexp-progn funcbody))) + (pcase-let ((`(,decls . ,body) (macroexp-parse-body funcbody))) + (let ((body (macroexp-progn body))) (dolist (wrapper wrappers) (setq body (funcall wrapper body))) - `(,@(nreverse special-forms) ,@(macroexp-unprogn body)))) + `(,@decls ,@(macroexp-unprogn body)))) funcbody))) +(defun cconv--lifted-arg (var env) + "The argument to use for VAR in λ-lifted calls according to ENV. +This is used when VAR is being shadowed; we may still need its value for +such calls." + (let ((mapping (cdr (assq var env)))) + (pcase-exhaustive mapping + (`(internal-get-closed-var . ,_) + ;; The variable is captured. + mapping) + (`(car-safe ,exp) + ;; The variable is mutably captured; skip + ;; the indirection step because the variable is + ;; passed "by reference" to the λ-lifted function. + exp) + (_ + ;; The variable is not captured; use the (shadowed) variable value. + ;; (If the mapping is `(car-safe SYMBOL)', SYMBOL is always VAR. + var)))) + (defun cconv-convert (form env extend) ;; This function actually rewrites the tree. "Return FORM with all its lambdas changed so they are closed. @@ -428,10 +442,11 @@ places where they originally did not directly appear." ;; One of the lambda-lifted vars is shadowed, so add ;; a reference to the outside binding and arrange to use ;; that reference. - (let ((closedsym (make-symbol (format "closed-%s" var)))) + (let ((var-def (cconv--lifted-arg var env)) + (closedsym (make-symbol (format "closed-%s" var)))) (setq new-env (cconv--remap-llv new-env var closedsym)) (setq new-extend (cons closedsym (remq var new-extend))) - (push `(,closedsym ,var) binders-new))) + (push `(,closedsym ,var-def) binders-new))) ;; We push the element after redefined free variables are ;; processed. This is important to avoid the bug when free @@ -449,14 +464,13 @@ places where they originally did not directly appear." ;; before we know that the var will be in `new-extend' (bug#24171). (dolist (binder binders-new) (when (memq (car-safe binder) new-extend) - ;; One of the lambda-lifted vars is shadowed, so add - ;; a reference to the outside binding and arrange to use - ;; that reference. + ;; One of the lambda-lifted vars is shadowed. (let* ((var (car-safe binder)) + (var-def (cconv--lifted-arg var env)) (closedsym (make-symbol (format "closed-%s" var)))) (setq new-env (cconv--remap-llv new-env var closedsym)) (setq new-extend (cons closedsym (remq var new-extend))) - (push `(,closedsym ,var) binders-new))))) + (push `(,closedsym ,var-def) binders-new))))) `(,letsym ,(nreverse binders-new) . ,(mapcar (lambda (form) @@ -608,10 +622,9 @@ FORM is the parent form that binds this var." (`((,(and var (guard (eq ?_ (aref (symbol-name var) 0)))) . ,_) ,_ ,_ ,_ ,_) ;; FIXME: Convert this warning to use `macroexp--warn-wrap' - ;; so as to give better position information and obey - ;; `byte-compile-warnings'. - (byte-compile-warn - "%s `%S' not left unused" varkind var)) + ;; so as to give better position information. + (when (byte-compile-warning-enabled-p 'not-unused var) + (byte-compile-warn "%s `%S' not left unused" varkind var))) ((and (let (or 'let* 'let) (car form)) `((,var) ;; (or `(,var nil) : Too many false positives: bug#47080 t nil ,_ ,_)) diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index e03ddc4c666..ab2f34c3104 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -339,6 +339,7 @@ See Info node `(elisp) Documentation Tips' for background." ;; (setq checkdoc--argument-missing-flag nil) ; optional ;; (setq checkdoc--disambiguate-symbol-flag nil) ; optional ;; (setq checkdoc--interactive-docstring-flag nil) ; optional +;; (setq checkdoc-verb-check-experimental-flag nil) ;; Then use `M-x find-dired' ("-name '*.el'") and `M-x checkdoc-dired' (defvar checkdoc--argument-missing-flag t @@ -493,6 +494,9 @@ be re-created.") (defconst checkdoc--help-buffer "*Checkdoc Help*" "Name of buffer used for Checkdoc Help.") +(defvar checkdoc-commentary-header-string "\n;;; Commentary:\n;; \n\n" + "String inserted as commentary marker in `checkdoc-file-comments-engine'.") + ;;; User level commands ;; ;;;###autoload @@ -1112,6 +1116,7 @@ space at the end of each line." ";;; lisp/trampver.el. Generated from trampver.el.in by configure.")) "Regexp that when it matches tells `checkdoc-dired' to skip a file.") +;;;###autoload (defun checkdoc-dired (files) "In Dired, run `checkdoc' on marked files. Skip anything that doesn't have the Emacs Lisp library file @@ -2125,13 +2130,11 @@ Examples of recognized abbreviations: \"e.g.\", \"i.e.\", \"cf.\"." ;; a part of a list. (rx letter ".") (rx (or - ;; The abbreviations: + ;; The abbreviations (a trailing dot is added below). (seq (any "cC") "f") ; cf. (seq (any "eE") ".g") ; e.g. (seq (any "iI") "." (any "eE")) ; i.e. - "a.k.a" ; a.k.a. - "etc" ; etc. - "vs" ; vs. + "a.k.a" "etc" "vs" "N.B" ;; Some non-standard or less common ones that we ;; might as well accept. "Inc" "Univ" "misc" "resp") @@ -2410,7 +2413,7 @@ Code:, and others referenced in the style guide." nil nil t))) (if (checkdoc-y-or-n-p "You should have a \";;; Commentary:\", add one?") - (insert "\n;;; Commentary:\n;; \n\n") + (insert checkdoc-commentary-header-string) (checkdoc-create-error "You should have a section marked \";;; Commentary:\"" nil nil t))) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 4834fb13c6a..d162dfbbeb5 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -86,6 +86,14 @@ ;;; Code: +;; We provide a mechanism to define new specializers. +;; Related work can be found in: +;; - http://www.p-cos.net/documents/filtered-dispatch.pdf +;; - Generalizers: New metaobjects for generalized dispatch +;; http://research.gold.ac.uk/9924/1/els-specializers.pdf +;; This second one is closely related to what we do here (and that's +;; the name "generalizer" comes from). + ;; The autoloads.el mechanism which adds package--builtin-versions ;; maintenance to loaddefs.el doesn't work for preloaded packages (such ;; as this one), so we have to do it by hand! @@ -100,6 +108,7 @@ (eval-when-compile (require 'cl-lib)) (eval-when-compile (require 'cl-macs)) ;For cl--find-class. (eval-when-compile (require 'pcase)) +(eval-when-compile (require 'subr-x)) (cl-defstruct (cl--generic-generalizer (:constructor nil) @@ -277,7 +286,9 @@ DEFAULT-BODY, if present, is used as the body of a default method. (progn (defalias ',name (cl-generic-define ',name ',args ',(nreverse options)) - ,(help-add-fundoc-usage doc args)) + ,(if (consp doc) ;An expression rather than a constant. + `(help-add-fundoc-usage ,doc ',args) + (help-add-fundoc-usage doc args))) :autoload-end ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method)) (nreverse methods))) @@ -589,19 +600,10 @@ The set of acceptable TYPEs (also called \"specializers\") is defined ;; e.g. for tracing/debug-on-entry. (defalias sym gfun))))) -(defmacro cl--generic-with-memoization (place &rest code) - (declare (indent 1) (debug t)) - (gv-letplace (getter setter) place - `(or ,getter - ,(macroexp-let2 nil val (macroexp-progn code) - `(progn - ,(funcall setter val) - ,val))))) - (defvar cl--generic-dispatchers (make-hash-table :test #'equal)) (defun cl--generic-get-dispatcher (dispatch) - (cl--generic-with-memoization + (with-memoization (gethash dispatch cl--generic-dispatchers) ;; (message "cl--generic-get-dispatcher (%S)" dispatch) (let* ((dispatch-arg (car dispatch)) @@ -644,10 +646,13 @@ The set of acceptable TYPEs (also called \"specializers\") is defined ;; overkill: better just use a `cl-typep' test. (byte-compile `(lambda (generic dispatches-left methods) + ;; FIXME: We should find a way to expand `with-memoize' once + ;; and forall so we don't need `subr-x' when we get here. + (eval-when-compile (require 'subr-x)) (let ((method-cache (make-hash-table :test #'eql))) (lambda (,@fixedargs &rest args) (let ,bindings - (apply (cl--generic-with-memoization + (apply (with-memoization (gethash ,tag-exp method-cache) (cl--generic-cache-miss generic ',dispatch-arg dispatches-left methods @@ -684,14 +689,14 @@ This is particularly useful when many different tags select the same set of methods, since this table then allows us to share a single combined-method for all those different tags in the method-cache.") -(define-error 'cl--generic-cyclic-definition "Cyclic definition: %S") +(define-error 'cl--generic-cyclic-definition "Cyclic definition") (defun cl--generic-build-combined-method (generic methods) (if (null methods) ;; Special case needed to fix a circularity during bootstrap. (cl--generic-standard-method-combination generic methods) (let ((f - (cl--generic-with-memoization + (with-memoization ;; FIXME: Since the fields of `generic' are modified, this ;; hash-table won't work right, because the hashes will change! ;; It's not terribly serious, but reduces the effectiveness of @@ -1143,7 +1148,7 @@ These match if the argument is a cons cell whose car is `eql' to VAL." ;; since we can't use the `head' specializer to implement itself. (if (not (eq (car-safe specializer) 'head)) (cl-call-next-method) - (cl--generic-with-memoization + (with-memoization (gethash (cadr specializer) cl--generic-head-used) specializer) (list cl--generic-head-generalizer))) diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 317a4c62309..b01a32ca60c 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -560,4 +560,9 @@ of record objects." (t (advice-remove 'type-of #'cl--old-struct-type-of)))) +(defun cl-constantly (value) + "Return a function that takes any number of arguments, but returns VALUE." + (lambda (&rest _) + value)) + ;;; cl-lib.el ends here diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 1852471bcbb..a8f046b148c 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -301,24 +301,31 @@ FORM is of the form (ARGS . BODY)." (t ;; `simple-args' doesn't handle all the parsing that we need, ;; so we pass the rest to cl--do-arglist which will do ;; "manual" parsing. - (let ((slen (length simple-args))) - (when (memq '&optional simple-args) - (cl-decf slen)) - (setq header + (let ((slen (length simple-args)) + (usage-str ;; Macro expansion can take place in the middle of ;; apparently harmless computation, so it should not ;; touch the match-data. (save-match-data - (cons (help-add-fundoc-usage - (if (stringp (car header)) (pop header)) - ;; Be careful with make-symbol and (back)quote, - ;; see bug#12884. - (help--docstring-quote - (let ((print-gensym nil) (print-quoted t) - (print-escape-newlines t)) - (format "%S" (cons 'fn (cl--make-usage-args - orig-args)))))) - header))) + (help--docstring-quote + (let ((print-gensym nil) (print-quoted t) + (print-escape-newlines t)) + (format "%S" (cons 'fn (cl--make-usage-args + orig-args)))))))) + (when (memq '&optional simple-args) + (cl-decf slen)) + (setq header + (cons + (if (eq :documentation (car-safe (car header))) + `(:documentation (help-add-fundoc-usage + ,(cadr (pop header)) + ,usage-str)) + (help-add-fundoc-usage + (if (stringp (car header)) (pop header)) + ;; Be careful with make-symbol and (back)quote, + ;; see bug#12884. + usage-str)) + header)) ;; FIXME: we'd want to choose an arg name for the &rest param ;; and pass that as `expr' to cl--do-arglist, but that ends up ;; generating code with a redundant let-binding, so we instead @@ -2139,9 +2146,14 @@ Like `cl-flet' but the definitions can refer to previous ones. ;; setq the fresh new `ofargs' vars instead ;-) (let ((shadowings (mapcar (lambda (b) (if (consp b) (car b) b)) bindings))) - ;; If `var' is shadowed, then it clearly can't be - ;; tail-called any more. - (not (memq var shadowings))))) + (and + ;; If `var' is shadowed, then it clearly can't be + ;; tail-called any more. + (not (memq var shadowings)) + ;; If any of the new bindings is a dynamic + ;; variable, the body is not in tail position. + (not (delq nil (mapcar #'macroexp--dynamic-variable-p + shadowings))))))) `(,(car exp) ,bindings . ,(funcall opt-exps exps))) ((and `(condition-case ,err-var ,bodyform . ,handlers) (guard (not (eq err-var var)))) @@ -3050,7 +3062,7 @@ To see the documentation for a defined struct type, use `(,predicate cl-x)))) (when pred-form (push `(,defsym ,predicate (cl-x) - (declare (side-effect-free error-free)) + (declare (side-effect-free error-free) (pure t)) ,(if (eq (car pred-form) 'and) (append pred-form '(t)) `(and ,pred-form t))) @@ -3365,6 +3377,7 @@ Of course, we really can't know that for sure, so it's just a heuristic." (integer . integerp) (keyword . keywordp) (list . listp) + (natnum . natnump) (number . numberp) (null . null) (real . numberp) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 5518cdb4c90..3e816195209 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -70,7 +70,7 @@ (irange &aux (range (list irange)) (typeset ()))) - (:copier comp-cstr-shallow-copy)) + (:copier nil)) "Internal representation of a type/value constraint." (typeset '(t) :type list :documentation "List of possible types the mvar can assume. @@ -133,6 +133,14 @@ Integer values are handled in the `range' slot.") :range (copy-tree (range cstr)) :neg (neg cstr)))) +(defsubst comp-cstr-shallow-copy (dst src) + "Copy the content of SRC into DST." + (with-comp-cstr-accessors + (setf (range dst) (range src) + (valset dst) (valset src) + (typeset dst) (typeset src) + (neg dst) (neg src)))) + (defsubst comp-cstr-empty-p (cstr) "Return t if CSTR is equivalent to the nil type specifier or nil otherwise." (with-comp-cstr-accessors @@ -438,10 +446,7 @@ Return them as multiple value." ext-range) ext-range) (neg dst) nil) - (setf (typeset dst) (typeset old-dst) - (valset dst) (valset old-dst) - (range dst) (range old-dst) - (neg dst) (neg old-dst))))) + (comp-cstr-shallow-copy dst old-dst)))) (defmacro comp-cstr-set-range-for-arithm (dst src1 src2 &rest range-body) ;; Prevent some code duplication for `comp-cstr-add-2' @@ -581,10 +586,8 @@ DST is returned." (when (range pos) '(integer))))) (typeset neg))) - (setf (typeset dst) (typeset pos) - (valset dst) (valset pos) - (range dst) (range pos) - (neg dst) nil) + (comp-cstr-shallow-copy dst pos) + (setf (neg dst) nil) (cl-return-from comp-cstr-union-1-no-mem dst)) ;; Verify disjoint condition between positive types and @@ -631,15 +634,9 @@ DST is returned." (comp-range-negation (range neg)) (range pos)))))) - (if (comp-cstr-empty-p neg) - (setf (typeset dst) (typeset pos) - (valset dst) (valset pos) - (range dst) (range pos) - (neg dst) nil) - (setf (typeset dst) (typeset neg) - (valset dst) (valset neg) - (range dst) (range neg) - (neg dst) (neg neg))))) + (comp-cstr-shallow-copy dst (if (comp-cstr-empty-p neg) + pos + neg)))) ;; (not null) => t (when (and (neg dst) @@ -663,10 +660,7 @@ DST is returned." (mapcar #'comp-cstr-copy srcs) (apply #'comp-cstr-union-1-no-mem range srcs) mem-h)))) - (setf (typeset dst) (typeset res) - (valset dst) (valset res) - (range dst) (range res) - (neg dst) (neg res)) + (comp-cstr-shallow-copy dst res) res))) (cl-defun comp-cstr-intersection-homogeneous (dst &rest srcs) @@ -753,10 +747,8 @@ Non memoized version of `comp-cstr-intersection-no-mem'." ;; In case pos is not relevant return directly the content ;; of neg. (when (equal (typeset pos) '(t)) - (setf (typeset dst) (typeset neg) - (valset dst) (valset neg) - (range dst) (range neg) - (neg dst) t) + (comp-cstr-shallow-copy dst neg) + (setf (neg dst) t) ;; (not t) => nil (when (and (null (valset dst)) @@ -800,10 +792,8 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (cl-set-difference (valset pos) (valset neg))) ;; Return a non negated form. - (setf (typeset dst) (typeset pos) - (valset dst) (valset pos) - (range dst) (range pos) - (neg dst) nil))) + (comp-cstr-shallow-copy dst pos) + (setf (neg dst) nil))) dst)))) @@ -883,7 +873,7 @@ Non memoized version of `comp-cstr-intersection-no-mem'." "Constraint OP1 being = OP2 setting the result into DST." (with-comp-cstr-accessors (cl-flet ((relax-cstr (cstr) - (setf cstr (comp-cstr-shallow-copy cstr)) + (setf cstr (copy-sequence cstr)) ;; If can be any float extend it to all integers. (when (memq 'float (typeset cstr)) (setf (range cstr) '((- . +)))) @@ -1008,10 +998,7 @@ DST is returned." (mapcar #'comp-cstr-copy srcs) (apply #'comp-cstr-intersection-no-mem srcs) mem-h)))) - (setf (typeset dst) (typeset res) - (valset dst) (valset res) - (range dst) (range res) - (neg dst) (neg res)) + (comp-cstr-shallow-copy dst res) res))) (defun comp-cstr-intersection-no-hashcons (dst &rest srcs) @@ -1067,10 +1054,9 @@ DST is returned." (valset dst) () (range dst) nil (neg dst) nil)) - (t (setf (typeset dst) (typeset src) - (valset dst) (valset src) - (range dst) (range src) - (neg dst) (not (neg src))))) + (t + (comp-cstr-shallow-copy dst src) + (setf (neg dst) (not (neg src))))) dst)) (defun comp-cstr-value-negation (dst src) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 0a105052570..ea52aba5d32 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1181,7 +1181,9 @@ clashes." for i across orig-name for byte = (format "%x" i) do (aset str j (aref byte 0)) - (aset str (1+ j) (aref byte 1)) + (aset str (1+ j) (if (length> byte 1) + (aref byte 1) + ?\_)) finally return str)) (human-readable (string-replace "-" "_" orig-name)) @@ -3086,13 +3088,6 @@ Forward propagate immediate involed in assignments." ; FIXME: Typo. Involved or (`(setimm ,lval ,v) (setf (comp-cstr-imm lval) v)))))) -(defun comp-mvar-propagate (lval rval) - "Propagate into LVAL properties of RVAL." - (setf (comp-mvar-typeset lval) (comp-mvar-typeset rval) - (comp-mvar-valset lval) (comp-mvar-valset rval) - (comp-mvar-range lval) (comp-mvar-range rval) - (comp-mvar-neg lval) (comp-mvar-neg rval))) - (defun comp-function-foldable-p (f args) "Given function F called with ARGS, return non-nil when optimizable." (and (comp-function-pure-p f) @@ -3142,10 +3137,7 @@ Fold the call in case." (when (comp-cstr-empty-p cstr) ;; Store it to be rewritten as non local exit. (setf (comp-block-lap-non-ret-insn comp-block) insn)) - (setf (comp-mvar-range lval) (comp-cstr-range cstr) - (comp-mvar-valset lval) (comp-cstr-valset cstr) - (comp-mvar-typeset lval) (comp-cstr-typeset cstr) - (comp-mvar-neg lval) (comp-cstr-neg cstr)))) + (comp-cstr-shallow-copy lval cstr))) (cl-case f (+ (comp-cstr-add lval args)) (- (comp-cstr-sub lval args)) @@ -3163,9 +3155,9 @@ Fold the call in case." (let ((f (comp-func-name (gethash f (comp-ctxt-funcs-h comp-ctxt))))) (comp-fwprop-call insn lval f args))) (_ - (comp-mvar-propagate lval rval)))) + (comp-cstr-shallow-copy lval rval)))) (`(assume ,lval ,(and (pred comp-mvar-p) rval)) - (comp-mvar-propagate lval rval)) + (comp-cstr-shallow-copy lval rval)) (`(assume ,lval (,kind . ,operands)) (cl-case kind (and diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el index d24ea355a51..59cbc0e50d5 100644 --- a/lisp/emacs-lisp/crm.el +++ b/lisp/emacs-lisp/crm.el @@ -244,30 +244,29 @@ contents of the minibuffer are \"alice,bob,eve\" and point is between This function returns a list of the strings that were read, with empty strings removed." - (unwind-protect - (progn - (add-hook 'choose-completion-string-functions - 'crm--choose-completion-string) - (let* ((minibuffer-completion-table #'crm--collection-fn) - (minibuffer-completion-predicate predicate) - ;; see completing_read in src/minibuf.c - (minibuffer-completion-confirm - (unless (eq require-match t) require-match)) - (crm-completion-table table) - (map (if require-match - crm-local-must-match-map - crm-local-completion-map)) - ;; If the user enters empty input, `read-from-minibuffer' - ;; returns the empty string, not DEF. - (input (read-from-minibuffer - prompt initial-input map - nil hist def inherit-input-method))) - (when (and def (string-equal input "")) - (setq input (if (consp def) (car def) def))) - ;; Remove empty strings in the list of read strings. - (split-string input crm-separator t))) - (remove-hook 'choose-completion-string-functions - 'crm--choose-completion-string))) + (let* ((map (if require-match + crm-local-must-match-map + crm-local-completion-map)) + input) + (minibuffer-with-setup-hook + (lambda () + (add-hook 'choose-completion-string-functions + 'crm--choose-completion-string nil 'local) + (setq-local minibuffer-completion-table #'crm--collection-fn) + (setq-local minibuffer-completion-predicate predicate) + ;; see completing_read in src/minibuf.c + (setq-local minibuffer-completion-confirm + (unless (eq require-match t) require-match)) + (setq-local crm-completion-table table)) + (setq input (read-from-minibuffer + prompt initial-input map + nil hist def inherit-input-method))) + ;; If the user enters empty input, `read-from-minibuffer' + ;; returns the empty string, not DEF. + (when (and def (string-equal input "")) + (setq input (if (consp def) (car def) def))) + ;; Remove empty strings in the list of read strings. + (split-string input crm-separator t))) ;; testing and debugging ;; (defun crm-init-test-environ () diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 0592db85df4..163528acf6f 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -701,7 +701,8 @@ To specify a nil argument interactively, exit with an empty minibuffer." (interactive (list (let ((name (completing-read - "Cancel debug on entry to function (default all functions): " + (format-prompt "Cancel debug on entry to function" + "all functions") (mapcar #'symbol-name (debug--function-list)) nil t))) (when name (unless (string= name "") @@ -804,7 +805,8 @@ To specify a nil argument interactively, exit with an empty minibuffer." (interactive (list (let ((name (completing-read - "Cancel debug on set for variable (default all variables): " + (format-prompt "Cancel debug on set for variable" + "all variables") (mapcar #'symbol-name (debug--variable-list)) nil t))) (when name (unless (string= name "") diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el index dd30846546b..af5eecc22a5 100644 --- a/lisp/emacs-lisp/derived.el +++ b/lisp/emacs-lisp/derived.el @@ -175,12 +175,7 @@ See Info node `(elisp)Derived Modes' for more details. (declare (debug (&define name symbolp sexp [&optional stringp] [&rest keywordp sexp] def-body)) (doc-string 4) - ;; Ask not what - ;;(indent 3) - ;; can do for you, ask what it can do to others. IOW, the - ;; missing of indentation setting here is the indentation - ;; setting and not an oversight. - ) + (indent defun)) (when (and docstring (not (stringp docstring))) ;; Some trickiness, since what appears to be the docstring may really be diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index f752861d80a..db86e0e0292 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -198,6 +198,7 @@ INIT-VALUE LIGHTER KEYMAP. \(fn MODE DOC [KEYWORD VAL ... &rest BODY])" (declare (doc-string 2) + (indent defun) (debug (&define name string-or-null-p [&optional [¬ keywordp] sexp &optional [¬ keywordp] sexp @@ -450,7 +451,7 @@ after running the major mode's hook. However, MODE is not turned on if the hook has explicitly disabled it. \(fn GLOBAL-MODE MODE TURN-ON [KEY VALUE]... BODY...)" - (declare (doc-string 2)) + (declare (doc-string 2) (indent defun)) (let* ((global-mode-name (symbol-name global-mode)) (mode-name (symbol-name mode)) (pretty-name (easy-mmode-pretty-mode-name mode)) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 1ef29599512..ac1cd22ac27 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -3519,7 +3519,8 @@ The removes the effect of `edebug-on-entry'. If FUNCTION is nil, remove `edebug-on-entry' on all functions." (interactive (list (let ((name (completing-read - "Cancel edebug on entry to (default all functions): " + (format-prompt "Cancel edebug on entry to" + "all functions") (let ((functions (edebug--edebug-on-entry-functions))) (unless functions (user-error "No functions have `edebug-on-entry'")) @@ -4548,7 +4549,8 @@ instrumentation for, defaulting to all functions." (user-error "Found no functions to remove instrumentation from")) (let ((name (completing-read - "Remove instrumentation from (default all functions): " + (format-prompt "Remove instrumentation from" + "all functions") functions))) (if (and name (not (equal name ""))) diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 80d1711d817..ca47ec77f76 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -450,7 +450,7 @@ See `defclass' for more information." )) ;; Now that everything has been loaded up, all our lists are backwards! - ;; Fix that up now and then them into vectors. + ;; Fix that up now and turn them into vectors. (cl-callf (lambda (slots) (apply #'vector (nreverse slots))) (eieio--class-slots newc)) (cl-callf nreverse (eieio--class-initarg-tuples newc)) @@ -478,7 +478,8 @@ See `defclass' for more information." ;; (dotimes (cnt (length cslots)) ;; (setf (gethash (cl--slot-descriptor-name (aref cslots cnt)) oa) (- -1 cnt))) (dotimes (cnt (length slots)) - (setf (gethash (cl--slot-descriptor-name (aref slots cnt)) oa) cnt)) + (setf (gethash (cl--slot-descriptor-name (aref slots cnt)) oa) + (+ (eval-when-compile eieio--object-num-slots) cnt))) (setf (eieio--class-index-table newc) oa)) ;; Set up a specialized doc string. @@ -508,6 +509,7 @@ See `defclass' for more information." ;; Create the cached default object. (let ((cache (make-record newc (+ (length (eieio--class-slots newc)) + ;; FIXME: Why +1 -1 ? (eval-when-compile eieio--object-num-slots) -1) nil))) @@ -702,11 +704,15 @@ an error." nil ;; Trim off object IDX junk added in for the object index. (setq slot-idx (- slot-idx (eval-when-compile eieio--object-num-slots))) - (let ((st (cl--slot-descriptor-type (aref (eieio--class-slots class) - slot-idx)))) - (if (not (eieio--perform-slot-validation st value)) - (signal 'invalid-slot-type - (list (eieio--class-name class) slot st value)))))) + (let* ((sd (aref (eieio--class-slots class) + slot-idx)) + (st (cl--slot-descriptor-type sd))) + (cond + ((not (eieio--perform-slot-validation st value)) + (signal 'invalid-slot-type + (list (eieio--class-name class) slot st value))) + ((alist-get :read-only (cl--slot-descriptor-props sd)) + (signal 'eieio-read-only (list (eieio--class-name class) slot))))))) (defun eieio--validate-class-slot-value (class slot-idx value slot) "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. @@ -747,7 +753,7 @@ Argument FN is the function calling this verifier." (_ exp)))) (gv-setter eieio-oset)) (cl-check-type slot symbol) - (cl-check-type obj (or eieio-object class)) + (cl-check-type obj (or eieio-object class cl-structure-object)) (let* ((class (cond ((symbolp obj) (error "eieio-oref called on a class: %s" obj) (eieio--full-class-object obj)) @@ -763,7 +769,7 @@ Argument FN is the function calling this verifier." ;; to intercept missing slot definitions. Since it is also the LAST ;; thing called in this fn, its return value would be retrieved. (slot-missing obj slot 'oref)) - (cl-check-type obj eieio-object) + (cl-check-type obj (or eieio-object cl-structure-object)) (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref)))) @@ -811,7 +817,7 @@ Fills in CLASS's SLOT with its default value." (defun eieio-oset (obj slot value) "Do the work for the macro `oset'. Fills in OBJ's SLOT with VALUE." - (cl-check-type obj eieio-object) + (cl-check-type obj (or eieio-object cl-structure-object)) (cl-check-type slot symbol) (let* ((class (eieio--object-class obj)) (c (eieio--slot-name-index class slot))) @@ -892,7 +898,7 @@ reverse-lookup that name, and recurse with the associated slot value." ;; Removed checks to outside this call (let* ((fsi (gethash slot (eieio--class-index-table class)))) (if (integerp fsi) - (+ (eval-when-compile eieio--object-num-slots) fsi) + fsi (let ((fn (eieio--initarg-to-attribute class slot))) (if fn ;; Accessing a slot via its :initarg is accepted by EIEIO @@ -1061,6 +1067,7 @@ method invocation orders of the involved classes." ;; (define-error 'invalid-slot-name "Invalid slot name") (define-error 'invalid-slot-type "Invalid slot type") +(define-error 'eieio-read-only "Read-only slot") (define-error 'unbound-slot "Unbound slot") (define-error 'inconsistent-class-hierarchy "Inconsistent class hierarchy") diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index 9c842f46829..680395387c2 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -130,6 +130,7 @@ are not abstract." ;;;###autoload (defun eieio-help-constructor (ctr) "Describe CTR if it is a class constructor." + (declare (obsolete "use `describe-function' or `cl--describe-class'." "29.1")) (when (class-p ctr) (erase-buffer) (let ((location (find-lisp-object-file-name ctr 'define-type)) diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 2dc3e0aeffa..2850c91ecdf 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -110,7 +110,7 @@ Options in CLOS not supported in EIEIO: Due to the way class options are set up, you can add any tags you wish, and reference them using the function `class-option'." - (declare (doc-string 4)) + (declare (doc-string 4) (indent defun)) (cl-check-type superclasses list) (cond ((and (stringp (car options-and-doc)) @@ -359,9 +359,7 @@ variable name of the same name as the slot." (defun eieio-pcase-slot-index-from-index-table (index-table slot) "Find the index to pass to `aref' to access SLOT." - (let ((index (gethash slot index-table))) - (if index (+ (eval-when-compile eieio--object-num-slots) - index)))) + (gethash slot index-table)) (pcase-defmacro eieio (&rest fields) "Pcase patterns that match EIEIO object EXPVAL. @@ -994,11 +992,6 @@ of `eq'." (error "EIEIO: `change-class' is unimplemented")) (define-obsolete-function-alias 'change-class #'eieio-change-class "26.1") -;; Hook ourselves into help system for describing classes and methods. -;; FIXME: This is not actually needed any more since we can click on the -;; hyperlink from the constructor's docstring to see the type definition. -(add-hook 'help-fns-describe-function-functions #'eieio-help-constructor) - (provide 'eieio) ;;; eieio.el ends here diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index a1c3c3268f2..cd0e7dca7cf 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -380,7 +380,15 @@ Also store it in `eldoc-last-message' and return that value." ;; it undesirable to print eldoc messages right this instant. (defun eldoc-display-message-no-interference-p () "Return nil if displaying a message would cause interference." - (not (or executing-kbd-macro (bound-and-true-p edebug-active)))) + (not (or executing-kbd-macro + (bound-and-true-p edebug-active) + ;; The following configuration shows "Matches..." in the + ;; echo area when point is after a closing bracket, which + ;; conflicts with eldoc. + (and (boundp 'show-paren-context-when-offscreen) + show-paren-context-when-offscreen + (not (pos-visible-in-window-p + (overlay-end show-paren--overlay))))))) (defvar eldoc-documentation-functions nil diff --git a/lisp/emacs-lisp/elp.el b/lisp/emacs-lisp/elp.el index 8c33b7c9948..fdd0ad6666e 100644 --- a/lisp/emacs-lisp/elp.el +++ b/lisp/emacs-lisp/elp.el @@ -202,14 +202,13 @@ This variable is set by the master function.") (defvar elp-not-profilable ;; First, the functions used inside each instrumented function: '(called-interactively-p - ;; Then the functions used by the above functions. I used - ;; (delq nil (mapcar (lambda (x) (and (symbolp x) (fboundp x) x)) - ;; (aref (symbol-function 'elp-wrapper) 2))) - ;; to help me find this list. - error call-interactively apply current-time + ;; (delq + ;; nil (mapcar + ;; (lambda (x) (and (symbolp x) (fboundp x) x)) + ;; (aref (aref (aref (symbol-function 'elp--make-wrapper) 2) 1) 2))) + error apply current-time float-time time-subtract ;; Andreas Politz reports problems profiling these (Bug#4233): - + byte-code-function-p functionp byte-code subrp - indirect-function fboundp) + + byte-code-function-p functionp byte-code subrp fboundp) "List of functions that cannot be profiled. Those functions are used internally by the profiling code and profiling them would thus lead to infinite recursion.") @@ -299,10 +298,18 @@ For example, to instrument all ELP functions, do the following: 'intern (all-completions prefix obarray 'elp-profilable-p)))) +(defun elp-restore-package (prefix) + "Remove instrumentation from functions with names starting with PREFIX." + (interactive "SPrefix: ") + (elp-restore-list + (mapcar #'intern + (all-completions (symbol-name prefix) + obarray 'elp-profilable-p)))) + (defun elp-restore-list (&optional list) "Restore the original definitions for all functions in `elp-function-list'. Use optional LIST if provided instead." - (interactive "PList of functions to restore: ") ;FIXME: Doesn't work!? + (interactive) (mapcar #'elp-restore-function (or list elp-function-list))) (defun elp-restore-all () @@ -324,7 +331,7 @@ Use optional LIST if provided instead." (defun elp-reset-list (&optional list) "Reset the profiling information for all functions in `elp-function-list'. Use optional LIST if provided instead." - (interactive "PList of functions to reset: ") ;FIXME: Doesn't work!? + (interactive) (let ((list (or list elp-function-list))) (mapcar 'elp-reset-function list))) diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index 3fc57d5182d..7fc316d1469 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -352,7 +352,6 @@ convert it to a string and pass it to COLLECTOR first." (defvar ert-resource-directory-trim-right-regexp "\\(-tests?\\)?\\.el" "Regexp for `string-trim' (right) used by `ert-resource-directory'.") -;; Has to be a macro for `load-file-name'. (defmacro ert-resource-directory () "Return absolute file name of the resource (test data) directory. @@ -368,17 +367,17 @@ variable `ert-resource-directory-format'. Before formatting, the file name will be trimmed using `string-trim' with arguments `ert-resource-directory-trim-left-regexp' and `ert-resource-directory-trim-right-regexp'." - `(let* ((testfile ,(or (macroexp-file-name) - buffer-file-name)) - (default-directory (file-name-directory testfile))) - (file-truename - (if (file-accessible-directory-p "resources/") - (expand-file-name "resources/") - (expand-file-name - (format ert-resource-directory-format - (string-trim testfile - ert-resource-directory-trim-left-regexp - ert-resource-directory-trim-right-regexp))))))) + `(when-let ((testfile ,(or (macroexp-file-name) + buffer-file-name))) + (let ((default-directory (file-name-directory testfile))) + (file-truename + (if (file-accessible-directory-p "resources/") + (expand-file-name "resources/") + (expand-file-name + (format ert-resource-directory-format + (string-trim testfile + ert-resource-directory-trim-left-regexp + ert-resource-directory-trim-right-regexp)))))))) (defmacro ert-resource-file (file) "Return absolute file name of resource (test data) file named FILE. @@ -386,6 +385,96 @@ A resource file is defined as any file placed in the resource directory as returned by `ert-resource-directory'." `(expand-file-name ,file (ert-resource-directory))) +(defvar ert-temp-file-prefix "emacs-test-" + "Prefix used by `ert-with-temp-file' and `ert-with-temp-directory'.") + +(defvar ert-temp-file-suffix nil + "Suffix used by `ert-with-temp-file' and `ert-with-temp-directory'.") + +(defun ert--with-temp-file-generate-suffix (filename) + "Generate temp file suffix from FILENAME." + (thread-last + (file-name-base filename) + (replace-regexp-in-string (rx string-start + (group (+? not-newline)) + (regexp "-?tests?") + string-end) + "\\1") + (concat "-"))) + +(defmacro ert-with-temp-file (name &rest body) + "Bind NAME to the name of a new temporary file and evaluate BODY. +Delete the temporary file after BODY exits normally or +non-locally. NAME will be bound to the file name of the temporary +file. + +The following keyword arguments are supported: + +:prefix STRING If non-nil, pass STRING to `make-temp-file' as + the PREFIX argument. Otherwise, use the value of + `ert-temp-file-prefix'. + +:suffix STRING If non-nil, pass STRING to `make-temp-file' as the + SUFFIX argument. Otherwise, use the value of + `ert-temp-file-suffix'; if the value of that + variable is nil, generate a suffix based on the + name of the file that `ert-with-temp-file' is + called from. + +:text STRING If non-nil, pass STRING to `make-temp-file' as + the TEXT argument. + +See also `ert-with-temp-directory'." + (declare (indent 1) (debug (symbolp body))) + (cl-check-type name symbol) + (let (keyw prefix suffix directory text extra-keywords) + (while (keywordp (setq keyw (car body))) + (setq body (cdr body)) + (pcase keyw + (:prefix (setq prefix (pop body))) + (:suffix (setq suffix (pop body))) + (:directory (setq directory (pop body))) + (:text (setq text (pop body))) + (_ (push keyw extra-keywords) (pop body)))) + (when extra-keywords + (error "Invalid keywords: %s" (mapconcat #'symbol-name extra-keywords " "))) + (let ((temp-file (make-symbol "temp-file")) + (prefix (or prefix ert-temp-file-prefix)) + (suffix (or suffix ert-temp-file-suffix + (ert--with-temp-file-generate-suffix + (or (macroexp-file-name) buffer-file-name))))) + `(let* ((,temp-file (,(if directory 'file-name-as-directory 'identity) + (make-temp-file ,prefix ,directory ,suffix ,text))) + (,name ,(if directory + `(file-name-as-directory ,temp-file) + temp-file))) + (unwind-protect + (progn ,@body) + (ignore-errors + ,(if directory + `(delete-directory ,temp-file :recursive) + `(delete-file ,temp-file)))))))) + +(defmacro ert-with-temp-directory (name &rest body) + "Bind NAME to the name of a new temporary directory and evaluate BODY. +Delete the temporary directory after BODY exits normally or +non-locally. + +NAME is bound to the directory name, not the directory file +name. (In other words, it will end with the directory delimiter; +on Unix-like systems, it will end with \"/\".) + +The same keyword arguments are supported as in +`ert-with-temp-file' (which see), except for :text." + (declare (indent 1) (debug (symbolp body))) + (let ((tail body) keyw) + (while (keywordp (setq keyw (car tail))) + (setq tail (cddr tail)) + (pcase keyw (:text (error "Invalid keyword for directory: :text"))))) + `(ert-with-temp-file ,name + :directory t + ,@body)) + (provide 'ert-x) ;;; ert-x.el ends here diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index b7d984374cb..70ce3a71b23 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -39,7 +39,7 @@ ;; but signals a different error when its condition is violated that ;; is caught and processed by ERT. In addition, it analyzes its ;; argument form and records information that helps debugging -;; (`assert' tries to do something similar when its second argument +;; (`cl-assert' tries to do something similar when its second argument ;; SHOW-ARGS is true, but `should' is more sophisticated). For ;; information on `should-not' and `should-error', see their ;; docstrings. `skip-unless' skips the test immediately without @@ -63,6 +63,9 @@ (require 'ewoc) (require 'find-func) (require 'pp) +(require 'map) + +(autoload 'xml-escape-string "xml.el") ;;; UI customization options. @@ -76,6 +79,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)) @@ -88,23 +120,6 @@ Use nil for no limit (caution: backtrace lines can be very long)." :background "red3")) "Face used for unexpected results in the ERT results buffer.") - -;;; Copies/reimplementations of cl functions. - -(defun ert-equal-including-properties (a b) - "Return t if A and B have similar structure and contents. - -This is like `equal-including-properties' except that it compares -the property values of text properties structurally (by -recursing) rather than with `eq'. Perhaps this is what -`equal-including-properties' should do in the first place; see -Emacs bug 6581 at URL `https://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'." - ;; This implementation is inefficient. Rather than making it - ;; efficient, let's hope bug 6581 gets fixed so that we can delete - ;; it altogether. - (not (ert--explain-equal-including-properties a b))) - - ;;; Defining and locating tests. ;; The data structure that represents a test case. @@ -136,6 +151,10 @@ Emacs bug 6581 at URL `https://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'." ;; 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) @@ -191,6 +210,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] @@ -218,11 +240,7 @@ it has to be wrapped in `(eval (quote ...))'. `(:expected-result-type ,expected-result)) ,@(when tags-supplied-p `(:tags ,tags)) - :body (lambda () - ;; Use the value of `lexical-binding' in - ;; the source file when evaluating the body. - (let ((lexical-binding ,lexical-binding)) - ,@body)))) + :body (lambda () ,@body))) ',name)))) (defvar ert--find-test-regexp @@ -231,7 +249,6 @@ it has to be wrapped in `(eval (quote ...))'. "%s\\(\\s-\\|$\\)") "The regexp the `find-function' mechanisms use for finding test definitions.") - (define-error 'ert-test-failed "Test failed") (define-error 'ert-test-skipped "Test skipped") @@ -469,7 +486,7 @@ Errors during evaluation are caught and handled like nil." (defun ert--explain-equal-rec (a b) "Return a programmer-readable explanation of why A and B are not `equal'. -Returns nil if they are." +Return nil if they are." (if (not (eq (type-of a) (type-of b))) `(different-types ,a ,b) (pcase a @@ -602,14 +619,9 @@ If SUFFIXP is non-nil, returns a suffix of S, otherwise a prefix." (t (substring s 0 len))))) -;; TODO(ohler): Once bug 6581 is fixed, rename this to -;; `ert--explain-equal-including-properties-rec' and add a fast-path -;; wrapper like `ert--explain-equal'. -(defun ert--explain-equal-including-properties (a b) - "Explainer function for `ert-equal-including-properties'. - -Returns a programmer-readable explanation of why A and B are not -`ert-equal-including-properties', or nil if they are." +(defun ert--explain-equal-including-properties-rec (a b) + "Return explanation of why A and B are not `equal-including-properties'. +Return nil if they are." (if (not (equal a b)) (ert--explain-equal a b) (cl-assert (stringp a) t) @@ -631,15 +643,17 @@ Returns a programmer-readable explanation of why A and B are not ,(ert--abbreviate-string (substring-no-properties a (1+ i)) 10 nil)))) - ;; TODO(ohler): Get `equal-including-properties' fixed in - ;; Emacs, delete `ert-equal-including-properties', and - ;; re-enable this assertion. - ;;finally (cl-assert (equal-including-properties a b) t) - ))) -(put 'ert-equal-including-properties - 'ert-explainer - 'ert--explain-equal-including-properties) + finally (cl-assert (equal-including-properties a b) t)))) +(defun ert--explain-equal-including-properties (a b) + "Explainer function for `equal-including-properties'." + ;; Do a quick comparison in C to avoid running our expensive + ;; comparison when possible. + (if (equal-including-properties a b) + nil + (ert--explain-equal-including-properties-rec a b))) +(put 'equal-including-properties 'ert-explainer + 'ert--explain-equal-including-properties) ;;; Implementation of `ert-info'. @@ -664,7 +678,6 @@ and is displayed in front of the value of MESSAGE-FORM." ,@body)) - ;;; Facilities for running a single test. (defvar ert-debug-on-error nil @@ -779,7 +792,8 @@ This mainly sets up debugger-related bindings." ;; handle ert errors. Once that's done, remove ;; `ert--should-signal-hook'. See Bug#24402 and Bug#11218 for ;; details. - (let ((debugger (lambda (&rest args) + (let ((lexical-binding t) + (debugger (lambda (&rest args) (ert--run-test-debugger test-execution-info args))) (debug-on-error t) @@ -936,7 +950,8 @@ t -- Selects UNIVERSE. :expected, :unexpected -- Select tests according to their most recent result. a string -- A regular expression selecting all tests with matching names. a test -- (i.e., an object of the ert-test data-type) Selects that test. -a symbol -- Selects the test that the symbol names, errors if none. +a symbol -- Selects the test that the symbol names, signals an + `ert-test-unbound' error if none. \(member TESTS...) -- Selects the elements of TESTS, a list of tests or symbols naming tests. \(eql TEST) -- Selects TEST, a test or a symbol naming a test. @@ -998,52 +1013,47 @@ contained in UNIVERSE." universe)))) ((pred ert-test-p) (list selector)) ((pred symbolp) - (cl-assert (ert-test-boundp selector)) + (unless (ert-test-boundp selector) + (signal 'ert-test-unbound (list selector))) (list (ert-get-test selector))) - (`(,operator . ,operands) - (cl-ecase operator - (member - (mapcar (lambda (purported-test) - (pcase-exhaustive purported-test - ((pred symbolp) - (cl-assert (ert-test-boundp purported-test)) - (ert-get-test purported-test)) - ((pred ert-test-p) purported-test))) - operands)) - (eql - (cl-assert (eql (length operands) 1)) - (ert-select-tests `(member ,@operands) universe)) - (and - ;; Do these definitions of AND, NOT and OR satisfy de - ;; Morgan's laws? Should they? - (cl-case (length operands) - (0 (ert-select-tests 't universe)) - (t (ert-select-tests `(and ,@(cdr operands)) - (ert-select-tests (car operands) - universe))))) - (not - (cl-assert (eql (length operands) 1)) - (let ((all-tests (ert-select-tests 't universe))) - (cl-set-difference all-tests - (ert-select-tests (car operands) - all-tests)))) - (or - (cl-case (length operands) - (0 (ert-select-tests 'nil universe)) - (t (cl-union (ert-select-tests (car operands) universe) - (ert-select-tests `(or ,@(cdr operands)) - universe))))) - (tag - (cl-assert (eql (length operands) 1)) - (let ((tag (car operands))) - (ert-select-tests `(satisfies - ,(lambda (test) - (member tag (ert-test-tags test)))) - universe))) - (satisfies - (cl-assert (eql (length operands) 1)) - (cl-remove-if-not (car operands) - (ert-select-tests 't universe))))))) + (`(member . ,operands) + (mapcar (lambda (purported-test) + (pcase-exhaustive purported-test + ((pred symbolp) + (unless (ert-test-boundp purported-test) + (signal 'ert-test-unbound + (list purported-test))) + (ert-get-test purported-test)) + ((pred ert-test-p) purported-test))) + operands)) + (`(eql ,operand) + (ert-select-tests `(member ,operand) universe)) + ;; Do these definitions of AND, NOT and OR satisfy de Morgan's + ;; laws? Should they? + (`(and) + (ert-select-tests 't universe)) + (`(and ,first . ,rest) + (ert-select-tests `(and ,@rest) + (ert-select-tests first universe))) + (`(not ,operand) + (let ((all-tests (ert-select-tests 't universe))) + (cl-set-difference all-tests + (ert-select-tests operand all-tests)))) + (`(or) + (ert-select-tests 'nil universe)) + (`(or ,first . ,rest) + (cl-union (ert-select-tests first universe) + (ert-select-tests `(or ,@rest) universe))) + (`(tag ,tag) + (ert-select-tests `(satisfies + ,(lambda (test) + (member tag (ert-test-tags test)))) + universe)) + (`(satisfies ,predicate) + (cl-remove-if-not predicate + (ert-select-tests 't universe))))) + +(define-error 'ert-test-unbound "ERT test is unbound") (defun ert--insert-human-readable-selector (selector) "Insert a human-readable presentation of SELECTOR into the current buffer." @@ -1423,9 +1433,10 @@ Returns the stats object." (if (getenv "EMACS_TEST_VERBOSE") (ert-reason-for-test-result result) "")))) - (message "%s" ""))))) - (test-started - ) + (message "%s" "")) + (when (getenv "EMACS_TEST_JUNIT_REPORT") + (ert-write-junit-test-report stats))))) + (test-started) (test-ended (cl-destructuring-bind (stats test result) event-args (unless (ert-test-result-expected-p test result) @@ -1435,8 +1446,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) @@ -1455,8 +1472,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))) @@ -1506,6 +1523,183 @@ the tests)." (backtrace)) (kill-emacs 2)))) +(defvar ert-load-file-name nil + "The name of the loaded ERT test file, a string. +Usually, it is not needed to be defined, but if different ERT +test packages depend on each other, it might be helpful.") + +(defun ert-write-junit-test-report (stats) + "Write a JUnit test report, generated from STATS." + ;; https://www.ibm.com/docs/en/developer-for-zos/14.1.0?topic=formats-junit-xml-format + ;; https://llg.cubic.org/docs/junit/ + (when-let ((symbol (car (apropos-internal "" #'ert-test-boundp))) + (test-file (symbol-file symbol 'ert--test)) + (test-report + (file-name-with-extension + (or ert-load-file-name test-file) "xml"))) + (with-temp-file test-report + (insert "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n") + (insert (format "<testsuites name=\"%s\" tests=\"%s\" errors=\"%s\" failures=\"%s\" skipped=\"%s\" time=\"%s\">\n" + (file-name-nondirectory test-report) + (ert-stats-total stats) + (if (ert--stats-aborted-p stats) 1 0) + (ert-stats-completed-unexpected stats) + (ert-stats-skipped stats) + (float-time + (time-subtract + (ert--stats-end-time stats) + (ert--stats-start-time stats))))) + (insert (format " <testsuite id=\"0\" name=\"%s\" tests=\"%s\" errors=\"%s\" failures=\"%s\" skipped=\"%s\" time=\"%s\" timestamp=\"%s\">\n" + (file-name-nondirectory test-report) + (ert-stats-total stats) + (if (ert--stats-aborted-p stats) 1 0) + (ert-stats-completed-unexpected stats) + (ert-stats-skipped stats) + (float-time + (time-subtract + (ert--stats-end-time stats) + (ert--stats-start-time stats))) + (ert--format-time-iso8601 (ert--stats-end-time stats)))) + ;; If the test has aborted, `ert--stats-selector' might return + ;; huge junk. Skip this. + (when (< (length (format "%s" (ert--stats-selector stats))) 1024) + (insert " <properties>\n" + (format " <property name=\"selector\" value=\"%s\"/>\n" + (xml-escape-string + (format "%s" (ert--stats-selector stats)) 'noerror)) + " </properties>\n")) + (cl-loop for test across (ert--stats-tests stats) + for result = (ert-test-most-recent-result test) do + (insert (format " <testcase name=\"%s\" status=\"%s\" time=\"%s\"" + (xml-escape-string + (symbol-name (ert-test-name test)) 'noerror) + (ert-string-for-test-result + result + (ert-test-result-expected-p test result)) + (ert-test-result-duration result))) + (if (and (ert-test-result-expected-p test result) + (not (ert-test-aborted-with-non-local-exit-p result)) + (not (ert-test-skipped-p result)) + (zerop (length (ert-test-result-messages result)))) + (insert "/>\n") + (insert ">\n") + (cond + ((ert-test-skipped-p result) + (insert (format " <skipped message=\"%s\" type=\"%s\">\n" + (xml-escape-string + (string-trim + (ert-reason-for-test-result result)) + 'noerror) + (ert-string-for-test-result + result + (ert-test-result-expected-p + test result))) + (xml-escape-string + (string-trim + (ert-reason-for-test-result result)) + 'noerror) + "\n" + " </skipped>\n")) + ((ert-test-aborted-with-non-local-exit-p result) + (insert (format " <error message=\"%s\" type=\"%s\">\n" + (file-name-nondirectory test-report) + (ert-string-for-test-result + result + (ert-test-result-expected-p + test result))) + (format "Test %s aborted with non-local exit\n" + (xml-escape-string + (symbol-name (ert-test-name test)) 'noerror)) + " </error>\n")) + ((not (ert-test-result-type-p + result (ert-test-expected-result-type test))) + (insert (format " <failure message=\"%s\" type=\"%s\">\n" + (xml-escape-string + (string-trim + (ert-reason-for-test-result result)) + 'noerror) + (ert-string-for-test-result + result + (ert-test-result-expected-p + test result))) + (xml-escape-string + (string-trim + (ert-reason-for-test-result result)) + 'noerror) + "\n" + " </failure>\n"))) + (unless (zerop (length (ert-test-result-messages result))) + (insert " <system-out>\n" + (xml-escape-string + (ert-test-result-messages result) 'noerror) + " </system-out>\n")) + (insert " </testcase>\n"))) + (insert " </testsuite>\n") + (insert "</testsuites>\n")))) + +(defun ert-write-junit-test-summary-report (&rest logfiles) + "Write a JUnit summary test report, generated from LOGFILES." + (let ((report (file-name-with-extension + (getenv "EMACS_TEST_JUNIT_REPORT") "xml")) + (tests 0) (errors 0) (failures 0) (skipped 0) (time 0) (id 0)) + (with-temp-file report + (dolist (logfile logfiles) + (let ((test-report (file-name-with-extension logfile "xml"))) + (if (not (file-readable-p test-report)) + (let* ((logfile (file-name-with-extension logfile "log")) + (logfile-contents + (when (file-readable-p logfile) + (with-temp-buffer + (insert-file-contents-literally logfile) + (buffer-string))))) + (unless + ;; No defined tests, perhaps a helper file. + (and logfile-contents + (string-match-p "^Running 0 tests" logfile-contents)) + (insert (format " <testsuite id=\"%s\" name=\"%s\" tests=\"1\" errors=\"1\" failures=\"0\" skipped=\"0\" time=\"0\" timestamp=\"%s\">\n" + id test-report + (ert--format-time-iso8601 (current-time)))) + (insert (format " <testcase name=\"Test report missing %s\" status=\"error\" time=\"0\">\n" + (file-name-nondirectory test-report))) + (insert (format " <error message=\"Test report missing %s\" type=\"error\">\n" + (file-name-nondirectory test-report))) + (when logfile-contents + (insert (xml-escape-string logfile-contents 'noerror))) + (insert " </error>\n" + " </testcase>\n" + " </testsuite>\n") + (cl-incf errors 1) + (cl-incf id 1))) + + (insert-file-contents-literally test-report) + (when (looking-at-p + (regexp-quote "<?xml version=\"1.0\" encoding=\"utf-8\"?>")) + (delete-region (point) (line-beginning-position 2))) + (when (looking-at + "<testsuites name=\".+\" tests=\"\\(.+\\)\" errors=\"\\(.+\\)\" failures=\"\\(.+\\)\" skipped=\"\\(.+\\)\" time=\"\\(.+\\)\">") + (cl-incf tests (string-to-number (match-string 1))) + (cl-incf errors (string-to-number (match-string 2))) + (cl-incf failures (string-to-number (match-string 3))) + (cl-incf skipped (string-to-number (match-string 4))) + (cl-incf time (string-to-number (match-string 5))) + (delete-region (point) (line-beginning-position 2))) + (when (looking-at " <testsuite id=\"\\(0\\)\"") + (replace-match (number-to-string id) nil nil nil 1) + (cl-incf id 1)) + (goto-char (point-max)) + (beginning-of-line 0) + (when (looking-at-p "</testsuites>") + (delete-region (point) (line-beginning-position 2)))) + + (narrow-to-region (point-max) (point-max)))) + + (insert "</testsuites>\n") + (widen) + (goto-char (point-min)) + (insert "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n") + (insert (format "<testsuites name=\"%s\" tests=\"%s\" errors=\"%s\" failures=\"%s\" skipped=\"%s\" time=\"%s\">\n" + (file-name-nondirectory report) + tests errors failures skipped time))))) (defun ert-summarize-tests-batch-and-exit (&optional high) "Summarize the results of testing. @@ -1521,6 +1715,8 @@ If HIGH is a natural number, the HIGH long lasting tests are summarized." ;; behavior. (setq attempt-stack-overflow-recovery nil attempt-orderly-shutdown-on-fatal-signal nil) + (when (getenv "EMACS_TEST_JUNIT_REPORT") + (apply #'ert-write-junit-test-summary-report command-line-args-left)) (let ((nlogs (length command-line-args-left)) (ntests 0) (nrun 0) (nexpected 0) (nunexpected 0) (nskipped 0) nnotrun logfile notests badtests unexpected skipped tests) @@ -1836,7 +2032,6 @@ Also sets `ert--results-progress-bar-button-begin'." ;; should test it again.) "\n"))) - (defvar ert-test-run-redisplay-interval-secs .1 "How many seconds ERT should wait between redisplays while running tests. @@ -1984,13 +2179,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) @@ -2018,22 +2213,14 @@ BUFFER-NAME, if non-nil, is the buffer name to use." (goto-char (1- (point-max))) buffer))))) - (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 @@ -2044,25 +2231,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) "" @@ -2416,7 +2596,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. @@ -2665,9 +2845,135 @@ To be used in the ERT results buffer." 'ert--activate-font-lock-keywords) nil) +(defun ert-test-erts-file (file &optional transform) + "Parse FILE as a file containing before/after parts. +TRANSFORM will be called to get from before to after." + (with-temp-buffer + (insert-file-contents file) + (let ((gen-specs (list (cons 'dummy t) + (cons 'code transform)))) + ;; Find the start of a test. + (while (re-search-forward "^=-=\n" nil t) + (setq gen-specs (ert-test--erts-test gen-specs file)) + ;; Search to the end of the test. + (re-search-forward "^=-=-=\n"))))) + +(defun ert-test--erts-test (gen-specs file) + (let* ((file-buffer (current-buffer)) + (specs (ert--erts-specifications (match-beginning 0))) + (name (cdr (assq 'name specs))) + (start-before (point)) + (end-after (if (re-search-forward "^=-=-=\n" nil t) + (match-beginning 0) + (point-max))) + (skip (cdr (assq 'skip specs))) + end-before start-after + after after-point) + (unless name + (error "No name for test case")) + (if (and skip + (eval (car (read-from-string skip)))) + ;; Skipping this test. + () + ;; Do the test. + (goto-char end-after) + ;; We have a separate after section. + (if (re-search-backward "^=-=\n" start-before t) + (setq end-before (match-beginning 0) + start-after (match-end 0)) + (setq end-before end-after + start-after start-before)) + ;; Update persistent specs. + (when-let ((point-char (assq 'point-char specs))) + (setq gen-specs + (map-insert gen-specs 'point-char (cdr point-char)))) + (when-let ((code (cdr (assq 'code specs)))) + (setq gen-specs + (map-insert gen-specs 'code (car (read-from-string code))))) + ;; Get the "after" strings. + (with-temp-buffer + (insert-buffer-substring file-buffer start-after end-after) + (ert--erts-unquote) + ;; Remove the newline at the end of the buffer. + (when-let ((no-newline (cdr (assq 'no-after-newline specs)))) + (goto-char (point-min)) + (when (re-search-forward "\n\\'" nil t) + (delete-region (match-beginning 0) (match-end 0)))) + ;; Get the expected "after" point. + (when-let ((point-char (cdr (assq 'point-char gen-specs)))) + (goto-char (point-min)) + (when (search-forward point-char nil t) + (delete-region (match-beginning 0) (match-end 0)) + (setq after-point (point)))) + (setq after (buffer-string))) + ;; Do the test. + (with-temp-buffer + (insert-buffer-substring file-buffer start-before end-before) + (ert--erts-unquote) + ;; Remove the newline at the end of the buffer. + (when-let ((no-newline (cdr (assq 'no-before-newline specs)))) + (goto-char (point-min)) + (when (re-search-forward "\n\\'" nil t) + (delete-region (match-beginning 0) (match-end 0)))) + (goto-char (point-min)) + ;; Place point in the specified place. + (when-let ((point-char (cdr (assq 'point-char gen-specs)))) + (when (search-forward point-char nil t) + (delete-region (match-beginning 0) (match-end 0)))) + (let ((code (cdr (assq 'code gen-specs)))) + (unless code + (error "No code to run the transform")) + (funcall code)) + (unless (equal (buffer-string) after) + (ert-fail (list (format "Mismatch in test \"%s\", file %s" + name file) + (buffer-string) + after))) + (when (and after-point + (not (= after-point (point)))) + (ert-fail (list (format "Point wrong in test \"%s\", expected point %d, actual %d, file %s" + name + after-point (point) + file) + (buffer-string))))))) + ;; Return the new value of the general specifications. + gen-specs) + +(defun ert--erts-unquote () + (goto-char (point-min)) + (while (re-search-forward "^\\=-=\\(-=\\)$" nil t) + (delete-region (match-beginning 0) (1+ (match-beginning 0))))) + +(defun ert--erts-specifications (end) + "Find specifications before point (back to the previous test)." + (save-excursion + (goto-char end) + (goto-char + (if (re-search-backward "^=-=-=\n" nil t) + (match-end 0) + (point-min))) + (let ((specs nil)) + (while (< (point) end) + (if (looking-at "\\([^ \n\t:]+\\):\\([ \t]+\\)?\\(.*\\)") + (let ((name (intern (downcase (match-string 1)))) + (value (match-string 3))) + (forward-line 1) + (while (looking-at "[ \t]+\\(.*\\)") + (setq value (concat value (match-string 1))) + (forward-line 1)) + (push (cons name (substring-no-properties value)) specs)) + (forward-line 1))) + (nreverse specs)))) + (defvar ert-unload-hook ()) (add-hook 'ert-unload-hook #'ert--unload-function) +;;; Obsolete + +(define-obsolete-function-alias 'ert-equal-including-properties + #'equal-including-properties "29.1") +(put 'ert-equal-including-properties 'ert-explainer + 'ert--explain-equal-including-properties) (provide 'ert) diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el index 2075ac472d1..86119d3e3ed 100644 --- a/lisp/emacs-lisp/generator.el +++ b/lisp/emacs-lisp/generator.el @@ -143,8 +143,7 @@ the CPS state machinery." (setf ,static-var ,dynamic-var))))) (defmacro cps--with-dynamic-binding (dynamic-var static-var &rest body) - "Evaluate BODY such that generated atomic evaluations run with -DYNAMIC-VAR bound to STATIC-VAR." + "Run BODY's atomic evaluations run with DYNAMIC-VAR bound to STATIC-VAR." (declare (indent 2)) `(cps--with-value-wrapper (cps--make-dynamic-binding-wrapper ,dynamic-var ,static-var) @@ -291,22 +290,28 @@ DYNAMIC-VAR bound to STATIC-VAR." (cps--transform-1 `(progn ,@rest) next-state))) - ;; Process `let' in a helper function that transforms it into a - ;; let* with temporaries. + (`(,(or 'let 'let*) () . ,body) + (cps--transform-1 `(progn ,@body) next-state)) + + ;; Transform multi-variable `let' into `let*': + ;; (let ((v1 e1) ... (vN eN)) BODY) + ;; -> (let* ((t1 e1) ... (tN-1 eN-1) (vN eN) (v1 t1) (vN-1 tN-1)) BODY) (`(let ,bindings . ,body) (let* ((bindings (cl-loop for binding in bindings collect (if (symbolp binding) (list binding nil) binding))) - (temps (cl-loop for (var _value-form) in bindings + (butlast-bindings (butlast bindings)) + (temps (cl-loop for (var _value-form) in butlast-bindings collect (cps--add-binding var)))) (cps--transform-1 `(let* ,(append - (cl-loop for (_var value-form) in bindings + (cl-loop for (_var value-form) in butlast-bindings for temp in temps collect (list temp value-form)) - (cl-loop for (var _binding) in bindings + (last bindings) + (cl-loop for (var _binding) in butlast-bindings for temp in temps collect (list var temp))) ,@body) @@ -315,9 +320,6 @@ DYNAMIC-VAR bound to STATIC-VAR." ;; Process `let*' binding: process one binding at a time. Flatten ;; lexical bindings. - (`(let* () . ,body) - (cps--transform-1 `(progn ,@body) next-state)) - (`(let* (,binding . ,more-bindings) . ,body) (let* ((var (if (symbolp binding) binding (car binding))) (value-form (car (cdr-safe binding))) @@ -642,12 +644,11 @@ modified copy." (iter-close iterator))))) iterator)))) -(defun iter-yield (value) +(defun iter-yield (_value) "When used inside a generator, yield control to caller. The caller of `iter-next' receives VALUE, and the next call to `iter-next' resumes execution with the form immediately following this `iter-yield' call." - (identity value) (error "`iter-yield' used outside a generator")) (defmacro iter-yield-from (value) @@ -689,8 +690,10 @@ of values. Callers can retrieve each value using `iter-next'." (declare (indent defun) (debug (&define lambda-list lambda-doc &rest sexp))) (cl-assert lexical-binding) - `(lambda ,arglist - ,(cps-generate-evaluator body))) + (pcase-let* ((`(,declarations . ,exps) (macroexp-parse-body body))) + `(lambda ,arglist + ,@declarations + ,(cps-generate-evaluator exps)))) (defmacro iter-make (&rest body) "Return a new iterator." diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index d6272a52469..ebcc63cc2a5 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -74,7 +74,7 @@ ;; (defvar gv--macro-environment nil ;; "Macro expanders for generalized variables.") -(define-error 'gv-invalid-place "%S is not a valid place expression") +(define-error 'gv-invalid-place "Invalid place expression") ;;;###autoload (defun gv-get (place do) diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index bb00a97f8e3..416d64558d9 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -29,6 +29,7 @@ ;;; Code: (eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'subr-x)) (defvar font-lock-comment-face) (defvar font-lock-doc-face) @@ -590,6 +591,8 @@ containing STARTPOS." (defun lisp-string-after-doc-keyword-p (listbeg startpos) "Return non-nil if `:documentation' symbol ends at STARTPOS inside a list. +`:doc' can also be used. + LISTBEG is the position of the start of the innermost list containing STARTPOS." (and listbeg ; We are inside a Lisp form. @@ -597,7 +600,7 @@ containing STARTPOS." (goto-char startpos) (ignore-errors (progn (backward-sexp 1) - (looking-at ":documentation\\_>")))))) + (looking-at ":documentation\\_>\\|:doc\\_>")))))) (defun lisp-font-lock-syntactic-face-function (state) "Return syntactic face function for the position represented by STATE. @@ -1106,6 +1109,53 @@ is the buffer position of the start of the containing expression." (t normal-indent)))))) +(defun lisp--local-defform-body-p (state) + "Return non-nil when at local definition body according to STATE. +STATE is the `parse-partial-sexp' state for current position." + (when-let ((start-of-innermost-containing-list (nth 1 state))) + (let* ((parents (nth 9 state)) + (first-cons-after (cdr parents)) + (second-cons-after (cdr first-cons-after)) + first-order-parent second-order-parent) + (while second-cons-after + (when (= start-of-innermost-containing-list + (car second-cons-after)) + (setq second-order-parent (pop parents) + first-order-parent (pop parents) + ;; Leave the loop. + second-cons-after nil)) + (pop second-cons-after) + (pop parents)) + (when second-order-parent + (let (local-definitions-starting-point) + (and (save-excursion + (goto-char (1+ second-order-parent)) + (when-let ((head (ignore-errors + ;; FIXME: This does not distinguish + ;; between reading nil and a read error. + ;; We don't care but still, better fix this. + (read (current-buffer))))) + (when (memq head '( cl-flet cl-labels cl-macrolet cl-flet* + cl-symbol-macrolet)) + ;; In what follows, we rely on (point) returning non-nil. + (setq local-definitions-starting-point + (progn + (parse-partial-sexp + (point) first-order-parent nil + ;; From docstring of `parse-partial-sexp': + ;; Fourth arg non-nil means stop + ;; when we come to any character + ;; that starts a sexp. + t) + (point)))))) + (save-excursion + (when (ignore-errors + ;; We rely on `backward-up-list' working + ;; even when sexp is incomplete “to the right”. + (backward-up-list 2) + t) + (= local-definitions-starting-point (point)))))))))) + (defun lisp-indent-function (indent-point state) "This function is the normal value of the variable `lisp-indent-function'. The function `calculate-lisp-indent' calls this to determine @@ -1139,16 +1189,19 @@ Lisp function does not specify a special indentation." (if (and (elt state 2) (not (looking-at "\\sw\\|\\s_"))) ;; car of form doesn't seem to be a symbol - (progn + (if (lisp--local-defform-body-p state) + ;; We nevertheless check whether we are in flet-like form + ;; as we presume local function names could be non-symbols. + (lisp-indent-defform state indent-point) (if (not (> (save-excursion (forward-line 1) (point)) calculate-lisp-indent-last-sexp)) - (progn (goto-char calculate-lisp-indent-last-sexp) - (beginning-of-line) - (parse-partial-sexp (point) - calculate-lisp-indent-last-sexp 0 t))) - ;; Indent under the list or under the first sexp on the same - ;; line as calculate-lisp-indent-last-sexp. Note that first - ;; thing on that line has to be complete sexp since we are + (progn (goto-char calculate-lisp-indent-last-sexp) + (beginning-of-line) + (parse-partial-sexp (point) + calculate-lisp-indent-last-sexp 0 t))) + ;; Indent under the list or under the first sexp on the same + ;; line as calculate-lisp-indent-last-sexp. Note that first + ;; thing on that line has to be complete sexp since we are ;; inside the innermost containing sexp. (backward-prefix-chars) (current-column)) @@ -1159,15 +1212,14 @@ Lisp function does not specify a special indentation." 'lisp-indent-function) (get (intern-soft function) 'lisp-indent-hook))) (cond ((or (eq method 'defun) - (and (null method) - (> (length function) 3) - (string-match "\\`def" function))) + ;; Check whether we are in flet-like form. + (lisp--local-defform-body-p state)) (lisp-indent-defform state indent-point)) ((integerp method) (lisp-indent-specform method state indent-point normal-indent)) (method - (funcall method indent-point state))))))) + (funcall method indent-point state))))))) (defcustom lisp-body-indent 2 "Number of columns to indent the second line of a `(def...)' form." @@ -1235,6 +1287,13 @@ Lisp function does not specify a special indentation." (put 'autoload 'lisp-indent-function 'defun) ;Elisp (put 'progn 'lisp-indent-function 0) +(put 'defvar 'lisp-indent-function 'defun) +(put 'defalias 'lisp-indent-function 'defun) +(put 'defvaralias 'lisp-indent-function 'defun) +(put 'defconst 'lisp-indent-function 'defun) +(put 'define-category 'lisp-indent-function 'defun) +(put 'define-charset-internal 'lisp-indent-function 'defun) +(put 'define-fringe-bitmap 'lisp-indent-function 'defun) (put 'prog1 'lisp-indent-function 1) (put 'save-excursion 'lisp-indent-function 0) ;Elisp (put 'save-restriction 'lisp-indent-function 0) ;Elisp @@ -1249,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/macroexp.el b/lisp/emacs-lisp/macroexp.el index 1e4fdd126cb..c04cbb7fffd 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -136,9 +136,12 @@ Other uses risk returning non-nil value that point to the wrong file." (defvar macroexp--warned (make-hash-table :test #'equal :weakness 'key)) (defun macroexp--warn-wrap (msg form category) - (let ((when-compiled (lambda () - (when (byte-compile-warning-enabled-p category) - (byte-compile-warn "%s" msg))))) + (let ((when-compiled + (lambda () + (when (if (consp category) + (apply #'byte-compile-warning-enabled-p category) + (byte-compile-warning-enabled-p category)) + (byte-compile-warn "%s" msg))))) `(progn (macroexp--funcall-if-compiled ',when-compiled) ,form))) @@ -220,7 +223,7 @@ is executed without being compiled first." fun obsolete (if (symbolp (symbol-function fun)) "alias" "macro")) - new-form 'obsolete)) + new-form (list 'obsolete fun))) new-form))) (defun macroexp--unfold-lambda (form &optional name) @@ -286,6 +289,16 @@ is executed without being compiled first." `(let ,(nreverse bindings) . ,body) (macroexp-progn body))))) +(defun macroexp--dynamic-variable-p (var) + "Whether the variable VAR is dynamically scoped. +Only valid during macro-expansion." + (defvar byte-compile-bound-variables) + (or (not lexical-binding) + (special-variable-p var) + (memq var macroexp--dynvars) + (and (boundp 'byte-compile-bound-variables) + (memq var byte-compile-bound-variables)))) + (defun macroexp--expand-all (form) "Expand all macros in FORM. This is an internal version of `macroexpand-all'. @@ -313,28 +326,32 @@ Assumes the caller has bound `macroexpand-all-environment'." (cddr form)) (cdr form)) form)) - (`(,(or 'defvar 'defconst) . ,_) (macroexp--all-forms form 2)) + (`(,(or 'defvar 'defconst) ,(and name (pred symbolp)) . ,_) + (push name macroexp--dynvars) + (macroexp--all-forms form 2)) (`(function ,(and f `(lambda . ,_))) - (macroexp--cons 'function - (macroexp--cons (macroexp--all-forms f 2) - nil - (cdr form)) - form)) + (let ((macroexp--dynvars macroexp--dynvars)) + (macroexp--cons 'function + (macroexp--cons (macroexp--all-forms f 2) + nil + (cdr form)) + form))) (`(,(or 'function 'quote) . ,_) form) (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) pcase--dontcare)) - (macroexp--cons - fun - (macroexp--cons - (macroexp--all-clauses bindings 1) - (if (null body) - (macroexp-unprogn - (macroexp-warn-and-return - (format "Empty %s body" fun) - nil nil 'compile-only)) - (macroexp--all-forms body)) - (cdr form)) - form)) + (let ((macroexp--dynvars macroexp--dynvars)) + (macroexp--cons + fun + (macroexp--cons + (macroexp--all-clauses bindings 1) + (if (null body) + (macroexp-unprogn + (macroexp-warn-and-return + (format "Empty %s body" fun) + nil nil 'compile-only)) + (macroexp--all-forms body)) + (cdr form)) + form))) (`(,(and fun `(lambda . ,_)) . ,args) ;; Embedded lambda in function position. ;; If the byte-optimizer is loaded, try to unfold this, @@ -418,6 +435,14 @@ Assumes the caller has bound `macroexpand-all-environment'." If no macros are expanded, FORM is returned unchanged. The second optional arg ENVIRONMENT specifies an environment of macro definitions to shadow the loaded ones for use in file byte-compilation." + (let ((macroexpand-all-environment environment) + (macroexp--dynvars macroexp--dynvars)) + (macroexp--expand-all form))) + +;; This function is like `macroexpand-all' but for use with top-level +;; forms. It does not dynbind `macroexp--dynvars' because we want +;; top-level `defvar' declarations to be recorded in that variable. +(defun macroexpand--all-toplevel (form &optional environment) (let ((macroexpand-all-environment environment)) (macroexp--expand-all form))) @@ -703,7 +728,7 @@ test of free variables in the following ways: (let ((macroexp--pending-eager-loads (cons load-file-name macroexp--pending-eager-loads))) (if full-p - (macroexpand-all form) + (macroexpand--all-toplevel form) (macroexpand form))) (error ;; Hopefully this shouldn't happen thanks to the cycle detection, 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/memory-report.el b/lisp/emacs-lisp/memory-report.el index 3166d33e029..450cdaa7a84 100644 --- a/lisp/emacs-lisp/memory-report.el +++ b/lisp/emacs-lisp/memory-report.el @@ -31,7 +31,7 @@ (require 'subr-x) (require 'cl-lib) -(defvar memory-report--type-size (make-hash-table)) +(defvar memory-report--type-size nil) ;;;###autoload (defun memory-report () @@ -84,6 +84,7 @@ by counted more than once." (gethash 'object memory-report--type-size))) (defun memory-report--set-size (elems) + (setq memory-report--type-size (make-hash-table)) (setf (gethash 'string memory-report--type-size) (cadr (assq 'strings elems))) (setf (gethash 'cons memory-report--type-size) @@ -282,7 +283,7 @@ by counted more than once." buffers) do (insert (memory-report--format size) " " - (button-buttonize + (buttonize (buffer-name buffer) #'memory-report--buffer-details buffer) "\n")) diff --git a/lisp/emacs-lisp/multisession.el b/lisp/emacs-lisp/multisession.el new file mode 100644 index 00000000000..c58a9abe020 --- /dev/null +++ b/lisp/emacs-lisp/multisession.el @@ -0,0 +1,449 @@ +;;; multisession.el --- Multisession storage for variables -*- 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'cl-lib) +(require 'eieio) +(require 'sqlite) +(require 'tabulated-list) + +(defcustom multisession-storage 'files + "Storage method for multisession variables. +Valid methods are `sqlite' and `files'." + :type '(choice (const :tag "SQLite" sqlite) + (const :tag "Files" files)) + :version "29.1" + :group 'files) + +(defcustom multisession-directory (expand-file-name "multisession/" + user-emacs-directory) + "Directory to store multisession variables." + :type 'file + :version "29.1" + :group 'files) + +;;;###autoload +(defmacro define-multisession-variable (name initial-value &optional doc + &rest args) + "Make NAME into a multisession variable initialized from INITIAL-VALUE. +DOC should be a doc string, and ARGS are keywords as applicable to +`make-multisession'." + (declare (indent defun)) + (unless (plist-get args :package) + (setq args (nconc (list :package + (replace-regexp-in-string "-.*" "" + (symbol-name name))) + args))) + `(defvar ,name + (make-multisession :key ,(symbol-name name) + :initial-value ,initial-value + ,@args) + ,@(list doc))) + +(defconst multisession--unbound (make-symbol "unbound")) + +(cl-defstruct (multisession + (:constructor nil) + (:constructor multisession--create) + (:conc-name multisession--)) + "A persistent variable that will live across Emacs invocations." + key + (initial-value nil) + package + (storage multisession-storage) + (synchronized nil) + (cached-value multisession--unbound) + (cached-sequence 0)) + +(cl-defun make-multisession (&key key initial-value package synchronized + storage) + "Create a multisession object." + (unless package + (error "No package for the multisession object")) + (unless key + (error "No key for the multisession object")) + (unless (stringp package) + (error "The package has to be a string")) + (unless (stringp key) + (error "The key has to be a string")) + (multisession--create + :key key + :synchronized synchronized + :initial-value initial-value + :package package + :storage (or storage multisession-storage))) + +(defun multisession-value (object) + "Return the value of the multisession OBJECT." + (if (null user-init-file) + ;; If we don't have storage, then just return the value from the + ;; object. + (if (eq (multisession--cached-value object) multisession--unbound) + (multisession--initial-value object) + (multisession--cached-value object)) + ;; We have storage, so we update from storage. + (multisession-backend-value (multisession--storage object) object))) + +(defun multisession--set-value (object value) + "Set the stored value of OBJECT to VALUE." + (if (null user-init-file) + ;; We have no backend, so just store the value. + (setf (multisession--cached-value object) value) + ;; We have a backend. + (multisession--backend-set-value (multisession--storage object) + object value))) + +(defun multisession-delete (object) + "Delete OBJECT from the backend storage." + (multisession--backend-delete (multisession--storage object) object)) + +(gv-define-simple-setter multisession-value multisession--set-value) + +;; SQLite Backend + +(declare-function sqlite-execute "sqlite.c") +(declare-function sqlite-select "sqlite.c") +(declare-function sqlite-open "sqlite.c") +(declare-function sqlite-pragma "sqlite.c") +(declare-function sqlite-transaction "sqlite.c") +(declare-function sqlite-commit "sqlite.c") + +(defvar multisession--db nil) + +(defun multisession--ensure-db () + (unless multisession--db + (let* ((file (expand-file-name "sqlite/multisession.sqlite" + multisession-directory)) + (dir (file-name-directory file))) + (unless (file-exists-p dir) + (make-directory dir t)) + (setq multisession--db (sqlite-open file))) + (with-sqlite-transaction multisession--db + ;; Use a write-ahead-log (available since 2010), which makes + ;; writes a lot faster. + (sqlite-pragma multisession--db "journal_mode = WAL") + (sqlite-pragma multisession--db "synchronous = NORMAL") + (unless (sqlite-select + multisession--db + "select name from sqlite_master where type = 'table' and name = 'multisession'") + ;; Tidy up the database automatically. + (sqlite-pragma multisession--db "auto_vacuum = FULL") + ;; Create the table. + (sqlite-execute + multisession--db + "create table multisession (package text not null, key text not null, sequence number not null default 1, value text not null)") + (sqlite-execute + multisession--db + "create unique index multisession_idx on multisession (package, key)"))))) + +(cl-defmethod multisession-backend-value ((_type (eql 'sqlite)) object) + (multisession--ensure-db) + (let ((id (list (multisession--package object) + (multisession--key object)))) + (cond + ;; We have no value yet; check the database. + ((eq (multisession--cached-value object) multisession--unbound) + (let ((stored + (car + (sqlite-select + multisession--db + "select value, sequence from multisession where package = ? and key = ?" + id)))) + (if stored + (let ((value (car (read-from-string (car stored))))) + (setf (multisession--cached-value object) value + (multisession--cached-sequence object) (cadr stored)) + value) + ;; Nothing; return the initial value. + (multisession--initial-value object)))) + ;; We have a value, but we want to update in case some other + ;; Emacs instance has updated. + ((multisession--synchronized object) + (let ((stored + (car + (sqlite-select + multisession--db + "select value, sequence from multisession where sequence > ? and package = ? and key = ?" + (cons (multisession--cached-sequence object) id))))) + (if stored + (let ((value (car (read-from-string (car stored))))) + (setf (multisession--cached-value object) value + (multisession--cached-sequence object) (cadr stored)) + value) + ;; Nothing, return the cached value. + (multisession--cached-value object)))) + ;; Just return the cached value. + (t + (multisession--cached-value object))))) + +(cl-defmethod multisession--backend-set-value ((_type (eql 'sqlite)) + object value) + (catch 'done + (let ((i 0)) + (while (< i 10) + (condition-case nil + (throw 'done (multisession--set-value-sqlite object value)) + (sqlite-locked-error + (setq i (1+ i)) + (sleep-for (+ 0.1 (/ (float (random 10)) 10)))))) + (signal 'sqlite-locked-error "Database is locked")))) + +(defun multisession--set-value-sqlite (object value) + (multisession--ensure-db) + (with-sqlite-transaction multisession--db + (let ((id (list (multisession--package object) + (multisession--key object))) + (pvalue + (let ((print-length nil) + (print-circle t) + (print-level nil)) + (prin1-to-string value)))) + (condition-case nil + (ignore (read-from-string pvalue)) + (error (error "Unable to store unreadable value: %s" pvalue))) + (sqlite-execute + multisession--db + "insert into multisession(package, key, sequence, value) values(?, ?, 1, ?) on conflict(package, key) do update set sequence = sequence + 1, value = ?" + (append id (list pvalue pvalue))) + (setf (multisession--cached-sequence object) + (caar (sqlite-select + multisession--db + "select sequence from multisession where package = ? and key = ?" + id))) + (setf (multisession--cached-value object) value)))) + +(cl-defmethod multisession--backend-values ((_type (eql 'sqlite))) + (multisession--ensure-db) + (sqlite-select + multisession--db + "select package, key, value from multisession order by package, key")) + +(cl-defmethod multisession--backend-delete ((_type (eql 'sqlite)) object) + (sqlite-execute multisession--db + "delete from multisession where package = ? and key = ?" + (list (multisession--package object) + (multisession--key object)))) + +;; Files Backend + +(defun multisession--encode-file-name (name) + (url-hexify-string name)) + +(defun multisession--read-file-value (file object) + (catch 'done + (let ((i 0) + last-error) + (while (< i 10) + (condition-case err + (throw 'done + (with-temp-buffer + (let* ((time (file-attribute-modification-time + (file-attributes file))) + (coding-system-for-read 'utf-8-emacs-unix)) + (insert-file-contents file) + (let ((stored (read (current-buffer)))) + (setf (multisession--cached-value object) stored + (multisession--cached-sequence object) time) + stored)))) + ;; Windows uses OS-level file locking that may preclude + ;; reading the file in some circumstances. In addition, + ;; rename-file is not an atomic operation on MS-Windows, + ;; when the target file already exists, so there could be a + ;; small race window when the file to read doesn't yet + ;; exist. So when these problems happen, wait a bit and retry. + ((permission-denied file-missing) + (setq i (1+ i) + last-error err) + (sleep-for (+ 0.1 (/ (float (random 10)) 10)))))) + (signal (car last-error) (cdr last-error))))) + +(defun multisession--object-file-name (object) + (expand-file-name + (concat "files/" + (multisession--encode-file-name (multisession--package object)) + "/" + (multisession--encode-file-name (multisession--key object)) + ".value") + multisession-directory)) + +(cl-defmethod multisession-backend-value ((_type (eql 'files)) object) + (let ((file (multisession--object-file-name object))) + (cond + ;; We have no value yet; see whether it's stored. + ((eq (multisession--cached-value object) multisession--unbound) + (if (file-exists-p file) + (multisession--read-file-value file object) + ;; Nope; return the initial value. + (multisession--initial-value object))) + ;; We have a value, but we want to update in case some other + ;; Emacs instance has updated. + ((multisession--synchronized object) + (if (and (file-exists-p file) + (time-less-p (multisession--cached-sequence object) + (file-attribute-modification-time + (file-attributes file)))) + (multisession--read-file-value file object) + ;; Nothing, return the cached value. + (multisession--cached-value object))) + ;; Just return the cached value. + (t + (multisession--cached-value object))))) + +(cl-defmethod multisession--backend-set-value ((_type (eql 'files)) + object value) + (let ((file (multisession--object-file-name object)) + (time (current-time))) + ;; Ensure that the directory exists. + (let ((dir (file-name-directory file))) + (unless (file-exists-p dir) + (make-directory dir t))) + (with-temp-buffer + (let ((print-length nil) + (print-circle t) + (print-level nil)) + (prin1 value (current-buffer))) + (goto-char (point-min)) + (condition-case nil + (read (current-buffer)) + (error (error "Unable to store unreadable value: %s" (buffer-string)))) + ;; Write to a temp file in the same directory and rename to the + ;; file for somewhat better atomicity. + (let ((coding-system-for-write 'utf-8-emacs-unix) + (create-lockfiles nil) + (temp (make-temp-name file)) + (write-region-inhibit-fsync nil)) + (write-region (point-min) (point-max) temp nil 'silent) + (set-file-times temp time) + (rename-file temp file t))) + (setf (multisession--cached-sequence object) time + (multisession--cached-value object) value))) + +(cl-defmethod multisession--backend-values ((_type (eql 'files))) + (mapcar (lambda (file) + (let ((bits (file-name-split file))) + (list (url-unhex-string (car (last bits 2))) + (url-unhex-string + (file-name-sans-extension (car (last bits)))) + (with-temp-buffer + (let ((coding-system-for-read 'utf-8-emacs-unix)) + (insert-file-contents file) + (read (current-buffer))))))) + (directory-files-recursively + (expand-file-name "files" multisession-directory) + "\\.value\\'"))) + +(cl-defmethod multisession--backend-delete ((_type (eql 'files)) object) + (let ((file (multisession--object-file-name object))) + (when (file-exists-p file) + (delete-file file)))) + +;; Mode for editing. + +(defvar-keymap multisession-edit-mode-map + :parent tabulated-list-mode-map + "d" #'multisession-delete-value + "e" #'multisession-edit-value) + +(define-derived-mode multisession-edit-mode special-mode "Multisession" + "This mode lists all elements in the \"multisession\" database." + :interactive nil + (buffer-disable-undo) + (setq-local buffer-read-only t + truncate-lines t) + (setq tabulated-list-format + [("Package" 10) + ("Key" 30) + ("Value" 30)]) + (setq-local revert-buffer-function #'multisession-edit-mode--revert)) + +;;;###autoload +(defun list-multisession-values (&optional choose-storage) + "List all values in the \"multisession\" database. +If CHOOSE-STORAGE (interactively, the prefix), query for the +storage method to list." + (interactive "P") + (let ((storage + (if choose-storage + (intern (completing-read "Storage method: " '(sqlite files) nil t)) + multisession-storage))) + (pop-to-buffer (get-buffer-create (format "*Multisession %s*" storage))) + (multisession-edit-mode) + (setq-local multisession-storage storage) + (multisession-edit-mode--revert) + (goto-char (point-min)))) + +(defun multisession-edit-mode--revert (&rest _) + (let ((inhibit-read-only t) + (id (get-text-property (point) 'tabulated-list-id))) + (erase-buffer) + (tabulated-list-init-header) + (setq tabulated-list-entries + (mapcar (lambda (elem) + (list + (cons (car elem) (cadr elem)) + (vector (car elem) (cadr elem) + (string-replace "\n" "\\n" + (format "%s" (caddr elem)))))) + (multisession--backend-values multisession-storage))) + (tabulated-list-print t) + (goto-char (point-min)) + (when id + (when-let ((match + (text-property-search-forward 'tabulated-list-id id t))) + (goto-char (prop-match-beginning match)))))) + +(defun multisession-delete-value (id) + "Delete the value at point." + (interactive (list (get-text-property (point) 'tabulated-list-id)) + multisession-edit-mode) + (unless id + (error "No value on the current line")) + (unless (yes-or-no-p "Really delete this item? ") + (user-error "Not deleting")) + (multisession--backend-delete multisession-storage + (make-multisession :package (car id) + :key (cdr id))) + (let ((inhibit-read-only t)) + (beginning-of-line) + (delete-region (point) (progn (forward-line 1) (point))))) + +(defun multisession-edit-value (id) + "Edit the value at point." + (interactive (list (get-text-property (point) 'tabulated-list-id)) + multisession-edit-mode) + (unless id + (error "No value on the current line")) + (let* ((object (make-multisession + :package (car id) + :key (cdr id) + :storage multisession-storage)) + (value (multisession-value object))) + (setf (multisession-value object) + (car (read-from-string + (read-string "New value: " (prin1-to-string value)))))) + (multisession-edit-mode--revert)) + +(provide 'multisession) + +;;; multisession.el ends here diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 8fc2986ab41..27c289e385e 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -480,6 +480,8 @@ is defined as a macro, alias, command, ..." (get symbol 'advice--pending)) (t (symbol-function symbol))) function props) + ;; FIXME: We could use a defmethod on `function-docstring' instead, + ;; except when (or (not nf) (autoloadp nf))! (put symbol 'function-documentation `(advice--make-docstring ',symbol)) (add-function :around (get symbol 'defalias-fset-function) #'advice--defalias-fset)) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 2c37e19980d..7b90e361bd4 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -714,6 +714,7 @@ REQUIREMENTS is a list of dependencies on other packages. where OTHER-VERSION is a string. EXTRA-PROPERTIES is currently unused." + (declare (indent defun)) ;; FIXME: Placeholder! Should we keep it? (error "Don't call me!")) @@ -757,47 +758,47 @@ PKG-DESC is a `package-desc' object." (format "%s-autoloads" (package-desc-name pkg-desc)) (package-desc-dir pkg-desc))) -(defun package--activate-autoloads-and-load-path (pkg-desc) - "Load the autoloads file and add package dir to `load-path'. -PKG-DESC is a `package-desc' object." - (let* ((old-lp load-path) - (pkg-dir (package-desc-dir pkg-desc)) - (pkg-dir-dir (file-name-as-directory pkg-dir))) - (with-demoted-errors "Error loading autoloads: %s" - (load (package--autoloads-file-name pkg-desc) nil t)) - (when (and (eq old-lp load-path) - (not (or (member pkg-dir load-path) - (member pkg-dir-dir load-path)))) - ;; Old packages don't add themselves to the `load-path', so we have to - ;; do it ourselves. - (push pkg-dir load-path)))) - (defvar Info-directory-list) (declare-function info-initialize "info" ()) (defvar package--quickstart-pkgs t "If set to a list, we're computing the set of pkgs to activate.") -(defun package--load-files-for-activation (pkg-desc reload) - "Load files for activating a package given by PKG-DESC. -Load the autoloads file, and ensure `load-path' is setup. If -RELOAD is non-nil, also load all files in the package that -correspond to previously loaded files." - (let* ((loaded-files-list - (when reload - (package--list-loaded-files (package-desc-dir pkg-desc))))) - ;; Add to load path, add autoloads, and activate the package. - (package--activate-autoloads-and-load-path pkg-desc) - ;; Call `load' on all files in `package-desc-dir' already present in - ;; `load-history'. This is done so that macros in these files are updated - ;; to their new definitions. If another package is being installed which - ;; depends on this new definition, not doing this update would cause - ;; compilation errors and break the installation. - (with-demoted-errors "Error in package--load-files-for-activation: %s" - (mapc (lambda (feature) (load feature nil t)) - ;; Skip autoloads file since we already evaluated it above. - (remove (file-truename (package--autoloads-file-name pkg-desc)) - loaded-files-list))))) +(defsubst package--library-stem (file) + (catch 'done + (let (result) + (dolist (suffix (get-load-suffixes) file) + (setq result (string-trim file nil suffix)) + (unless (equal file result) + (throw 'done result)))))) + +(defun package--reload-previously-loaded (pkg-desc) + "Force reimportation of files in PKG-DESC already present in `load-history'. +New editions of files contain macro definitions and +redefinitions, the overlooking of which would cause +byte-compilation of the new package to fail." + (with-demoted-errors "Error in package--load-files-for-activation: %s" + (let* (result + (dir (package-desc-dir pkg-desc)) + (load-path-sans-dir + (cl-remove-if (apply-partially #'string= dir) + (or (bound-and-true-p find-function-source-path) + load-path))) + (files (directory-files-recursively dir "\\`[^\\.].*\\.el\\'")) + (history (mapcar #'file-truename + (cl-remove-if-not #'stringp + (mapcar #'car load-history))))) + (dolist (file files) + (when-let ((library (package--library-stem + (file-relative-name file dir))) + (canonical (locate-library library nil load-path-sans-dir)) + (found (member (file-truename canonical) history)) + (recent-index (length found))) + (unless (equal (file-name-base library) + (format "%s-autoloads" (package-desc-name pkg-desc))) + (push (cons (expand-file-name library dir) recent-index) result)))) + (mapc (lambda (c) (load (car c) nil t)) + (sort result (lambda (x y) (< (cdr x) (cdr y)))))))) (defun package-activate-1 (pkg-desc &optional reload deps) "Activate package given by PKG-DESC, even if it was already active. @@ -824,7 +825,11 @@ correspond to previously loaded files (those returned by (if (listp package--quickstart-pkgs) ;; We're only collecting the set of packages to activate! (push pkg-desc package--quickstart-pkgs) - (package--load-files-for-activation pkg-desc reload)) + (when reload + (package--reload-previously-loaded pkg-desc)) + (with-demoted-errors "Error loading autoloads: %s" + (load (package--autoloads-file-name pkg-desc) nil t)) + (add-to-list 'load-path (directory-file-name pkg-dir))) ;; Add info node. (when (file-exists-p (expand-file-name "dir" pkg-dir)) ;; FIXME: not the friendliest, but simple. @@ -835,48 +840,6 @@ correspond to previously loaded files (those returned by ;; Don't return nil. t))) -(defun package--files-load-history () - (delq nil - (mapcar (lambda (x) - (let ((f (car x))) - (and (stringp f) - (file-name-sans-extension (file-truename f))))) - load-history))) - -(defun package--list-of-conflicts (dir history) - (require 'find-func) - (declare-function find-library-name "find-func" (library)) - (delq - nil - (mapcar - (lambda (x) (let* ((file (file-relative-name x dir)) - ;; Previously loaded file, if any. - (previous - (ignore-error file-error ;"Can't find library" - (file-name-sans-extension - (file-truename (find-library-name file))))) - (pos (when previous (member previous history)))) - ;; Return (RELATIVE-FILENAME . HISTORY-POSITION) - (when pos - (cons (file-name-sans-extension file) (length pos))))) - (directory-files-recursively dir "\\`[^\\.].*\\.el\\'")))) - -(defun package--list-loaded-files (dir) - "Recursively list all files in DIR which correspond to loaded features. -Returns the `file-name-sans-extension' of each file, relative to -DIR, sorted by most recently loaded last." - (let* ((history (package--files-load-history)) - (dir (file-truename dir)) - ;; List all files that have already been loaded. - (list-of-conflicts (package--list-of-conflicts dir history))) - ;; Turn the list of (FILENAME . POS) back into a list of features. Files in - ;; subdirectories are returned relative to DIR (so not actually features). - (let ((default-directory (file-name-as-directory dir))) - (mapcar (lambda (x) (file-truename (car x))) - (sort list-of-conflicts - ;; Sort the files by ascending HISTORY-POSITION. - (lambda (x y) (< (cdr x) (cdr y)))))))) - ;;;; `package-activate' (defun package--get-activatable-pkg (pkg-name) @@ -995,7 +958,7 @@ untar into a directory named DIR; otherwise, signal an error." (package--native-compile-async new-desc)) ;; After compilation, load again any files loaded by ;; `activate-1', so that we use the byte-compiled definitions. - (package--load-files-for-activation new-desc :reload))) + (package--reload-previously-loaded new-desc))) pkg-dir)) (defun package-generate-description-file (pkg-desc pkg-file) @@ -1218,13 +1181,17 @@ The return result is a `package-desc'." info) (while files (with-temp-buffer - (insert-file-contents (pop files)) - ;; When we find the file with the data, - (when (setq info (ignore-errors (package-buffer-info))) - ;; stop looping, - (setq files nil) - ;; set the 'dir kind, - (setf (package-desc-kind info) 'dir)))) + (let ((file (pop files))) + ;; The file may be a link to a nonexistent file; e.g., a + ;; lock file. + (when (file-exists-p file) + (insert-file-contents file) + ;; When we find the file with the data, + (when (setq info (ignore-errors (package-buffer-info))) + ;; stop looping, + (setq files nil) + ;; set the 'dir kind, + (setf (package-desc-kind info) 'dir)))))) (unless info (error "No .el files with package headers in `%s'" default-directory)) ;; and return the info. @@ -2488,6 +2455,15 @@ The description is read from the installed package files." (format "%s.el" (package-desc-name desc)) srcdir)) ""))) +(defun package--describe-add-library-links () + "Add links to library names in package description." + (while (re-search-forward "\\<\\([-[:alnum:]]+\\.el\\)\\>" nil t) + (if (locate-library (match-string 1)) + (make-text-button (match-beginning 1) (match-end 1) + 'xref (match-string-no-properties 1) + 'help-echo "Read this file's commentary" + :type 'package--finder-xref)))) + (defun describe-package-1 (pkg) "Insert the package description for PKG. Helper function for `describe-package'." @@ -2714,6 +2690,9 @@ Helper function for `describe-package'." t) (insert (or readme-string "This package does not provide a description."))))) + ;; Make library descriptions into links. + (goto-char start-of-description) + (package--describe-add-library-links) ;; Make URLs in the description into links. (goto-char start-of-description) (browse-url-add-buttons)))) @@ -2759,6 +2738,15 @@ function is a convenience wrapper used by `describe-package-1'." (apply #'insert-text-button button-text 'face button-face 'follow-link t properties))) +(defun package--finder-goto-xref (button) + "Jump to a Lisp file for the BUTTON at point." + (let* ((file (button-get button 'xref)) + (lib (locate-library file))) + (if lib (finder-commentary lib) + (message "Unable to locate `%s'" file)))) + +(define-button-type 'package--finder-xref 'action #'package--finder-goto-xref) + (defun package--print-email-button (recipient) "Insert a button whose action will send an email to RECIPIENT. NAME should have the form (FULLNAME . EMAIL) where FULLNAME is @@ -2780,35 +2768,33 @@ either a full name or nil, and EMAIL is a valid email address." ;;;; Package menu mode. -(defvar package-menu-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map tabulated-list-mode-map) - (define-key map "\C-m" 'package-menu-describe-package) - (define-key map "u" 'package-menu-mark-unmark) - (define-key map "\177" 'package-menu-backup-unmark) - (define-key map "d" 'package-menu-mark-delete) - (define-key map "i" 'package-menu-mark-install) - (define-key map "U" 'package-menu-mark-upgrades) - (define-key map "r" 'revert-buffer) - (define-key map "~" 'package-menu-mark-obsolete-for-deletion) - (define-key map "w" 'package-browse-url) - (define-key map "x" 'package-menu-execute) - (define-key map "h" 'package-menu-quick-help) - (define-key map "H" #'package-menu-hide-package) - (define-key map "?" 'package-menu-describe-package) - (define-key map "(" #'package-menu-toggle-hiding) - (define-key map (kbd "/ /") 'package-menu-clear-filter) - (define-key map (kbd "/ a") 'package-menu-filter-by-archive) - (define-key map (kbd "/ d") 'package-menu-filter-by-description) - (define-key map (kbd "/ k") 'package-menu-filter-by-keyword) - (define-key map (kbd "/ N") 'package-menu-filter-by-name-or-description) - (define-key map (kbd "/ n") 'package-menu-filter-by-name) - (define-key map (kbd "/ s") 'package-menu-filter-by-status) - (define-key map (kbd "/ v") 'package-menu-filter-by-version) - (define-key map (kbd "/ m") 'package-menu-filter-marked) - (define-key map (kbd "/ u") 'package-menu-filter-upgradable) - map) - "Local keymap for `package-menu-mode' buffers.") +(defvar-keymap package-menu-mode-map + :doc "Local keymap for `package-menu-mode' buffers." + :parent tabulated-list-mode-map + "C-m" #'package-menu-describe-package + "u" #'package-menu-mark-unmark + "DEL" #'package-menu-backup-unmark + "d" #'package-menu-mark-delete + "i" #'package-menu-mark-install + "U" #'package-menu-mark-upgrades + "r" #'revert-buffer + "~" #'package-menu-mark-obsolete-for-deletion + "w" #'package-browse-url + "x" #'package-menu-execute + "h" #'package-menu-quick-help + "H" #'package-menu-hide-package + "?" #'package-menu-describe-package + "(" #'package-menu-toggle-hiding + "/ /" #'package-menu-clear-filter + "/ a" #'package-menu-filter-by-archive + "/ d" #'package-menu-filter-by-description + "/ k" #'package-menu-filter-by-keyword + "/ N" #'package-menu-filter-by-name-or-description + "/ n" #'package-menu-filter-by-name + "/ s" #'package-menu-filter-by-status + "/ v" #'package-menu-filter-by-version + "/ m" #'package-menu-filter-marked + "/ u" #'package-menu-filter-upgradable) (easy-menu-define package-menu-mode-menu package-menu-mode-map "Menu for `package-menu-mode'." @@ -4090,7 +4076,9 @@ The list is displayed in a buffer named `*Packages*'." "Return the version number of the package in which this is used. Assumes it is used from an Elisp file placed inside the top-level directory of an installed ELPA package. -The return value is a string (or nil in case we can't find it)." +The return value is a string (or nil in case we can't find it). +It works in more cases if the call is in the file which contains +the `Version:' header." ;; In a sense, this is a lie, but it does just what we want: precompute ;; the version at compile time and hardcodes it into the .elc file! (declare (pure t)) @@ -4109,6 +4097,7 @@ The return value is a string (or nil in case we can't find it)." (let* ((pkgdir (file-name-directory file)) (pkgname (file-name-nondirectory (directory-file-name pkgdir))) (mainfile (expand-file-name (concat pkgname ".el") pkgdir))) + (unless (file-readable-p mainfile) (setq mainfile file)) (when (file-readable-p mainfile) (require 'lisp-mnt) (with-temp-buffer @@ -4195,6 +4184,7 @@ activations need to be changed, such as when `package-load-list' is modified." (replace-match (if (match-end 1) "" pfile) t t))) (unless (bolp) (insert "\n")) (insert ")\n"))) + (pp `(defvar package-activated-list) (current-buffer)) (pp `(setq package-activated-list (append ',(mapcar #'package-desc-name package--quickstart-pkgs) package-activated-list)) @@ -4212,6 +4202,7 @@ activations need to be changed, such as when `package-load-list' is modified." ;; Local\sVariables: ;; version-control: never ;; no-update-autoloads: t +;; byte-compile-warnings: (not make-local) ;; End: ")) ;; FIXME: Do it asynchronously in an Emacs subprocess, and diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index 0bf774dffd8..8464b5a5198 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -33,22 +33,43 @@ (defcustom pp-escape-newlines t "Value of `print-escape-newlines' used by pp-* functions." + :type 'boolean) + +(defcustom pp-max-width t + "Max width to use when formatting. +If nil, there's no max width. If t, use the window width. +Otherwise this should be a number." + :type '(choice (const :tag "none" nil) + (const :tag "window width" t) + number) + :version "29.1") + +(defcustom pp-use-max-width nil + "If non-nil, `pp'-related functions will try to fold lines. +The target width is given by the `pp-max-width' variable." :type 'boolean - :group 'pp) + :version "29.1") + +(defvar pp--inhibit-function-formatting nil) ;;;###autoload (defun pp-to-string (object) "Return a string containing the pretty-printed representation of OBJECT. OBJECT can be any Lisp object. Quoting characters are used as needed to make output that `read' can handle, whenever this is possible." - (with-temp-buffer - (lisp-mode-variables nil) - (set-syntax-table emacs-lisp-mode-syntax-table) - (let ((print-escape-newlines pp-escape-newlines) - (print-quoted t)) - (prin1 object (current-buffer))) - (pp-buffer) - (buffer-string))) + (if pp-use-max-width + (let ((pp--inhibit-function-formatting t)) + (with-temp-buffer + (pp-emacs-lisp-code object) + (buffer-string))) + (with-temp-buffer + (lisp-mode-variables nil) + (set-syntax-table emacs-lisp-mode-syntax-table) + (let ((print-escape-newlines pp-escape-newlines) + (print-quoted t)) + (prin1 object (current-buffer))) + (pp-buffer) + (buffer-string)))) ;;;###autoload (defun pp-buffer () @@ -56,7 +77,6 @@ to make output that `read' can handle, whenever this is possible." (interactive) (goto-char (point-min)) (while (not (eobp)) - ;; (message "%06d" (- (point-max) (point))) (cond ((ignore-errors (down-list 1) t) (save-excursion @@ -82,11 +102,21 @@ to make output that `read' can handle, whenever this is possible." "Output the pretty-printed representation of OBJECT, any Lisp object. Quoting characters are printed as needed to make output that `read' can handle, whenever this is possible. + +This function does not apply special formatting rules for Emacs +Lisp code. See `pp-emacs-lisp-code' instead. + +By default, this function won't limit the line length of lists +and vectors. Bind `pp-use-max-width' to a non-nil value to do so. + Output stream is STREAM, or value of `standard-output' (which see)." (princ (pp-to-string object) (or stream standard-output))) -(defun pp-display-expression (expression out-buffer-name) +;;;###autoload +(defun pp-display-expression (expression out-buffer-name &optional lisp) "Prettify and display EXPRESSION in an appropriate way, depending on length. +If LISP, format with `pp-emacs-lisp-code'; use `pp' otherwise. + If a temporary buffer is needed for representation, it will be named after OUT-BUFFER-NAME." (let* ((old-show-function temp-buffer-show-function) @@ -110,11 +140,13 @@ after OUT-BUFFER-NAME." (select-window window) (run-hooks 'temp-buffer-show-hook)) (when (window-live-p old-selected) - (select-window old-selected)) - (message "See buffer %s." out-buffer-name))) + (select-window old-selected)))) (message "%s" (buffer-substring (point-min) (point)))))))) (with-output-to-temp-buffer out-buffer-name - (pp expression) + (if lisp + (with-current-buffer standard-output + (pp-emacs-lisp-code expression)) + (pp expression)) (with-current-buffer standard-output (emacs-lisp-mode) (setq buffer-read-only nil) @@ -179,6 +211,188 @@ Ignores leading comment characters." (insert (pp-to-string (macroexpand-1 (pp-last-sexp)))) (pp-macroexpand-expression (pp-last-sexp)))) +;;;###autoload +(defun pp-emacs-lisp-code (sexp) + "Insert SEXP into the current buffer, formatted as Emacs Lisp code. +Use the `pp-max-width' variable to control the desired line length." + (require 'edebug) + (let ((obuf (current-buffer))) + (with-temp-buffer + (emacs-lisp-mode) + (pp--insert-lisp sexp) + (insert "\n") + (goto-char (point-min)) + (indent-sexp) + (while (re-search-forward " +$" nil t) + (replace-match "")) + (insert-into-buffer obuf)))) + +(defun pp--insert-lisp (sexp) + (cl-case (type-of sexp) + (vector (pp--format-vector sexp)) + (cons (cond + ((consp (cdr sexp)) + (if (and (length= sexp 2) + (eq (car sexp) 'quote)) + (cond + ((symbolp (cadr sexp)) + (let ((print-quoted t)) + (prin1 sexp (current-buffer)))) + ((consp (cadr sexp)) + (insert "'") + (pp--format-list (cadr sexp) + (set-marker (make-marker) (1- (point)))))) + (pp--format-list sexp))) + (t + (princ sexp (current-buffer))))) + ;; Print some of the smaller integers as characters, perhaps? + (integer + (if (<= ?0 sexp ?z) + (let ((print-integers-as-characters t)) + (princ sexp (current-buffer))) + (princ sexp (current-buffer)))) + (string + (let ((print-escape-newlines t)) + (prin1 sexp (current-buffer)))) + (otherwise (princ sexp (current-buffer))))) + +(defun pp--format-vector (sexp) + (insert "[") + (cl-loop for i from 0 + for element across sexp + do (pp--insert (and (> i 0) " ") element)) + (insert "]")) + +(defun pp--format-list (sexp &optional start) + (if (and (symbolp (car sexp)) + (not pp--inhibit-function-formatting) + (not (keywordp (car sexp)))) + (pp--format-function sexp) + (insert "(") + (pp--insert start (pop sexp)) + (while sexp + (pp--insert " " (pop sexp))) + (insert ")"))) + +(defun pp--format-function (sexp) + (let* ((sym (car sexp)) + (edebug (get sym 'edebug-form-spec)) + (indent (get sym 'lisp-indent-function)) + (doc (get sym 'doc-string-elt))) + (when (eq indent 'defun) + (setq indent 2)) + ;; We probably want to keep all the elements before the doc string + ;; on a single line. + (when doc + (setq indent (1- doc))) + ;; Special-case closures -- these shouldn't really exist in actual + ;; source code, so there's no indentation information. But make + ;; them output slightly better. + (when (and (not indent) + (eq sym 'closure)) + (setq indent 0)) + (pp--insert "(" sym) + (pop sexp) + ;; Get the first entries on the first line. + (if indent + (pp--format-definition sexp indent edebug) + (let ((prev 0)) + (while sexp + (let ((start (point))) + ;; Don't put sexps on the same line as a multi-line sexp + ;; preceding it. + (pp--insert (if (> prev 1) "\n" " ") + (pop sexp)) + (setq prev (count-lines start (point))))))) + (insert ")"))) + +(defun pp--format-definition (sexp indent edebug) + (while (and (cl-plusp indent) + sexp) + (insert " ") + ;; We don't understand all the edebug specs. + (unless (consp edebug) + (setq edebug nil)) + (if (and (consp (car edebug)) + (eq (caar edebug) '&rest)) + (pp--insert-binding (pop sexp)) + (if (null (car sexp)) + (insert "()") + (pp--insert-lisp (car sexp))) + (pop sexp)) + (pop edebug) + (cl-decf indent)) + (when (stringp (car sexp)) + (insert "\n") + (prin1 (pop sexp) (current-buffer))) + ;; Then insert the rest with line breaks before each form. + (while sexp + (insert "\n") + (if (keywordp (car sexp)) + (progn + (pp--insert-lisp (pop sexp)) + (when sexp + (pp--insert " " (pop sexp)))) + (pp--insert-lisp (pop sexp))))) + +(defun pp--insert-binding (sexp) + (insert "(") + (while sexp + (if (consp (car sexp)) + ;; Newlines after each (...) binding. + (progn + (pp--insert-lisp (car sexp)) + (when (cdr sexp) + (insert "\n"))) + ;; Keep plain symbols on the same line. + (pp--insert " " (car sexp))) + (pop sexp)) + (insert ")")) + +(defun pp--insert (delim &rest things) + (let ((start (if (markerp delim) + (prog1 + delim + (setq delim nil)) + (point-marker)))) + (when delim + (insert delim)) + (dolist (thing things) + (pp--insert-lisp thing)) + ;; We need to indent what we have so far to see if we have to fold. + (pp--indent-buffer) + (when (> (current-column) (pp--max-width)) + (save-excursion + (goto-char start) + (unless (looking-at "[ \t]+$") + (insert "\n")) + (pp--indent-buffer) + (goto-char (point-max)) + ;; If we're still too wide, then go up one step and try to + ;; insert a newline there. + (when (> (current-column) (pp--max-width)) + (condition-case () + (backward-up-list 1) + (:success (when (looking-back " " 2) + (insert "\n"))) + (error nil))))))) + +(defun pp--max-width () + (cond ((numberp pp-max-width) + pp-max-width) + ((null pp-max-width) + most-positive-fixnum) + ((eq pp-max-width t) + (window-width)) + (t + (error "Invalid pp-max-width value: %s" pp-max-width)))) + +(defun pp--indent-buffer () + (goto-char (point-min)) + (while (not (eobp)) + (lisp-indent-line) + (forward-line 1))) + (provide 'pp) ; so (require 'pp) works ;;; pp.el ends here diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el index aec438ed994..9be6ac649f3 100644 --- a/lisp/emacs-lisp/re-builder.el +++ b/lisp/emacs-lisp/re-builder.el @@ -274,8 +274,8 @@ Except for Lisp syntax this is the same as `reb-regexp'.") emacs-lisp-mode "RE Builder Lisp" "Major mode for interactively building symbolic Regular Expressions." ;; Pull in packages as needed - (cond ((memq reb-re-syntax '(sregex rx)) ; rx-to-string is autoloaded - (require 'rx))) ; require rx anyway + (when (eq reb-re-syntax 'rx) ; rx-to-string is autoloaded + (require 'rx)) ; require rx anyway (reb-mode-common)) (defvar reb-subexp-mode-map @@ -307,8 +307,8 @@ Except for Lisp syntax this is the same as `reb-regexp'.") (eq 'color (frame-parameter nil 'display-type))) (defsubst reb-lisp-syntax-p () - "Return non-nil if RE Builder uses a Lisp syntax." - (memq reb-re-syntax '(sregex rx))) + "Return non-nil if RE Builder uses `rx' syntax." + (eq reb-re-syntax 'rx)) (defmacro reb-target-binding (symbol) "Return binding for SYMBOL in the RE Builder target buffer." @@ -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. @@ -482,11 +483,11 @@ Optional argument SYNTAX must be specified if called non-interactively." (list (intern (completing-read (format-prompt "Select syntax" reb-re-syntax) - '(read string sregex rx) + '(read string rx) nil t nil nil (symbol-name reb-re-syntax) 'reb-change-syntax-hist)))) - (if (memq syntax '(read string sregex rx)) + (if (memq syntax '(read string rx)) (let ((buffer (get-buffer reb-buffer))) (setq reb-re-syntax syntax) (when buffer @@ -605,9 +606,9 @@ optional fourth argument FORCE is non-nil." (defun reb-cook-regexp (re) "Return RE after processing it according to `reb-re-syntax'." - (cond ((memq reb-re-syntax '(sregex rx)) - (rx-to-string (eval (car (read-from-string re))))) - (t re))) + (if (eq reb-re-syntax 'rx) + (rx-to-string (eval (car (read-from-string re)))) + re)) (defun reb-update-regexp () "Update the regexp for the target buffer. diff --git a/lisp/emacs-lisp/rmc.el b/lisp/emacs-lisp/rmc.el index 8abe570e64b..ed764f5350e 100644 --- a/lisp/emacs-lisp/rmc.el +++ b/lisp/emacs-lisp/rmc.el @@ -25,8 +25,101 @@ (require 'seq) +(defun rmc--add-key-description (elem) + (let* ((char (car elem)) + (name (cadr elem)) + (pos (seq-position name char)) + (desc (key-description (char-to-string char))) + (graphical-terminal + (display-supports-face-attributes-p + '(:underline t) (window-frame))) + (altered-name + (cond + ;; Not in the name string, or a special character. + ((or (not pos) + (member desc '("ESC" "TAB" "RET" "DEL" "SPC"))) + (format "%s %s" + (if graphical-terminal + (propertize desc 'face 'read-multiple-choice-face) + (propertize desc 'face 'help-key-binding)) + name)) + ;; The prompt character is in the name, so highlight + ;; it on graphical terminals. + (graphical-terminal + (setq name (copy-sequence name)) + (put-text-property pos (1+ pos) + 'face 'read-multiple-choice-face + name) + name) + ;; And put it in [bracket] on non-graphical terminals. + (t + (concat + (substring name 0 pos) + "[" + (upcase (substring name pos (1+ pos))) + "]" + (substring name (1+ pos))))))) + (cons char altered-name))) + +(defun rmc--show-help (prompt help-string show-help choices altered-names) + (let* ((buf-name (if (stringp show-help) + show-help + "*Multiple Choice Help*")) + (buf (get-buffer-create buf-name))) + (if (stringp help-string) + (with-help-window buf + (with-current-buffer buf + (insert help-string))) + (with-help-window buf + (with-current-buffer buf + (erase-buffer) + (pop-to-buffer buf) + (insert prompt "\n\n") + (let* ((columns (/ (window-width) 25)) + (fill-column 21) + (times 0) + (start (point))) + (dolist (elem choices) + (goto-char start) + (unless (zerop times) + (if (zerop (mod times columns)) + ;; Go to the next "line". + (goto-char (setq start (point-max))) + ;; Add padding. + (while (not (eobp)) + (end-of-line) + (insert (make-string (max (- (* (mod times columns) + (+ fill-column 4)) + (current-column)) + 0) + ?\s)) + (forward-line 1)))) + (setq times (1+ times)) + (let ((text + (with-temp-buffer + (insert (format + "%c: %s\n" + (car elem) + (cdr (assq (car elem) altered-names)))) + (fill-region (point-min) (point-max)) + (when (nth 2 elem) + (let ((start (point))) + (insert (nth 2 elem)) + (unless (bolp) + (insert "\n")) + (fill-region start (point-max)))) + (buffer-string)))) + (goto-char start) + (dolist (line (split-string text "\n")) + (end-of-line) + (if (bolp) + (insert line "\n") + (insert line)) + (forward-line 1)))))))) + buf)) + ;;;###autoload -(defun read-multiple-choice (prompt choices &optional help-string) +(defun read-multiple-choice (prompt choices &optional help-string show-help) "Ask user to select an entry from CHOICES, promting with PROMPT. This function allows to ask the user a multiple-choice question. @@ -42,6 +135,9 @@ the optional argument HELP-STRING. This argument is a string that should contain a more detailed description of all of the possible choices. `read-multiple-choice' will display that description in a help buffer if the user requests that. +If optional argument SHOW-HELP is non-nil, show the help screen +immediately, before any user input. If SHOW-HELP is a string, +use it as the name of the help buffer. This function translates user input into responses by consulting the bindings in `query-replace-map'; see the documentation of @@ -67,45 +163,19 @@ Usage example: \\='((?a \"always\") (?s \"session only\") (?n \"no\")))" - (let* ((altered-names nil) + (let* ((choices (if show-help choices (append choices '((?? "?"))))) + (altered-names (mapcar #'rmc--add-key-description choices)) (full-prompt (format "%s (%s): " prompt - (mapconcat - (lambda (elem) - (let* ((name (cadr elem)) - (pos (seq-position name (car elem))) - (altered-name - (cond - ;; Not in the name string. - ((not pos) - (format "[%c] %s" (car elem) name)) - ;; The prompt character is in the name, so highlight - ;; it on graphical terminals... - ((display-supports-face-attributes-p - '(:underline t) (window-frame)) - (setq name (copy-sequence name)) - (put-text-property pos (1+ pos) - 'face 'read-multiple-choice-face - name) - name) - ;; And put it in [bracket] on non-graphical terminals. - (t - (concat - (substring name 0 pos) - "[" - (upcase (substring name pos (1+ pos))) - "]" - (substring name (1+ pos))))))) - (push (cons (car elem) altered-name) - altered-names) - altered-name)) - (append choices '((?? "?"))) - ", "))) + (mapconcat (lambda (e) (cdr e)) altered-names ", "))) tchar buf wrong-char answer) (save-window-excursion (save-excursion + (if show-help + (setq buf (rmc--show-help prompt help-string show-help + choices altered-names))) (while (not tchar) (message "%s%s" (if wrong-char @@ -161,57 +231,8 @@ Usage example: tchar nil) (when wrong-char (ding)) - (setq buf (get-buffer-create "*Multiple Choice Help*")) - (if (stringp help-string) - (with-help-window buf - (with-current-buffer buf - (insert help-string))) - (with-help-window buf - (with-current-buffer buf - (erase-buffer) - (pop-to-buffer buf) - (insert prompt "\n\n") - (let* ((columns (/ (window-width) 25)) - (fill-column 21) - (times 0) - (start (point))) - (dolist (elem choices) - (goto-char start) - (unless (zerop times) - (if (zerop (mod times columns)) - ;; Go to the next "line". - (goto-char (setq start (point-max))) - ;; Add padding. - (while (not (eobp)) - (end-of-line) - (insert (make-string (max (- (* (mod times columns) - (+ fill-column 4)) - (current-column)) - 0) - ?\s)) - (forward-line 1)))) - (setq times (1+ times)) - (let ((text - (with-temp-buffer - (insert (format - "%c: %s\n" - (car elem) - (cdr (assq (car elem) altered-names)))) - (fill-region (point-min) (point-max)) - (when (nth 2 elem) - (let ((start (point))) - (insert (nth 2 elem)) - (unless (bolp) - (insert "\n")) - (fill-region start (point-max)))) - (buffer-string)))) - (goto-char start) - (dolist (line (split-string text "\n")) - (end-of-line) - (if (bolp) - (insert line "\n") - (insert line)) - (forward-line 1)))))))))))) + (setq buf (rmc--show-help prompt help-string show-help + choices altered-names)))))) (when (buffer-live-p buf) (kill-buffer buf)) (assq tchar choices))) diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el index e2a24e9949c..1fbe946a7f9 100644 --- a/lisp/emacs-lisp/shadow.el +++ b/lisp/emacs-lisp/shadow.el @@ -151,9 +151,6 @@ See the documentation for `list-load-path-shadows' for further information." ;; Return the list of shadowings. shadows)) -(define-obsolete-function-alias 'find-emacs-lisp-shadows - 'load-path-shadows-find "23.3") - ;; Return true if neither file exists, or if both exist and have identical ;; contents. (defun load-path-shadows-same-file-or-nonexistent (f1 f2) diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index 17ac3e471c0..b9e000cc05f 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -71,6 +71,7 @@ string, it'll be inserted as is, then the string will be `read', and then evaluated. There can be any number of :example/:result elements." + (declare (indent defun)) `(progn (setq shortdoc--groups (delq (assq ',group shortdoc--groups) shortdoc--groups)) @@ -195,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")) @@ -241,7 +249,14 @@ There can be any number of :example/:result elements." :eval (number-to-string 42)) "Data About Strings" (length - :eval (length "foo")) + :eval (length "foo") + :eval (length "avocado: 🥑")) + (string-width + :eval (string-width "foo") + :eval (string-width "avocado: 🥑")) + (string-pixel-width + :eval (string-pixel-width "foo") + :eval (string-pixel-width "avocado: 🥑")) (string-search :eval (string-search "bar" "foobarzot")) (assoc-string @@ -271,6 +286,9 @@ There can be any number of :example/:result elements." :eval (file-name-base "/tmp/foo.txt")) (file-relative-name :eval (file-relative-name "/tmp/foo" "/tmp")) + (file-name-split + :eval (file-name-split "/tmp/foo") + :eval (file-name-split "foo/bar")) (make-temp-name :eval (make-temp-name "/tmp/foo-")) (file-name-concat @@ -348,6 +366,9 @@ There can be any number of :example/:result elements." (file-newer-than-file-p :no-eval (file-newer-than-file-p "/tmp/foo" "/tmp/bar") :eg-result nil) + (file-has-changed-p + :no-eval (file-has-changed-p "/tmp/foo") + :eg-result t) (file-equal-p :no-eval (file-equal-p "/tmp/foo" "/tmp/bar") :eg-result nil) @@ -1206,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" #'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 "<separator-2>" 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. @@ -1369,14 +1423,12 @@ Example: (setq slist (cdr slist))) (setcdr slist (cons elem (cdr slist)))))) -(defvar shortdoc-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "n") 'shortdoc-next) - (define-key map (kbd "p") 'shortdoc-previous) - (define-key map (kbd "C-c C-n") 'shortdoc-next-section) - (define-key map (kbd "C-c C-p") 'shortdoc-previous-section) - map) - "Keymap for `shortdoc-mode'.") +(defvar-keymap shortdoc-mode-map + :doc "Keymap for `shortdoc-mode'." + "n" #'shortdoc-next + "p" #'shortdoc-previous + "C-c C-n" #'shortdoc-next-section + "C-c C-p" #'shortdoc-previous-section) (define-derived-mode shortdoc-mode special-mode "shortdoc" "Mode for shortdoc." diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 788cd0f34bf..b53245b9b5f 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -208,7 +208,9 @@ The variable list SPEC is the same as in `if-let'." (string= string "")) (defsubst string-join (strings &optional separator) - "Join all STRINGS using SEPARATOR." + "Join all STRINGS using SEPARATOR. +Optional argument SEPARATOR must be a string, a vector, or a list of +characters; nil stands for the empty string." (mapconcat #'identity strings separator)) (define-obsolete-function-alias 'string-reverse 'reverse "25.1") @@ -400,6 +402,114 @@ as the new values of the bound variables in the recursive invocation." (cl-labels ((,name ,fargs . ,body)) #',name) . ,aargs))) +(defmacro with-memoization (place &rest code) + "Return the value of CODE and stash it in PLACE. +If PLACE's value is non-nil, then don't bother evaluating CODE +and return the value found in PLACE instead." + (declare (indent 1) (debug (gv-place body))) + (gv-letplace (getter setter) place + `(or ,getter + ,(macroexp-let2 nil val (macroexp-progn code) + `(progn + ,(funcall setter val) + ,val))))) + +;;;###autoload +(defun ensure-empty-lines (&optional lines) + "Ensure that there are LINES number of empty lines before point. +If LINES is nil or omitted, ensure that there is a single empty +line before point. + +If called interactively, LINES is given by the prefix argument. + +If there are more than LINES empty lines before point, the number +of empty lines is reduced to LINES. + +If point is not at the beginning of a line, a newline character +is inserted before adjusting the number of empty lines." + (interactive "p") + (unless (bolp) + (insert "\n")) + (let ((lines (or lines 1)) + (start (save-excursion + (if (re-search-backward "[^\n]" nil t) + (+ (point) 2) + (point-min))))) + (cond + ((> (- (point) start) lines) + (delete-region (point) (- (point) (- (point) start lines)))) + ((< (- (point) start) lines) + (insert (make-string (- lines (- (point) start)) ?\n)))))) + +;;;###autoload +(defun string-pixel-width (string) + "Return the width of STRING in pixels." + (with-temp-buffer + (insert string) + (car (buffer-text-pixel-size nil nil t)))) + +;;;###autoload +(defun string-glyph-split (string) + "Split STRING into a list of strings representing separate glyphs. +This takes into account combining characters and grapheme clusters." + (let ((result nil) + (start 0) + comp) + (while (< start (length string)) + (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))) + (push (substring string start (1+ start)) result) + (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) diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 0ae355e5917..075fe836f6b 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -115,16 +115,25 @@ where: This should be either a function, or a list. If a list, each element has the form (ID [DESC1 ... DESCN]), where: + - ID is nil, or a Lisp object uniquely identifying this entry, which is used to keep the cursor on the \"same\" entry when rearranging the list. Comparison is done with `equal'. - Each DESC is a column descriptor, one for each column - specified in `tabulated-list-format'. A descriptor is either - a string, which is printed as-is, or a list (LABEL . PROPS), - which means to use `insert-text-button' to insert a text - button with label LABEL and button properties PROPS. - The string, or button label, must not contain any newline. + specified in `tabulated-list-format'. The descriptor DESC is + one of: + + - A string, which is printed as-is, and must not contain any + newlines. + + - An image descriptor (a list), which is used to insert an + image (see Info node `(elisp) Image Descriptors'). + + - A list (LABEL . PROPS), which means to use + `insert-text-button' to insert a text button with label + LABEL and button properties PROPS. LABEL must not contain + any newlines. If `tabulated-list-entries' is a function, it is called with no arguments and must return a list of the above form.") @@ -547,7 +556,9 @@ Return the column number after insertion." (props (nthcdr 3 format)) (pad-right (or (plist-get props :pad-right) 1)) (right-align (plist-get props :right-align)) - (label (if (stringp col-desc) col-desc (car col-desc))) + (label (cond ((stringp col-desc) col-desc) + ((eq (car col-desc) 'image) " ") + (t (car col-desc)))) (label-width (string-width label)) (help-echo (concat (car format) ": " label)) (opoint (point)) @@ -571,11 +582,15 @@ Return the column number after insertion." 'display `(space :align-to ,(+ x shift)))) (setq width (- width shift)) (setq x (+ x shift)))) - (if (stringp col-desc) - (insert (if (get-text-property 0 'help-echo label) - label - (propertize label 'help-echo help-echo))) - (apply 'insert-text-button label (cdr col-desc))) + (cond ((stringp col-desc) + (insert (if (get-text-property 0 'help-echo label) + label + (propertize label 'help-echo help-echo)))) + ((eq (car col-desc) 'image) + (insert (propertize " " + 'display col-desc + 'help-echo help-echo))) + ((apply 'insert-text-button label (cdr col-desc)))) (let ((next-x (+ x pad-right width))) ;; No need to append any spaces if this is the last column. (when not-last-col @@ -669,6 +684,10 @@ With a numeric prefix argument N, sort the Nth column. If the numeric prefix is -1, restore order the list was originally displayed in." (interactive "P") + (when (and n + (or (>= n (length tabulated-list-format)) + (< n -1))) + (user-error "Invalid column number")) (if (equal n -1) ;; Restore original order. (progn diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index 1ef4931b7be..c7d02cc7487 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -314,7 +314,7 @@ This function is called, by name, directly by the C code." (not (timer--idle-delay timer))) (setf (timer--time timer) (timer-next-integral-multiple-of-time - (current-time) (timer--repeat-delay timer)))) + nil (timer--repeat-delay timer)))) ;; Place it back on the timer-list before running ;; timer--function, so it can cancel-timer itself. (timer-activate timer t cell) @@ -351,19 +351,27 @@ This function is called, by name, directly by the C code." Repeat the action every REPEAT seconds, if REPEAT is non-nil. REPEAT may be an integer or floating point number. TIME should be one of: + - a string giving today's time like \"11:23pm\" (the acceptable formats are HHMM, H:MM, HH:MM, HHam, HHAM, HHpm, HHPM, HH:MMam, HH:MMAM, HH:MMpm, or HH:MMPM; a period `.' can be used instead of a colon `:' to separate the hour and minute parts); + - a string giving a relative time like \"90\" or \"2 hours 35 minutes\" (the acceptable forms are a number of seconds without units or some combination of values using units in `timer-duration-words'); + - nil, meaning now; + - a number of seconds from now; + - a value from `encode-time'; -- or t (with non-nil REPEAT) meaning the next integral - multiple of REPEAT. + +- or t (with non-nil REPEAT) meaning the next integral multiple + of REPEAT. This is handy when you want the function to run at + a certain \"round\" number. For instance, (run-at-time t 60 ...) + will run at 11:04:00, 11:05:00, etc. The action is to call FUNCTION with arguments ARGS. @@ -383,7 +391,7 @@ This function returns a timer object which you can use in ;; Special case: t means the next integral multiple of REPEAT. (when (and (eq time t) repeat) - (setq time (timer-next-integral-multiple-of-time (current-time) repeat)) + (setq time (timer-next-integral-multiple-of-time nil repeat)) (setf (timer--integral-multiple timer) t)) ;; Handle numbers as relative times in seconds. diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el index 36b275e2d3c..1d061364a03 100644 --- a/lisp/emacs-lisp/warnings.el +++ b/lisp/emacs-lisp/warnings.el @@ -307,7 +307,9 @@ entirely by setting `warning-suppress-types' or 'type 'warning-suppress-log-warning 'warning-type type)) (funcall newline) - (when (and warning-fill-prefix (not (string-search "\n" message))) + (when (and warning-fill-prefix + (not (string-search "\n" message)) + (not noninteractive)) (let ((fill-prefix warning-fill-prefix) (fill-column warning-fill-column)) (fill-region start (point)))) diff --git a/lisp/emulation/cua-base.el b/lisp/emulation/cua-base.el index 3976c1ea063..befcb423823 100644 --- a/lisp/emulation/cua-base.el +++ b/lisp/emulation/cua-base.el @@ -396,17 +396,17 @@ and after the region marked by the rectangle to search." (defcustom cua-rectangle-mark-key [(control return)] "Global key used to toggle the cua rectangle mark." - :set #'(lambda (symbol value) - (set symbol value) - (when (and (boundp 'cua--keymaps-initialized) - cua--keymaps-initialized) - (define-key cua-global-keymap value - #'cua-set-rectangle-mark) - (when (boundp 'cua--rectangle-keymap) - (define-key cua--rectangle-keymap value - #'cua-clear-rectangle-mark) - (define-key cua--region-keymap value - #'cua-toggle-rectangle-mark)))) + :set (lambda (symbol value) + (set symbol value) + (when (and (boundp 'cua--keymaps-initialized) + cua--keymaps-initialized) + (define-key cua-global-keymap value + #'cua-set-rectangle-mark) + (when (boundp 'cua--rectangle-keymap) + (define-key cua--rectangle-keymap value + #'cua-clear-rectangle-mark) + (define-key cua--region-keymap value + #'cua-toggle-rectangle-mark)))) :type 'key-sequence) (defcustom cua-rectangle-modifier-key 'meta @@ -699,6 +699,11 @@ Repeating prefix key when region is active works as a single prefix key." (interactive) (cua--prefix-override-replay 0)) +;; These aliases are so that we can look up the commands and find the +;; correct keys when generating menus. +(defalias 'cua-cut-handler #'cua--prefix-override-handler) +(defalias 'cua-copy-handler #'cua--prefix-override-handler) + (defun cua--prefix-repeat-handler () "Repeating prefix key when region is active works as a single prefix key." (interactive) @@ -1258,10 +1263,8 @@ If ARG is the atom `-', scroll upward by nearly full screen." (define-key cua--cua-keys-keymap [(meta v)] #'delete-selection-repeat-replace-region)) - (define-key cua--prefix-override-keymap [(control x)] - #'cua--prefix-override-handler) - (define-key cua--prefix-override-keymap [(control c)] - #'cua--prefix-override-handler) + (define-key cua--prefix-override-keymap [(control x)] #'cua-cut-handler) + (define-key cua--prefix-override-keymap [(control c)] #'cua-copy-handler) (define-key cua--prefix-repeat-keymap [(control x) (control x)] #'cua--prefix-repeat-handler) diff --git a/lisp/emulation/cua-rect.el b/lisp/emulation/cua-rect.el index 65ae2f192fa..7df45e705d3 100644 --- a/lisp/emulation/cua-rect.el +++ b/lisp/emulation/cua-rect.el @@ -486,10 +486,8 @@ Activates the region if needed. Only lasts until the region is deactivated." (cua--deactivate t)) (setq cua--last-rectangle nil) (mouse-set-point event) - ;; FIX ME -- need to calculate virtual column. - (cua-set-rectangle-mark) - (setq cua--buffer-and-point-before-command nil) - (setq cua--mouse-last-pos nil)) + (activate-mark) + (cua-rectangle-mark-mode)) (defun cua-mouse-save-then-kill-rectangle (event arg) "Expand rectangle to mouse click position and copy rectangle. diff --git a/lisp/emulation/viper-cmd.el b/lisp/emulation/viper-cmd.el index 9f3d515bc6d..849ad3d8241 100644 --- a/lisp/emulation/viper-cmd.el +++ b/lisp/emulation/viper-cmd.el @@ -35,9 +35,7 @@ (defvar viper--key-maps) (defvar viper--intercept-key-maps) (defvar iso-accents-mode) -(defvar quail-mode) (defvar quail-current-str) -(defvar mark-even-if-inactive) (defvar viper--init-message) (defvar viper-initial) (defvar undo-beg-posn) @@ -69,8 +67,7 @@ (nm-p (intern (concat snm "-p"))) (nms (intern (concat snm "s")))) `(defun ,nm-p (com) - (consp (viper-memq-char com ,nms) - )))) + (consp (memq com ,nms))))) ;; Variables for defining VI commands @@ -1035,23 +1032,23 @@ as a Meta key and any number of multiple escapes are allowed." cmd-info cmd-to-exec-at-end) (while (and cont - (viper-memq-char char - (list ?c ?d ?y ?! ?< ?> ?= ?# ?r ?R ?\" - viper-buffer-search-char))) + (memq char + (list ?c ?d ?y ?! ?< ?> ?= ?# ?r ?R ?\" + viper-buffer-search-char))) (if com ;; this means that we already have a command character, so we ;; construct a com list and exit while. however, if char is " ;; it is an error. (progn ;; new com is (CHAR . OLDCOM) - (if (viper-memq-char char '(?# ?\")) (user-error viper-ViperBell)) + (if (memq char '(?# ?\")) (user-error viper-ViperBell)) (setq com (cons char com)) (setq cont nil)) ;; If com is nil we set com as char, and read more. Again, if char is ;; ", we read the name of register and store it in viper-use-register. ;; if char is !, =, or #, a complete com is formed so we exit the while ;; loop. - (cond ((viper-memq-char char '(?! ?=)) + (cond ((memq char '(?! ?=)) (setq com char) (setq char (read-char)) (setq cont nil)) @@ -1091,7 +1088,7 @@ as a Meta key and any number of multiple escapes are allowed." `(key-binding (char-to-string ,char))))) ;; as com is non-nil, this means that we have a command to execute - (if (viper-memq-char (car com) '(?r ?R)) + (if (memq (car com) '(?r ?R)) ;; execute appropriate region command. (let ((char (car com)) (com (cdr com))) (setq prefix-arg (cons value com)) @@ -2314,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) @@ -2603,12 +2599,12 @@ On reaching beginning of line, stop and signal error." (let ((prev-char (viper-char-at-pos 'backward)) (saved-point (point))) ;; skip non-newline separators backward - (while (and (not (viper-memq-char prev-char '(nil \n))) + (while (and (not (memq prev-char '(nil \n))) (< lim (point)) ;; must be non-newline separator (if (eq viper-syntax-preference 'strict-vi) - (viper-memq-char prev-char '(?\ ?\t)) - (viper-memq-char (char-syntax prev-char) '(?\ ?-)))) + (memq prev-char '(?\ ?\t)) + (memq (char-syntax prev-char) '(?\ ?-)))) (viper-backward-char-carefully) (setq prev-char (viper-char-at-pos 'backward))) @@ -2622,12 +2618,12 @@ On reaching beginning of line, stop and signal error." ;; skip again, but make sure we don't overshoot the limit (if twice - (while (and (not (viper-memq-char prev-char '(nil \n))) + (while (and (not (memq prev-char '(nil \n))) (< lim (point)) ;; must be non-newline separator (if (eq viper-syntax-preference 'strict-vi) - (viper-memq-char prev-char '(?\ ?\t)) - (viper-memq-char (char-syntax prev-char) '(?\ ?-)))) + (memq prev-char '(?\ ?\t)) + (memq (char-syntax prev-char) '(?\ ?-)))) (viper-backward-char-carefully) (setq prev-char (viper-char-at-pos 'backward)))) @@ -2645,10 +2641,10 @@ On reaching beginning of line, stop and signal error." (viper-forward-word-kernel val) (if com (progn - (cond ((viper-char-equal com ?c) + (cond ((eq com ?c) (viper-separator-skipback-special 'twice viper-com-point)) ;; Yank words including the whitespace, but not newline - ((viper-char-equal com ?y) + ((eq com ?y) (viper-separator-skipback-special nil viper-com-point)) ((viper-dotable-command-p com) (viper-separator-skipback-special nil viper-com-point))) @@ -2666,10 +2662,10 @@ On reaching beginning of line, stop and signal error." (viper-skip-nonseparators 'forward) (viper-skip-separators t)) (if com (progn - (cond ((viper-char-equal com ?c) + (cond ((eq com ?c) (viper-separator-skipback-special 'twice viper-com-point)) ;; Yank words including the whitespace, but not newline - ((viper-char-equal com ?y) + ((eq com ?y) (viper-separator-skipback-special nil viper-com-point)) ((viper-dotable-command-p com) (viper-separator-skipback-special nil viper-com-point))) @@ -4714,15 +4710,15 @@ Please, specify your level now: ")) (defun viper-submit-report () "Submit bug report on Viper." (interactive) - (defvar viper-color-display-p) + (defvar x-display-color-p) (defvar viper-frame-parameters) (defvar viper-minibuffer-emacs-face) (defvar viper-minibuffer-vi-face) (defvar viper-minibuffer-insert-face) (let ((reporter-prompt-for-summary-p t) - (viper-color-display-p (if (viper-window-display-p) - (viper-color-display-p) - 'non-x)) + (x-display-color-p (if (viper-window-display-p) + (x-display-color-p) + 'non-x)) (viper-frame-parameters (frame-parameters (selected-frame))) (viper-minibuffer-emacs-face (if (viper-has-face-support-p) (facep @@ -4780,7 +4776,7 @@ Please, specify your level now: ")) 'viper-expert-level 'major-mode 'window-system - 'viper-color-display-p + 'x-display-color-p 'viper-frame-parameters 'viper-minibuffer-vi-face 'viper-minibuffer-insert-face diff --git a/lisp/emulation/viper-ex.el b/lisp/emulation/viper-ex.el index ef15779e1bf..85c8b87b9a1 100644 --- a/lisp/emulation/viper-ex.el +++ b/lisp/emulation/viper-ex.el @@ -25,7 +25,6 @@ ;;; Code: ;; Compiler pacifier -(defvar read-file-name-map) (defvar viper-use-register) (defvar viper-s-string) (defvar viper-shift-width) diff --git a/lisp/emulation/viper-init.el b/lisp/emulation/viper-init.el index fe3704841ac..368a5dc40a6 100644 --- a/lisp/emulation/viper-init.el +++ b/lisp/emulation/viper-init.el @@ -25,16 +25,12 @@ ;;; Code: ;; compiler pacifier -(defvar mark-even-if-inactive) -(defvar quail-mode) (defvar iso-accents-mode) (defvar viper-current-state) (defvar viper-version) (defvar viper-expert-level) (defvar current-input-method) (defvar default-input-method) -(defvar describe-current-input-method-function) -(defvar bar-cursor) (defvar cursor-type) ;; end pacifier @@ -48,12 +44,6 @@ (define-obsolete-function-alias 'viper-device-type #'window-system "27.1") -(defun viper-color-display-p () - (condition-case nil - (display-color-p) - (error nil))) - -;; 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))))) @@ -81,7 +71,7 @@ In all likelihood, you don't need to bother with this setting." (defun viper-has-face-support-p () (cond ((viper-window-display-p)) (viper-force-faces) - ((viper-color-display-p)) + ((x-display-color-p)) (t (memq window-system '(pc))))) diff --git a/lisp/emulation/viper-mous.el b/lisp/emulation/viper-mous.el index 02db39f1cb0..879d8edca6f 100644 --- a/lisp/emulation/viper-mous.el +++ b/lisp/emulation/viper-mous.el @@ -26,7 +26,6 @@ ;; compiler pacifier (defvar double-click-time) -(defvar mouse-track-multi-click-time) (defvar viper-search-start-marker) (defvar viper-local-search-start-marker) (defvar viper-search-history) @@ -76,8 +75,8 @@ or a triple-click." ;; remembers prefix argument to pass along to commands invoked by second ;; click. -;; This is needed because in Emacs (not XEmacs), assigning to prefix-arg -;; causes Emacs to count the second click as if it was a single click +;; This is needed because assigning to prefix-arg causes Emacs to +;; count the second click as if it was a single click (defvar viper-global-prefix-argument nil) @@ -199,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/emulation/viper-util.el b/lisp/emulation/viper-util.el index 0f6dceb13cf..0af54b37432 100644 --- a/lisp/emulation/viper-util.el +++ b/lisp/emulation/viper-util.el @@ -29,9 +29,6 @@ ;; Compiler pacifier (defvar viper-minibuffer-current-face) -(defvar viper-minibuffer-insert-face) -(defvar viper-minibuffer-vi-face) -(defvar viper-minibuffer-emacs-face) (defvar viper-replace-overlay-face) (defvar viper-fast-keyseq-timeout) (defvar ex-unix-type-shell) @@ -64,22 +61,8 @@ (define-obsolete-function-alias 'viper-iconify #'iconify-or-deiconify-frame "27.1") - -;; CHAR is supposed to be a char or an integer (positive or negative) -;; LIST is a list of chars, nil, and negative numbers -;; Check if CHAR is a member by trying to convert in characters, if necessary. -;; Introduced for compatibility with XEmacs, where integers are not the same as -;; chars. -(defun viper-memq-char (char list) - (cond ((and (integerp char) (>= char 0)) - (memq char list)) - ((memq char list)))) - -;; Check if char-or-int and char are the same as characters -(defun viper-char-equal (char-or-int char) - (cond ((and (integerp char-or-int) (>= char-or-int 0)) - (= char-or-int char)) - ((eq char-or-int char)))) +(define-obsolete-function-alias 'viper-memq-char #'memq "29.1") +(define-obsolete-function-alias 'viper-char-equal #'eq "29.1") ;; Like =, but accommodates null and also is t for eq-objects (defun viper= (char char1) @@ -88,8 +71,7 @@ (= char char1)) (t nil))) -(defsubst viper-color-display-p () - (x-display-color-p)) +(define-obsolete-function-alias 'viper-color-display-p #'x-display-color-p "29.1") (defun viper-get-cursor-color (&optional _frame) (cdr (assoc 'cursor-color (frame-parameters)))) @@ -97,9 +79,6 @@ (defmacro viper-frame-value (variable) "Return the value of VARIABLE local to the current frame, if there is one. Otherwise return the normal value." - ;; Frame-local variables are obsolete from Emacs 22.2 onwards, - ;; so we do it by hand instead. - ;; Buffer-local values take precedence over frame-local ones. `(if (local-variable-p ',variable) ,variable ;; Distinguish between no frame parameter and a frame parameter @@ -110,7 +89,7 @@ Otherwise return the normal value." ;; cursor colors (defun viper-change-cursor-color (new-color &optional frame) - (if (and (viper-window-display-p) (viper-color-display-p) + (if (and (viper-window-display-p) (x-display-color-p) (stringp new-color) (x-color-defined-p new-color) (not (string= new-color (viper-get-cursor-color)))) (modify-frame-parameters @@ -142,7 +121,7 @@ Otherwise return the normal value." ;; By default, saves current frame cursor color before changing viper state (defun viper-save-cursor-color (before-which-mode) - (if (and (viper-window-display-p) (viper-color-display-p)) + (if (and (viper-window-display-p) (x-display-color-p)) (let ((color (viper-get-cursor-color))) (if (and (stringp color) (x-color-defined-p color) ;; there is something fishy in that the color is not saved if @@ -1183,25 +1162,23 @@ This option is appropriate if you like Emacs-style words." (looking-at (concat "[" viper-strict-ALPHA-chars addl-chars "]")) (or ;; or one of the additional chars being asked to include - (viper-memq-char char (viper-string-to-list addl-chars)) + (memq char (viper-string-to-list addl-chars)) (and ;; not one of the excluded word chars (note: ;; viper-non-word-characters is a list) - (not (viper-memq-char char viper-non-word-characters)) + (not (memq char viper-non-word-characters)) ;; char of the Viper-word syntax class - (viper-memq-char (char-syntax char) - (viper-string-to-list viper-ALPHA-char-class)))))) - )) + (memq (char-syntax char) + (viper-string-to-list viper-ALPHA-char-class)))))))) (defun viper-looking-at-separator () (let ((char (char-after (point)))) (if char (if (eq viper-syntax-preference 'strict-vi) - (viper-memq-char char (viper-string-to-list viper-strict-SEP-chars)) + (memq char (viper-string-to-list viper-strict-SEP-chars)) (or (eq char ?\n) ; RET is always a separator in Vi - (viper-memq-char (char-syntax char) - (viper-string-to-list viper-SEP-char-class))))) - )) + (memq (char-syntax char) + (viper-string-to-list viper-SEP-char-class))))))) (defsubst viper-looking-at-alphasep (&optional addl-chars) (or (viper-looking-at-separator) (viper-looking-at-alpha addl-chars))) @@ -1327,8 +1304,7 @@ This option is appropriate if you like Emacs-style words." ;; of the excluded characters (if (and (eq syntax-of-char-looked-at ?w) (not negated-syntax)) - (not (viper-memq-char - char-looked-at viper-non-word-characters)) + (not (memq char-looked-at viper-non-word-characters)) t)) (funcall skip-syntax-func 1) 0) diff --git a/lisp/emulation/viper.el b/lisp/emulation/viper.el index e9c0fb5e24b..1ee53651264 100644 --- a/lisp/emulation/viper.el +++ b/lisp/emulation/viper.el @@ -304,7 +304,6 @@ ;; compiler pacifier (defvar mark-even-if-inactive) -(defvar quail-mode) (defvar viper-expert-level) (defvar viper-mode-string) (defvar viper-major-mode-modifier-list) diff --git a/lisp/epa-hook.el b/lisp/epa-hook.el index aa196851d4d..5b250af6d70 100644 --- a/lisp/epa-hook.el +++ b/lisp/epa-hook.el @@ -56,15 +56,15 @@ through Custom does that automatically." May either be a string or a list of strings.") (put 'epa-file-encrypt-to 'safe-local-variable - #'(lambda (val) - (or (stringp val) - (and (listp val) - (catch 'safe - (mapc (lambda (elt) - (unless (stringp elt) - (throw 'safe nil))) - val) - t))))) + (lambda (val) + (or (stringp val) + (and (listp val) + (catch 'safe + (mapc (lambda (elt) + (unless (stringp elt) + (throw 'safe nil))) + val) + t))))) (put 'epa-file-encrypt-to 'permanent-local t) diff --git a/lisp/epa-ks.el b/lisp/epa-ks.el index 35caa1a93c5..186b0ac9d1c 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 @@ -294,12 +295,12 @@ enough, since keyservers have strict timeout settings." :created (and (match-string 4) (not (string-empty-p (match-string 4))) - (seconds-to-time + (time-convert (string-to-number (match-string 4)))) :expires (and (match-string 5) (not (string-empty-p (match-string 5))) - (seconds-to-time + (time-convert (string-to-number (match-string 5)))) :flags (mapcar (lambda (flag) @@ -318,15 +319,11 @@ enough, since keyservers have strict timeout settings." :created (and (match-string 2) (not (string-empty-p (match-string 2))) - (decode-time (seconds-to-time - (string-to-number - (match-string 2))))) + (decode-time (string-to-number (match-string 2)))) :expires (and (match-string 3) (not (string-empty-p (match-string 3))) - (decode-time (seconds-to-time - (string-to-number - (match-string 3))))) + (decode-time (string-to-number (match-string 3)))) :flags (mapcar (lambda (flag) (cdr (assq flag '((?r revoked) diff --git a/lisp/epa.el b/lisp/epa.el index 57d355cb3e0..d9a3531af27 100644 --- a/lisp/epa.el +++ b/lisp/epa.el @@ -235,11 +235,6 @@ You should bind this variable with `let', but do not set it globally.") (define-key keymap "q" 'epa-exit-buffer) keymap)) -(defvar epa-info-mode-map - (let ((keymap (make-sparse-keymap))) - (define-key keymap "q" 'delete-window) - keymap)) - (defvar epa-exit-buffer-function #'quit-window) (defun epa--button-key-text (key) @@ -607,7 +602,11 @@ If SECRET is non-nil, list secret keys instead of public keys." (_ "Error while executing \"%s\":\n\n")) (epg-context-program context)) "\n\n" - (epg-context-error-output context))) + (epg-context-error-output context) + (if (string-search "Unexpected error" + (epg-context-error-output context)) + "\n(File possibly not an encrypted file, but is perhaps a key ring file?)\n" + ""))) (epa-info-mode) (goto-char (point-min))) (display-buffer buffer))))) @@ -648,7 +647,7 @@ If SECRET is non-nil, list secret keys instead of public keys." (setq input (file-name-sans-extension (expand-file-name input))) (expand-file-name (read-file-name - (concat "To file (default " (file-name-nondirectory input) ") ") + (format-prompt "To file" (file-name-nondirectory input)) (file-name-directory input) input))) @@ -1236,9 +1235,7 @@ If no one is selected, symmetric encryption will be performed. ") (list keys (expand-file-name (read-file-name - (concat "To file (default " - (file-name-nondirectory default-name) - ") ") + (format-prompt "To file" (file-name-nondirectory default-name)) (file-name-directory default-name) default-name))))) (let ((context (epg-make-context epa-protocol))) diff --git a/lisp/epg.el b/lisp/epg.el index ea7aa869a0f..3354eb2c1ed 100644 --- a/lisp/epg.el +++ b/lisp/epg.el @@ -334,6 +334,7 @@ callback data (if any)." (cl-defstruct (epg-key (:constructor nil) + (:copier epg--copy-key) (:constructor epg-make-key (owner-trust)) (:predicate nil)) (owner-trust nil :read-only t) @@ -1389,7 +1390,7 @@ NAME is either a string or a list of strings." (if (seq-find (lambda (user) (eq (epg-user-id-validity user) 'revoked)) (epg-key-user-id-list key)) - (let ((copy (copy-epg-key key))) + (let ((copy (epg--copy-key key))) (setf (epg-key-user-id-list copy) (seq-remove (lambda (user) (eq (epg-user-id-validity user) 'revoked)) diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index 140755fab51..69f63dfbc44 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -199,6 +199,11 @@ active, use the `erc-server-process-alive' function instead.") (defvar-local erc-server-reconnecting nil "Non-nil if the user requests an explicit reconnect, and the current IRC process is still alive.") +(make-obsolete-variable 'erc-server-reconnecting + "see `erc--server-reconnecting'" "29.1") + +(defvar-local erc--server-reconnecting nil + "Non-nil when reconnecting.") (defvar-local erc-server-timed-out nil "Non-nil if the IRC server failed to respond to a ping.") @@ -533,7 +538,8 @@ TLS (see `erc-session-client-certificate' for more details)." (with-current-buffer buffer (setq erc-server-process process) (setq erc-server-quitting nil) - (setq erc-server-reconnecting nil) + (setq erc-server-reconnecting nil + erc--server-reconnecting nil) (setq erc-server-timed-out nil) (setq erc-server-banned nil) (setq erc-server-error-occurred nil) @@ -616,36 +622,42 @@ Make sure you are in an ERC buffer when running this." (erc-log-irc-protocol line nil) (erc-parse-server-response process line))))))) -(define-inline erc-server-reconnect-p (event) +(defun erc--server-reconnect-p (event) + "Return non-nil when ERC should attempt to reconnect. +EVENT is the message received from the closed connection process." + (and erc-server-auto-reconnect + (not erc-server-banned) + ;; make sure we don't infinitely try to reconnect, unless the + ;; user wants that + (or (eq erc-server-reconnect-attempts t) + (and (integerp erc-server-reconnect-attempts) + (< erc-server-reconnect-count + erc-server-reconnect-attempts))) + (or erc-server-timed-out + (not (string-match "^deleted" event))) + ;; open-network-stream-nowait error for connection refused + (if (string-match "^failed with code 111" event) 'nonblocking t))) + +(defun erc-server-reconnect-p (event) "Return non-nil if ERC should attempt to reconnect automatically. EVENT is the message received from the closed connection process." - (inline-letevals (event) - (inline-quote - (or erc-server-reconnecting - (and erc-server-auto-reconnect - (not erc-server-banned) - ;; make sure we don't infinitely try to reconnect, unless the - ;; user wants that - (or (eq erc-server-reconnect-attempts t) - (and (integerp erc-server-reconnect-attempts) - (< erc-server-reconnect-count - erc-server-reconnect-attempts))) - (or erc-server-timed-out - (not (string-match "^deleted" ,event))) - ;; open-network-stream-nowait error for connection refused - (if (string-match "^failed with code 111" ,event) 'nonblocking t)))))) + (declare (obsolete "see `erc--server-reconnect-p'" "29.1")) + (or (with-suppressed-warnings ((obsolete erc-server-reconnecting)) + erc-server-reconnecting) + (erc--server-reconnect-p event))) (defun erc-process-sentinel-2 (event buffer) "Called when `erc-process-sentinel-1' has detected an unexpected disconnect." (if (not (buffer-live-p buffer)) (erc-update-mode-line) (with-current-buffer buffer - (let ((reconnect-p (erc-server-reconnect-p event)) message delay) + (let ((reconnect-p (erc--server-reconnect-p event)) message delay) (setq message (if reconnect-p 'disconnected 'disconnected-noreconnect)) (erc-display-message nil 'error (current-buffer) message) (if (not reconnect-p) ;; terminate, do not reconnect (progn + (setq erc--server-reconnecting nil) (erc-display-message nil 'error (current-buffer) 'terminated ?e event) ;; Update mode line indicators @@ -654,7 +666,8 @@ EVENT is the message received from the closed connection process." ;; reconnect (condition-case nil (progn - (setq erc-server-reconnecting nil + (setq erc-server-reconnecting nil + erc--server-reconnecting t erc-server-reconnect-count (1+ erc-server-reconnect-count)) (setq delay erc-server-reconnect-timeout) (run-at-time delay nil @@ -1169,7 +1182,8 @@ Would expand to: \(fn (NAME &rest ALIASES) &optional EXTRA-FN-DOC EXTRA-VAR-DOC &rest FN-BODY)" (declare (debug (&define [&name "erc-response-handler@" (symbolp &rest symbolp)] - &optional sexp sexp def-body))) + &optional sexp sexp def-body)) + (indent defun)) (if (numberp name) (setq name (intern (format "%03i" name)))) (setq aliases (mapcar (lambda (a) (if (numberp a) diff --git a/lisp/erc/erc-compat.el b/lisp/erc/erc-compat.el index 6b1da2f9054..9bbc1f6a0d1 100644 --- a/lisp/erc/erc-compat.el +++ b/lisp/erc/erc-compat.el @@ -27,8 +27,6 @@ ;;; Code: -(require 'format-spec) - ;;;###autoload(autoload 'erc-define-minor-mode "erc-compat") (define-obsolete-function-alias 'erc-define-minor-mode #'define-minor-mode "28.1") diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el index db278a1275c..f27425ac8a1 100644 --- a/lisp/erc/erc-dcc.el +++ b/lisp/erc/erc-dcc.el @@ -1,7 +1,6 @@ ;;; erc-dcc.el --- CTCP DCC module for ERC -*- lexical-binding: t; -*- -;; Copyright (C) 1993-1995, 1998, 2002-2004, 2006-2021 Free Software -;; Foundation, Inc. +;; Copyright (C) 1993-2021 Free Software Foundation, Inc. ;; Author: Ben A. Mesander <ben@gnu.ai.mit.edu> ;; Noah Friedman <friedman@prep.ai.mit.edu> @@ -183,9 +182,7 @@ compared with `erc-nick-equal-p' which is IRC case-insensitive." (let ((prop (car prem)) (val (cadr prem))) (setq prem (cddr prem) - ;; plist-member is a predicate in xemacs - test (and (plist-member elt prop) - (plist-get elt prop))) + test (cadr (plist-member elt prop))) ;; if the property exists and is equal, we continue, else, try the ;; next element of the list (or (and (eq prop :nick) (if (>= emacs-major-version 28) diff --git a/lisp/erc/erc-goodies.el b/lisp/erc/erc-goodies.el index fc9a8d39ef4..683ac2d37c5 100644 --- a/lisp/erc/erc-goodies.el +++ b/lisp/erc/erc-goodies.el @@ -137,7 +137,7 @@ Put this function on `erc-insert-post-hook' and/or `erc-send-post-hook'." (goto-char (point-max)))) (defun erc-move-to-prompt-setup () - "Initialize the move-to-prompt module for XEmacs." + "Initialize the move-to-prompt module." (add-hook 'pre-command-hook #'erc-move-to-prompt nil t)) ;;; Keep place in unvisited channels diff --git a/lisp/erc/erc-imenu.el b/lisp/erc/erc-imenu.el index dcf6db7407a..522bc805f8d 100644 --- a/lisp/erc/erc-imenu.el +++ b/lisp/erc/erc-imenu.el @@ -1,7 +1,6 @@ ;;; erc-imenu.el --- Imenu support for ERC -*- lexical-binding: t; -*- -;; Copyright (C) 2001-2002, 2004, 2006-2021 Free Software Foundation, -;; Inc. +;; Copyright (C) 2001-2021 Free Software Foundation, Inc. ;; Author: Mario Lang <mlang@delysid.org> ;; Maintainer: Amin Bandali <bandali@gnu.org> diff --git a/lisp/erc/erc-replace.el b/lisp/erc/erc-replace.el index 90c0ee6f8a4..b2e9047ce77 100644 --- a/lisp/erc/erc-replace.el +++ b/lisp/erc/erc-replace.el @@ -1,7 +1,6 @@ ;;; erc-replace.el --- wash and massage messages inserted into the buffer -*- lexical-binding: t; -*- -;; Copyright (C) 2001-2002, 2004, 2006-2021 Free Software Foundation, -;; Inc. +;; Copyright (C) 2001-2021 Free Software Foundation, Inc. ;; Author: Andreas Fuchs <asf@void.at> ;; Maintainer: Amin Bandali <bandali@gnu.org> diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 885d311cf38..df6c3c09d90 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -12,7 +12,7 @@ ;; David Edmondson (dme@dme.org) ;; Michael Olson (mwolson@gnu.org) ;; Kelvin White (kwhite@gnu.org) -;; Version: 5.4 +;; Version: 5.4.1 ;; Package-Requires: ((emacs "27.1")) ;; Keywords: IRC, chat, client, Internet ;; URL: https://www.gnu.org/software/emacs/erc.html @@ -69,7 +69,7 @@ (require 'iso8601) (eval-when-compile (require 'subr-x)) -(defconst erc-version "5.4" +(defconst erc-version "5.4.1" "This version of ERC.") (defvar erc-official-location @@ -83,7 +83,8 @@ 'customize-package-emacs-version-alist '(ERC ("5.2" . "22.1") ("5.3" . "23.1") - ("5.4" . "28.1"))) + ("5.4" . "28.1") + ("5.4.1" . "29.1"))) (defgroup erc nil "Emacs Internet Relay Chat client." @@ -871,8 +872,8 @@ See `erc-server-flood-margin' for other flood-related parameters.") ;; Script parameters (defcustom erc-startup-file-list - (list (concat user-emacs-directory ".ercrc.el") - (concat user-emacs-directory ".ercrc") + (list (locate-user-emacs-file ".ercrc.el") + (locate-user-emacs-file ".ercrc") "~/.ercrc.el" "~/.ercrc" ".ercrc.el" ".ercrc") "List of files to try for a startup script. The first existent and readable one will get executed. @@ -1291,7 +1292,7 @@ Example: #\\='erc-replace-insert)) ((remove-hook \\='erc-insert-modify-hook #\\='erc-replace-insert)))" - (declare (doc-string 3)) + (declare (doc-string 3) (indent defun)) (let* ((sn (symbol-name name)) (mode (intern (format "erc-%s-mode" (downcase sn)))) (group (intern (format "erc-%s" (downcase sn)))) @@ -1478,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) @@ -2403,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)) @@ -2816,20 +2819,17 @@ present." (let ((prop-val (erc-get-parsed-vector position))) (and prop-val (member (erc-response.command prop-val) list)))) -(defvar-local erc-send-input-line-function 'erc-send-input-line) +(defvar-local erc-send-input-line-function 'erc-send-input-line + "Function for sending lines lacking a leading user command. +When a line typed into a buffer contains an explicit command, like /msg, +a corresponding handler (here, erc-cmd-MSG) is called. But lines typed +into a channel or query buffer already have an implicit target and +command (PRIVMSG). This function is called on such occasions and also +for special purposes (see erc-dcc.el).") (defun erc-send-input-line (target line &optional force) - "Send LINE to TARGET. - -See also `erc-server-send'." - (setq line (format "PRIVMSG %s :%s" - target - ;; If the line is empty, we still want to - ;; send it - i.e. an empty pasted line. - (if (string= line "\n") - " \n" - line))) - (erc-server-send line force target)) + "Send LINE to TARGET." + (erc-message "PRIVMSG" (concat target " " line) force)) (defun erc-get-arglist (fun) "Return the argument list of a function without the parens." @@ -2967,7 +2967,7 @@ Commands for which no erc-cmd-xxx exists, are tunneled through this function. LINE is sent to the server verbatim, and therefore has to contain the command itself as well." (erc-log (format "cmd: DEFAULT: %s" line)) - (erc-server-send (substring line 1)) + (erc-server-send (string-trim-right (substring line 1) "[\r\n]")) t) (defvar erc--read-time-period-history nil) @@ -3608,11 +3608,13 @@ other people should be displayed." (defun erc-cmd-QUERY (&optional user) "Open a query with USER. -The type of query window/frame/etc will depend on the value of -`erc-query-display'. - -If USER is omitted, close the current query buffer if one exists -- except this is broken now ;-)" +How the query is displayed (in a new window, frame, etc.) depends +on the value of `erc-query-display'." + ;; FIXME: The doc string used to say at the end: + ;; "If USER is omitted, close the current query buffer if one exists + ;; - except this is broken now ;-)" + ;; Does it make sense to have that functionality? What's wrong with + ;; `kill-buffer'? If it makes sense, re-add it. -- SK @ 2021-11-11 (interactive (list (read-string "Start a query with: "))) (let ((session-buffer (erc-server-buffer)) @@ -3754,13 +3756,17 @@ the message given by REASON." (setq buffer (current-buffer))) (with-current-buffer buffer (setq erc-server-quitting nil) - (setq erc-server-reconnecting t) + (with-suppressed-warnings ((obsolete erc-server-reconnecting)) + (setq erc-server-reconnecting t)) + (setq erc--server-reconnecting t) (setq erc-server-reconnect-count 0) (setq process (get-buffer-process (erc-server-buffer))) (if process (delete-process process) (erc-server-reconnect)) - (setq erc-server-reconnecting nil))) + (with-suppressed-warnings ((obsolete erc-server-reconnecting)) + (setq erc-server-reconnecting nil)) + (setq erc--server-reconnecting nil))) t) (put 'erc-cmd-RECONNECT 'process-not-needed t) diff --git a/lisp/eshell/em-banner.el b/lisp/eshell/em-banner.el index 034fa059b16..cebb030deda 100644 --- a/lisp/eshell/em-banner.el +++ b/lisp/eshell/em-banner.el @@ -61,10 +61,9 @@ modules may have a simple template to begin with." "The banner message to be displayed when Eshell is loaded. This can be any sexp, and should end with at least two newlines." :type 'sexp + :risky t :group 'eshell-banner) -(put 'eshell-banner-message 'risky-local-variable t) - (defcustom eshell-banner-load-hook nil "A list of functions to run when `eshell-banner' is loaded." :version "24.1" ; removed eshell-banner-initialize diff --git a/lisp/eshell/em-cmpl.el b/lisp/eshell/em-cmpl.el index 96ec031fba6..0b19d1be698 100644 --- a/lisp/eshell/em-cmpl.el +++ b/lisp/eshell/em-cmpl.el @@ -226,19 +226,17 @@ to writing a completion function." (let ((completion-at-point-functions '(elisp-completion-at-point))) (completion-at-point))) -(defvar eshell-cmpl-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [(control ?i)] #'completion-at-point) - ;; jww (1999-10-19): Will this work on anything but X? - (define-key map [backtab] #'pcomplete-reverse) - (define-key map [(meta ??)] #'completion-help-at-point) - (define-key map [(meta control ?i)] #'eshell-complete-lisp-symbol) - ;; C-c prefix: - (define-key map (kbd "C-c M-h") #'eshell-completion-help) - (define-key map (kbd "C-c TAB") #'pcomplete-expand-and-complete) - (define-key map (kbd "C-c C-i") #'pcomplete-expand-and-complete) - (define-key map (kbd "C-c SPC") #'pcomplete-expand) - map)) +(defvar-keymap eshell-cmpl-mode-map + "C-i" #'completion-at-point + ;; jww (1999-10-19): Will this work on anything but X? + "<backtab>" #'pcomplete-reverse + "M-?" #'completion-help-at-point + "C-M-i" #'eshell-complete-lisp-symbol + ;; C-c prefix: + "C-c M-h" #'eshell-completion-help + "C-c TAB" #'pcomplete-expand-and-complete + "C-c C-i" #'pcomplete-expand-and-complete + "C-c SPC" #'pcomplete-expand) (define-minor-mode eshell-cmpl-mode "Minor mode that provides a keymap when `eshell-cmpl' active. diff --git a/lisp/eshell/em-hist.el b/lisp/eshell/em-hist.el index aa158fa24cc..ea9b820bcd0 100644 --- a/lisp/eshell/em-hist.el +++ b/lisp/eshell/em-hist.el @@ -125,16 +125,34 @@ the input history list. Default is to save anything that isn't all whitespace." :type '(radio (function-item eshell-input-filter-default) (function-item eshell-input-filter-initial-space) - (function :tag "Other function"))) - -(put 'eshell-input-filter 'risky-local-variable t) + (function :tag "Other function")) + :risky t) + +(defun eshell-hist--update-keymap (symbol value) + "Update `eshell-hist-mode-map' for `eshell-hist-match-partial'." + ;; Don't try to set this before it is bound. See below. + (when (and (boundp 'eshell-hist-mode-map) + (eq symbol 'eshell-hist-match-partial)) + (dolist (keyb + (if value + `(("M-p" . ,#'eshell-previous-matching-input-from-input) + ("M-n" . ,#'eshell-next-matching-input-from-input) + ("C-c M-p" . ,#'eshell-previous-input) + ("C-c M-n" . ,#'eshell-next-input)) + `(("M-p" . ,#'eshell-previous-input) + ("M-n" . ,#'eshell-next-input) + ("C-c M-p" . ,#'eshell-previous-matching-input-from-input) + ("C-c M-n" . ,#'eshell-next-matching-input-from-input)))) + (keymap-set eshell-hist-mode-map (car keyb) (cdr keyb)))) + (set-default symbol value)) (defcustom eshell-hist-match-partial t "If non-nil, movement through history is constrained by current input. -Otherwise, typing <M-p> and <M-n> will always go to the next history +Otherwise, typing \\`M-p' and \\`M-n' will always go to the next history element, regardless of any text on the command line. In that case, -<C-c M-r> and <C-c M-s> still offer that functionality." - :type 'boolean) +\\`C-c M-r' and \\`C-c M-s' still offer that functionality." + :type 'boolean + :set 'eshell-hist--update-keymap) (defcustom eshell-hist-move-to-end t "If non-nil, move to the end of the buffer before cycling history." @@ -180,43 +198,31 @@ element, regardless of any text on the command line. In that case, (defvar eshell-matching-input-from-input-string "") (defvar eshell-save-history-index nil) -(defvar eshell-isearch-map - (let ((map (copy-keymap isearch-mode-map))) - (define-key map [(control ?m)] 'eshell-isearch-return) - (define-key map [(control ?r)] 'eshell-isearch-repeat-backward) - (define-key map [(control ?s)] 'eshell-isearch-repeat-forward) - (define-key map [(control ?g)] 'eshell-isearch-abort) - (define-key map [backspace] 'eshell-isearch-delete-char) - (define-key map [delete] 'eshell-isearch-delete-char) - (define-key map "\C-c\C-c" 'eshell-isearch-cancel) - map) - "Keymap used in isearch in Eshell.") - -(defvar eshell-hist-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [up] #'eshell-previous-matching-input-from-input) - (define-key map [down] #'eshell-next-matching-input-from-input) - (define-key map [(control up)] #'eshell-previous-input) - (define-key map [(control down)] #'eshell-next-input) - (define-key map [(meta ?r)] #'eshell-previous-matching-input) - (define-key map [(meta ?s)] #'eshell-next-matching-input) - (define-key map (kbd "C-c M-r") #'eshell-previous-matching-input-from-input) - (define-key map (kbd "C-c M-s") #'eshell-next-matching-input-from-input) - ;; FIXME: Relies on `eshell-hist-match-partial' being set _before_ - ;; em-hist is loaded and won't respect changes. - (if eshell-hist-match-partial - (progn - (define-key map [(meta ?p)] 'eshell-previous-matching-input-from-input) - (define-key map [(meta ?n)] 'eshell-next-matching-input-from-input) - (define-key map (kbd "C-c M-p") #'eshell-previous-input) - (define-key map (kbd "C-c M-n") #'eshell-next-input)) - (define-key map [(meta ?p)] #'eshell-previous-input) - (define-key map [(meta ?n)] #'eshell-next-input) - (define-key map (kbd "C-c M-p") #'eshell-previous-matching-input-from-input) - (define-key map (kbd "C-c M-n") #'eshell-next-matching-input-from-input)) - (define-key map (kbd "C-c C-l") #'eshell-list-history) - (define-key map (kbd "C-c C-x") #'eshell-get-next-from-history) - map)) +(defvar-keymap eshell-isearch-map + :doc "Keymap used in isearch in Eshell." + :parent isearch-mode-map + "C-m" #'eshell-isearch-return + "C-r" #'eshell-isearch-repeat-backward + "C-s" #'eshell-isearch-repeat-forward + "C-g" #'eshell-isearch-abort + "<backspace>" #'eshell-isearch-delete-char + "<delete>" #'eshell-isearch-delete-char + "C-c C-c" #'eshell-isearch-cancel) + +(defvar-keymap eshell-hist-mode-map + "<up>" #'eshell-previous-matching-input-from-input + "<down>" #'eshell-next-matching-input-from-input + "C-<up>" #'eshell-previous-input + "C-<down>" #'eshell-next-input + "M-r" #'eshell-previous-matching-input + "M-s" #'eshell-next-matching-input + "C-c M-r" #'eshell-previous-matching-input-from-input + "C-c M-s" #'eshell-next-matching-input-from-input + "C-c C-l" #'eshell-list-history + "C-c C-x" #'eshell-get-next-from-history) +;; Update `eshell-hist-mode-map' for `eshell-hist-match-partial'. +(eshell-hist--update-keymap 'eshell-hist-match-partial + eshell-hist-match-partial) (defvar eshell-rebind-keys-alist) diff --git a/lisp/eshell/em-pred.el b/lisp/eshell/em-pred.el index 75a803d3ad4..41afcc3dce4 100644 --- a/lisp/eshell/em-pred.el +++ b/lisp/eshell/em-pred.el @@ -107,9 +107,8 @@ ordinary strings." The format of each entry is (CHAR . PREDICATE-FUNC-SEXP)" - :type '(repeat (cons character sexp))) - -(put 'eshell-predicate-alist 'risky-local-variable t) + :type '(repeat (cons character sexp)) + :risky t) (defcustom eshell-modifier-alist '((?E . (lambda (lst) @@ -144,9 +143,8 @@ The format of each entry is The format of each entry is (CHAR ENTRYWISE-P MODIFIER-FUNC-SEXP)" - :type '(repeat (cons character sexp))) - -(put 'eshell-modifier-alist 'risky-local-variable t) + :type '(repeat (cons character sexp)) + :risky t) (defvar eshell-predicate-help-string "Eshell predicate quick reference: @@ -225,11 +223,9 @@ FOR LISTS OF ARGUMENTS: EXAMPLES: *.c(:o) sorted list of .c files") -(defvar eshell-pred-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c M-q") #'eshell-display-predicate-help) - (define-key map (kbd "C-c M-m") #'eshell-display-modifier-help) - map)) +(defvar-keymap eshell-pred-mode-map + "C-c M-q" #'eshell-display-predicate-help + "C-c M-m" #'eshell-display-modifier-help) ;;; Functions: diff --git a/lisp/eshell/em-prompt.el b/lisp/eshell/em-prompt.el index aa96166087a..6a4c05d34f8 100644 --- a/lisp/eshell/em-prompt.el +++ b/lisp/eshell/em-prompt.el @@ -96,11 +96,9 @@ arriving, or after." :options '(eshell-show-maximum-output) :group 'eshell-prompt) -(defvar eshell-prompt-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c C-n") #'eshell-next-prompt) - (define-key map (kbd "C-c C-p") #'eshell-previous-prompt) - map)) +(defvar-keymap eshell-prompt-mode-map + "C-c C-n" #'eshell-next-prompt + "C-c C-p" #'eshell-previous-prompt) ;;; Functions: diff --git a/lisp/eshell/em-rebind.el b/lisp/eshell/em-rebind.el index d70444ea109..d24cfb3f429 100644 --- a/lisp/eshell/em-rebind.el +++ b/lisp/eshell/em-rebind.el @@ -136,10 +136,8 @@ This is default behavior of shells like bash." :type '(repeat function) :group 'eshell-rebind) -(defvar eshell-rebind-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c M-l") #'eshell-lock-local-map) - map)) +(defvar-keymap eshell-rebind-mode-map + "C-c M-l" #'eshell-lock-local-map) ;; Internal Variables: diff --git a/lisp/eshell/esh-arg.el b/lisp/eshell/esh-arg.el index 1990c0cfa55..907625a554d 100644 --- a/lisp/eshell/esh-arg.el +++ b/lisp/eshell/esh-arg.el @@ -152,10 +152,8 @@ treated as a literal character." :type 'hook :group 'eshell-arg) -(defvar eshell-arg-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c M-b") #'eshell-insert-buffer-name) - map)) +(defvar-keymap eshell-arg-mode-map + "C-c M-b" #'eshell-insert-buffer-name) ;;; Functions: diff --git a/lisp/eshell/esh-cmd.el b/lisp/eshell/esh-cmd.el index 213b7ab2893..1ddcc50f6fd 100644 --- a/lisp/eshell/esh-cmd.el +++ b/lisp/eshell/esh-cmd.el @@ -258,9 +258,8 @@ the command." (default-directory default-directory) (process-environment (eshell-copy-environment))) "A list of `let' bindings for subcommand environments." - :type 'sexp) - -(put 'risky-local-variable 'eshell-subcommand-bindings t) + :type 'sexp + :risky t) (defvar eshell-ensure-newline-p nil "If non-nil, ensure that a newline is emitted after a Lisp form. diff --git a/lisp/eshell/esh-io.el b/lisp/eshell/esh-io.el index c2471912ab8..205275154b8 100644 --- a/lisp/eshell/esh-io.el +++ b/lisp/eshell/esh-io.el @@ -147,10 +147,9 @@ not be added to this variable." function (choice (const :tag "Func returns output-func" t) (const :tag "Func is output-func" nil)))) + :risky t :group 'eshell-io) -(put 'eshell-virtual-targets 'risky-local-variable t) - ;;; Internal Variables: (defvar eshell-current-handles nil) diff --git a/lisp/eshell/esh-mode.el b/lisp/eshell/esh-mode.el index 8e6506c301c..7d176f4ea07 100644 --- a/lisp/eshell/esh-mode.el +++ b/lisp/eshell/esh-mode.el @@ -260,31 +260,28 @@ This is used by `eshell-watch-for-password-prompt'." (standard-syntax-table)) st)) -(defvar eshell-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [(control ?c)] 'eshell-command-map) - (define-key map "\r" #'eshell-send-input) - (define-key map "\M-\r" #'eshell-queue-input) - (define-key map [(meta control ?l)] #'eshell-show-output) - (define-key map [(control ?a)] #'eshell-bol) - map)) - -(defvar eshell-command-map - (let ((map (define-prefix-command 'eshell-command-map))) - (define-key map [(meta ?o)] #'eshell-mark-output) - (define-key map [(meta ?d)] #'eshell-toggle-direct-send) - (define-key map [(control ?a)] #'eshell-bol) - (define-key map [(control ?b)] #'eshell-backward-argument) - (define-key map [(control ?e)] #'eshell-show-maximum-output) - (define-key map [(control ?f)] #'eshell-forward-argument) - (define-key map [(control ?m)] #'eshell-copy-old-input) - (define-key map [(control ?o)] #'eshell-kill-output) - (define-key map [(control ?r)] #'eshell-show-output) - (define-key map [(control ?t)] #'eshell-truncate-buffer) - (define-key map [(control ?u)] #'eshell-kill-input) - (define-key map [(control ?w)] #'backward-kill-word) - (define-key map [(control ?y)] #'eshell-repeat-argument) - map)) +(defvar-keymap eshell-mode-map + "C-c" 'eshell-command-map + "RET" #'eshell-send-input + "M-RET" #'eshell-queue-input + "C-M-l" #'eshell-show-output + "C-a" #'eshell-bol) + +(defvar-keymap eshell-command-map + :prefix 'eshell-command-map + "M-o" #'eshell-mark-output + "M-d" #'eshell-toggle-direct-send + "C-a" #'eshell-bol + "C-b" #'eshell-backward-argument + "C-e" #'eshell-show-maximum-output + "C-f" #'eshell-forward-argument + "C-m" #'eshell-copy-old-input + "C-o" #'eshell-kill-output + "C-r" #'eshell-show-output + "C-t" #'eshell-truncate-buffer + "C-u" #'eshell-kill-input + "C-w" #'backward-kill-word + "C-y" #'eshell-repeat-argument) ;;; User Functions: @@ -308,7 +305,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)))) @@ -616,6 +613,14 @@ newline." (and eshell-send-direct-to-subprocesses proc-running-p)) (insert-before-markers-and-inherit ?\n)) + ;; Delete and reinsert input. This seems like a no-op, except + ;; for the resulting entries in the undo list: undoing this + ;; insertion will delete the region, moving the process mark + ;; back to its original position. + (let ((text (buffer-substring eshell-last-output-end (point))) + (inhibit-read-only t)) + (delete-region eshell-last-output-end (point)) + (insert text)) (if proc-running-p (progn (eshell-update-markers eshell-last-output-end) @@ -939,7 +944,14 @@ This function could be in the list `eshell-output-filter-functions'." (beginning-of-line) (if (re-search-forward eshell-password-prompt-regexp eshell-last-output-end t) - (eshell-send-invisible)))))) + ;; Use `run-at-time' in order not to pause execution of + ;; the process filter with a minibuffer + (run-at-time + 0 nil + (lambda (current-buf) + (with-current-buffer current-buf + (eshell-send-invisible))) + (current-buffer))))))) (custom-add-option 'eshell-output-filter-functions 'eshell-watch-for-password-prompt) diff --git a/lisp/eshell/esh-proc.el b/lisp/eshell/esh-proc.el index 7a0b26a0658..75f3872d755 100644 --- a/lisp/eshell/esh-proc.el +++ b/lisp/eshell/esh-proc.el @@ -101,15 +101,13 @@ information, for example." (defvar eshell-process-list nil "A list of the current status of subprocesses.") -(defvar eshell-proc-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c M-i") #'eshell-insert-process) - (define-key map (kbd "C-c C-c") #'eshell-interrupt-process) - (define-key map (kbd "C-c C-k") #'eshell-kill-process) - (define-key map (kbd "C-c C-d") #'eshell-send-eof-to-process) - (define-key map (kbd "C-c C-s") #'list-processes) - (define-key map (kbd "C-c C-\\") #'eshell-quit-process) - map)) +(defvar-keymap eshell-proc-mode-map + "C-c M-i" #'eshell-insert-process + "C-c C-c" #'eshell-interrupt-process + "C-c C-k" #'eshell-kill-process + "C-c C-d" #'eshell-send-eof-to-process + "C-c C-s" #'list-processes + "C-c C-\\" #'eshell-quit-process) ;;; Functions: diff --git a/lisp/eshell/esh-util.el b/lisp/eshell/esh-util.el index 72de6b13e2e..0eef45e0efb 100644 --- a/lisp/eshell/esh-util.el +++ b/lisp/eshell/esh-util.el @@ -63,11 +63,11 @@ has no effect." Setting this to nil is offered as an aid to debugging only." :type 'boolean) -(defcustom eshell-private-file-modes 384 ; umask 177 +(defcustom eshell-private-file-modes #o600 ; umask 177 "The file-modes value to use for creating \"private\" files." :type 'integer) -(defcustom eshell-private-directory-modes 448 ; umask 077 +(defcustom eshell-private-directory-modes #o700 ; umask 077 "The file-modes value to use for creating \"private\" directories." :type 'integer) diff --git a/lisp/eshell/esh-var.el b/lisp/eshell/esh-var.el index fa9853ae00a..1c5a2f28cb7 100644 --- a/lisp/eshell/esh-var.el +++ b/lisp/eshell/esh-var.el @@ -205,14 +205,11 @@ Additionally, each member may specify if it should be copied to the environment of created subprocesses." :type '(repeat (list string sexp (choice (const :tag "Copy to environment" t) - (const :tag "Use only in Eshell" nil))))) + (const :tag "Use only in Eshell" nil)))) + :risky t) -(put 'eshell-variable-aliases-list 'risky-local-variable t) - -(defvar eshell-var-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c M-v") #'eshell-insert-envvar) - map)) +(defvar-keymap eshell-var-mode-map + "C-c M-v" #'eshell-insert-envvar) ;;; Functions: diff --git a/lisp/eshell/eshell.el b/lisp/eshell/eshell.el index c66ad000722..47fdfa095fc 100644 --- a/lisp/eshell/eshell.el +++ b/lisp/eshell/eshell.el @@ -260,7 +260,7 @@ information on Eshell, see Info node `(eshell)Top'." (t (get-buffer-create eshell-buffer-name))))) (cl-assert (and buf (buffer-live-p buf))) - (pop-to-buffer-same-window buf) + (pop-to-buffer buf display-comint-buffer-action) (unless (derived-mode-p 'eshell-mode) (eshell-mode)) buf)) diff --git a/lisp/ezimage.el b/lisp/ezimage.el index 13f5c039a7f..57033cde058 100644 --- a/lisp/ezimage.el +++ b/lisp/ezimage.el @@ -45,6 +45,7 @@ (defmacro defezimage (variable imagespec docstring) "Define VARIABLE as an image if `defimage' is not available. IMAGESPEC is the image data, and DOCSTRING is documentation for the image." + (declare (indent defun)) `(progn (defimage ,variable ,imagespec ,docstring) (put (quote ,variable) 'ezimage t))) diff --git a/lisp/face-remap.el b/lisp/face-remap.el index 50302b9682c..3440f4c9416 100644 --- a/lisp/face-remap.el +++ b/lisp/face-remap.el @@ -390,6 +390,40 @@ a top-level keymap, `text-scale-increase' or (lambda () (interactive) (text-scale-adjust (abs inc)))))) map))))) ;; ) +(defvar-local text-scale--pinch-start-scale 0 + "The text scale at the start of a pinch sequence.") + +;;;###autoload (define-key global-map [pinch] 'text-scale-pinch) +;;;###autoload +(defun text-scale-pinch (event) + "Adjust the height of the default face by the scale in the pinch event EVENT." + (interactive "e") + (when (not (eq (event-basic-type event) 'pinch)) + (error "`text-scale-pinch' bound to bad event type")) + (let ((evt)) + (catch 'done + (while t + (unless (and (setq evt (read-event nil nil 0.01)) + (eq (car evt) 'pinch)) + (throw 'done nil)))) + (when (and (consp evt) + (eq (car evt) 'pinch)) + (setq event evt))) + (let ((window (posn-window (nth 1 event))) + (scale (nth 4 event)) + (dx (nth 2 event)) + (dy (nth 3 event)) + (angle (nth 5 event))) + (with-selected-window window + (when (and (zerop dx) + (zerop dy) + (zerop angle)) + (setq text-scale--pinch-start-scale + (if text-scale-mode text-scale-mode-amount 0))) + (text-scale-set + (+ text-scale--pinch-start-scale + (round (log scale text-scale-mode-step))))))) + ;; ---------------------------------------------------------------- ;; buffer-face-mode diff --git a/lisp/facemenu.el b/lisp/facemenu.el index 7417bb12030..fe458b8c07b 100644 --- a/lisp/facemenu.el +++ b/lisp/facemenu.el @@ -551,8 +551,8 @@ If the optional argument CALLBACK is non-nil, it should be a function to call each time the user types RET or clicks on a color. The function should accept a single argument, the color name." (interactive) - (when (and (null list) (> (display-color-cells) 0)) - (setq list (list-colors-duplicates (defined-colors))) + (when (> (display-color-cells) 0) + (setq list (list-colors-duplicates (or list (defined-colors)))) (when list-colors-sort ;; Schwartzian transform with `(color key1 key2 key3 ...)'. (setq list (mapcar diff --git a/lisp/faces.el b/lisp/faces.el index 327b0ac01ec..37fbf155842 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -88,9 +88,9 @@ a font height that isn't optimal." :tag "Font selection order" :type '(list symbol symbol symbol symbol) :group 'font-selection - :set #'(lambda (symbol value) - (set-default symbol value) - (internal-set-font-selection-order value))) + :set (lambda (symbol value) + (set-default symbol value) + (internal-set-font-selection-order value))) ;; In the absence of Fontconfig support, Monospace and Sans Serif are @@ -140,9 +140,9 @@ ALTERNATIVE2 etc." :tag "Alternative font families to try" :type '(repeat (repeat string)) :group 'font-selection - :set #'(lambda (symbol value) - (set-default symbol value) - (internal-set-alternative-font-family-alist value))) + :set (lambda (symbol value) + (set-default symbol value) + (internal-set-alternative-font-family-alist value))) ;; This is defined originally in xfaces.c. @@ -167,9 +167,9 @@ REGISTRY, ALTERNATIVE1, ALTERNATIVE2, and etc." :type '(repeat (repeat string)) :version "21.1" :group 'font-selection - :set #'(lambda (symbol value) - (set-default symbol value) - (internal-set-alternative-font-registry-alist value))) + :set (lambda (symbol value) + (set-default symbol value) + (internal-set-alternative-font-registry-alist value))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -702,9 +702,10 @@ for it to be relative to). `:weight' -VALUE specifies the weight of the font to use. It must be one of the -symbols `ultra-bold', `extra-bold', `bold', `semi-bold', `normal', -`semi-light', `light', `extra-light', `ultra-light'. +VALUE specifies the weight of the font to use. It must be one of +the symbols `ultra-heavy', `heavy', `ultra-bold', `extra-bold', +`bold', `semi-bold', `medium', `normal', `book', `semi-light', +`light', `extra-light', `ultra-light', or `thin'. `:slant' @@ -861,8 +862,8 @@ is specified, `:italic' is ignored." (defun make-face-bold (face &optional frame _noerror) "Make the font of FACE be bold, if possible. FRAME nil or not specified means change face on all frames. -Argument NOERROR is ignored and retained for compatibility. Use `set-face-attribute' for finer control of the font weight." + (declare (advertised-calling-convention (face &optional frame) "29.1")) (interactive (list (read-face-name "Make which face bold" (face-at-point t)))) (set-face-attribute face frame :weight 'bold)) @@ -870,8 +871,8 @@ Use `set-face-attribute' for finer control of the font weight." (defun make-face-unbold (face &optional frame _noerror) "Make the font of FACE be non-bold, if possible. -FRAME nil or not specified means change face on all frames. -Argument NOERROR is ignored and retained for compatibility." +FRAME nil or not specified means change face on all frames." + (declare (advertised-calling-convention (face &optional frame) "29.1")) (interactive (list (read-face-name "Make which face non-bold" (face-at-point t)))) (set-face-attribute face frame :weight 'normal)) @@ -880,8 +881,8 @@ Argument NOERROR is ignored and retained for compatibility." (defun make-face-italic (face &optional frame _noerror) "Make the font of FACE be italic, if possible. FRAME nil or not specified means change face on all frames. -Argument NOERROR is ignored and retained for compatibility. Use `set-face-attribute' for finer control of the font slant." + (declare (advertised-calling-convention (face &optional frame) "29.1")) (interactive (list (read-face-name "Make which face italic" (face-at-point t)))) (set-face-attribute face frame :slant 'italic)) @@ -889,8 +890,8 @@ Use `set-face-attribute' for finer control of the font slant." (defun make-face-unitalic (face &optional frame _noerror) "Make the font of FACE be non-italic, if possible. -FRAME nil or not specified means change face on all frames. -Argument NOERROR is ignored and retained for compatibility." +FRAME nil or not specified means change face on all frames." + (declare (advertised-calling-convention (face &optional frame) "29.1")) (interactive (list (read-face-name "Make which face non-italic" (face-at-point t)))) (set-face-attribute face frame :slant 'normal)) @@ -899,8 +900,8 @@ Argument NOERROR is ignored and retained for compatibility." (defun make-face-bold-italic (face &optional frame _noerror) "Make the font of FACE be bold and italic, if possible. FRAME nil or not specified means change face on all frames. -Argument NOERROR is ignored and retained for compatibility. Use `set-face-attribute' for finer control of font weight and slant." + (declare (advertised-calling-convention (face &optional frame) "29.1")) (interactive (list (read-face-name "Make which face bold-italic" (face-at-point t)))) (set-face-attribute face frame :weight 'bold :slant 'italic)) @@ -1100,7 +1101,7 @@ returned. Otherwise, DEFAULT is returned verbatim." ;; prompt. If so, remove it. (setq prompt (replace-regexp-in-string ": ?\\'" "" prompt)) (let ((prompt (if default - (format-message "%s (default `%s'): " prompt default) + (format-prompt prompt default) (format "%s: " prompt))) aliasfaces nonaliasfaces faces) ;; Build up the completion tables. @@ -1146,42 +1147,42 @@ an integer value." (:foundry (list nil)) (:width - (mapcar #'(lambda (x) (cons (symbol-name (aref x 1)) (aref x 1))) + (mapcar (lambda (x) (cons (symbol-name (aref x 1)) (aref x 1))) font-width-table)) (:weight - (mapcar #'(lambda (x) (cons (symbol-name (aref x 1)) (aref x 1))) + (mapcar (lambda (x) (cons (symbol-name (aref x 1)) (aref x 1))) font-weight-table)) (:slant - (mapcar #'(lambda (x) (cons (symbol-name (aref x 1)) (aref x 1))) + (mapcar (lambda (x) (cons (symbol-name (aref x 1)) (aref x 1))) font-slant-table)) ((or :inverse-video :extend) - (mapcar #'(lambda (x) (cons (symbol-name x) x)) + (mapcar (lambda (x) (cons (symbol-name x) x)) (internal-lisp-face-attribute-values attribute))) ((or :underline :overline :strike-through :box) (if (window-system frame) - (nconc (mapcar #'(lambda (x) (cons (symbol-name x) x)) + (nconc (mapcar (lambda (x) (cons (symbol-name x) x)) (internal-lisp-face-attribute-values attribute)) - (mapcar #'(lambda (c) (cons c c)) + (mapcar (lambda (c) (cons c c)) (defined-colors frame))) - (mapcar #'(lambda (x) (cons (symbol-name x) x)) + (mapcar (lambda (x) (cons (symbol-name x) x)) (internal-lisp-face-attribute-values attribute)))) ((or :foreground :background) - (mapcar #'(lambda (c) (cons c c)) + (mapcar (lambda (c) (cons c c)) (defined-colors frame))) (:height 'integerp) (:stipple - (and (memq (window-system frame) '(x ns)) ; No stipple on w32 + (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) (file-directory-p dir) - (directory-files dir))) + (directory-files dir 'full))) x-bitmap-file-path))))) (:inherit (cons '("none" . nil) - (mapcar #'(lambda (c) (cons (symbol-name c) c)) + (mapcar (lambda (c) (cons (symbol-name c) c)) (face-list)))) (_ (error "Internal error"))))) @@ -1515,7 +1516,7 @@ If FRAME is nil, the current FRAME is used." match (cond ((eq req 'type) (or (memq (window-system frame) options) (and (memq 'graphic options) - (memq (window-system frame) '(x w32 ns))) + (memq (window-system frame) '(x w32 ns pgtk))) ;; FIXME: This should be revisited to use ;; display-graphic-p, provided that the ;; color selection depends on the number @@ -2285,19 +2286,19 @@ If you set `term-file-prefix' to nil, this function does nothing." (let* (term-init-func) ;; First, load the terminal initialization file, if it is ;; available and it hasn't been loaded already. - (tty-find-type #'(lambda (type) - (let ((file (locate-library (concat term-file-prefix type)))) - (and file - (or (assoc file load-history) - (load (replace-regexp-in-string - "\\.el\\(\\.gz\\)?\\'" "" - file) - t t))))) - type) + (tty-find-type (lambda (type) + (let ((file (locate-library (concat term-file-prefix type)))) + (and file + (or (assoc file load-history) + (load (replace-regexp-in-string + "\\.el\\(\\.gz\\)?\\'" "" + file) + t t))))) + type) ;; Next, try to find a matching initialization function, and call it. - (tty-find-type #'(lambda (type) - (fboundp (setq term-init-func - (intern (concat "terminal-init-" type))))) + (tty-find-type (lambda (type) + (fboundp (setq term-init-func + (intern (concat "terminal-init-" type))))) type) (when (fboundp term-init-func) (funcall term-init-func)) @@ -2380,6 +2381,15 @@ If you set `term-file-prefix' to nil, this function does nothing." "The basic variable-pitch face." :group 'basic-faces) +(defface variable-pitch-text + '((t :inherit variable-pitch + :height 1.1)) + "The proportional face used for longer texts. +This is like the `variable-pitch' face, but is slightly bigger by +default." + :version "29.1" + :group 'basic-faces) + (defface shadow '((((class color grayscale) (min-colors 88) (background light)) :foreground "grey50") @@ -2613,11 +2623,20 @@ 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)) + "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) @@ -2821,7 +2840,7 @@ Note: Other faces cannot inherit from the cursor face." '((default :box (:line-width 1 :style released-button) :foreground "black") - (((type x w32 ns) (class color)) + (((type x w32 ns haiku pgtk) (class color)) :background "grey75") (((type x) (class mono)) :background "grey")) @@ -2877,14 +2896,22 @@ Note: Other faces cannot inherit from the cursor face." :background "grey96" :foreground "DarkBlue" ;; We use negative thickness of the horizontal box border line to ;; avoid enlarging the height of the echo-area display, which - ;; would then move the mode line a few pixels up. - :box (:line-width (1 . -1) :color "grey80")) + ;; would then move the mode line a few pixels up. We use + ;; negative thickness for the vertical border line to avoid + ;; 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") + :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. @@ -2936,7 +2963,7 @@ It is used for characters of no fonts too." :group 'basic-faces) (defface read-multiple-choice-face - '((t (:inherit underline + '((t (:inherit (help-key-binding underline) :weight bold))) "Face for the symbol name in `read-multiple-choice' output." :group 'basic-faces diff --git a/lisp/ffap.el b/lisp/ffap.el index 964daaaa15d..5d3cee591be 100644 --- a/lisp/ffap.el +++ b/lisp/ffap.el @@ -651,7 +651,7 @@ also is substituted for the first empty-string component, if there is one. Uses `path-separator' to separate the path into substrings." ;; We cannot use parse-colon-path (files.el), since it kills ;; "//" entries using file-name-as-directory. - ;; Similar: dired-split, TeX-split-string, and RHOGEE's psg-list-env + ;; Similar: TeX-split-string, and RHOGEE's psg-list-env ;; in ff-paths and bib-cite. The EMPTY arg may help mimic kpathsea. (if (or empty (getenv env)) ; should return something (let ((start 0) match dir ret) diff --git a/lisp/filenotify.el b/lisp/filenotify.el index 271fa270836..26954cc73f2 100644 --- a/lisp/filenotify.el +++ b/lisp/filenotify.el @@ -480,6 +480,14 @@ DESCRIPTOR should be an object returned by `file-notify-add-watch'." ;; Modify `file-notify-descriptors' and send a `stopped' event. (file-notify--rm-descriptor descriptor)))) +(defun file-notify-rm-all-watches () + "Remove all existing file notification watches from Emacs." + (interactive) + (maphash + (lambda (key _value) + (file-notify-rm-watch key)) + file-notify-descriptors)) + (defun file-notify-valid-p (descriptor) "Check a watch specified by its DESCRIPTOR. DESCRIPTOR should be an object returned by `file-notify-add-watch'." diff --git a/lisp/files.el b/lisp/files.el index 32b7faa43d0..81e91567d08 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. @@ -1985,12 +2010,14 @@ otherwise a string <2> or <3> or ... is appended to get an unused name. Emacs treats buffers whose names begin with a space as internal buffers. To avoid confusion when visiting a file whose name begins with a space, this function prepends a \"|\" to the final result if necessary." - (let ((lastname (file-name-nondirectory filename))) - (if (string= lastname "") - (setq lastname filename)) - (generate-new-buffer (if (string-prefix-p " " lastname) - (concat "|" lastname) - lastname)))) + (let* ((lastname (file-name-nondirectory filename)) + (lastname (if (string= lastname "") + filename lastname)) + (buf (generate-new-buffer (if (string-prefix-p " " lastname) + (concat "|" lastname) + lastname)))) + (uniquify--create-file-buffer-advice buf filename) + buf)) (defcustom automount-dir-prefix (purecopy "^/tmp_mnt/") "Regexp to match the automounter prefix in a directory name." @@ -2015,73 +2042,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 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)))) + (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)) + + ;; 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). @@ -2761,6 +2769,7 @@ since only a single case-insensitive search through the alist is made." ("\\.gif\\'" . image-mode) ("\\.png\\'" . image-mode) ("\\.jpe?g\\'" . image-mode) + ("\\.webp\\'" . image-mode) ("\\.te?xt\\'" . text-mode) ("\\.[tT]e[xX]\\'" . tex-mode) ("\\.ins\\'" . tex-mode) ;Installation files for TeX packages. @@ -2886,6 +2895,7 @@ ARC\\|ZIP\\|LZH\\|LHA\\|ZOO\\|[JEW]AR\\|XPI\\|RAR\\|CBR\\|7Z\\|SQUASHFS\\)\\'" . ("\\.[ds]?va?h?\\'" . verilog-mode) ("\\.by\\'" . bovine-grammar-mode) ("\\.wy\\'" . wisent-grammar-mode) + ("\\.erts\\'" . erts-mode) ;; .emacs or .gnus or .viper following a directory delimiter in ;; Unix or MS-DOS syntax. ("[:/\\]\\..*\\(emacs\\|gnus\\|viper\\)\\'" . emacs-lisp-mode) @@ -2978,6 +2988,7 @@ ARC\\|ZIP\\|LZH\\|LHA\\|ZOO\\|[JEW]AR\\|XPI\\|RAR\\|CBR\\|7Z\\|SQUASHFS\\)\\'" . ("\\.dng\\'" . image-mode) ("\\.dpx\\'" . image-mode) ("\\.fax\\'" . image-mode) + ("\\.heic\\'" . image-mode) ("\\.hrz\\'" . image-mode) ("\\.icb\\'" . image-mode) ("\\.icc\\'" . image-mode) @@ -4736,7 +4747,6 @@ using \\<minibuffer-local-map>\\[next-history-element]. If optional second arg CONFIRM is non-nil, this function asks for confirmation before overwriting an existing file. Interactively, confirmation is required unless you supply a prefix argument." -;; (interactive "FWrite file: ") (interactive (list (if buffer-file-name (read-file-name "Write file: " @@ -4747,33 +4757,44 @@ Interactively, confirmation is required unless you supply a prefix argument." default-directory) nil nil)) (not current-prefix-arg))) - (or (null filename) (string-equal filename "") - (progn - ;; If arg is a directory name, - ;; use the default file name, but in that directory. - (if (directory-name-p filename) - (setq filename (concat filename - (file-name-nondirectory - (or buffer-file-name (buffer-name)))))) - (and confirm - (file-exists-p filename) - ;; NS does its own confirm dialog. - (not (and (eq (framep-on-display) 'ns) - (listp last-nonmenu-event) - use-dialog-box)) - (or (y-or-n-p (format-message - "File `%s' exists; overwrite? " filename)) - (user-error "Canceled"))) - (set-visited-file-name filename (not confirm)))) - (set-buffer-modified-p t) - ;; Make buffer writable if file is writable. - (and buffer-file-name - (file-writable-p buffer-file-name) - (setq buffer-read-only nil)) - (save-buffer) - ;; It's likely that the VC status at the new location is different from - ;; the one at the old location. - (vc-refresh-state)) + (let ((old-modes + (and buffer-file-name + ;; File may have gone away; ignore errors in that case. + (ignore-errors (file-modes buffer-file-name))))) + (or (null filename) (string-equal filename "") + (progn + ;; If arg is a directory name, + ;; use the default file name, but in that directory. + (if (directory-name-p filename) + (setq filename (concat filename + (file-name-nondirectory + (or buffer-file-name (buffer-name)))))) + (and confirm + (file-exists-p filename) + ;; NS does its own confirm dialog. + (not (and (eq (framep-on-display) 'ns) + (listp last-nonmenu-event) + use-dialog-box)) + (or (y-or-n-p (format-message + "File `%s' exists; overwrite? " filename)) + (user-error "Canceled"))) + (set-visited-file-name filename (not confirm)))) + (set-buffer-modified-p t) + ;; Make buffer writable if file is writable. + (and buffer-file-name + (file-writable-p buffer-file-name) + (setq buffer-read-only nil)) + (save-buffer) + ;; If the old file was executable, then make the new file + ;; executable, too. + (when (and old-modes + (not (zerop (logand #o111 old-modes)))) + (set-file-modes buffer-file-name + (logior (logand #o111 old-modes) + (file-modes buffer-file-name)))) + ;; It's likely that the VC status at the new location is different from + ;; the one at the old location. + (vc-refresh-state))) (defun file-extended-attributes (filename) "Return an alist of extended attributes of file FILENAME. @@ -5048,6 +5069,29 @@ See also `file-name-sans-extension'." (file-name-sans-extension (file-name-nondirectory (or filename (buffer-file-name))))) +(defun file-name-split (filename) + "Return a list of all the components of FILENAME. +On most systems, this will be true: + + (equal (string-join (file-name-split filename) \"/\") filename)" + (let ((components nil)) + ;; If this is a directory file name, then we have a null file name + ;; at the end. + (when (directory-name-p filename) + (push "" components) + (setq filename (directory-file-name filename))) + ;; Loop, chopping off components. + (while (length> filename 0) + (push (file-name-nondirectory filename) components) + (let ((dir (file-name-directory filename))) + (setq filename (and dir (directory-file-name dir))) + ;; If there's nothing left to peel off, we're at the root and + ;; we can stop. + (when (and dir (equal dir filename)) + (push "" components) + (setq filename nil)))) + components)) + (defcustom make-backup-file-name-function #'make-backup-file-name--default-function "A function that `make-backup-file-name' uses to create backup file names. @@ -5774,13 +5818,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 @@ -6180,6 +6224,29 @@ Return nil if DIR is not an existing directory." (unless mismatch (file-equal-p root dir))))))) +(defvar file-has-changed-p--hash-table (make-hash-table :test #'equal) + "Internal variable used by `file-has-changed-p'.") + +(defun file-has-changed-p (file &optional tag) + "Return non-nil if FILE has changed. +The size and modification time of FILE are compared to the size +and modification time of the same FILE during a previous +invocation of `file-has-changed-p'. Thus, the first invocation +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* ((file (directory-file-name (expand-file-name file))) + (remote-file-name-inhibit-cache t) + (fileattr (file-attributes file 'integer)) + (attr (and fileattr + (cons (file-attribute-size fileattr) + (file-attribute-modification-time fileattr)))) + (sym (concat (symbol-name tag) "@" file)) + (cachedattr (gethash sym file-has-changed-p--hash-table))) + (when (not (equal attr cachedattr)) + (puthash sym attr file-has-changed-p--hash-table)))) + (defun copy-directory (directory newname &optional keep-time parents copy-contents) "Copy DIRECTORY to NEWNAME. Both args must be strings. This function always sets the file modes of the output files to match @@ -7132,16 +7199,16 @@ default directory. However, if FULL is non-nil, they are absolute." (let ((this-dir-contents ;; Filter out "." and ".." (delq nil - (mapcar #'(lambda (name) - (unless (string-match "\\`\\.\\.?\\'" - (file-name-nondirectory name)) - name)) + (mapcar (lambda (name) + (unless (string-match "\\`\\.\\.?\\'" + (file-name-nondirectory name)) + name)) (directory-files (or dir ".") full (wildcard-to-regexp nondir)))))) (setq contents (nconc (if (and dir (not full)) - (mapcar #'(lambda (name) (concat dir name)) + (mapcar (lambda (name) (concat dir name)) this-dir-contents) this-dir-contents) contents))))) @@ -7156,11 +7223,18 @@ DIRNAME is globbed by the shell if necessary. Prefix arg (second arg if noninteractive) means supply -l switch to `ls'. Actions controlled by variables `list-directory-brief-switches' and `list-directory-verbose-switches'." - (interactive (let ((pfx current-prefix-arg)) - (list (read-directory-name (if pfx "List directory (verbose): " - "List directory (brief): ") - nil default-directory nil) - pfx))) + (interactive + (let ((pfx current-prefix-arg)) + (list (read-file-name + (if pfx "List directory (verbose): " + "List directory (brief): ") + nil default-directory t + nil + (lambda (file) + (or (file-directory-p file) + (insert-directory-wildcard-in-dir-p + (expand-file-name file))))) + pfx))) (let ((switches (if verbose list-directory-verbose-switches list-directory-brief-switches)) buffer) @@ -7611,21 +7685,7 @@ normally equivalent short `-D' option is just passed on to (if val coding-no-eol coding)) (if val (put-text-property pos (point) - 'dired-filename t))))))) - - (if full-directory-p - ;; Try to insert the amount of free space. - (save-excursion - (goto-char beg) - ;; First find the line to put it on. - (when (re-search-forward "^ *\\(total\\)" nil t) - ;; Replace "total" with "total used in directory" to - ;; avoid confusion. - (replace-match "total used in directory" nil nil nil 1) - (let ((available (get-free-disk-space file))) - (when available - (end-of-line) - (insert " available " available)))))))))) + 'dired-filename t))))))))))) (defun insert-directory-adj-pos (pos error-lines) "Convert `ls --dired' file name position value POS to a buffer position. @@ -7786,10 +7846,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/finder.el b/lisp/finder.el index c2b9a6d0ef9..00f321b8028 100644 --- a/lisp/finder.el +++ b/lisp/finder.el @@ -362,19 +362,13 @@ not `finder-known-keywords'." (let ((package-list-unversioned t)) (package-show-package-list packages)))) -(define-button-type 'finder-xref 'action #'finder-goto-xref) - -(defun finder-goto-xref (button) - "Jump to a Lisp file for the BUTTON at point." - (let* ((file (button-get button 'xref)) - (lib (locate-library file))) - (if lib (finder-commentary lib) - (message "Unable to locate `%s'" file)))) - ;;;###autoload (defun finder-commentary (file) "Display FILE's commentary section. FILE should be in a form suitable for passing to `locate-library'." + ;; FIXME: Merge this function into `describe-package', which is + ;; strictly better as it has links to URL's and is in a proper help + ;; buffer with navigation forward and backward, etc. (interactive (list (completing-read "Library name: " @@ -391,12 +385,7 @@ FILE should be in a form suitable for passing to `locate-library'." (erase-buffer) (insert str) (goto-char (point-min)) - (while (re-search-forward "\\<\\([-[:alnum:]]+\\.el\\)\\>" nil t) - (if (locate-library (match-string 1)) - (make-text-button (match-beginning 1) (match-end 1) - 'xref (match-string-no-properties 1) - 'help-echo "Read this file's commentary" - :type 'finder-xref))) + (package--describe-add-library-links) (goto-char (point-min)) (setq buffer-read-only t) (set-buffer-modified-p nil) @@ -469,6 +458,9 @@ Quit the window and kill all Finder-related buffers." ;; continue standard unloading nil) +(define-obsolete-function-alias 'finder-goto-xref + #'package--finder-goto-xref "29.1") + (provide 'finder) diff --git a/lisp/font-lock.el b/lisp/font-lock.el index a4ab897f6f2..c2590eb3c11 100644 --- a/lisp/font-lock.el +++ b/lisp/font-lock.el @@ -2075,7 +2075,7 @@ as the constructs of Haddock, Javadoc and similar systems." (((class color) (min-colors 16) (background dark)) :foreground "PaleGreen") (((class color) (min-colors 8)) :foreground "green") (t :weight bold :underline t)) - "Font Lock mode face used to highlight type and classes." + "Font Lock mode face used to highlight type and class names." :group 'font-lock-faces) (defface font-lock-constant-face diff --git a/lisp/format.el b/lisp/format.el index 6c0ba11641e..8ae51f19ebc 100644 --- a/lisp/format.el +++ b/lisp/format.el @@ -320,7 +320,7 @@ If the format is not specified, attempt a regexp-based guess. Set `buffer-file-format' to the format used, and call any format-specific mode functions." (interactive - (list (format-read "Translate buffer from format (default guess): "))) + (list (format-read (format-prompt "Translate buffer from format" "guess")))) (save-excursion (goto-char (point-min)) (format-decode format (buffer-size) t))) @@ -331,7 +331,7 @@ Arg FORMAT is optional; if omitted the format will be determined by looking for identifying regular expressions at the beginning of the region." (interactive (list (region-beginning) (region-end) - (format-read "Translate region from format (default guess): "))) + (format-read (format-prompt "Translate region from format" "guess")))) (save-excursion (goto-char from) (format-decode format (- to from) nil))) diff --git a/lisp/frame.el b/lisp/frame.el index 2c73737a541..13929047d08 100644 --- a/lisp/frame.el +++ b/lisp/frame.el @@ -808,12 +808,16 @@ also select the new frame." new-frame)) (defvar before-make-frame-hook nil - "Functions to run before `make-frame' creates a new frame.") + "Functions to run before `make-frame' creates a new frame. +Note that these functions are usually not run for the initial +frame, unless you add them to the hook in your early-init file.") (defvar after-make-frame-functions nil "Functions to run after `make-frame' created a new frame. The functions are run with one argument, the newly created -frame.") +frame. +Note that these functions are usually not run for the initial +frame, unless you add them to the hook in your early-init file.") (defvar after-setting-font-hook nil "Functions to run after a frame's font has been changed.") @@ -1633,6 +1637,8 @@ live frame and defaults to the selected one." (declare-function x-frame-geometry "xfns.c" (&optional frame)) (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. @@ -1682,6 +1688,10 @@ and width values are in pixels. (w32-frame-geometry frame)) ((eq frame-type 'ns) (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) @@ -1806,6 +1816,8 @@ of frames like calls to map a frame or change its visibility." (declare-function x-frame-edges "xfns.c" (&optional frame type)) (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. @@ -1829,12 +1841,18 @@ FRAME." (w32-frame-edges frame type)) ((eq frame-type 'ns) (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)))))) (declare-function w32-mouse-absolute-pixel-position "w32fns.c") (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. @@ -1849,12 +1867,18 @@ position (0, 0) of the selected frame's terminal." (w32-mouse-absolute-pixel-position)) ((eq frame-type 'ns) (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))))) +(declare-function pgtk-set-mouse-absolute-pixel-position "pgtkfns.c" (x y)) (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). @@ -1862,12 +1886,16 @@ The coordinates X and Y are interpreted in pixels relative to a position (0, 0) of the selected frame's terminal." (let ((frame-type (framep-on-display))) (cond + ((eq frame-type 'pgtk) + (pgtk-set-mouse-absolute-pixel-position x y)) ((eq frame-type 'ns) (ns-set-mouse-absolute-pixel-position x y)) ((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. @@ -1960,6 +1988,8 @@ workarea attribute." (declare-function x-frame-list-z-order "xfns.c" (&optional display)) (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. @@ -1979,11 +2009,16 @@ Return nil if DISPLAY contains no Emacs frame." ((eq frame-type 'w32) (w32-frame-list-z-order display)) ((eq frame-type 'ns) - (ns-frame-list-z-order display))))) + (ns-frame-list-z-order display)) + ((eq frame-type 'pgtk) + (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)) (declare-function ns-frame-restack "nsfns.m" (frame1 frame2 &optional above)) +(declare-function pgtk-frame-restack "pgtkfns.c" (frame1 frame2 &optional above)) (defun frame-restack (frame1 frame2 &optional above) "Restack FRAME1 below FRAME2. @@ -2013,7 +2048,9 @@ Some window managers may refuse to restack windows." ((eq frame-type 'w32) (w32-frame-restack frame1 frame2 above)) ((eq frame-type 'ns) - (ns-frame-restack frame1 frame2 above)))) + (ns-frame-restack frame1 frame2 above)) + ((eq frame-type 'pgtk) + (pgtk-frame-restack frame1 frame2 above)))) (error "Cannot restack frames"))) (defun frame-size-changed-p (&optional frame) @@ -2060,8 +2097,8 @@ frame's display)." ((eq frame-type 'w32) (with-no-warnings (> w32-num-mouse-buttons 0))) - ((memq frame-type '(x ns)) - 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) @@ -2086,7 +2123,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))))) + (not (null (memq (framep-on-display display) '(x w32 ns pgtk haiku))))) (defun display-images-p (&optional display) "Return non-nil if DISPLAY can display images. @@ -2114,7 +2151,7 @@ frame's display)." ;; a Windows DOS Box. (with-no-warnings (not (null dos-windows-version)))) - ((memq frame-type '(x w32 ns)) + ((memq frame-type '(x w32 ns pgtk)) t) (t nil)))) @@ -2124,7 +2161,7 @@ frame's display)." This means that, for example, DISPLAY can differentiate between the keybinding RET and [return]." (let ((frame-type (framep-on-display display))) - (or (memq frame-type '(x w32 ns pc)) + (or (memq frame-type '(x w32 ns pc pgtk)) ;; MS-DOS and MS-Windows terminals have built-in support for ;; function (symbol) keys (memq system-type '(ms-dos windows-nt))))) @@ -2137,7 +2174,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)) + ((memq frame-type '(x w32 ns haiku pgtk)) (x-display-screens display)) (t 1)))) @@ -2157,7 +2194,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)) + ((memq frame-type '(x w32 ns haiku pgtk)) (x-display-pixel-height display)) (t (frame-height (if (framep display) display (selected-frame))))))) @@ -2177,7 +2214,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)) + ((memq frame-type '(x w32 ns haiku pgtk)) (x-display-pixel-width display)) (t (frame-width (if (framep display) display (selected-frame))))))) @@ -2215,7 +2252,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)) + (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)) @@ -2236,7 +2273,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)) + (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)) @@ -2254,7 +2291,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)) + ((memq frame-type '(x w32 ns haiku pgtk)) (x-display-backing-store display)) (t 'not-useful)))) @@ -2267,7 +2304,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)) + ((memq frame-type '(x w32 ns haiku pgtk)) (x-display-save-under display)) (t 'not-useful)))) @@ -2280,7 +2317,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)) + ((memq frame-type '(x w32 ns haiku pgtk)) (x-display-planes display)) ((eq frame-type 'pc) 4) @@ -2295,7 +2332,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)) + ((memq frame-type '(x w32 ns haiku pgtk)) (x-display-color-cells display)) ((eq frame-type 'pc) 16) @@ -2312,7 +2349,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)) + ((memq frame-type '(x w32 ns haiku pgtk)) (x-display-visual-class display)) ((and (memq frame-type '(pc t)) (tty-display-color-p display)) @@ -2326,6 +2363,8 @@ If DISPLAY is omitted or nil, it defaults to the selected frame's display." (&optional display)) (declare-function ns-display-monitor-attributes-list "nsfns.m" (&optional terminal)) +(declare-function pgtk-display-monitor-attributes-list "pgtkfns.c" + (&optional terminal)) (defun display-monitor-attributes-list (&optional display) "Return a list of physical monitor attributes on DISPLAY. @@ -2343,6 +2382,7 @@ of attribute keys and values as follows: mm-size -- Width and height in millimeters in the form of (WIDTH HEIGHT) frames -- List of frames dominated by the physical monitor + scale-factor (*) -- Scale factor (float) name (*) -- Name of the physical monitor as a string source (*) -- Source of multi-monitor information as a string @@ -2374,6 +2414,8 @@ monitors." (w32-display-monitor-attributes-list display)) ((eq frame-type 'ns) (ns-display-monitor-attributes-list display)) + ((eq frame-type 'pgtk) + (pgtk-display-monitor-attributes-list display)) (t (let ((geometry (list 0 0 (display-pixel-width display) (display-pixel-height display)))) diff --git a/lisp/gnus/gmm-utils.el b/lisp/gnus/gmm-utils.el index bcf8dd014bc..68a90989046 100644 --- a/lisp/gnus/gmm-utils.el +++ b/lisp/gnus/gmm-utils.el @@ -239,6 +239,7 @@ DEFAULT-MAP specifies the default key map for ICON-LIST." "Create function NAME. If FUNCTION exists, then NAME becomes an alias for FUNCTION. Otherwise, create function NAME with ARG-LIST and BODY." + (declare (indent defun)) (let ((defined-p (fboundp function))) (if defined-p `(defalias ',name ',function) diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index 6426d825465..169a351c2c7 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -475,17 +475,16 @@ manipulated as follows: (gnus-run-hooks 'gnus-agent-mode-hook (intern (format "gnus-agent-%s-mode-hook" buffer))))) -(defvar gnus-agent-group-mode-map (make-sparse-keymap)) -(gnus-define-keys 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) +(defvar-keymap gnus-agent-group-mode-map + "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,16 +503,15 @@ manipulated as follows: ["Synchronize flags" gnus-agent-synchronize-flags t] )))) -(defvar gnus-agent-summary-mode-map (make-sparse-keymap)) -(gnus-define-keys 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 - "@" gnus-agent-toggle-mark - "Jc" gnus-agent-catchup) +(defvar-keymap gnus-agent-summary-mode-map + "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 + "J c" #'gnus-agent-catchup) (defun gnus-agent-summary-make-menu-bar () (unless (boundp 'gnus-agent-summary-menu) @@ -527,11 +525,10 @@ manipulated as follows: ["Fetch downloadable" gnus-agent-summary-fetch-group t] ["Catchup undownloaded" gnus-agent-catchup t])))) -(defvar gnus-agent-server-mode-map (make-sparse-keymap)) -(gnus-define-keys gnus-agent-server-mode-map - "Jj" gnus-agent-toggle-plugged - "Ja" gnus-agent-add-server - "Jr" gnus-agent-remove-server) +(defvar-keymap gnus-agent-server-mode-map + "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) @@ -2597,25 +2594,20 @@ General format specifiers can also be used. See Info node (defvar gnus-category-line-format-spec nil) (defvar gnus-category-mode-line-format-spec nil) -(defvar gnus-category-mode-map nil) - -(unless gnus-category-mode-map - (setq gnus-category-mode-map (make-sparse-keymap)) - (suppress-keymap gnus-category-mode-map) - - (gnus-define-keys gnus-category-mode-map - "q" gnus-category-exit - "k" gnus-category-kill - "c" gnus-category-copy - "a" gnus-category-add - "e" gnus-agent-customize-category - "p" gnus-category-edit-predicate - "g" gnus-category-edit-groups - "s" gnus-category-edit-score - "l" gnus-category-list - - "\C-c\C-i" gnus-info-find-node - "\C-c\C-b" gnus-bug)) +(defvar-keymap gnus-category-mode-map + :suppress t + "q" #'gnus-category-exit + "k" #'gnus-category-kill + "c" #'gnus-category-copy + "a" #'gnus-category-add + "e" #'gnus-agent-customize-category + "p" #'gnus-category-edit-predicate + "g" #'gnus-category-edit-groups + "s" #'gnus-category-edit-score + "l" #'gnus-category-list + + "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 b97cd711c4e..545b55bbea5 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 :inherit variable-pitch-text)) + "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) @@ -1167,6 +1177,19 @@ predicate. See Info node `(gnus)Customizing Articles'." :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) +(defcustom gnus-treat-emojize-symbols nil + "Display emoji versions of symbol. +Some symbols have both a non-emoji presentation and an emoji +presentation. This treatment will make Gnus display the latter +as emojis even when they weren't sent as such. + +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." + :version "29.1" + :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") + :type gnus-article-treat-custom) + (defcustom gnus-treat-unsplit-urls nil "Remove newlines from within URLs. Valid values are nil, t, `head', `first', `last', an integer or a @@ -1360,11 +1383,11 @@ This variable has no effect if `gnus-treat-unfold-headers' is nil." (const :tag "all" t) (regexp))) -(defcustom gnus-treat-fold-headers nil +(defcustom gnus-treat-fold-headers 'head "Fold headers. Valid values are nil, t, `head', `first', `last', an integer or a predicate. See Info node `(gnus)Customizing Articles'." - :version "22.1" + :version "29.1" :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) @@ -1650,6 +1673,7 @@ regexp." (defvar gnus-article-mime-handle-alist-1 nil) (defvar gnus-treatment-function-alist '((gnus-treat-strip-cr gnus-article-remove-cr) + (gnus-treat-emojize-symbols gnus-article-emojize-symbols) (gnus-treat-x-pgp-sig gnus-article-verify-x-pgp-sig) (gnus-treat-strip-banner gnus-article-strip-banner) (gnus-treat-strip-headers-in-body gnus-article-strip-headers-in-body) @@ -2188,6 +2212,14 @@ unfolded." (replace-match " " t t)))) (goto-char (point-max))))))) +(defun gnus--variable-pitch-p (face) + (when face + (or (eq face 'variable-pitch) + (let ((parent (face-attribute face :inherit))) + (if (eq parent 'unspecified) + nil + (seq-some #'gnus--variable-pitch-p (ensure-list parent))))))) + (defun gnus-article-treat-fold-headers () "Fold message headers." (interactive nil gnus-article-mode gnus-summary-mode) @@ -2195,7 +2227,10 @@ unfolded." (while (not (eobp)) (save-restriction (mail-header-narrow-to-field) - (mail-header-fold-field) + (if (not (gnus--variable-pitch-p (get-text-property (point) 'face))) + (mail-header-fold-field) + (forward-char 1) + (pixel-fill-region (point) (point-max) (pixel-fill-width))) (goto-char (point-max)))))) (defun gnus-treat-smiley () @@ -2360,6 +2395,20 @@ fill width." (while (search-forward "\r" nil t) (replace-match "\n" t t))))) +(defun article-emojize-symbols () + "Display symbols (that have an emoji version) as emojis." + (interactive nil gnus-article-mode) + (when-let ((font (and (display-multi-font-p) + (car (internal-char-font nil ?😀))))) + (save-excursion + (let ((inhibit-read-only t)) + (goto-char (point-min)) + (while (re-search-forward "[[:multibyte:]]" nil t) + ;; If there's already a grapheme cluster here, skip it. + (when (and (not (find-composition (point))) + (font-has-char-p font (char-after (match-beginning 0)))) + (insert "\N{VARIATION SELECTOR-16}"))))))) + (defun article-remove-trailing-blank-lines () "Remove all trailing blank lines from the article." (interactive nil gnus-article-mode) @@ -3933,8 +3982,8 @@ This format is defined by the `gnus-article-time-format' variable." ;; No split name was found. ((null split-name) (read-file-name - (concat prompt " (default " - (file-name-nondirectory default-name) "): ") + (format-prompt prompt + (file-name-nondirectory default-name)) (file-name-directory default-name) default-name)) ;; A single group name is returned. @@ -3943,8 +3992,8 @@ This format is defined by the `gnus-article-time-format' variable." (funcall function split-name headers (symbol-value variable))) (read-file-name - (concat prompt " (default " - (file-name-nondirectory default-name) "): ") + (format-prompt prompt + (file-name-nondirectory default-name)) (file-name-directory default-name) default-name)) ;; A single split name was found @@ -3956,9 +4005,8 @@ This format is defined by the `gnus-article-time-format' variable." (file-name-as-directory name)) ((file-exists-p name) name) (t gnus-article-save-directory)))) - (read-file-name - (concat prompt " (default " name "): ") - dir name))) + (read-file-name (format-prompt prompt name) + dir name))) ;; A list of splits was found. (t (setq split-name (nreverse split-name)) @@ -4342,6 +4390,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is article-fill-long-lines article-capitalize-sentences article-remove-cr + article-emojize-symbols article-remove-leading-whitespace article-display-x-face article-display-face @@ -4387,44 +4436,44 @@ If variable `gnus-use-long-file-name' is non-nil, it is ;;; Gnus article mode ;;; -(set-keymap-parent gnus-article-mode-map button-buffer-map) - -(gnus-define-keys gnus-article-mode-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 - "h" gnus-article-show-summary - "s" gnus-article-show-summary - "\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 - "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 - - "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) +(defvar gnus-article-send-map nil) + +(define-keymap :keymap gnus-article-mode-map :suppress t + :parent button-buffer-map + "SPC" #'gnus-article-goto-next-page + "S-SPC" #'gnus-article-goto-prev-page + "DEL" #'gnus-article-goto-prev-page + "<delete>" #'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 + "?" #'gnus-article-describe-briefly + "<" #'beginning-of-buffer + ">" #'end-of-buffer + "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-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 + + "S" (define-keymap :prefix 'gnus-article-send-map + "W" #'gnus-article-wide-reply-with-original + "<t>" #'gnus-article-read-summary-send-keys)) (substitute-key-definition #'undefined #'gnus-article-read-summary-keys gnus-article-mode-map) -(defvar gnus-article-send-map) -(gnus-define-keys (gnus-article-send-map "S" gnus-article-mode-map) - "W" gnus-article-wide-reply-with-original - [t] gnus-article-read-summary-send-keys) - (defun gnus-article-make-menu-bar () (unless (boundp 'gnus-article-commands-menu) (gnus-summary-make-menu-bar)) @@ -4449,6 +4498,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is ["Treat overstrike" gnus-article-treat-overstrike t] ["Treat ANSI sequences" gnus-article-treat-ansi-sequences t] ["Remove carriage return" gnus-article-remove-cr t] + ["Emojize Symbols" gnus-article-emojize-symbols t] ["Remove leading whitespace" gnus-article-remove-leading-whitespace t] ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t] ["Remove base64" gnus-article-de-base64-unreadable t] @@ -4509,7 +4559,8 @@ commands: (setq show-trailing-whitespace nil) ;; Arrange a callback from `mm-inline-message' if we're ;; displaying a message/rfc822 part. - (setq-local mm-inline-message-prepare-function #'gnus-mime--inline-message) + (setq-local mm-inline-message-prepare-function + #'gnus-mime--inline-message-function) (mm-enable-multibyte)) (defun gnus-article-setup-buffer () @@ -4549,7 +4600,6 @@ commands: (let ((summary gnus-summary-buffer)) (with-current-buffer name (setq-local gnus-article-edit-mode nil) - (gnus-article-stop-animations) (when gnus-article-mime-handles (mm-destroy-parts gnus-article-mime-handles) (setq gnus-article-mime-handles nil)) @@ -4575,6 +4625,7 @@ commands: (current-buffer)))))) (defun gnus-article-stop-animations () + (declare (obsolete nil "29.1")) (cancel-function-timers 'image-animate-timeout)) (defun gnus-stop-downloads () @@ -6033,6 +6084,34 @@ If nil, don't show those extra buttons." ((equal (car handle) "multipart/encrypted") (gnus-add-wash-type 'encrypted) (gnus-mime-display-security handle)) + ;; pkcs7-mime handling: + ;; + ;; although not really multipart these are structured internally by + ;; mm-dissect-buffer like multipart to not discard the decryption + ;; and verification results + ;; + ;; application/pkcs7-mime + ((and (equal (car handle) "application/pkcs7-mime") + (equal (mm-handle-multipart-ctl-parameter handle 'protocol) + "application/pkcs7-mime_signed-data")) + (gnus-add-wash-type 'signed) + (gnus-mime-display-security handle)) + ((and (equal (car handle) "application/pkcs7-mime") + (equal (mm-handle-multipart-ctl-parameter handle 'protocol) + "application/pkcs7-mime_enveloped-data")) + (gnus-add-wash-type 'encrypted) + (gnus-mime-display-security handle)) + ;; application/x-pkcs7-mime + ((and (equal (car handle) "application/x-pkcs7-mime") + (equal (mm-handle-multipart-ctl-parameter handle 'protocol) + "application/x-pkcs7-mime_signed-data")) + (gnus-add-wash-type 'signed) + (gnus-mime-display-security handle)) + ((and (equal (car handle) "application/x-pkcs7-mime") + (equal (mm-handle-multipart-ctl-parameter handle 'protocol) + "application/x-pkcs7-mime_enveloped-data")) + (gnus-add-wash-type 'encrypted) + (gnus-mime-display-security handle)) ;; Other multiparts are handled like multipart/mixed. (t (gnus-mime-display-mixed (cdr handle))))) @@ -6045,7 +6124,7 @@ If nil, don't show those extra buttons." (defun gnus-mime-display-mixed (handles) (mapcar #'gnus-mime-display-part handles)) -(defun gnus-mime--inline-message (handle charset) +(defun gnus-mime--inline-message-function (handle charset) (let ((handles (let (gnus-article-mime-handles ;; disable prepare hook @@ -7222,50 +7301,42 @@ other groups." (defvar gnus-article-edit-done-function nil) -(defvar gnus-article-edit-mode-map nil) - -;; Should we be using derived.el for this? -(unless gnus-article-edit-mode-map - (setq gnus-article-edit-mode-map (make-keymap)) - (set-keymap-parent gnus-article-edit-mode-map text-mode-map) - - (gnus-define-keys gnus-article-edit-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\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) - - (gnus-define-keys (gnus-article-edit-wash-map - "\C-c\C-w" gnus-article-edit-mode-map) - "f" gnus-article-edit-full-stops)) +(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-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-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)) (easy-menu-define gnus-article-edit-mode-field-menu gnus-article-edit-mode-map "" @@ -7864,8 +7935,8 @@ variable is the real callback function." (function :tag "Callback") (repeat :tag "Par" :inline t - (integer :tag "Regexp group"))))) -(put 'gnus-button-alist 'risky-local-variable t) + (integer :tag "Regexp group")))) + :risky t) (defcustom gnus-header-button-alist '(("^\\(References\\|Message-I[Dd]\\|^In-Reply-To\\):" "<[^<>]+>" @@ -7904,8 +7975,8 @@ HEADER is a regexp to match a header. For a fuller explanation, see (function :tag "Callback") (repeat :tag "Par" :inline t - (integer :tag "Regexp group"))))) -(put 'gnus-header-button-alist 'risky-local-variable t) + (integer :tag "Regexp group")))) + :risky t) ;;; Commands: @@ -8790,11 +8861,19 @@ For example: (setq point (point)) (with-current-buffer (mm-handle-multipart-original-buffer handle) (let* ((mm-verify-option 'known) - (mm-decrypt-option 'known) - (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle))) - (unless (eq nparts (cdr handle)) - (mm-destroy-parts (cdr handle)) - (setcdr handle nparts)))) + (mm-decrypt-option 'known) + (pkcs7-mime-p (or (equal (car handle) "application/pkcs7-mime") + (equal (car handle) "application/x-pkcs7-mime"))) + (nparts (if pkcs7-mime-p + (list (mm-possibly-verify-or-decrypt + (cadr handle) (cadadr handle))) + (mm-possibly-verify-or-decrypt (cdr handle) handle)))) + (unless (eq nparts (cdr handle)) + ;; if pkcs7-mime don't destroy the parts as the buffer in + ;; the cdr still needs to be accessible + (when (not pkcs7-mime-p) + (mm-destroy-parts (cdr handle))) + (setcdr handle nparts)))) (gnus-mime-display-security handle) (when region (delete-region (point) (cdr region)) @@ -8848,14 +8927,35 @@ For example: (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol)) (gnus-tmp-type (concat - (or (nth 2 (assoc protocol mm-verify-function-alist)) - (nth 2 (assoc protocol mm-decrypt-function-alist)) - "Unknown") - (if (equal (car handle) "multipart/signed") - " Signed" " Encrypted") - " Part")) - (gnus-tmp-info - (or (mm-handle-multipart-ctl-parameter handle 'gnus-info) + (or (nth 2 (assoc protocol mm-verify-function-alist)) + (nth 2 (assoc protocol mm-decrypt-function-alist)) + "Unknown") + (cond ((equal (car handle) "multipart/signed") " Signed") + ((equal (car handle) "multipart/encrypted") " Encrypted") + ((and (equal (car handle) "application/pkcs7-mime") + (equal + (mm-handle-multipart-ctl-parameter handle 'protocol) + "application/pkcs7-mime_signed-data")) + " Signed") + ((and (equal (car handle) "application/pkcs7-mime") + (equal + (mm-handle-multipart-ctl-parameter handle 'protocol) + "application/pkcs7-mime_enveloped-data")) + " Encrypted") + ;; application/x-pkcs7-mime + ((and (equal (car handle) "application/x-pkcs7-mime") + (equal + (mm-handle-multipart-ctl-parameter handle 'protocol) + "application/x-pkcs7-mime_signed-data")) + " Signed") + ((and (equal (car handle) "application/x-pkcs7-mime") + (equal + (mm-handle-multipart-ctl-parameter handle 'protocol) + "application/x-pkcs7-mime_enveloped-data")) + " Encrypted")) + " Part")) + (gnus-tmp-info + (or (mm-handle-multipart-ctl-parameter handle 'gnus-info) "Undecided")) (gnus-tmp-details (mm-handle-multipart-ctl-parameter handle 'gnus-details)) diff --git a/lisp/gnus/gnus-bookmark.el b/lisp/gnus/gnus-bookmark.el index 83e482f14c1..e9696b66a9f 100644 --- a/lisp/gnus/gnus-bookmark.el +++ b/lisp/gnus/gnus-bookmark.el @@ -418,32 +418,29 @@ That is, all information but the name." (defvar gnus-bookmark-bmenu-bookmark-column nil) (defvar gnus-bookmark-bmenu-hidden-bookmarks ()) -(defvar gnus-bookmark-bmenu-mode-map nil) - -(if gnus-bookmark-bmenu-mode-map - nil - (setq gnus-bookmark-bmenu-mode-map (make-keymap)) - (suppress-keymap gnus-bookmark-bmenu-mode-map t) - (define-key gnus-bookmark-bmenu-mode-map "q" 'quit-window) - (define-key gnus-bookmark-bmenu-mode-map "\C-m" 'gnus-bookmark-bmenu-select) - (define-key gnus-bookmark-bmenu-mode-map "v" 'gnus-bookmark-bmenu-select) - (define-key gnus-bookmark-bmenu-mode-map "d" 'gnus-bookmark-bmenu-delete) - (define-key gnus-bookmark-bmenu-mode-map "k" 'gnus-bookmark-bmenu-delete) - (define-key gnus-bookmark-bmenu-mode-map "\C-d" 'gnus-bookmark-bmenu-delete-backwards) - (define-key gnus-bookmark-bmenu-mode-map "x" 'gnus-bookmark-bmenu-execute-deletions) - (define-key gnus-bookmark-bmenu-mode-map " " 'next-line) - (define-key gnus-bookmark-bmenu-mode-map "n" 'next-line) - (define-key gnus-bookmark-bmenu-mode-map "p" 'previous-line) - (define-key gnus-bookmark-bmenu-mode-map "\177" 'gnus-bookmark-bmenu-backup-unmark) - (define-key gnus-bookmark-bmenu-mode-map "?" 'describe-mode) - (define-key gnus-bookmark-bmenu-mode-map "u" 'gnus-bookmark-bmenu-unmark) - (define-key gnus-bookmark-bmenu-mode-map "m" 'gnus-bookmark-bmenu-mark) - (define-key gnus-bookmark-bmenu-mode-map "l" 'gnus-bookmark-bmenu-load) - (define-key gnus-bookmark-bmenu-mode-map "s" 'gnus-bookmark-bmenu-save) - (define-key gnus-bookmark-bmenu-mode-map "t" 'gnus-bookmark-bmenu-toggle-infos) - (define-key gnus-bookmark-bmenu-mode-map "a" 'gnus-bookmark-bmenu-show-details) - (define-key gnus-bookmark-bmenu-mode-map [mouse-2] - 'gnus-bookmark-bmenu-select-by-mouse)) + +(defvar-keymap gnus-bookmark-bmenu-mode-map + :full t + :suppress 'nodigits + "q" #'quit-window + "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 + "x" #'gnus-bookmark-bmenu-execute-deletions + "SPC" #'next-line + "n" #'next-line + "p" #'previous-line + "DEL" #'gnus-bookmark-bmenu-backup-unmark + "?" #'describe-mode + "u" #'gnus-bookmark-bmenu-unmark + "m" #'gnus-bookmark-bmenu-mark + "l" #'gnus-bookmark-bmenu-load + "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) ;; 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 e9eddae942f..00769a5da6e 100644 --- a/lisp/gnus/gnus-dired.el +++ b/lisp/gnus/gnus-dired.el @@ -53,12 +53,10 @@ (autoload 'message-buffers "message") (autoload 'gnus-print-buffer "gnus-sum") -(defvar gnus-dired-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-c\C-m\C-a" 'gnus-dired-attach) - (define-key map "\C-c\C-m\C-l" 'gnus-dired-find-file-mailcap) - (define-key map "\C-c\C-m\C-p" 'gnus-dired-print) - map)) +(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) ;; FIXME: Make it customizable, change the default to `mail-user-agent' when ;; this file is renamed (e.g. to `dired-mime.el'). @@ -206,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. @@ -246,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 9a0f21359f8..7c56db0ba45 100644 --- a/lisp/gnus/gnus-draft.el +++ b/lisp/gnus/gnus-draft.el @@ -33,15 +33,12 @@ ;;; Draft minor mode -(defvar gnus-draft-mode-map - (let ((map (make-sparse-keymap))) - (gnus-define-keys map - "Dt" 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) - map)) +(defvar-keymap gnus-draft-mode-map + "D t" #'gnus-draft-toggle-sending + "e" #' gnus-draft-edit-message ;; Use `B w' for `gnus-summary-edit-article' + "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 3fd8bf51de4..c727926731b 100644 --- a/lisp/gnus/gnus-eform.el +++ b/lisp/gnus/gnus-eform.el @@ -48,13 +48,10 @@ (defvar gnus-edit-form-buffer "*Gnus edit form*") (defvar gnus-edit-form-done-function nil) -(defvar gnus-edit-form-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map emacs-lisp-mode-map) - (gnus-define-keys map - "\C-c\C-c" gnus-edit-form-done - "\C-c\C-k" gnus-edit-form-exit) - map)) +(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) (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 b1e486b0627..b04293067c8 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. @@ -380,8 +380,8 @@ variables in the Lisp expression: `group-age': Time in seconds since the group was last read (see info node `(gnus)Group Timestamp')." :group 'gnus-group-visual - :type '(repeat (cons (sexp :tag "Form") face))) -(put 'gnus-group-highlight 'risky-local-variable t) + :type '(repeat (cons (sexp :tag "Form") face)) + :risky t) (defcustom gnus-new-mail-mark ?% "Mark used for groups with new mail." @@ -409,8 +409,8 @@ requires an understanding of Lisp expressions. Hopefully this will change in a future release. For now, you can use the same variables in the Lisp expression as in `gnus-group-highlight'." :group 'gnus-group-icons - :type '(repeat (cons (sexp :tag "Form") file))) -(put 'gnus-group-icon-list 'risky-local-variable t) + :type '(repeat (cons (sexp :tag "Form") file)) + :risky t) (defcustom gnus-group-name-charset-method-alist nil "Alist of method and the charset for group names. @@ -573,209 +573,209 @@ simple manner." ;;; Gnus group mode ;;; -(gnus-define-keys gnus-group-mode-map - " " 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 - "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 - "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 - "," 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 - "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 - "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 - "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 - "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 - "^" gnus-group-enter-server-mode - [mouse-2] gnus-mouse-pick-group - [follow-link] mouse-face - "<" beginning-of-buffer - ">" end-of-buffer - "\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 - "#" gnus-group-mark-group - "\M-#" gnus-group-unmark-group) - -(gnus-define-keys (gnus-group-cloud-map "~" gnus-group-mode-map) - "u" gnus-cloud-upload-all-data - "~" gnus-cloud-upload-all-data - "d" gnus-cloud-download-all-data - "\r" gnus-cloud-download-all-data) - -(gnus-define-keys (gnus-group-mark-map "M" gnus-group-mode-map) - "m" gnus-group-mark-group - "u" gnus-group-unmark-group - "w" gnus-group-mark-region - "b" gnus-group-mark-buffer - "r" gnus-group-mark-regexp - "U" gnus-group-unmark-all-groups) - -(gnus-define-keys (gnus-group-sieve-map "D" gnus-group-mode-map) - "u" gnus-sieve-update - "g" gnus-sieve-generate) - -(gnus-define-keys (gnus-group-group-map "G" gnus-group-mode-map) - "d" gnus-group-make-directory-group - "h" gnus-group-make-help-group - "u" gnus-group-make-useful-group - "l" gnus-group-nnimap-edit-acl - "m" gnus-group-make-group - "E" gnus-group-edit-group - "e" gnus-group-edit-group-method - "p" gnus-group-edit-group-parameters - "v" gnus-group-add-to-virtual - "V" gnus-group-make-empty-virtual - "D" gnus-group-enter-directory - "f" gnus-group-make-doc-group - "w" gnus-group-make-web-group - "G" gnus-group-read-ephemeral-search-group - "g" gnus-group-make-search-group - "M" gnus-group-read-ephemeral-group - "r" gnus-group-rename-group - "R" gnus-group-make-rss-group - "c" gnus-group-customize - "z" gnus-group-compact-group - "x" gnus-group-expunge-group - "\177" gnus-group-delete-group - [delete] gnus-group-delete-group) - -(gnus-define-keys (gnus-group-sort-map "S" gnus-group-group-map) - "s" gnus-group-sort-groups - "a" gnus-group-sort-groups-by-alphabet - "u" gnus-group-sort-groups-by-unread - "l" gnus-group-sort-groups-by-level - "v" gnus-group-sort-groups-by-score - "r" gnus-group-sort-groups-by-rank - "m" gnus-group-sort-groups-by-method - "n" gnus-group-sort-groups-by-real-name) - -(gnus-define-keys (gnus-group-sort-selected-map "P" gnus-group-group-map) - "s" gnus-group-sort-selected-groups - "a" gnus-group-sort-selected-groups-by-alphabet - "u" gnus-group-sort-selected-groups-by-unread - "l" gnus-group-sort-selected-groups-by-level - "v" gnus-group-sort-selected-groups-by-score - "r" gnus-group-sort-selected-groups-by-rank - "m" gnus-group-sort-selected-groups-by-method - "n" gnus-group-sort-selected-groups-by-real-name) - -(gnus-define-keys (gnus-group-list-map "A" gnus-group-mode-map) - "k" gnus-group-list-killed - "z" gnus-group-list-zombies - "s" gnus-group-list-groups - "u" gnus-group-list-all-groups - "A" gnus-group-list-active - "a" gnus-group-apropos - "d" gnus-group-description-apropos - "m" gnus-group-list-matching - "M" gnus-group-list-all-matching - "l" gnus-group-list-level - "c" gnus-group-list-cached - "?" gnus-group-list-dormant - "!" gnus-group-list-ticked) - -(gnus-define-keys (gnus-group-list-limit-map "/" gnus-group-list-map) - "k" gnus-group-list-limit - "z" gnus-group-list-limit - "s" gnus-group-list-limit - "u" gnus-group-list-limit - "A" gnus-group-list-limit - "m" gnus-group-list-limit - "M" gnus-group-list-limit - "l" gnus-group-list-limit - "c" gnus-group-list-limit - "?" gnus-group-list-limit - "!" gnus-group-list-limit) - -(gnus-define-keys (gnus-group-list-flush-map "f" gnus-group-list-map) - "k" gnus-group-list-flush - "z" gnus-group-list-flush - "s" gnus-group-list-flush - "u" gnus-group-list-flush - "A" gnus-group-list-flush - "m" gnus-group-list-flush - "M" gnus-group-list-flush - "l" gnus-group-list-flush - "c" gnus-group-list-flush - "?" gnus-group-list-flush - "!" gnus-group-list-flush) - -(gnus-define-keys (gnus-group-list-plus-map "p" gnus-group-list-map) - "k" gnus-group-list-plus - "z" gnus-group-list-plus - "s" gnus-group-list-plus - "u" gnus-group-list-plus - "A" gnus-group-list-plus - "m" gnus-group-list-plus - "M" gnus-group-list-plus - "l" gnus-group-list-plus - "c" gnus-group-list-plus - "?" gnus-group-list-plus - "!" gnus-group-list-plus) - -(gnus-define-keys (gnus-group-score-map "W" gnus-group-mode-map) - "f" gnus-score-flush-cache - "e" gnus-score-edit-all-score) - -(gnus-define-keys (gnus-group-help-map "H" gnus-group-mode-map) - "d" gnus-group-describe-group - "v" gnus-version) - -(gnus-define-keys (gnus-group-sub-map "S" gnus-group-mode-map) - "l" gnus-group-set-current-level - "t" gnus-group-toggle-subscription-at-point - "s" gnus-group-toggle-subscription - "k" gnus-group-kill-group - "y" gnus-group-yank-group - "w" gnus-group-kill-region - "\C-k" gnus-group-kill-level - "z" gnus-group-kill-all-zombies) +(define-keymap :keymap gnus-group-mode-map + "SPC" #'gnus-group-read-group + "=" #'gnus-group-select-group + "RET" #'gnus-group-select-group + "M-RET" #'gnus-group-quick-select-group + "M-SPC" #'gnus-group-visible-select-group + "C-M-<return>" #'gnus-group-select-group-ephemerally + "j" #'gnus-group-jump-to-group + "n" #'gnus-group-next-unread-group + "p" #'gnus-group-prev-unread-group + "DEL" #'gnus-group-prev-unread-group + "<delete>" #'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 + "," #'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 + "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 + "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 C-M-a" #'gnus-group-description-apropos + "a" #'gnus-group-post-news + "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 + "^" #'gnus-group-enter-server-mode + "<mouse-2>" #'gnus-mouse-pick-group + "<follow-link>" 'mouse-face + "<" #'beginning-of-buffer + ">" #'end-of-buffer + "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 + "#" #'gnus-group-mark-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 + "RET" #'gnus-cloud-download-all-data) + + "M" (define-keymap :prefix 'gnus-group-mark-map + "m" #'gnus-group-mark-group + "u" #'gnus-group-unmark-group + "w" #'gnus-group-mark-region + "b" #'gnus-group-mark-buffer + "r" #'gnus-group-mark-regexp + "U" #'gnus-group-unmark-all-groups) + + "D" (define-keymap :prefix 'gnus-group-sieve-map + "u" #'gnus-sieve-update + "g" #'gnus-sieve-generate) + + "G" (define-keymap :prefix 'gnus-group-group-map + "d" #'gnus-group-make-directory-group + "h" #'gnus-group-make-help-group + "u" #'gnus-group-make-useful-group + "l" #'gnus-group-nnimap-edit-acl + "m" #'gnus-group-make-group + "E" #'gnus-group-edit-group + "e" #'gnus-group-edit-group-method + "p" #'gnus-group-edit-group-parameters + "v" #'gnus-group-add-to-virtual + "V" #'gnus-group-make-empty-virtual + "D" #'gnus-group-enter-directory + "f" #'gnus-group-make-doc-group + "w" #'gnus-group-make-web-group + "G" #'gnus-group-read-ephemeral-search-group + "g" #'gnus-group-make-search-group + "M" #'gnus-group-read-ephemeral-group + "r" #'gnus-group-rename-group + "R" #'gnus-group-make-rss-group + "c" #'gnus-group-customize + "z" #'gnus-group-compact-group + "x" #'gnus-group-expunge-group + "DEL" #'gnus-group-delete-group + "<delete>" #'gnus-group-delete-group + + "S" (define-keymap :prefix 'gnus-group-sort-map + "s" #'gnus-group-sort-groups + "a" #'gnus-group-sort-groups-by-alphabet + "u" #'gnus-group-sort-groups-by-unread + "l" #'gnus-group-sort-groups-by-level + "v" #'gnus-group-sort-groups-by-score + "r" #'gnus-group-sort-groups-by-rank + "m" #'gnus-group-sort-groups-by-method + "n" #'gnus-group-sort-groups-by-real-name) + + "P" (define-keymap :prefix 'gnus-group-sort-selected-map + "s" #'gnus-group-sort-selected-groups + "a" #'gnus-group-sort-selected-groups-by-alphabet + "u" #'gnus-group-sort-selected-groups-by-unread + "l" #'gnus-group-sort-selected-groups-by-level + "v" #'gnus-group-sort-selected-groups-by-score + "r" #'gnus-group-sort-selected-groups-by-rank + "m" #'gnus-group-sort-selected-groups-by-method + "n" #'gnus-group-sort-selected-groups-by-real-name)) + + "A" (define-keymap :prefix 'gnus-group-list-map + "k" #'gnus-group-list-killed + "z" #'gnus-group-list-zombies + "s" #'gnus-group-list-groups + "u" #'gnus-group-list-all-groups + "A" #'gnus-group-list-active + "a" #'gnus-group-apropos + "d" #'gnus-group-description-apropos + "m" #'gnus-group-list-matching + "M" #'gnus-group-list-all-matching + "l" #'gnus-group-list-level + "c" #'gnus-group-list-cached + "?" #'gnus-group-list-dormant + "!" #'gnus-group-list-ticked + + "/" (define-keymap :prefix 'gnus-group-list-limit-map + "k" #'gnus-group-list-limit + "z" #'gnus-group-list-limit + "s" #'gnus-group-list-limit + "u" #'gnus-group-list-limit + "A" #'gnus-group-list-limit + "m" #'gnus-group-list-limit + "M" #'gnus-group-list-limit + "l" #'gnus-group-list-limit + "c" #'gnus-group-list-limit + "?" #'gnus-group-list-limit + "!" #'gnus-group-list-limit) + + "f" (define-keymap :prefix 'gnus-group-list-flush-map + "k" #'gnus-group-list-flush + "z" #'gnus-group-list-flush + "s" #'gnus-group-list-flush + "u" #'gnus-group-list-flush + "A" #'gnus-group-list-flush + "m" #'gnus-group-list-flush + "M" #'gnus-group-list-flush + "l" #'gnus-group-list-flush + "c" #'gnus-group-list-flush + "?" #'gnus-group-list-flush + "!" #'gnus-group-list-flush) + + "p" (define-keymap :prefix 'gnus-group-list-plus-map + "k" #'gnus-group-list-plus + "z" #'gnus-group-list-plus + "s" #'gnus-group-list-plus + "u" #'gnus-group-list-plus + "A" #'gnus-group-list-plus + "m" #'gnus-group-list-plus + "M" #'gnus-group-list-plus + "l" #'gnus-group-list-plus + "c" #'gnus-group-list-plus + "?" #'gnus-group-list-plus + "!" #'gnus-group-list-plus)) + + "W" (define-keymap :prefix 'gnus-group-score-map + "f" #'gnus-score-flush-cache + "e" #'gnus-score-edit-all-score) + + "H" (define-keymap :prefix 'gnus-group-help-map + "d" #'gnus-group-describe-group + "v" #'gnus-version) + + "S" (define-keymap :prefix 'gnus-group-sub-map + "l" #'gnus-group-set-current-level + "t" #'gnus-group-toggle-subscription-at-point + "s" #'gnus-group-toggle-subscription + "k" #'gnus-group-kill-group + "y" #'gnus-group-yank-group + "w" #'gnus-group-kill-region + "C-k" #'gnus-group-kill-level + "z" #'gnus-group-kill-all-zombies)) (defun gnus-topic-mode-p () "Return non-nil in `gnus-topic-mode'." diff --git a/lisp/gnus/gnus-html.el b/lisp/gnus/gnus-html.el index be62bfd81f5..ef376f138e7 100644 --- a/lisp/gnus/gnus-html.el +++ b/lisp/gnus/gnus-html.el @@ -71,21 +71,17 @@ fit these criteria." :group 'gnus-art :type 'float) -(defvar gnus-html-image-map - (let ((map (make-sparse-keymap))) - (define-key map "u" 'gnus-article-copy-string) - (define-key map "i" 'gnus-html-insert-image) - (define-key map "v" 'gnus-html-browse-url) - map)) - -(defvar gnus-html-displayed-image-map - (let ((map (make-sparse-keymap))) - (define-key map "a" 'gnus-html-show-alt-text) - (define-key map "i" 'gnus-html-browse-image) - (define-key map "\r" 'gnus-html-browse-url) - (define-key map "u" 'gnus-article-copy-string) - (define-key map [tab] 'button-forward) - map)) +(defvar-keymap gnus-html-image-map + "u" #'gnus-article-copy-string + "i" #'gnus-html-insert-image + "v" #'gnus-html-browse-url) + +(defvar-keymap gnus-html-displayed-image-map + "a" #'gnus-html-show-alt-text + "i" #'gnus-html-browse-image + "RET" #'gnus-html-browse-url + "u" #'gnus-article-copy-string + "<tab>" #'forward-button) (defun gnus-html-encode-url (url) "Encode URL." diff --git a/lisp/gnus/gnus-icalendar.el b/lisp/gnus/gnus-icalendar.el index b6e5e7f786a..81e46d7a51e 100644 --- a/lisp/gnus/gnus-icalendar.el +++ b/lisp/gnus/gnus-icalendar.el @@ -194,7 +194,11 @@ (caddr event)))) (cl-labels - ((attendee-role (prop) (plist-get (cadr prop) 'ROLE)) + ((attendee-role (prop) + ;; RFC5546: default ROLE is REQ-PARTICIPANT + (and prop + (or (plist-get (cadr prop) 'ROLE) + "REQ-PARTICIPANT"))) (attendee-name (prop) (or (plist-get (cadr prop) 'CN) @@ -225,7 +229,10 @@ (gnus-icalendar-event--find-attendee ical attendee-name-or-email))) (attendee-names (gnus-icalendar-event--get-attendee-names ical)) - (role (plist-get (cadr attendee) 'ROLE)) + ;; RFC5546: default ROLE is REQ-PARTICIPANT + (role (and attendee + (or (plist-get (cadr attendee) 'ROLE) + "REQ-PARTICIPANT"))) (participation-type (pcase role ("REQ-PARTICIPANT" 'required) ("OPT-PARTICIPANT" 'optional) @@ -345,10 +352,16 @@ status will be retrieved from the first matching attendee record." (mapc #'process-event-line (split-string ical-request "\n")) + ;; RFC5546 refers to uninvited attendees as "party crashers". + ;; This situation is common if the invitation is sent to a group + ;; of people via a mailing list. (unless (gnus-icalendar-find-if (lambda (x) (string-match "^ATTENDEE" x)) reply-event-lines) (lwarn 'gnus-icalendar :warning - "Could not find an event attendee matching given identity")) + "Could not find an event attendee matching given identity") + (push (format "ATTENDEE;RSVP=TRUE;PARTSTAT=%s;CN=%s:MAILTO:%s" + attendee-status user-full-name user-mail-address) + reply-event-lines)) (mapconcat #'identity `("BEGIN:VEVENT" ,@(nreverse reply-event-lines) @@ -847,10 +860,14 @@ These will be used to retrieve the RSVP information from ical events." button t gnus-data ,data)))) -(defun gnus-icalendar-send-buffer-by-mail (buffer-name subject) +(defun gnus-icalendar-send-buffer-by-mail (buffer-name subject organizer) (let ((message-signature nil)) (with-current-buffer gnus-summary-buffer (gnus-summary-reply) + ;; Reply to the organizer, not to whoever sent the invitation. person + ;; Some calendar systems use specific email address as organizer to + ;; receive these responses. + (message-replace-header "To" organizer) (message-goto-body) (mml-insert-multipart "alternative") (mml-insert-empty-tag 'part 'type "text/plain") @@ -866,7 +883,8 @@ These will be used to retrieve the RSVP information from ical events." (event (caddr data)) (reply (gnus-icalendar-with-decoded-handle handle (gnus-icalendar-event-reply-from-buffer - (current-buffer) status (gnus-icalendar-identities))))) + (current-buffer) status (gnus-icalendar-identities)))) + (organizer (gnus-icalendar-event:organizer event))) (when reply (cl-labels @@ -883,7 +901,7 @@ These will be used to retrieve the RSVP information from ical events." (delete-region (point-min) (point-max)) (insert reply) (fold-icalendar-buffer) - (gnus-icalendar-send-buffer-by-mail (buffer-name) subject)) + (gnus-icalendar-send-buffer-by-mail (buffer-name) subject organizer)) ;; Back in article buffer (setq-local gnus-icalendar-reply-status status) @@ -897,10 +915,16 @@ These will be used to retrieve the RSVP information from ical events." (gnus-icalendar-event:sync-to-org event gnus-icalendar-reply-status)) (cl-defmethod gnus-icalendar-event:inline-reply-buttons ((event gnus-icalendar-event) handle) - (when (gnus-icalendar-event:rsvp event) - `(("Accept" gnus-icalendar-reply (,handle accepted ,event)) - ("Tentative" gnus-icalendar-reply (,handle tentative ,event)) - ("Decline" gnus-icalendar-reply (,handle declined ,event))))) + (let ((accept-btn "Accept") + (tentative-btn "Tentative") + (decline-btn "Decline")) + (unless (gnus-icalendar-event:rsvp event) + (setq accept-btn "Uninvited Accept" + tentative-btn "Uninvited Tentative" + decline-btn "Uninvited Decline")) + `((,accept-btn gnus-icalendar-reply (,handle accepted ,event)) + (,tentative-btn gnus-icalendar-reply (,handle tentative ,event)) + (,decline-btn gnus-icalendar-reply (,handle declined ,event))))) (cl-defmethod gnus-icalendar-event:inline-reply-buttons ((_event gnus-icalendar-event-reply) _handle) "No buttons for REPLY events." @@ -1038,13 +1062,14 @@ These will be used to retrieve the RSVP information from ical events." (add-to-list 'mm-automatic-display "text/calendar") (add-to-list 'mm-inline-media-tests '("text/calendar" gnus-icalendar-mm-inline identity)) - (gnus-define-keys (gnus-summary-calendar-map "i" gnus-summary-mode-map) - "a" gnus-icalendar-reply-accept - "t" gnus-icalendar-reply-tentative - "d" gnus-icalendar-reply-decline - "c" gnus-icalendar-event-check-agenda - "e" gnus-icalendar-event-export - "s" gnus-icalendar-event-show) + (define-key gnus-summary-mode-map "i" + (define-keymap :prefix 'gnus-summary-calendar-map + "a" #'gnus-icalendar-reply-accept + "t" #'gnus-icalendar-reply-tentative + "d" #'gnus-icalendar-reply-decline + "c" #'gnus-icalendar-event-check-agenda + "e" #'gnus-icalendar-event-export + "s" #'gnus-icalendar-event-show)) (require 'gnus-art) (add-to-list 'gnus-mime-action-alist diff --git a/lisp/gnus/gnus-kill.el b/lisp/gnus/gnus-kill.el index 525823e72ce..7137efd7309 100644 --- a/lisp/gnus/gnus-kill.el +++ b/lisp/gnus/gnus-kill.el @@ -66,18 +66,15 @@ of time." ;;; Gnus Kill File Mode ;;; -(defvar gnus-kill-file-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map emacs-lisp-mode-map) - (gnus-define-keymap 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) - map)) +(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) (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 ee3abf2f7be..a5358e9ff42 100644 --- a/lisp/gnus/gnus-ml.el +++ b/lisp/gnus/gnus-ml.el @@ -31,16 +31,13 @@ ;;; Mailing list minor mode -(defvar gnus-mailing-list-mode-map - (let ((map (make-sparse-keymap))) - (gnus-define-keys 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) - map)) +(defvar-keymap gnus-mailing-list-mode-map + "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 8a3272042f3..c60faa13263 100644 --- a/lisp/gnus/gnus-msg.el +++ b/lisp/gnus/gnus-msg.el @@ -349,39 +349,39 @@ only affect the Gcc copy, but not the original message." ;;; Gnus Posting Functions ;;; -(gnus-define-keys (gnus-summary-send-map "S" gnus-summary-mode-map) - "p" gnus-summary-post-news - "i" gnus-summary-news-other-window - "f" gnus-summary-followup - "F" gnus-summary-followup-with-original - "c" gnus-summary-cancel-article - "s" gnus-summary-supersede-article - "r" gnus-summary-reply - "y" gnus-summary-yank-message - "R" gnus-summary-reply-with-original - "L" gnus-summary-reply-to-list-with-original - "w" gnus-summary-wide-reply - "W" gnus-summary-wide-reply-with-original - "v" gnus-summary-very-wide-reply - "V" gnus-summary-very-wide-reply-with-original - "n" gnus-summary-followup-to-mail - "N" gnus-summary-followup-to-mail-with-original - "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) - -(gnus-define-keys (gnus-send-bounce-map "D" gnus-summary-send-map) - "b" gnus-summary-resend-bounced-mail - ;; "c" gnus-summary-send-draft - "r" gnus-summary-resend-message - "e" gnus-summary-resend-message-edit) +(define-keymap :prefix 'gnus-summary-send-map + "p" #'gnus-summary-post-news + "i" #'gnus-summary-news-other-window + "f" #'gnus-summary-followup + "F" #'gnus-summary-followup-with-original + "c" #'gnus-summary-cancel-article + "s" #'gnus-summary-supersede-article + "r" #'gnus-summary-reply + "y" #'gnus-summary-yank-message + "R" #'gnus-summary-reply-with-original + "L" #'gnus-summary-reply-to-list-with-original + "w" #'gnus-summary-wide-reply + "W" #'gnus-summary-wide-reply-with-original + "v" #'gnus-summary-very-wide-reply + "V" #'gnus-summary-very-wide-reply-with-original + "n" #'gnus-summary-followup-to-mail + "N" #'gnus-summary-followup-to-mail-with-original + "m" #'gnus-summary-mail-other-window + "u" #'gnus-uu-post-news + "A" #'gnus-summary-attach-article + "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 + ;; "c" gnus-summary-send-draft + "r" #'gnus-summary-resend-message + "e" #'gnus-summary-resend-message-edit)) ;;; Internal functions. @@ -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)) @@ -1748,7 +1748,7 @@ this is a reply." (concat "\"" str "\"") str))) (when groups - (insert " "))) + (insert ","))) (insert "\n"))))))) (defun gnus-mailing-list-followup-to () diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el index 9b76f983227..163d543afd1 100644 --- a/lisp/gnus/gnus-registry.el +++ b/lisp/gnus/gnus-registry.el @@ -847,7 +847,8 @@ Overrides existing keywords with FORCE set non-nil." (defun gnus-registry-register-message-ids () "Register the Message-ID of every article in the group." (unless (or (gnus-parameter-registry-ignore gnus-newsgroup-name) - (null gnus-registry-register-all)) + (null gnus-registry-register-all) + (null (eieio-object-p gnus-registry-db))) (dolist (article gnus-newsgroup-articles) (let* ((id (gnus-registry-fetch-message-id-fast article)) (groups (gnus-registry-get-id-key id 'group))) @@ -990,9 +991,9 @@ Uses `gnus-registry-marks' to find what shortcuts to install." gnus-registry-misc-menus) (gnus-message 9 "Defined mark handling function %s" function-name)))))) - (gnus-define-keys-1 - '(gnus-registry-mark-map "M" gnus-summary-mark-map) - keys-plist) + (define-key gnus-summary-mark-map "M" + (apply #'define-keymap :prefix 'gnus-summary-mark-map + keys-plist)) (add-hook 'gnus-summary-menu-hook (lambda () (easy-menu-add-item @@ -1142,7 +1143,7 @@ non-nil." entry) (while (car-safe old) (cl-incf count) - ;; don't use progress reporters for backwards compatibility + ;; todo: use progress reporters. (when (and (< 0 expected) (= 0 (mod count 100))) (message "importing: %d of %d (%.2f%%)" diff --git a/lisp/gnus/gnus-rmail.el b/lisp/gnus/gnus-rmail.el new file mode 100644 index 00000000000..f9dcc286a68 --- /dev/null +++ b/lisp/gnus/gnus-rmail.el @@ -0,0 +1,142 @@ +;;; gnus-rmail.el --- Saving to rmail/babyl files -*- 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +;;; Functions for saving to babyl/mail files. + +(require 'rmail) +(require 'rmailsum) +(require 'nnmail) + +(defun gnus-output-to-rmail (filename &optional ask) + "Append the current article to an Rmail file named FILENAME. +In Emacs 22 this writes Babyl format; in Emacs 23 it writes mbox unless +FILENAME exists and is Babyl format." + ;; Some of this codes is borrowed from rmailout.el. + (setq filename (expand-file-name filename)) + ;; FIXME should we really be messing with this defcustom? + ;; It is not needed for the operation of this function. + (if (boundp 'rmail-default-rmail-file) + (setq rmail-default-rmail-file filename) ; 22 + (setq rmail-default-file filename)) ; 23 + (let ((artbuf (current-buffer)) + (tmpbuf (gnus-get-buffer-create " *Gnus-output*")) + ;; Babyl rmail.el defines this, mbox does not. + (babyl (fboundp 'rmail-insert-rmail-file-header))) + (save-excursion + ;; Note that we ignore the possibility of visiting a Babyl + ;; format buffer in Emacs 23, since Rmail no longer supports that. + (or (get-file-buffer filename) + (progn + ;; In case someone wants to write to a Babyl file from Emacs 23. + (when (file-exists-p filename) + (setq babyl (mail-file-babyl-p filename)) + t)) + (if (or (not ask) + (gnus-yes-or-no-p + (concat "\"" filename "\" does not exist, create it? "))) + (let ((file-buffer (create-file-buffer filename))) + (with-current-buffer file-buffer + (if (fboundp 'rmail-insert-rmail-file-header) + (rmail-insert-rmail-file-header)) + (let ((require-final-newline nil) + (coding-system-for-write mm-text-coding-system)) + (gnus-write-buffer filename))) + (kill-buffer file-buffer)) + (error "Output file does not exist"))) + (set-buffer tmpbuf) + (erase-buffer) + (insert-buffer-substring artbuf) + (if babyl + (gnus-convert-article-to-rmail) + ;; Non-Babyl case copied from gnus-output-to-mail. + (goto-char (point-min)) + (if (looking-at "From ") + (forward-line 1) + (insert "From nobody " (current-time-string) "\n")) + (let (case-fold-search) + (while (re-search-forward "^From " nil t) + (beginning-of-line) + (insert ">")))) + ;; Decide whether to append to a file or to an Emacs buffer. + (let ((outbuf (get-file-buffer filename))) + (if (not outbuf) + (progn + (unless babyl ; from gnus-output-to-mail + (let ((buffer-read-only nil)) + (goto-char (point-max)) + (forward-char -2) + (unless (looking-at "\n\n") + (goto-char (point-max)) + (unless (bolp) + (insert "\n")) + (insert "\n")))) + (let ((file-name-coding-system nnmail-pathname-coding-system)) + (mm-append-to-file (point-min) (point-max) filename))) + ;; File has been visited, in buffer OUTBUF. + (set-buffer outbuf) + (let ((buffer-read-only nil) + (msg (and (boundp 'rmail-current-message) + (symbol-value 'rmail-current-message)))) + ;; If MSG is non-nil, buffer is in RMAIL mode. + ;; Compare this with rmail-output-to-rmail-buffer in Emacs 23. + (when msg + (unless babyl + (rmail-swap-buffers-maybe) + (rmail-maybe-set-message-counters)) + (widen) + (unless babyl + (goto-char (point-max)) + ;; Ensure we have a blank line before the next message. + (unless (bolp) + (insert "\n")) + (insert "\n")) + (narrow-to-region (point-max) (point-max))) + (insert-buffer-substring tmpbuf) + (when msg + (when babyl + (goto-char (point-min)) + (widen) + (search-backward "\n\^_") + (narrow-to-region (point) (point-max))) + (rmail-count-new-messages t) + (when (rmail-summary-exists) + (rmail-select-summary + (rmail-update-summary))) + (rmail-show-message msg)) + (save-buffer))))) + (kill-buffer tmpbuf))) + +(defun gnus-convert-article-to-rmail () + "Convert article in current buffer to Rmail message format." + (let ((buffer-read-only nil)) + ;; Convert article directly into Babyl format. + (goto-char (point-min)) + (insert "\^L\n0, unseen,,\n*** EOOH ***\n") + (while (search-forward "\n\^_" nil t) ;single char + (replace-match "\n^_" t t)) ;2 chars: "^" and "_" + (goto-char (point-max)) + (insert "\^_"))) + +;;; gnus-rmail.el ends here diff --git a/lisp/gnus/gnus-salt.el b/lisp/gnus/gnus-salt.el index dc81dfc5f6c..205e936bc7e 100644 --- a/lisp/gnus/gnus-salt.el +++ b/lisp/gnus/gnus-salt.el @@ -64,15 +64,12 @@ It accepts the same format specs that `gnus-summary-line-format' does." ;;; Internal variables. -(defvar gnus-pick-mode-map - (let ((map (make-sparse-keymap))) - (gnus-define-keys map - " " 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) - map)) +(defvar-keymap gnus-pick-mode-map + "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 + "RET" #'gnus-pick-start-reading) (defun gnus-pick-make-menu-bar () (unless (boundp 'gnus-pick-menu) @@ -315,11 +312,8 @@ This must be bound to a button-down mouse event." (defvar gnus-binary-mode-hook nil "Hook run in summary binary mode buffers.") -(defvar gnus-binary-mode-map - (let ((map (make-sparse-keymap))) - (gnus-define-keys map - "g" gnus-binary-show-article) - map)) +(defvar-keymap gnus-binary-mode-map + "g" #'gnus-binary-show-article) (defun gnus-binary-make-menu-bar () (unless (boundp 'gnus-binary-menu) @@ -424,21 +418,17 @@ Two predefined functions are available: (defvar gnus-tree-displayed-thread nil) (defvar gnus-tree-inhibit nil) -(defvar gnus-tree-mode-map - (let ((map (make-keymap))) - (suppress-keymap map) - (gnus-define-keys - map - "\r" gnus-tree-select-article - [mouse-2] gnus-tree-pick-article - "\C-?" gnus-tree-read-summary-keys - "h" gnus-tree-show-summary - - "\C-c\C-i" gnus-info-find-node) - - (substitute-key-definition - 'undefined 'gnus-tree-read-summary-keys map) - map)) +(defvar-keymap gnus-tree-mode-map + :full t :suppress t + "RET" #'gnus-tree-select-article + "<mouse-2>" #'gnus-tree-pick-article + "DEL" #'gnus-tree-read-summary-keys + "h" #'gnus-tree-show-summary + + "C-c C-i" #'gnus-info-find-node) + +(substitute-key-definition 'undefined #'gnus-tree-read-summary-keys + gnus-tree-mode-map) (defun gnus-tree-make-menu-bar () (unless (boundp 'gnus-tree-menu) diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el index e0ad9f698d3..a25673a0e75 100644 --- a/lisp/gnus/gnus-score.el +++ b/lisp/gnus/gnus-score.el @@ -502,19 +502,20 @@ of the last successful match.") ;;; Summary mode score maps. -(gnus-define-keys (gnus-summary-score-map "V" gnus-summary-mode-map) - "s" gnus-summary-set-score - "S" gnus-summary-current-score - "c" gnus-score-change-score-file - "C" gnus-score-customize - "m" gnus-score-set-mark-below - "x" gnus-score-set-expunge-below - "R" gnus-summary-rescore - "e" gnus-score-edit-current-scores - "f" gnus-score-edit-file - "F" gnus-score-flush-cache - "t" gnus-score-find-trace - "w" gnus-score-find-favorite-words) +(define-key gnus-summary-mode-map "V" + (define-keymap :prefix 'gnus-summary-score-map + "s" #'gnus-summary-set-score + "S" #'gnus-summary-current-score + "c" #'gnus-score-change-score-file + "C" #'gnus-score-customize + "m" #'gnus-score-set-mark-below + "x" #'gnus-score-set-expunge-below + "R" #'gnus-summary-rescore + "e" #'gnus-score-edit-current-scores + "f" #'gnus-score-edit-file + "F" #'gnus-score-flush-cache + "t" #'gnus-score-find-trace + "w" #'gnus-score-find-favorite-words)) ;; Summary score file commands @@ -1748,7 +1749,7 @@ score in `gnus-newsgroup-scored' by SCORE." (setq type 'after match-func 'string< match (gnus-time-iso8601 - (time-subtract (current-time) + (time-subtract nil (* 86400 (nth 0 kill)))))) ((eq type 'before) (setq match-func 'gnus-string> @@ -1757,7 +1758,7 @@ score in `gnus-newsgroup-scored' by SCORE." (setq type 'before match-func 'gnus-string> match (gnus-time-iso8601 - (time-subtract (current-time) + (time-subtract nil (* 86400 (nth 0 kill)))))) ((eq type 'at) (setq match-func 'string= @@ -2561,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-search.el b/lisp/gnus/gnus-search.el index 9c83d5fa376..d64c0cb90c3 100644 --- a/lisp/gnus/gnus-search.el +++ b/lisp/gnus/gnus-search.el @@ -105,9 +105,13 @@ (gnus-add-shutdown #'gnus-search-shutdown 'gnus) -(define-error 'gnus-search-parse-error "Gnus search parsing error") +(define-error 'gnus-search-error "Gnus search error") -(define-error 'gnus-search-config-error "Gnus search configuration error") +(define-error 'gnus-search-parse-error "Gnus search parsing error" + 'gnus-search-error) + +(define-error 'gnus-search-config-error "Gnus search configuration error" + 'gnus-search-error) ;;; User Customizable Variables: @@ -568,15 +572,13 @@ REL-DATE, or (current-time) if REL-DATE is nil." ;; Time parsing doesn't seem to work with slashes. (let ((value (string-replace "/" "-" value)) (now (append '(0 0 0) - (seq-subseq (decode-time (or rel-date - (current-time))) - 3)))) + (seq-subseq (decode-time rel-date) 3)))) ;; Check for relative time parsing. (if (string-match "\\([[:digit:]]+\\)\\([dwmy]\\)" value) (seq-subseq (decode-time (time-subtract - (apply #'encode-time now) + (encode-time now) (days-to-time (* (string-to-number (match-string 1 value)) (cdr (assoc (match-string 2 value) @@ -595,7 +597,7 @@ REL-DATE, or (current-time) if REL-DATE is nil." ;; If DOW is given, handle that specially. (if (and (seq-elt d-time 6) (null (seq-elt d-time 3))) (decode-time - (time-subtract (apply #'encode-time now) + (time-subtract (encode-time now) (days-to-time (+ (if (> (seq-elt d-time 6) (seq-elt now 6)) @@ -1018,7 +1020,7 @@ Responsible for handling and, or, and parenthetical expressions.") (single-search (gnus-search-single-p query)) (grouplist (or groups (gnus-search-get-active srv))) q-string artlist group) - (message "Opening server %s" server) + (gnus-message 7 "Opening server %s" server) (gnus-open-server srv) ;; We should only be doing this once, in ;; `nnimap-open-connection', but it's too frustrating to try to @@ -1058,11 +1060,11 @@ Responsible for handling and, or, and parenthetical expressions.") q-string))) (while (and (setq group (pop grouplist)) - (or (null single-search) (null artlist))) + (or (null single-search) (= 0 (length artlist)))) (when (nnimap-change-group (gnus-group-short-name group) server) (with-current-buffer (nnimap-buffer) - (message "Searching %s..." group) + (gnus-message 7 "Searching %s..." group) (let ((result (gnus-search-imap-search-command engine q-string))) (when (car result) @@ -1075,7 +1077,7 @@ Responsible for handling and, or, and parenthetical expressions.") (vector group artn 100)))) (cdr (assoc "SEARCH" (cdr result)))) artlist)))) - (message "Searching %s...done" group)))) + (gnus-message 7 "Searching %s...done" group)))) (nreverse artlist)))) (cl-defmethod gnus-search-imap-search-command ((engine gnus-search-imap) @@ -1084,7 +1086,8 @@ Responsible for handling and, or, and parenthetical expressions.") Currently takes into account support for the LITERAL+ capability. Other capabilities could be tested here." (with-slots (literal-plus) engine - (when literal-plus + (when (and literal-plus + (string-match-p "\n" query)) (setq query (split-string query "\n"))) (cond ((consp query) @@ -1234,8 +1237,7 @@ nil (except that (dd nil yyyy) is not allowed). Massage those numbers into the most recent past occurrence of whichever date elements are present." (pcase-let ((`(,nday ,nmonth ,nyear) - (seq-subseq (decode-time (current-time)) - 3 6)) + (seq-subseq (decode-time) 3 6)) (`(,dday ,dmonth ,dyear) date)) (unless (and dday dmonth dyear) (unless dday (setq dday 1)) @@ -1255,9 +1257,7 @@ elements are present." (setq dmonth 1)))) (format-time-string "%e-%b-%Y" - (apply #'encode-time - (append '(0 0 0) - (list dday dmonth dyear)))))) + (encode-time 0 0 0 dday dmonth dyear)))) (cl-defmethod gnus-search-imap-handle-string ((engine gnus-search-imap) (str string)) @@ -1329,8 +1329,8 @@ Returns a list of [group article score] vectors." (erase-buffer) (if groups - (message "Doing %s query on %s..." program groups) - (message "Doing %s query..." program)) + (gnus-message 7 "Doing %s query on %s..." program groups) + (gnus-message 7 "Doing %s query..." program)) (setq proc (apply #'start-process (format "search-%s" server) buffer program cp-list)) (while (process-live-p proc) @@ -1836,8 +1836,8 @@ Assume \"size\" key is equal to \"larger\"." (mapcar (lambda (x) (let ((group x) artlist) - (message "Searching %s using find-grep..." - (or group server)) + (gnus-message 7 "Searching %s using find-grep..." + (or group server)) (save-window-excursion (set-buffer buffer) (if (> gnus-verbose 6) @@ -1892,8 +1892,8 @@ Assume \"size\" key is equal to \"larger\"." (vector (gnus-group-full-name group server) art 0) artlist)) (forward-line 1))) - (message "Searching %s using find-grep...done" - (or group server)) + (gnus-message 7 "Searching %s using find-grep...done" + (or group server)) artlist))) grouplist)))) @@ -1926,7 +1926,7 @@ Assume \"size\" key is equal to \"larger\"." (apply #'nnheader-message 4 "Search engine for %s improperly configured: %s" server (cdr err)) - (signal 'gnus-search-config-error err))))) + (signal (car err) (cdr err)))))) (alist-get 'search-group-spec specs)) ;; Some search engines do their own limiting, but some don't, so ;; do it again here. This is bad because, if the user is diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el index 5f2fc463330..fa880b7eddb 100644 --- a/lisp/gnus/gnus-srvr.el +++ b/lisp/gnus/gnus-srvr.el @@ -103,7 +103,43 @@ If nil, a faster, but more primitive, buffer is used instead." (defvar gnus-server-mode-line-format-spec nil) (defvar gnus-server-killed-servers nil) -(defvar gnus-server-mode-map nil) +(defvar-keymap gnus-server-mode-map + :full t :suppress t + "SPC" #'gnus-server-read-server-in-server-buffer + "RET" #'gnus-server-read-server + "<mouse-2>" #'gnus-server-pick-server + "q" #'gnus-server-exit + "l" #'gnus-server-list-servers + "k" #'gnus-server-kill-server + "y" #'gnus-server-yank-server + "c" #'gnus-server-copy-server + "a" #'gnus-server-add-server + "e" #'gnus-server-edit-server + "S" #'gnus-server-show-server + "s" #'gnus-server-scan-server + + "O" #'gnus-server-open-server + "M-o" #'gnus-server-open-all-servers + "C" #'gnus-server-close-server + "M-c" #'gnus-server-close-all-servers + "D" #'gnus-server-deny-server + "L" #'gnus-server-offline-server + "R" #'gnus-server-remove-denials + + "n" #'next-line + "p" #'previous-line + + "g" #'gnus-server-regenerate-server + + "G" #'gnus-group-read-ephemeral-search-group + + "z" #'gnus-server-compact-server + + "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) (defcustom gnus-server-menu-hook nil "Hook run after the creation of the server mode menu." @@ -145,47 +181,6 @@ If nil, a faster, but more primitive, buffer is used instead." (gnus-run-hooks 'gnus-server-menu-hook))) -(unless gnus-server-mode-map - (setq gnus-server-mode-map (make-keymap)) - (suppress-keymap gnus-server-mode-map) - - (gnus-define-keys gnus-server-mode-map - " " gnus-server-read-server-in-server-buffer - "\r" gnus-server-read-server - [mouse-2] gnus-server-pick-server - "q" gnus-server-exit - "l" gnus-server-list-servers - "k" gnus-server-kill-server - "y" gnus-server-yank-server - "c" gnus-server-copy-server - "a" gnus-server-add-server - "e" gnus-server-edit-server - "S" gnus-server-show-server - "s" gnus-server-scan-server - - "O" gnus-server-open-server - "\M-o" gnus-server-open-all-servers - "C" gnus-server-close-server - "\M-c" gnus-server-close-all-servers - "D" gnus-server-deny-server - "L" gnus-server-offline-server - "R" gnus-server-remove-denials - - "n" next-line - "p" previous-line - - "g" gnus-server-regenerate-server - - "G" gnus-group-read-ephemeral-search-group - - "z" gnus-server-compact-server - - "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)) - (defface gnus-server-agent '((((class color) (background light)) (:foreground "PaleTurquoise" :bold t)) (((class color) (background dark)) (:foreground "PaleTurquoise" :bold t)) @@ -697,37 +692,31 @@ claim them." function (repeat function))) -(defvar gnus-browse-mode-map nil) - -(unless gnus-browse-mode-map - (setq gnus-browse-mode-map (make-keymap)) - (suppress-keymap gnus-browse-mode-map) - - (gnus-define-keys - gnus-browse-mode-map - " " 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 - "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 - "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-describe-briefly - - "\C-c\C-i" gnus-info-find-node - "\C-c\C-b" gnus-bug)) +(defvar-keymap gnus-browse-mode-map + :full t :suppress t + "SPC" #'gnus-browse-read-group + "=" #'gnus-browse-select-group + "n" #'gnus-browse-next-group + "p" #'gnus-browse-prev-group + "DEL" #'gnus-browse-prev-group + "<delete>" #'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 + "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-describe-briefly + + "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-start.el b/lisp/gnus/gnus-start.el index c7be958edd1..606bd3a39a4 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -663,6 +663,7 @@ the first newsgroup." (defvar mail-sources) (defvar nnmail-scan-directory-mail-source-once) (defvar nnmail-split-history) +(defvar gnus-save-newsrc-file-last-timestamp nil) (defun gnus-close-all-servers () "Close all servers." @@ -707,6 +708,7 @@ the first newsgroup." gnus-current-select-method nil nnmail-split-history nil gnus-extended-servers nil + gnus-save-newsrc-file-last-timestamp nil gnus-ephemeral-servers nil) (gnus-shutdown 'gnus) ;; Kill the startup file. @@ -2731,7 +2733,6 @@ The form should return either t or nil." 'msdos-long-file-names (lambda () t)))) -(defvar gnus-save-newsrc-file-last-timestamp nil) (defun gnus-save-newsrc-file (&optional force) "Save .newsrc file. Use the group string names in `gnus-group-list' to pull info diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index d790655aa90..cda6712f0d8 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -1182,8 +1182,8 @@ mark: The article's mark. uncached: Non-nil if the article is uncached." :group 'gnus-summary-visual :type '(repeat (cons (sexp :tag "Form" nil) - face))) -(put 'gnus-summary-highlight 'risky-local-variable t) + face)) + :risky t) (defcustom gnus-alter-header-function nil "Function called to allow alteration of article header structures. @@ -1907,485 +1907,483 @@ increase the score of each group you read." ;; Non-orthogonal keys -(gnus-define-keys 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 - "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 - "." 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 - "<" 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 - "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 - "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 - "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 - "&" gnus-summary-execute-command - "c" gnus-summary-catchup-and-exit - "\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 - "=" 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 - "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 - "o" gnus-summary-save-article - "\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 +(define-keymap :keymap gnus-summary-mode-map + "SPC" #'gnus-summary-next-page + "S-SPC" #'gnus-summary-prev-page + "DEL" #'gnus-summary-prev-page + "<delete>" #'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 + "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 + "<" #'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 + "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 + "k" #'gnus-summary-kill-same-subject-and-select + "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 + "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-<down>" #'gnus-summary-next-thread + "M-<up>" #'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 + "?" #'gnus-summary-mark-as-dormant + "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 + "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 + "o" #'gnus-summary-save-article + "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 ;; "V" gnus-version - "\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 - "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 - "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 - "*" gnus-cache-enter-article - "\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 - "h" gnus-summary-select-article-buffer - - "b" gnus-article-view-part - "\M-t" gnus-summary-toggle-display-buttonized - - "V" gnus-summary-score-map - "X" gnus-uu-extract-map - "S" gnus-summary-send-map) - -;; Sort of orthogonal keymap -(gnus-define-keys (gnus-summary-mark-map "M" gnus-summary-mode-map) - "t" gnus-summary-tick-article-forward - "!" gnus-summary-tick-article-forward - "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 - "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 - "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 - "k" gnus-summary-kill-same-subject-and-select - "K" gnus-summary-kill-same-subject - "P" gnus-uu-mark-map) - -(gnus-define-keys (gnus-summary-mscore-map "V" gnus-summary-mark-map) - "c" gnus-summary-clear-above - "u" gnus-summary-tick-above - "m" gnus-summary-mark-above - "k" gnus-summary-kill-below) - -(gnus-define-keys (gnus-summary-limit-map "/" gnus-summary-mode-map) - "/" gnus-summary-limit-to-subject - "n" gnus-summary-limit-to-articles - "b" gnus-summary-limit-to-bodies - "h" gnus-summary-limit-to-headers - "w" gnus-summary-pop-limit - "s" gnus-summary-limit-to-subject - "a" gnus-summary-limit-to-author - "u" gnus-summary-limit-to-unread - "m" gnus-summary-limit-to-marks - "M" gnus-summary-limit-exclude-marks - "v" gnus-summary-limit-to-score - "*" gnus-summary-limit-include-cached - "D" gnus-summary-limit-include-dormant - "T" gnus-summary-limit-include-thread - "d" gnus-summary-limit-exclude-dormant - "t" gnus-summary-limit-to-age - "." gnus-summary-limit-to-unseen - "x" gnus-summary-limit-to-extra - "p" gnus-summary-limit-to-display-predicate - "E" gnus-summary-limit-include-expunged - "c" gnus-summary-limit-exclude-childless-dormant - "C" gnus-summary-limit-mark-excluded-as-read - "o" gnus-summary-insert-old-articles - "N" gnus-summary-insert-new-articles - "S" gnus-summary-limit-to-singletons - "r" gnus-summary-limit-to-replied - "R" gnus-summary-limit-to-recipient - "A" gnus-summary-limit-to-address) - -(gnus-define-keys (gnus-summary-goto-map "G" gnus-summary-mode-map) - "n" gnus-summary-next-unread-article - "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 - "f" gnus-summary-first-unread-article - "b" gnus-summary-best-unread-article - "u" gnus-summary-next-unseen-article - "U" gnus-summary-prev-unseen-article - "j" gnus-summary-goto-article - "g" gnus-summary-goto-subject - "l" gnus-summary-goto-last-article - "o" gnus-summary-pop-article) - -(gnus-define-keys (gnus-summary-thread-map "T" gnus-summary-mode-map) - "k" gnus-summary-kill-thread - "E" gnus-summary-expire-thread - "l" gnus-summary-lower-thread - "i" gnus-summary-raise-thread - "T" gnus-summary-toggle-threads - "t" gnus-summary-rethread-current - "^" gnus-summary-reparent-thread - "\M-^" gnus-summary-reparent-children - "s" gnus-summary-show-thread - "S" gnus-summary-show-all-threads - "h" gnus-summary-hide-thread - "H" gnus-summary-hide-all-threads - "n" gnus-summary-next-thread - "p" gnus-summary-prev-thread - "u" gnus-summary-up-thread - "o" gnus-summary-top-thread - "d" gnus-summary-down-thread - "#" gnus-uu-mark-thread - "\M-#" gnus-uu-unmark-thread) - -(gnus-define-keys (gnus-summary-buffer-map "Y" gnus-summary-mode-map) - "g" gnus-summary-prepare - "c" gnus-summary-insert-cached-articles - "d" gnus-summary-insert-dormant-articles - "t" gnus-summary-insert-ticked-articles) - -(gnus-define-keys (gnus-summary-exit-map "Z" gnus-summary-mode-map) - "c" gnus-summary-catchup-and-exit - "C" gnus-summary-catchup-all-and-exit - "E" gnus-summary-exit-no-update - "Q" gnus-summary-exit - "Z" gnus-summary-exit - "n" gnus-summary-catchup-and-goto-next-group - "p" gnus-summary-catchup-and-goto-prev-group - "R" gnus-summary-reselect-current-group - "G" gnus-summary-rescan-group - "N" gnus-summary-next-group - "s" gnus-summary-save-newsrc - "P" gnus-summary-prev-group) - -(gnus-define-keys (gnus-summary-article-map "A" gnus-summary-mode-map) - " " gnus-summary-next-page - "n" gnus-summary-next-page - [?\S-\ ] gnus-summary-prev-page - "\177" gnus-summary-prev-page - [delete] gnus-summary-prev-page - "p" gnus-summary-prev-page - "\r" gnus-summary-scroll-up - "\M-\r" gnus-summary-scroll-down - "<" gnus-summary-beginning-of-article - ">" gnus-summary-end-of-article - "b" gnus-summary-beginning-of-article - "e" gnus-summary-end-of-article - "^" gnus-summary-refer-parent-article - "r" gnus-summary-refer-parent-article - "C" gnus-summary-show-complete-article - "D" gnus-summary-enter-digest-group - "R" gnus-summary-refer-references - "T" gnus-summary-refer-thread - "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 - "w" gnus-summary-browse-url - "P" gnus-summary-print-article - "S" gnus-sticky-article - "M" gnus-mailing-list-insinuate - "t" gnus-article-babel) - -(gnus-define-keys (gnus-summary-wash-map "W" gnus-summary-mode-map) - "b" gnus-article-add-buttons - "B" gnus-article-add-buttons-to-head - "o" gnus-article-treat-overstrike - "e" gnus-article-emphasize - "w" gnus-article-fill-cited-article - "Q" gnus-article-fill-long-lines - "L" gnus-article-toggle-truncate-lines - "C" gnus-article-capitalize-sentences - "c" gnus-article-remove-cr - "q" gnus-article-de-quoted-unreadable - "6" gnus-article-de-base64-unreadable - "Z" gnus-article-decode-HZ - "A" gnus-article-treat-ansi-sequences - "h" gnus-article-wash-html - "u" gnus-article-unsplit-urls - "s" gnus-summary-force-verify-and-decrypt - "f" gnus-article-display-x-face - "l" gnus-summary-stop-page-breaking - "r" gnus-summary-caesar-message - "m" gnus-summary-morse-message - "t" gnus-summary-toggle-header - "g" gnus-treat-smiley - "v" gnus-summary-verbose-headers - "a" gnus-article-strip-headers-in-body ;; mnemonic: wash archive - "p" gnus-article-verify-x-pgp-sig - "d" gnus-article-treat-smartquotes - "U" gnus-article-treat-non-ascii - "i" gnus-summary-idna-message) - -(gnus-define-keys (gnus-summary-wash-deuglify-map "Y" gnus-summary-wash-map) - ;; mnemonic: deuglif*Y* - "u" gnus-article-outlook-unwrap-lines - "a" gnus-article-outlook-repair-attribution - "c" gnus-article-outlook-rearrange-citation - "f" gnus-article-outlook-deuglify-article) ;; mnemonic: full deuglify - -(gnus-define-keys (gnus-summary-wash-hide-map "W" gnus-summary-wash-map) - "a" gnus-article-hide - "h" gnus-article-hide-headers - "b" gnus-article-hide-boring-headers - "s" gnus-article-hide-signature - "c" gnus-article-hide-citation - "C" gnus-article-hide-citation-in-followups - "l" gnus-article-hide-list-identifiers - "B" gnus-article-strip-banner - "P" gnus-article-hide-pem - "\C-c" gnus-article-hide-citation-maybe) - -(gnus-define-keys (gnus-summary-wash-highlight-map "H" gnus-summary-wash-map) - "a" gnus-article-highlight - "h" gnus-article-highlight-headers - "c" gnus-article-highlight-citation - "s" gnus-article-highlight-signature) - -(gnus-define-keys (gnus-summary-wash-header-map "G" gnus-summary-wash-map) - "f" gnus-article-treat-fold-headers - "u" gnus-article-treat-unfold-headers - "n" gnus-article-treat-fold-newsgroups) - -(gnus-define-keys (gnus-summary-wash-display-map "D" gnus-summary-wash-map) - "x" gnus-article-display-x-face - "d" gnus-article-display-face - "s" gnus-treat-smiley - "D" gnus-article-remove-images - "W" gnus-article-show-images - "F" gnus-article-toggle-fonts - "f" gnus-treat-from-picon - "m" gnus-treat-mail-picon - "n" gnus-treat-newsgroups-picon - "g" gnus-treat-from-gravatar - "h" gnus-treat-mail-gravatar) - -(gnus-define-keys (gnus-summary-wash-mime-map "M" gnus-summary-wash-map) - "w" gnus-article-decode-mime-words - "c" gnus-article-decode-charset - "h" gnus-mime-buttonize-attachments-in-header - "v" gnus-mime-view-all-parts - "b" gnus-article-view-part) - -(gnus-define-keys (gnus-summary-wash-time-map "T" gnus-summary-wash-map) - "z" gnus-article-date-ut - "u" gnus-article-date-ut - "l" gnus-article-date-local - "p" gnus-article-date-english - "e" gnus-article-date-lapsed - "o" gnus-article-date-original - "i" gnus-article-date-iso8601 - "s" gnus-article-date-user) - -(gnus-define-keys (gnus-summary-wash-empty-map "E" gnus-summary-wash-map) - "t" gnus-article-remove-trailing-blank-lines - "l" gnus-article-strip-leading-blank-lines - "m" gnus-article-strip-multiple-blank-lines - "a" gnus-article-strip-blank-lines - "A" gnus-article-strip-all-blank-lines - "s" gnus-article-strip-leading-space - "e" gnus-article-strip-trailing-space - "w" gnus-article-remove-leading-whitespace) - -(gnus-define-keys (gnus-summary-help-map "H" gnus-summary-mode-map) - "v" gnus-version - "d" gnus-summary-describe-group - "h" gnus-summary-describe-briefly - "i" gnus-info-find-node) - -(gnus-define-keys (gnus-summary-backend-map "B" gnus-summary-mode-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 - "m" gnus-summary-move-article - "r" gnus-summary-respool-article - "w" gnus-summary-edit-article - "c" gnus-summary-copy-article - "B" gnus-summary-crosspost-article - "q" gnus-summary-respool-query - "t" gnus-summary-respool-trace - "i" gnus-summary-import-article - "I" gnus-summary-create-article - "p" gnus-summary-article-posted-p) - -(gnus-define-keys (gnus-summary-save-map "O" gnus-summary-mode-map) - "o" gnus-summary-save-article - "m" gnus-summary-save-article-mail - "F" gnus-summary-write-article-file - "r" gnus-summary-save-article-rmail - "f" gnus-summary-save-article-file - "b" gnus-summary-save-article-body-file - "B" gnus-summary-write-article-body-file - "h" gnus-summary-save-article-folder - "v" gnus-summary-save-article-vm - "p" gnus-summary-pipe-output - "P" gnus-summary-muttprint) - -(gnus-define-keys (gnus-summary-mime-map "K" gnus-summary-mode-map) - "b" gnus-summary-display-buttonized - "m" gnus-summary-repair-multipart - "v" gnus-article-view-part - "o" gnus-article-save-part - "O" gnus-article-save-part-and-strip - "r" gnus-article-replace-part - "d" gnus-article-delete-part - "t" gnus-article-view-part-as-type - "j" gnus-article-jump-to-part - "c" gnus-article-copy-part - "C" gnus-article-view-part-as-charset - "e" gnus-article-view-part-externally - "H" gnus-article-browse-html-article - "E" gnus-article-encrypt-body - "i" gnus-article-inline-part - "|" gnus-article-pipe-part) - -(gnus-define-keys (gnus-uu-mark-map "P" gnus-summary-mark-map) - "p" gnus-summary-mark-as-processable - "u" gnus-summary-unmark-as-processable - "U" gnus-summary-unmark-all-processable - "v" gnus-uu-mark-over - "s" gnus-uu-mark-series - "r" gnus-uu-mark-region - "g" gnus-uu-unmark-region - "R" gnus-uu-mark-by-regexp - "G" gnus-uu-unmark-by-regexp - "t" gnus-uu-mark-thread - "T" gnus-uu-unmark-thread - "a" gnus-uu-mark-all - "b" gnus-uu-mark-buffer - "S" gnus-uu-mark-sparse - "k" gnus-summary-kill-process-mark - "y" gnus-summary-yank-process-mark - "w" gnus-summary-save-process-mark - "i" gnus-uu-invert-processable) - -(gnus-define-keys (gnus-uu-extract-map "X" gnus-summary-mode-map) - ;;"x" gnus-uu-extract-any - "m" gnus-summary-save-parts - "u" gnus-uu-decode-uu - "U" gnus-uu-decode-uu-and-save - "s" gnus-uu-decode-unshar - "S" gnus-uu-decode-unshar-and-save - "o" gnus-uu-decode-save - "O" gnus-uu-decode-save - "b" gnus-uu-decode-binhex - "B" gnus-uu-decode-binhex - "Y" gnus-uu-decode-yenc - "p" gnus-uu-decode-postscript - "P" gnus-uu-decode-postscript-and-save) - -(gnus-define-keys - (gnus-uu-extract-view-map "v" gnus-uu-extract-map) - "u" gnus-uu-decode-uu-view - "U" gnus-uu-decode-uu-and-save-view - "s" gnus-uu-decode-unshar-view - "S" gnus-uu-decode-unshar-and-save-view - "o" gnus-uu-decode-save-view - "O" gnus-uu-decode-save-view - "b" gnus-uu-decode-binhex-view - "B" gnus-uu-decode-binhex-view - "p" gnus-uu-decode-postscript-view - "P" gnus-uu-decode-postscript-and-save-view) + "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 + "m" #'gnus-summary-mail-other-window + "a" #'gnus-summary-post-news + "x" #'gnus-summary-limit-to-unread + "s" #'gnus-summary-isearch-article + "TAB" #'gnus-summary-button-forward + "<backtab>" #'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 + "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 + "I" #'gnus-summary-increase-score + "L" #'gnus-summary-lower-score + "M-i" #'gnus-symbolic-argument + "h" #'gnus-summary-select-article-buffer + + "b" #'gnus-article-view-part + "M-t" #'gnus-summary-toggle-display-buttonized + + "S" #'gnus-summary-send-map + + ;; Sort of orthogonal keymaps. + "M" (define-keymap :prefix 'gnus-summary-mark-map + "t" #'gnus-summary-tick-article-forward + "!" #'gnus-summary-tick-article-forward + "d" #'gnus-summary-mark-as-read-forward + "r" #'gnus-summary-mark-as-read-forward + "c" #'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 + "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 + "k" #'gnus-summary-kill-same-subject-and-select + "K" #'gnus-summary-kill-same-subject + + "P" (define-keymap :prefix 'gnus-uu-mark-map + "p" #'gnus-summary-mark-as-processable + "u" #'gnus-summary-unmark-as-processable + "U" #'gnus-summary-unmark-all-processable + "v" #'gnus-uu-mark-over + "s" #'gnus-uu-mark-series + "r" #'gnus-uu-mark-region + "g" #'gnus-uu-unmark-region + "R" #'gnus-uu-mark-by-regexp + "G" #'gnus-uu-unmark-by-regexp + "t" #'gnus-uu-mark-thread + "T" #'gnus-uu-unmark-thread + "a" #'gnus-uu-mark-all + "b" #'gnus-uu-mark-buffer + "S" #'gnus-uu-mark-sparse + "k" #'gnus-summary-kill-process-mark + "y" #'gnus-summary-yank-process-mark + "w" #'gnus-summary-save-process-mark + "i" #'gnus-uu-invert-processable) + + "V" (define-keymap :prefix 'gnus-summary-mscore-map + "c" #'gnus-summary-clear-above + "u" #'gnus-summary-tick-above + "m" #'gnus-summary-mark-above + "k" #'gnus-summary-kill-below)) + + "/" (define-keymap :prefix 'gnus-summary-limit-map + "/" #'gnus-summary-limit-to-subject + "n" #'gnus-summary-limit-to-articles + "b" #'gnus-summary-limit-to-bodies + "h" #'gnus-summary-limit-to-headers + "w" #'gnus-summary-pop-limit + "s" #'gnus-summary-limit-to-subject + "a" #'gnus-summary-limit-to-author + "u" #'gnus-summary-limit-to-unread + "m" #'gnus-summary-limit-to-marks + "M" #'gnus-summary-limit-exclude-marks + "v" #'gnus-summary-limit-to-score + "*" #'gnus-summary-limit-include-cached + "D" #'gnus-summary-limit-include-dormant + "T" #'gnus-summary-limit-include-thread + "d" #'gnus-summary-limit-exclude-dormant + "t" #'gnus-summary-limit-to-age + "." #'gnus-summary-limit-to-unseen + "x" #'gnus-summary-limit-to-extra + "p" #'gnus-summary-limit-to-display-predicate + "E" #'gnus-summary-limit-include-expunged + "c" #'gnus-summary-limit-exclude-childless-dormant + "C" #'gnus-summary-limit-mark-excluded-as-read + "o" #'gnus-summary-insert-old-articles + "N" #'gnus-summary-insert-new-articles + "S" #'gnus-summary-limit-to-singletons + "r" #'gnus-summary-limit-to-replied + "R" #'gnus-summary-limit-to-recipient + "A" #'gnus-summary-limit-to-address) + + "G" (define-keymap :prefix 'gnus-summary-goto-map + "n" #'gnus-summary-next-unread-article + "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 + "f" #'gnus-summary-first-unread-article + "b" #'gnus-summary-best-unread-article + "u" #'gnus-summary-next-unseen-article + "U" #'gnus-summary-prev-unseen-article + "j" #'gnus-summary-goto-article + "g" #'gnus-summary-goto-subject + "l" #'gnus-summary-goto-last-article + "o" #'gnus-summary-pop-article) + + "T" (define-keymap :prefix 'gnus-summary-thread-map + "k" #'gnus-summary-kill-thread + "E" #'gnus-summary-expire-thread + "l" #'gnus-summary-lower-thread + "i" #'gnus-summary-raise-thread + "T" #'gnus-summary-toggle-threads + "t" #'gnus-summary-rethread-current + "^" #'gnus-summary-reparent-thread + "M-^" #'gnus-summary-reparent-children + "s" #'gnus-summary-show-thread + "S" #'gnus-summary-show-all-threads + "h" #'gnus-summary-hide-thread + "H" #'gnus-summary-hide-all-threads + "n" #'gnus-summary-next-thread + "p" #'gnus-summary-prev-thread + "u" #'gnus-summary-up-thread + "o" #'gnus-summary-top-thread + "d" #'gnus-summary-down-thread + "#" #'gnus-uu-mark-thread + "M-#" #'gnus-uu-unmark-thread) + + "Y" (define-keymap :prefix 'gnus-summary-buffer-map + "g" #'gnus-summary-prepare + "c" #'gnus-summary-insert-cached-articles + "d" #'gnus-summary-insert-dormant-articles + "t" #'gnus-summary-insert-ticked-articles) + + "Z" (define-keymap :prefix 'gnus-summary-exit-map + "c" #'gnus-summary-catchup-and-exit + "C" #'gnus-summary-catchup-all-and-exit + "E" #'gnus-summary-exit-no-update + "Q" #'gnus-summary-exit + "Z" #'gnus-summary-exit + "n" #'gnus-summary-catchup-and-goto-next-group + "p" #'gnus-summary-catchup-and-goto-prev-group + "R" #'gnus-summary-reselect-current-group + "G" #'gnus-summary-rescan-group + "N" #'gnus-summary-next-group + "s" #'gnus-summary-save-newsrc + "P" #'gnus-summary-prev-group) + + "A" (define-keymap :prefix 'gnus-summary-article-map + "SPC" #'gnus-summary-next-page + "n" #'gnus-summary-next-page + "S-SPC" #'gnus-summary-prev-page + "DEL" #'gnus-summary-prev-page + "<delete>" #'gnus-summary-prev-page + "p" #'gnus-summary-prev-page + "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 + "e" #'gnus-summary-end-of-article + "^" #'gnus-summary-refer-parent-article + "r" #'gnus-summary-refer-parent-article + "C" #'gnus-summary-show-complete-article + "D" #'gnus-summary-enter-digest-group + "R" #'gnus-summary-refer-references + "T" #'gnus-summary-refer-thread + "W" #'gnus-warp-to-article + "g" #'gnus-summary-show-article + "s" #'gnus-summary-isearch-article + "TAB" #'gnus-summary-button-forward + "<backtab>" #'gnus-summary-button-backward + "w" #'gnus-summary-browse-url + "P" #'gnus-summary-print-article + "S" #'gnus-sticky-article + "M" #'gnus-mailing-list-insinuate + "t" #'gnus-article-babel) + + "W" (define-keymap :prefix 'gnus-summary-wash-map + "b" #'gnus-article-add-buttons + "B" #'gnus-article-add-buttons-to-head + "o" #'gnus-article-treat-overstrike + "e" #'gnus-article-emphasize + "w" #'gnus-article-fill-cited-article + "Q" #'gnus-article-fill-long-lines + "L" #'gnus-article-toggle-truncate-lines + "C" #'gnus-article-capitalize-sentences + "c" #'gnus-article-remove-cr + "q" #'gnus-article-de-quoted-unreadable + "6" #'gnus-article-de-base64-unreadable + "Z" #'gnus-article-decode-HZ + "A" #'gnus-article-treat-ansi-sequences + "h" #'gnus-article-wash-html + "u" #'gnus-article-unsplit-urls + "s" #'gnus-summary-force-verify-and-decrypt + "f" #'gnus-article-display-x-face + "l" #'gnus-summary-stop-page-breaking + "r" #'gnus-summary-caesar-message + "m" #'gnus-summary-morse-message + "t" #'gnus-summary-toggle-header + "g" #'gnus-treat-smiley + "v" #'gnus-summary-verbose-headers + "a" #'gnus-article-strip-headers-in-body ;; mnemonic: wash archive + "p" #'gnus-article-verify-x-pgp-sig + "d" #'gnus-article-treat-smartquotes + "U" #'gnus-article-treat-non-ascii + "i" #'gnus-summary-idna-message + + "Y" (define-keymap :prefix 'gnus-summary-wash-deuglify-map + ;; mnemonic: deuglif*Y* + "u" #'gnus-article-outlook-unwrap-lines + "a" #'gnus-article-outlook-repair-attribution + "c" #'gnus-article-outlook-rearrange-citation + ;; mnemonic: full deuglify + "f" #'gnus-article-outlook-deuglify-article) + + "W" (define-keymap :prefix 'gnus-summary-wash-hide-map + "a" #'gnus-article-hide + "h" #'gnus-article-hide-headers + "b" #'gnus-article-hide-boring-headers + "s" #'gnus-article-hide-signature + "c" #'gnus-article-hide-citation + "C" #'gnus-article-hide-citation-in-followups + "l" #'gnus-article-hide-list-identifiers + "B" #'gnus-article-strip-banner + "P" #'gnus-article-hide-pem + "C-c" #'gnus-article-hide-citation-maybe) + + "H" (define-keymap :prefix 'gnus-summary-wash-highlight-map + "a" #'gnus-article-highlight + "h" #'gnus-article-highlight-headers + "c" #'gnus-article-highlight-citation + "s" #'gnus-article-highlight-signature) + + "G" (define-keymap :prefix 'gnus-summary-wash-header-map + "f" #'gnus-article-treat-fold-headers + "u" #'gnus-article-treat-unfold-headers + "n" #'gnus-article-treat-fold-newsgroups) + + "D" (define-keymap :prefix 'gnus-summary-wash-display-map + "x" #'gnus-article-display-x-face + "d" #'gnus-article-display-face + "s" #'gnus-treat-smiley + "e" #'gnus-article-emojize-symbols + "D" #'gnus-article-remove-images + "W" #'gnus-article-show-images + "F" #'gnus-article-toggle-fonts + "f" #'gnus-treat-from-picon + "m" #'gnus-treat-mail-picon + "n" #'gnus-treat-newsgroups-picon + "g" #'gnus-treat-from-gravatar + "h" #'gnus-treat-mail-gravatar) + + "M" (define-keymap :prefix 'gnus-summary-wash-mime-map + "w" #'gnus-article-decode-mime-words + "c" #'gnus-article-decode-charset + "h" #'gnus-mime-buttonize-attachments-in-header + "v" #'gnus-mime-view-all-parts + "b" #'gnus-article-view-part) + + "T" (define-keymap :prefix 'gnus-summary-wash-time-map + "z" #'gnus-article-date-ut + "u" #'gnus-article-date-ut + "l" #'gnus-article-date-local + "p" #'gnus-article-date-english + "e" #'gnus-article-date-lapsed + "o" #'gnus-article-date-original + "i" #'gnus-article-date-iso8601 + "s" #'gnus-article-date-user) + + "E" (define-keymap :prefix 'gnus-summary-wash-empty-map + "t" #'gnus-article-remove-trailing-blank-lines + "l" #'gnus-article-strip-leading-blank-lines + "m" #'gnus-article-strip-multiple-blank-lines + "a" #'gnus-article-strip-blank-lines + "A" #'gnus-article-strip-all-blank-lines + "s" #'gnus-article-strip-leading-space + "e" #'gnus-article-strip-trailing-space + "w" #'gnus-article-remove-leading-whitespace)) + + "H" (define-keymap :prefix 'gnus-summary-help-map + "v" #'gnus-version + "d" #'gnus-summary-describe-group + "h" #'gnus-summary-describe-briefly + "i" #'gnus-info-find-node) + + "B" (define-keymap :prefix 'gnus-summary-backend-map + "e" #'gnus-summary-expire-articles + "C-M-e" #'gnus-summary-expire-articles-now + "DEL" #'gnus-summary-delete-article + "<delete>" #'gnus-summary-delete-article + "<backspace>" #'gnus-summary-delete-article + "m" #'gnus-summary-move-article + "r" #'gnus-summary-respool-article + "w" #'gnus-summary-edit-article + "c" #'gnus-summary-copy-article + "B" #'gnus-summary-crosspost-article + "q" #'gnus-summary-respool-query + "t" #'gnus-summary-respool-trace + "i" #'gnus-summary-import-article + "I" #'gnus-summary-create-article + "p" #'gnus-summary-article-posted-p) + + "O" (define-keymap :prefix 'gnus-summary-save-map + "o" #'gnus-summary-save-article + "m" #'gnus-summary-save-article-mail + "F" #'gnus-summary-write-article-file + "r" #'gnus-summary-save-article-rmail + "f" #'gnus-summary-save-article-file + "b" #'gnus-summary-save-article-body-file + "B" #'gnus-summary-write-article-body-file + "h" #'gnus-summary-save-article-folder + "v" #'gnus-summary-save-article-vm + "p" #'gnus-summary-pipe-output + "P" #'gnus-summary-muttprint) + + "K" (define-keymap :prefix 'gnus-summary-mime-map + "b" #'gnus-summary-display-buttonized + "m" #'gnus-summary-repair-multipart + "v" #'gnus-article-view-part + "o" #'gnus-article-save-part + "O" #'gnus-article-save-part-and-strip + "r" #'gnus-article-replace-part + "d" #'gnus-article-delete-part + "t" #'gnus-article-view-part-as-type + "j" #'gnus-article-jump-to-part + "c" #'gnus-article-copy-part + "C" #'gnus-article-view-part-as-charset + "e" #'gnus-article-view-part-externally + "H" #'gnus-article-browse-html-article + "E" #'gnus-article-encrypt-body + "i" #'gnus-article-inline-part + "|" #'gnus-article-pipe-part) + + "X" (define-keymap :prefix 'gnus-uu-extract-map + ;;"x" gnus-uu-extract-any + "m" #'gnus-summary-save-parts + "u" #'gnus-uu-decode-uu + "U" #'gnus-uu-decode-uu-and-save + "s" #'gnus-uu-decode-unshar + "S" #'gnus-uu-decode-unshar-and-save + "o" #'gnus-uu-decode-save + "O" #'gnus-uu-decode-save + "b" #'gnus-uu-decode-binhex + "B" #'gnus-uu-decode-binhex + "Y" #'gnus-uu-decode-yenc + "p" #'gnus-uu-decode-postscript + "P" #'gnus-uu-decode-postscript-and-save + + "v" (define-keymap :prefix 'gnus-uu-extract-view-map + "u" #'gnus-uu-decode-uu-view + "U" #'gnus-uu-decode-uu-and-save-view + "s" #'gnus-uu-decode-unshar-view + "S" #'gnus-uu-decode-unshar-and-save-view + "o" #'gnus-uu-decode-save-view + "O" #'gnus-uu-decode-save-view + "b" #'gnus-uu-decode-binhex-view + "B" #'gnus-uu-decode-binhex-view + "p" #'gnus-uu-decode-postscript-view + "P" #'gnus-uu-decode-postscript-and-save-view))) (defvar gnus-article-post-menu nil) @@ -3970,10 +3968,9 @@ Returns \" ? \" if there's bad input or if another error occurs. Input should look like this: \"Sun, 14 Oct 2001 13:34:39 +0200\"." (condition-case () (let* ((messy-date (gnus-date-get-time messy-date)) - (now (current-time)) ;;If we don't find something suitable we'll use this one (my-format "%b %d '%y")) - (let* ((difference (time-subtract now messy-date)) + (let* ((difference (time-subtract nil messy-date)) (templist gnus-user-date-format-alist) (top (eval (caar templist) t))) (while (if (numberp top) (time-less-p top difference) (not top)) @@ -5004,23 +5001,13 @@ If LINE, insert the rebuilt thread starting on line LINE." gnus-article-sort-functions))) (gnus-message 7 "Sorting articles...done")))) -;; Written by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>. -(defmacro gnus-thread-header (thread) - "Return header of first article in THREAD. -Note that THREAD must never, ever be anything else than a variable - -using some other form will lead to serious barfage." - (or (symbolp thread) (signal 'wrong-type-argument '(symbolp thread))) - ;; (8% speedup to gnus-summary-prepare, just for fun :-) - (cond - ((and (boundp 'lexical-binding) lexical-binding) - ;; FIXME: This version could be a "defsubst" rather than a macro. - `(#[257 "\211:\203\16\0\211@;\203\15\0A@@\207" - [] 2] - ,thread)) - (t - ;; Not sure how XEmacs handles these things, so let's keep the old code. - (list 'byte-code "\10\211:\203\17\0\211@;\203\16\0A@@\207" - (vector thread) 2)))) +(defsubst gnus-thread-header (thread) + "Return header of first article in THREAD." + (if (consp thread) + (car (if (stringp (car thread)) + (cadr thread) + thread)) + thread)) (defsubst gnus-article-sort-by-number (h1 h2) "Sort articles by article number." @@ -7208,7 +7195,6 @@ If FORCE (the prefix), also save the .newsrc file(s)." (gnus-dribble-save))) (declare-function gnus-cache-write-active "gnus-cache" (&optional force)) -(declare-function gnus-article-stop-animations "gnus-art" ()) (defun gnus-summary-exit (&optional temporary leave-hidden) "Exit reading current newsgroup, and then return to group selection mode. @@ -7272,7 +7258,6 @@ If FORCE (the prefix), also save the .newsrc file(s)." (not (string= group (gnus-group-group-name)))) (gnus-group-next-unread-group 1)) (setq group-point (point)) - (gnus-article-stop-animations) (unless leave-hidden (gnus-configure-windows 'group 'force)) (if temporary @@ -7332,7 +7317,6 @@ If FORCE (the prefix), also save the .newsrc file(s)." (run-hooks 'gnus-summary-prepare-exit-hook) (when (gnus-buffer-live-p gnus-article-buffer) (with-current-buffer gnus-article-buffer - (gnus-article-stop-animations) (gnus-stop-downloads) (mm-destroy-parts gnus-article-mime-handles) ;; Set it to nil for safety reason. @@ -7364,7 +7348,6 @@ If FORCE (the prefix), also save the .newsrc file(s)." (gnus-group-update-group group nil t)) (when (gnus-group-goto-group group) (gnus-group-next-unread-group 1)) - (gnus-article-stop-animations) (when quit-config (gnus-handle-ephemeral-exit quit-config))))) @@ -8067,9 +8050,7 @@ Return nil if there are no unread articles." Return nil if there are no unread articles." (interactive nil gnus-summary-mode) (prog1 - (when (gnus-summary-first-subject t) - (gnus-summary-show-thread) - (gnus-summary-first-subject t)) + (gnus-summary--goto-and-possibly-unhide t) (gnus-summary-position-point))) (defun gnus-summary-next-unseen-article (&optional backward) @@ -8103,23 +8084,27 @@ Return nil if there are no unread articles." Return nil if there are no unseen articles." (interactive nil gnus-summary-mode) (prog1 - (when (gnus-summary-first-subject nil nil t) - (gnus-summary-show-thread) - (gnus-summary-first-subject nil nil t)) + (gnus-summary--goto-and-possibly-unhide) (gnus-summary-position-point))) +(defun gnus-summary--goto-and-possibly-unhide (&optional unread undownloaded + unseen) + (let ((first (gnus-summary-first-subject unread undownloaded unseen))) + (if (and first + (not (= first (gnus-summary-article-number)))) + (progn + (gnus-summary-show-thread) + (gnus-summary-first-subject unread undownloaded unseen)) + first))) + (defun gnus-summary-first-unseen-or-unread-subject () "Place the point on the subject line of the first unseen and unread article. If all articles have been seen, on the subject line of the first unread article." (interactive nil gnus-summary-mode) (prog1 - (unless (when (gnus-summary-first-subject nil nil t) - (gnus-summary-show-thread) - (gnus-summary-first-subject nil nil t)) - (when (gnus-summary-first-subject t) - (gnus-summary-show-thread) - (gnus-summary-first-subject t))) + (unless (gnus-summary--goto-and-possibly-unhide nil nil t) + (gnus-summary-first-subject t)) (gnus-summary-position-point))) (defun gnus-summary-first-article () @@ -8673,20 +8658,20 @@ these articles." (gnus-fetch-old-headers nil) (gnus-build-sparse-threads nil)) (prog1 - (gnus-summary-limit (if thread-only articles - (nconc articles gnus-newsgroup-limit))) - (gnus-summary-limit-include-matching-articles - "subject" - (regexp-quote (gnus-general-simplify-subject - (mail-header-subject (gnus-id-to-header id))))) - ;; the previous two calls each push a limit onto the limit - ;; stack. the first pop remove the articles that match the - ;; subject, while the second pop gets us back to the state - ;; before we started to deal with the thread. presumably we want - ;; to think of the thread and its associated subject matches as - ;; a single thing so that we need to pop only once to get back - ;; to the original view. - (pop gnus-newsgroup-limits) + (gnus-summary-limit (if thread-only articles + (nconc articles gnus-newsgroup-limit))) + (let ((matching-subject (gnus-general-simplify-subject + (mail-header-subject (gnus-id-to-header id))))) + (when matching-subject + (gnus-summary-limit-include-matching-articles + "subject" + matching-subject) + ;; Each of the previous two limit calls push a limit onto + ;; the limit stack. Presumably we want to think of the + ;; thread and its associated subject matches as a single + ;; thing so we probably want a single pop to restore the + ;; original view. Hence we pop this last limit off. + (pop gnus-newsgroup-limits))) (gnus-summary-position-point)))) (defun gnus-summary-limit-include-matching-articles (header regexp) @@ -9908,7 +9893,6 @@ article. Normally, the keystroke is `\\[universal-argument] \\[gnus-summary-sho ;; Destroy any MIME parts. (when (gnus-buffer-live-p gnus-article-buffer) (with-current-buffer gnus-article-buffer - (gnus-article-stop-animations) (gnus-stop-downloads) (mm-destroy-parts gnus-article-mime-handles) ;; Set it to nil for safety reason. @@ -10501,7 +10485,6 @@ latter case, they will be copied into the relevant groups." "Create an article in a mail newsgroup." (interactive nil gnus-summary-mode) (let ((group gnus-newsgroup-name) - (now (current-time)) group-art) (unless (gnus-check-backend-function 'request-accept-article group) (error "%s does not support article importing" group)) @@ -10511,7 +10494,7 @@ latter case, they will be copied into the relevant groups." ;; This doesn't look like an article, so we fudge some headers. (insert "From: " (read-string "From: ") "\n" "Subject: " (read-string "Subject: ") "\n" - "Date: " (message-make-date now) "\n" + "Date: " (message-make-date) "\n" "Message-ID: " (message-make-message-id) "\n") (setq group-art (gnus-request-accept-article group nil t)) (kill-buffer (current-buffer))) diff --git a/lisp/gnus/gnus-topic.el b/lisp/gnus/gnus-topic.el index c8bcccdfdde..0855e98917f 100644 --- a/lisp/gnus/gnus-topic.el +++ b/lisp/gnus/gnus-topic.el @@ -1056,63 +1056,56 @@ articles in the topic and its subtopics." ;;; Topic mode, commands and keymap. -(defvar gnus-topic-mode-map nil) -(defvar gnus-group-topic-map nil) - -(unless gnus-topic-mode-map - (setq gnus-topic-mode-map (make-sparse-keymap)) - +(defvar-keymap gnus-topic-mode-map ;; Override certain group mode keys. - (gnus-define-keys gnus-topic-mode-map - "=" gnus-topic-select-group - "\r" gnus-topic-select-group - " " 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 - "#" 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) - - ;; Define a new submap. - (gnus-define-keys (gnus-group-topic-map "T" gnus-group-mode-map) - "#" gnus-topic-mark-topic - "\M-#" gnus-topic-unmark-topic - "n" gnus-topic-create-topic - "m" gnus-topic-move-group - "D" gnus-topic-remove-group - "c" gnus-topic-copy-group - "h" gnus-topic-hide-topic - "s" gnus-topic-show-topic - "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 - "r" gnus-topic-rename - "\177" gnus-topic-delete - [delete] gnus-topic-delete - "H" gnus-topic-toggle-display-empty-topics) - - (gnus-define-keys (gnus-topic-sort-map "S" gnus-group-topic-map) - "s" gnus-topic-sort-groups - "a" gnus-topic-sort-groups-by-alphabet - "u" gnus-topic-sort-groups-by-unread - "l" gnus-topic-sort-groups-by-level - "e" gnus-topic-sort-groups-by-server - "v" gnus-topic-sort-groups-by-score - "r" gnus-topic-sort-groups-by-rank - "m" gnus-topic-sort-groups-by-method)) + "=" #'gnus-topic-select-group + "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 + "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 + "M-<tab>" #'gnus-topic-unindent + "TAB" #'gnus-topic-indent + "C-M-i" #'gnus-topic-unindent + "<mouse-2>" #'gnus-mouse-pick-topic + + "T" (define-keymap :prefix 'gnus-group-topic-map + "#" #'gnus-topic-mark-topic + "M-#" #'gnus-topic-unmark-topic + "n" #'gnus-topic-create-topic + "m" #'gnus-topic-move-group + "D" #'gnus-topic-remove-group + "c" #'gnus-topic-copy-group + "h" #'gnus-topic-hide-topic + "s" #'gnus-topic-show-topic + "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 + "TAB" #'gnus-topic-indent + "<tab>" #'gnus-topic-indent + "r" #'gnus-topic-rename + "DEL" #'gnus-topic-delete + "<delete>" #'gnus-topic-delete + "H" #'gnus-topic-toggle-display-empty-topics + + "S" (define-keymap :prefix 'gnus-topic-sort-map + "s" #'gnus-topic-sort-groups + "a" #'gnus-topic-sort-groups-by-alphabet + "u" #'gnus-topic-sort-groups-by-unread + "l" #'gnus-topic-sort-groups-by-level + "e" #'gnus-topic-sort-groups-by-server + "v" #'gnus-topic-sort-groups-by-score + "r" #'gnus-topic-sort-groups-by-rank + "m" #'gnus-topic-sort-groups-by-method))) (defun gnus-topic-make-menu-bar () (unless (boundp 'gnus-topic-menu) diff --git a/lisp/gnus/gnus-undo.el b/lisp/gnus/gnus-undo.el index 07cf5d495a6..a82b1f87a3e 100644 --- a/lisp/gnus/gnus-undo.el +++ b/lisp/gnus/gnus-undo.el @@ -75,15 +75,12 @@ ;;; Minor mode definition. -(defvar gnus-undo-mode-map - (let ((map (make-sparse-keymap))) - (gnus-define-keys map - "\M-\C-_" gnus-undo - "\C-_" gnus-undo - "\C-xu" gnus-undo - ;; Many people are used to type `C-/' on GUI frames and get `C-_'. - [(control /)] gnus-undo) - map)) +(defvar-keymap gnus-undo-mode-map + "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-_'. + "C-/" #'gnus-undo) (defun gnus-undo-make-menu-bar () ;; This is disabled for the time being. diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index fb285962d6f..8dbdcc83f8b 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -300,25 +300,26 @@ Symbols are also allowed; their print names are used instead." (defmacro gnus-local-set-keys (&rest plist) "Set the keys in PLIST in the current keymap." - (declare (indent 1)) + (declare (obsolete define-keymap "29.1") (indent 1)) `(gnus-define-keys-1 (current-local-map) ',plist)) (defmacro gnus-define-keys (keymap &rest plist) "Define all keys in PLIST in KEYMAP." - (declare (indent 1)) + (declare (obsolete define-keymap "29.1") (indent 1)) `(gnus-define-keys-1 ,(if (symbolp keymap) keymap `',keymap) (quote ,plist))) (defmacro gnus-define-keys-safe (keymap &rest plist) "Define all keys in PLIST in KEYMAP without overwriting previous definitions." - (declare (indent 1)) + (declare (obsolete define-keymap "29.1") (indent 1)) `(gnus-define-keys-1 (quote ,keymap) (quote ,plist) t)) (defmacro gnus-define-keymap (keymap &rest plist) "Define all keys in PLIST in KEYMAP." - (declare (indent 1)) + (declare (obsolete define-keymap "29.1") (indent 1)) `(gnus-define-keys-1 ,keymap (quote ,plist))) (defun gnus-define-keys-1 (keymap plist &optional safe) + (declare (obsolete define-keymap "29.1")) (when (null keymap) (error "Can't set keys in a null keymap")) (cond ((symbolp keymap) (error "First arg should be a keymap object")) @@ -857,126 +858,9 @@ variables and then do only the assignment atomically." `(let ((inhibit-quit gnus-atomic-be-safe)) ,@forms)) -;;; Functions for saving to babyl/mail files. - -(require 'rmail) -(autoload 'rmail-update-summary "rmailsum") - (defvar mm-text-coding-system) - (declare-function mm-append-to-file "mm-util" (start end filename &optional codesys inhibit)) -(declare-function rmail-swap-buffers-maybe "rmail" ()) -(declare-function rmail-maybe-set-message-counters "rmail" ()) -(declare-function rmail-count-new-messages "rmail" (&optional nomsg)) -(declare-function rmail-summary-exists "rmail" ()) -(declare-function rmail-show-message "rmail" (&optional n no-summary)) -;; Macroexpansion of rmail-select-summary: -(declare-function rmail-summary-displayed "rmail" ()) -(declare-function rmail-pop-to-buffer "rmail" (&rest args)) -(declare-function rmail-maybe-display-summary "rmail" ()) - -(defun gnus-output-to-rmail (filename &optional ask) - "Append the current article to an Rmail file named FILENAME. -In Emacs 22 this writes Babyl format; in Emacs 23 it writes mbox unless -FILENAME exists and is Babyl format." - (require 'rmail) - (require 'mm-util) - (require 'nnmail) - ;; Some of this codes is borrowed from rmailout.el. - (setq filename (expand-file-name filename)) - ;; FIXME should we really be messing with this defcustom? - ;; It is not needed for the operation of this function. - (if (boundp 'rmail-default-rmail-file) - (setq rmail-default-rmail-file filename) ; 22 - (setq rmail-default-file filename)) ; 23 - (let ((artbuf (current-buffer)) - (tmpbuf (gnus-get-buffer-create " *Gnus-output*")) - ;; Babyl rmail.el defines this, mbox does not. - (babyl (fboundp 'rmail-insert-rmail-file-header))) - (save-excursion - ;; Note that we ignore the possibility of visiting a Babyl - ;; format buffer in Emacs 23, since Rmail no longer supports that. - (or (get-file-buffer filename) - (progn - ;; In case someone wants to write to a Babyl file from Emacs 23. - (when (file-exists-p filename) - (setq babyl (mail-file-babyl-p filename)) - t)) - (if (or (not ask) - (gnus-yes-or-no-p - (concat "\"" filename "\" does not exist, create it? "))) - (let ((file-buffer (create-file-buffer filename))) - (with-current-buffer file-buffer - (if (fboundp 'rmail-insert-rmail-file-header) - (rmail-insert-rmail-file-header)) - (let ((require-final-newline nil) - (coding-system-for-write mm-text-coding-system)) - (gnus-write-buffer filename))) - (kill-buffer file-buffer)) - (error "Output file does not exist"))) - (set-buffer tmpbuf) - (erase-buffer) - (insert-buffer-substring artbuf) - (if babyl - (gnus-convert-article-to-rmail) - ;; Non-Babyl case copied from gnus-output-to-mail. - (goto-char (point-min)) - (if (looking-at "From ") - (forward-line 1) - (insert "From nobody " (current-time-string) "\n")) - (let (case-fold-search) - (while (re-search-forward "^From " nil t) - (beginning-of-line) - (insert ">")))) - ;; Decide whether to append to a file or to an Emacs buffer. - (let ((outbuf (get-file-buffer filename))) - (if (not outbuf) - (progn - (unless babyl ; from gnus-output-to-mail - (let ((buffer-read-only nil)) - (goto-char (point-max)) - (forward-char -2) - (unless (looking-at "\n\n") - (goto-char (point-max)) - (unless (bolp) - (insert "\n")) - (insert "\n")))) - (let ((file-name-coding-system nnmail-pathname-coding-system)) - (mm-append-to-file (point-min) (point-max) filename))) - ;; File has been visited, in buffer OUTBUF. - (set-buffer outbuf) - (let ((buffer-read-only nil) - (msg (and (boundp 'rmail-current-message) - (symbol-value 'rmail-current-message)))) - ;; If MSG is non-nil, buffer is in RMAIL mode. - ;; Compare this with rmail-output-to-rmail-buffer in Emacs 23. - (when msg - (unless babyl - (rmail-swap-buffers-maybe) - (rmail-maybe-set-message-counters)) - (widen) - (unless babyl - (goto-char (point-max)) - ;; Ensure we have a blank line before the next message. - (unless (bolp) - (insert "\n")) - (insert "\n")) - (narrow-to-region (point-max) (point-max))) - (insert-buffer-substring tmpbuf) - (when msg - (when babyl - (goto-char (point-min)) - (widen) - (search-backward "\n\^_") - (narrow-to-region (point) (point-max))) - (rmail-count-new-messages t) - (when (rmail-summary-exists) - (rmail-select-summary - (rmail-update-summary))) - (rmail-show-message msg)) - (save-buffer))))) - (kill-buffer tmpbuf))) (defun gnus-output-to-mail (filename &optional ask) "Append the current article to a mail file named FILENAME." @@ -1034,17 +918,6 @@ FILENAME exists and is Babyl format." (insert-buffer-substring tmpbuf))))) (kill-buffer tmpbuf))) -(defun gnus-convert-article-to-rmail () - "Convert article in current buffer to Rmail message format." - (let ((buffer-read-only nil)) - ;; Convert article directly into Babyl format. - (goto-char (point-min)) - (insert "\^L\n0, unseen,,\n*** EOOH ***\n") - (while (search-forward "\n\^_" nil t) ;single char - (replace-match "\n^_" t t)) ;2 chars: "^" and "_" - (goto-char (point-max)) - (insert "\^_"))) - (defun gnus-map-function (funs arg) "Apply the result of the first function in FUNS to the second, and so on. ARG is passed to the first function." @@ -1310,9 +1183,7 @@ SPEC is a predicate specifier that contains stuff like `or', `and', initial-input history def) "Call `gnus-completing-read-function'." (funcall gnus-completing-read-function - (concat prompt (when def - (concat " (default " def ")")) - ": ") + (format-prompt prompt def) collection require-match initial-input history def)) (defun gnus-emacs-completing-read (prompt collection &optional require-match @@ -1676,6 +1547,11 @@ lists of strings." (while overlays (delete-overlay (pop overlays))))) +;; This function used to live in this file, but was moved to a +;; separate file to avoid pulling in rmail.el when requiring +;; gnus-util. +(autoload 'gnus-output-to-rmail "gnus-rmail") + (provide 'gnus-util) ;;; gnus-util.el ends here diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index 1d19a2ac565..1f1c39bb8b5 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).") @@ -2528,16 +2528,8 @@ are always t.") ("babel" babel-as-string) ("nnmail" nnmail-split-fancy nnmail-article-group) ("nnvirtual" nnvirtual-catchup-group nnvirtual-convert-headers) - ;; This is only used in message.el, which has an autoload. - ("rmailout" rmail-output) - ;; Next two used in gnus-util, which has autoloads, and contrib/sendmail. - ("rmail" rmail-count-new-messages rmail-show-message - ;; Next two only used in gnus-util. - rmail-summary-exists rmail-select-summary) - ;; Only used in gnus-util, which has an autoload. - ("rmailsum" rmail-update-summary) ("gnus-xmas" gnus-xmas-splash) - ("score-mode" :interactive t gnus-score-mode) + ("score-mode" :interactive t gnus-score-mode gnus-score-edit-all-score) ("gnus-mh" gnus-summary-save-article-folder gnus-Folder-save-name gnus-folder-save-name) ("gnus-mh" :interactive (gnus-summary-mode) gnus-summary-save-in-folder) @@ -2609,7 +2601,11 @@ are always t.") gnus-uu-decode-uu-and-save-view gnus-uu-decode-unshar-view gnus-uu-decode-unshar-and-save-view gnus-uu-decode-save-view gnus-uu-decode-binhex-view gnus-uu-unmark-thread - gnus-uu-mark-over gnus-uu-post-news gnus-uu-invert-processable) + gnus-uu-mark-over gnus-uu-post-news gnus-uu-invert-processable + gnus-uu-decode-postscript-and-save-view + gnus-uu-decode-postscript-view gnus-uu-decode-postscript-and-save + gnus-uu-decode-yenc gnus-uu-unmark-by-regexp gnus-uu-unmark-region + gnus-uu-decode-postscript) ("gnus-uu" gnus-uu-delete-work-dir gnus-uu-unmark-thread) ("gnus-msg" (gnus-summary-send-map keymap) gnus-article-mail gnus-copy-article-buffer gnus-extended-version) @@ -2656,6 +2652,7 @@ are always t.") gnus-article-hide-headers gnus-article-hide-boring-headers gnus-article-treat-overstrike gnus-article-remove-cr gnus-article-remove-trailing-blank-lines + gnus-article-emojize-symbols gnus-article-display-x-face gnus-article-de-quoted-unreadable gnus-article-de-base64-unreadable gnus-article-decode-HZ @@ -2667,7 +2664,34 @@ are always t.") gnus-article-edit-mode gnus-article-edit-article gnus-article-edit-done gnus-article-decode-encoded-words gnus-start-date-timer gnus-stop-date-timer - gnus-mime-view-all-parts) + gnus-mime-view-all-parts gnus-article-pipe-part + gnus-article-inline-part gnus-article-encrypt-body + gnus-article-browse-html-article gnus-article-view-part-externally + gnus-article-view-part-as-charset gnus-article-copy-part + gnus-article-jump-to-part gnus-article-view-part-as-type + gnus-article-delete-part gnus-article-replace-part + gnus-article-save-part-and-strip gnus-article-save-part + gnus-article-remove-leading-whitespace gnus-article-strip-trailing-space + gnus-article-strip-leading-space gnus-article-strip-all-blank-lines + gnus-article-strip-blank-lines gnus-article-strip-multiple-blank-lines + gnus-article-date-user gnus-article-date-iso8601 + gnus-article-date-english gnus-article-date-ut + gnus-article-decode-charset gnus-article-decode-mime-words + gnus-article-toggle-fonts gnus-article-show-images + gnus-article-remove-images gnus-article-display-face + gnus-article-treat-fold-newsgroups gnus-article-treat-unfold-headers + gnus-article-treat-fold-headers gnus-article-highlight-signature + gnus-article-highlight-headers gnus-article-highlight + gnus-article-strip-banner gnus-article-hide-list-identifiers + gnus-article-hide gnus-article-outlook-rearrange-citation + gnus-article-treat-non-ascii gnus-article-treat-smartquotes + gnus-article-verify-x-pgp-sig gnus-article-strip-headers-in-body + gnus-treat-smiley gnus-article-treat-ansi-sequences + gnus-article-capitalize-sentences gnus-article-toggle-truncate-lines + gnus-article-fill-long-lines gnus-article-emphasize + gnus-article-add-buttons-to-head gnus-article-add-button + gnus-article-babel gnus-sticky-article gnus-article-view-part + gnus-article-add-buttons) ("gnus-int" gnus-request-type) ("gnus-start" gnus-newsrc-parse-options gnus-1 gnus-no-server-1 gnus-dribble-enter gnus-read-init-file gnus-dribble-touch @@ -3118,9 +3142,9 @@ g -- Group name." "Check whether GROUP supports function FUNC. GROUP can either be a string (a group name) or a select method." (ignore-errors - (let ((method (if (stringp group) - (car (gnus-find-method-for-group group)) - group))) + (when-let ((method (if (stringp group) + (car (gnus-find-method-for-group group)) + group))) (unless (featurep method) (require method)) (fboundp (intern (format "%s-%s" method func)))))) @@ -3754,6 +3778,8 @@ just the host name." (setq foreign server group (substring group (+ 1 colon)))) (setq foreign (concat foreign ":"))) + ;; Remove braces from name (common in IMAP groups). + (setq group (replace-regexp-in-string "[][]+" "" group)) ;; Collapse group name leaving LEVELS uncollapsed elements (let* ((slist (split-string group "/")) (slen (length slist)) diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el index af0a1983766..efdddea69f6 100644 --- a/lisp/gnus/mail-source.el +++ b/lisp/gnus/mail-source.el @@ -224,12 +224,9 @@ Leave mails for this many days" :value 14))))) (const :format "" :value :plugged) (boolean :tag "Plugged")))))))) -(defcustom mail-source-ignore-errors nil - "Ignore errors when querying mail sources. -If nil, the user will be prompted when an error occurs. If non-nil, -the error will be ignored." - :version "22.1" - :type 'boolean) +(make-obsolete-variable 'mail-source-ignore-errors + "configure `gnus-verbose' instead" + "29.1") (defcustom mail-source-primary-source nil "Primary source for incoming mail. @@ -554,18 +551,16 @@ Return the number of files that were found." (condition-case err (funcall function source callback) (error - (if (and (not mail-source-ignore-errors) - (not - (yes-or-no-p - (format "Mail source %s error (%s). Continue? " + (gnus-error + 5 + (format "Mail source %s error (%s)" (if (memq ':password source) (let ((s (copy-sequence source))) (setcar (cdr (memq ':password s)) "********") s) source) - (cadr err))))) - (error "Cannot get new mail")) + (cadr err))) 0))))))))) (declare-function gnus-message "gnus-util" (level &rest args)) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index bbf1c78a01f..f69f51a8284 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -48,6 +48,8 @@ (require 'puny) (require 'rmc) ; read-multiple-choice (require 'subr-x) +(require 'yank-media) +(require 'mailcap) (autoload 'mailclient-send-it "mailclient") @@ -2051,7 +2053,7 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'." (autoload 'gnus-groups-from-server "gnus") (autoload 'gnus-open-server "gnus-int") (autoload 'gnus-output-to-mail "gnus-util") -(autoload 'gnus-output-to-rmail "gnus-util") +(autoload 'gnus-output-to-rmail "gnus-rmail") (autoload 'gnus-request-post "gnus-int") (autoload 'gnus-server-string "gnus") (autoload 'message-setup-toolbar "messagexmas") @@ -2870,84 +2872,78 @@ Consider adding this function to `message-header-setup-hook'" ;;; Set up keymap. -(defvar message-mode-map nil) - -(unless message-mode-map - (setq message-mode-map (make-keymap)) - (set-keymap-parent message-mode-map text-mode-map) - (define-key message-mode-map "\C-c?" #'describe-mode) - - (define-key message-mode-map "\C-c\C-f\C-t" #'message-goto-to) - (define-key message-mode-map "\C-c\C-f\C-o" #'message-goto-from) - (define-key message-mode-map "\C-c\C-f\C-b" #'message-goto-bcc) - (define-key message-mode-map "\C-c\C-f\C-w" #'message-goto-fcc) - (define-key message-mode-map "\C-c\C-f\C-c" #'message-goto-cc) - (define-key message-mode-map "\C-c\C-f\C-s" #'message-goto-subject) - (define-key message-mode-map "\C-c\C-f\C-r" #'message-goto-reply-to) - (define-key message-mode-map "\C-c\C-f\C-n" #'message-goto-newsgroups) - (define-key message-mode-map "\C-c\C-f\C-d" #'message-goto-distribution) - (define-key message-mode-map "\C-c\C-f\C-f" #'message-goto-followup-to) - (define-key message-mode-map "\C-c\C-f\C-m" #'message-goto-mail-followup-to) - (define-key message-mode-map "\C-c\C-f\C-k" #'message-goto-keywords) - (define-key message-mode-map "\C-c\C-f\C-u" #'message-goto-summary) - (define-key message-mode-map "\C-c\C-f\C-i" - #'message-insert-or-toggle-importance) - (define-key message-mode-map "\C-c\C-f\C-a" - #'message-generate-unsubscribed-mail-followup-to) +(defvar-keymap message-mode-map + :full t :parent text-mode-map + :doc "Message Mode keymap." + "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 ;; modify headers (and insert notes in body) - (define-key message-mode-map "\C-c\C-fs" #'message-change-subject) + "C-c C-f s" #'message-change-subject ;; - (define-key message-mode-map "\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 - (define-key message-mode-map "\C-c\C-ft" #'message-reduce-to-to-cc) - (define-key message-mode-map "\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 - (define-key message-mode-map "\C-c\M-m" #'message-mark-inserted-region) - (define-key message-mode-map "\C-c\M-f" #'message-mark-insert-file) - - (define-key message-mode-map "\C-c\C-b" #'message-goto-body) - (define-key message-mode-map "\C-c\C-i" #'message-goto-signature) - - (define-key message-mode-map "\C-c\C-t" #'message-insert-to) - (define-key message-mode-map "\C-c\C-fw" #'message-insert-wide-reply) - (define-key message-mode-map "\C-c\C-n" #'message-insert-newsgroups) - (define-key message-mode-map "\C-c\C-l" #'message-to-list-only) - (define-key message-mode-map "\C-c\C-f\C-e" #'message-insert-expires) - - (define-key message-mode-map "\C-c\C-u" #'message-insert-or-toggle-importance) - (define-key message-mode-map "\C-c\M-n" - #'message-insert-disposition-notification-to) - - (define-key message-mode-map "\C-c\C-y" #'message-yank-original) - (define-key message-mode-map "\C-c\M-\C-y" #'message-yank-buffer) - (define-key message-mode-map "\C-c\C-q" #'message-fill-yanked-message) - (define-key message-mode-map "\C-c\C-w" #'message-insert-signature) - (define-key message-mode-map "\C-c\M-h" #'message-insert-headers) - (define-key message-mode-map "\C-c\C-r" #'message-caesar-buffer-body) - (define-key message-mode-map "\C-c\C-o" #'message-sort-headers) - (define-key message-mode-map "\C-c\M-r" #'message-rename-buffer) - - (define-key message-mode-map "\C-c\C-c" #'message-send-and-exit) - (define-key message-mode-map "\C-c\C-s" #'message-send) - (define-key message-mode-map "\C-c\C-k" #'message-kill-buffer) - (define-key message-mode-map "\C-c\C-d" #'message-dont-send) - (define-key message-mode-map "\C-c\n" #'gnus-delay-article) - - (define-key message-mode-map "\C-c\M-k" #'message-kill-address) - (define-key message-mode-map "\C-c\C-e" #'message-elide-region) - (define-key message-mode-map "\C-c\C-v" #'message-delete-not-region) - (define-key message-mode-map "\C-c\C-z" #'message-kill-to-signature) - (define-key message-mode-map "\M-\r" #'message-newline-and-reformat) - (define-key message-mode-map [remap split-line] #'message-split-line) - - (define-key message-mode-map "\C-c\C-a" #'mml-attach-file) - (define-key message-mode-map "\C-c\C-p" #'message-insert-screenshot) - - (define-key message-mode-map "\C-a" #'message-beginning-of-line) - (define-key message-mode-map "\t" #'message-tab) - - (define-key message-mode-map "\M-n" #'message-display-abbrev)) + "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-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 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 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-RET" #'message-newline-and-reformat + "<remap> <split-line>" #'message-split-line + + "C-c C-a" #'mml-attach-file + "C-c C-p" #'message-insert-screenshot + + "C-a" #'message-beginning-of-line + "TAB" #'message-tab + + "M-n" #'message-display-abbrev) (easy-menu-define message-mode-menu message-mode-map "Message Menu." @@ -3161,6 +3157,7 @@ Like `text-mode', but with these additional commands: (setq-local message-checksum nil) (setq-local message-mime-part 0) (message-setup-fill-variables) + (yank-media-handler "image/.*" #'message--yank-media-image-handler) (when message-fill-column (setq fill-column message-fill-column) (turn-on-auto-fill)) @@ -4338,6 +4335,44 @@ Instead, just auto-save the buffer and then bury it." (autoload 'mml-secure-bcc-is-safe "mml-sec") +(defcustom message-server-alist nil + "Alist of rules to generate \"X-Message-SMTP-Method\" header. +The header will be inserted just before the message is sent. +Elements should be of the form (COND . METHOD). +If COND is a string, METHOD will be inserted if the \"From\" +address compares equal with COND. +If COND is a function, METHOD will be inserted if COND returns +a non-nil value when called in the message buffer without any +arguments. If METHOD is nil in this case, the return value of +the function will be inserted instead. +If the buffer already has a\"X-Message-SMTP-Method\" header, +it is left unchanged." + :type '(alist :key-type '(choice + (string :tag "From Address") + (function :tag "Predicate")) + :value-type 'string) + :version "29.1" + :group 'message-sending) + +(defun message-update-smtp-method-header () + "Insert an X-Message-SMTP-Method header according to `message-server-alist'." + (unless (message-fetch-field "X-Message-SMTP-Method") + (let ((from (cadr (mail-extract-address-components (message-fetch-field "From")))) + method) + (catch 'exit + (dolist (server message-server-alist) + (cond ((functionp (car server)) + (let ((res (funcall (car server)))) + (when res + (setq method (or (cdr server) res)) + (throw 'exit nil)))) + ((and (stringp (car server)) + (string= (car server) from)) + (setq method (cdr server)) + (throw 'exit nil))))) + (when method + (message-add-header (concat "X-Message-SMTP-Method: " method)))))) + (defun message-send (&optional arg) "Send the message in the current buffer. If `message-interactive' is non-nil, wait for success indication or @@ -4351,6 +4386,7 @@ It should typically alter the sending method in some way or other." (undo-boundary) (let ((inhibit-read-only t)) (put-text-property (point-min) (point-max) 'read-only nil)) + (message-update-smtp-method-header) (message-fix-before-sending) (run-hooks 'message-send-hook) (mml-secure-bcc-is-safe) @@ -4766,23 +4802,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 @@ -5358,7 +5396,7 @@ Otherwise, generate and save a value for `canlock-password' first." (zerop (length (setq to (completing-read - "Followups to (default no Followup-To header): " + (format-prompt "Followups to" "no Followup-To header") (mapcar #'list (cons "poster" (message-tokenize-header @@ -5829,15 +5867,15 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'." ;; You might for example insert a "." somewhere (not next to another dot ;; or string boundary), or modify the "fsf" string. (defun message-unique-id () - ;; Don't use microseconds from (current-time), they may be unsupported. + ;; Don't use fractional seconds from timestamp; they may be unsupported. ;; Instead we use this randomly inited counter. (setq message-unique-id-char - (% (1+ (or message-unique-id-char - (random (ash 1 20)))) - ;; (current-time) returns 16-bit ints, - ;; and 2^16*25 just fits into 4 digits i base 36. - (* 25 25))) - (let ((tm (current-time))) + ;; 2^16 * 25 just fits into 4 digits i base 36. + (let ((base (* 25 25))) + (if message-unique-id-char + (% (1+ message-unique-id-char) base) + (random base)))) + (let ((tm (time-convert nil 'integer))) (concat (if (or (eq system-type 'ms-dos) ;; message-number-base36 doesn't handle bigints. @@ -5847,10 +5885,12 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'." (aset user (match-beginning 0) ?_)) user) (message-number-base36 (user-uid) -1)) - (message-number-base36 (+ (car tm) - (ash (% message-unique-id-char 25) 16)) 4) - (message-number-base36 (+ (nth 1 tm) - (ash (/ message-unique-id-char 25) 16)) 4) + (message-number-base36 (+ (ash tm -16) + (ash (% message-unique-id-char 25) 16)) + 4) + (message-number-base36 (+ (logand tm #xffff) + (ash (/ message-unique-id-char 25) 16)) + 4) ;; Append a given name, because while the generated ID is unique ;; to this newsreader, other newsreaders might otherwise generate ;; the same ID via another algorithm. @@ -5947,12 +5987,9 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'." (defun message-make-expires () "Return an Expires header based on `message-expires'." - (let ((current (current-time)) - (future (* 1.0 message-expires 60 60 24))) + (let ((future (* 60 60 24 message-expires))) ;; Add the future to current. - (setcar current (+ (car current) (round (/ future (expt 2 16))))) - (setcar (cdr current) (+ (nth 1 current) (% (round future) (expt 2 16)))) - (message-make-date current))) + (message-make-date (time-add nil future)))) (defun message-make-path () "Return uucp path." @@ -8879,24 +8916,29 @@ used to take the screenshot." (car message-screenshot-command) nil (current-buffer) nil (cdr message-screenshot-command)) (buffer-string)))) - (set-mark (point)) - (insert-image - (create-image image 'png t - :max-width (truncate (* (frame-pixel-width) 0.8)) - :max-height (truncate (* (frame-pixel-height) 0.8)) - :scale 1) - (format "<#part type=\"image/png\" disposition=inline data-encoding=base64 raw=t>\n%s\n<#/part>" - ;; Get a base64 version of the image -- this avoids later - ;; complications if we're auto-saving the buffer and - ;; restoring from a file. - (with-temp-buffer - (set-buffer-multibyte nil) - (insert image) - (base64-encode-region (point-min) (point-max) t) - (buffer-string)))) - (insert "\n\n") + (message--yank-media-image-handler 'image/png image) (message ""))) +(defun message--yank-media-image-handler (type image) + (set-mark (point)) + (insert-image + (create-image image (mailcap-mime-type-to-extension type) t + :max-width (truncate (* (frame-pixel-width) 0.8)) + :max-height (truncate (* (frame-pixel-height) 0.8)) + :scale 1) + (format "<#part type=\"%s\" disposition=inline data-encoding=base64 raw=t>\n%s\n<#/part>" + type + ;; Get a base64 version of the image -- this avoids later + ;; complications if we're auto-saving the buffer and + ;; restoring from a file. + (with-temp-buffer + (set-buffer-multibyte nil) + (insert image) + (base64-encode-region (point-min) (point-max) t) + (buffer-string))) + nil nil t) + (insert "\n\n")) + (declare-function gnus-url-unhex-string "gnus-util") (defun message-parse-mailto-url (url) diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el index aca4bf2062d..e2fb4b66b1b 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. @@ -473,6 +474,7 @@ The file will be saved in the directory `mm-tmp-directory'.") (autoload 'mml2015-verify-test "mml2015") (autoload 'mml-smime-verify "mml-smime") (autoload 'mml-smime-verify-test "mml-smime") +(autoload 'mm-view-pkcs7-verify "mm-view") (defvar mm-verify-function-alist '(("application/pgp-signature" mml2015-verify "PGP" mml2015-verify-test) @@ -481,7 +483,15 @@ The file will be saved in the directory `mm-tmp-directory'.") ("application/pkcs7-signature" mml-smime-verify "S/MIME" mml-smime-verify-test) ("application/x-pkcs7-signature" mml-smime-verify "S/MIME" - mml-smime-verify-test))) + mml-smime-verify-test) + ("application/x-pkcs7-signature" mml-smime-verify "S/MIME" + mml-smime-verify-test) + ;; these are only used for security-buttons and contain the + ;; smime-type after the underscore + ("application/pkcs7-mime_signed-data" mm-view-pkcs7-verify "S/MIME" + nil) + ("application/x-pkcs7-mime_signed-data" mml-view-pkcs7-verify "S/MIME" + nil))) (defcustom mm-verify-option 'never "Option of verifying signed parts. @@ -500,11 +510,17 @@ result of the verification." (autoload 'mml2015-decrypt "mml2015") (autoload 'mml2015-decrypt-test "mml2015") +(autoload 'mm-view-pkcs7-decrypt "mm-view") (defvar mm-decrypt-function-alist '(("application/pgp-encrypted" mml2015-decrypt "PGP" mml2015-decrypt-test) ("application/x-gnus-pgp-encrypted" mm-uu-pgp-encrypted-extract-1 "PGP" - mm-uu-pgp-encrypted-test))) + mm-uu-pgp-encrypted-test) + ;; these are only used for security-buttons and contain the + ;; smime-type after the underscore + ("application/pkcs7-mime_enveloped-data" mm-view-pkcs7-decrypt "S/MIME" nil) + ("application/x-pkcs7-mime_enveloped-data" + mm-view-pkcs7-decrypt "S/MIME" nil))) (defcustom mm-decrypt-option nil "Option of decrypting encrypted parts. @@ -681,18 +697,35 @@ MIME-Version header before proceeding." 'start start) (car ctl)) (cons (car ctl) (mm-dissect-multipart ctl from)))) - (t - (mm-possibly-verify-or-decrypt - (mm-dissect-singlepart - ctl - (and cte (intern (downcase (mail-header-strip-cte cte)))) - no-strict-mime - (and cd (mail-header-parse-content-disposition cd)) - description id) - ctl from)))) - (when id - (when (string-match " *<\\(.*\\)> *" id) - (setq id (match-string 1 id))) + (t + (let* ((handle + (mm-dissect-singlepart + ctl + (and cte (intern (downcase (mail-header-strip-cte cte)))) + no-strict-mime + (and cd (mail-header-parse-content-disposition cd)) + description id)) + (intermediate-result + (mm-possibly-verify-or-decrypt handle ctl from))) + (when (and (equal type "application") + (or (equal subtype "pkcs7-mime") + (equal subtype "x-pkcs7-mime"))) + (add-text-properties + 0 (length (car ctl)) + (list 'protocol + (concat (substring-no-properties (car ctl)) + "_" + (cdr (assoc 'smime-type ctl)))) + (car ctl)) + ;; If this is a pkcs7-mime lets treat this special and + ;; more like multipart so the pkcs7-mime part does not + ;; get ignored. + (setq intermediate-result + (cons (car ctl) (list intermediate-result)))) + intermediate-result)))) + (when id + (when (string-match " *<\\(.*\\)> *" id) + (setq id (match-string 1 id))) (push (cons id result) mm-content-id-alist)) result)))) @@ -957,10 +990,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 @@ -1670,43 +1709,40 @@ If RECURSIVE, search recursively." (cond ((or (equal type "application/x-pkcs7-mime") (equal type "application/pkcs7-mime")) - (with-temp-buffer - (when (and (cond - ((equal smime-type "signed-data") t) - ((eq mm-decrypt-option 'never) nil) - ((eq mm-decrypt-option 'always) t) - ((eq mm-decrypt-option 'known) t) - (t (y-or-n-p "Decrypt (S/MIME) part? "))) - (mm-view-pkcs7 parts from)) - (goto-char (point-min)) - ;; The encrypted document is a MIME part, and may use either - ;; CRLF (Outlook and the like) or newlines for end-of-line - ;; markers. Translate from CRLF. - (while (search-forward "\r\n" nil t) - (replace-match "\n")) - ;; Normally there will be a Content-type header here, but - ;; some mailers don't add that to the encrypted part, which - ;; makes the subsequent re-dissection fail here. - (save-restriction - (mail-narrow-to-head) - (unless (mail-fetch-field "content-type") - (goto-char (point-max)) - (insert "Content-type: text/plain\n\n"))) - (setq parts - (if (equal smime-type "signed-data") - (list (propertize - "multipart/signed" - 'protocol "application/pkcs7-signature" - 'gnus-info - (format - "%s:%s" - (get-text-property 0 'gnus-info - (car mm-security-handle)) - (get-text-property 0 'gnus-details - (car mm-security-handle)))) - (mm-dissect-buffer t) - parts) - (mm-dissect-buffer t)))))) + (add-text-properties 0 (length (car ctl)) + (list 'buffer (car parts)) + (car ctl)) + (let* ((envelope-p (string= smime-type "enveloped-data")) + (decrypt-or-verify-option (if envelope-p + mm-decrypt-option + mm-verify-option)) + (question (if envelope-p + "Decrypt (S/MIME) part? " + "Verify signed (S/MIME) part? "))) + (with-temp-buffer + (when (and (cond + ((equal smime-type "signed-data") t) + ((eq decrypt-or-verify-option 'never) nil) + ((eq decrypt-or-verify-option 'always) t) + ((eq decrypt-or-verify-option 'known) t) + (t (y-or-n-p (format question)))) + (mm-view-pkcs7 parts from)) + + (goto-char (point-min)) + ;; The encrypted document is a MIME part, and may use either + ;; CRLF (Outlook and the like) or newlines for end-of-line + ;; markers. Translate from CRLF. + (while (search-forward "\r\n" nil t) + (replace-match "\n")) + ;; Normally there will be a Content-type header here, but + ;; some mailers don't add that to the encrypted part, which + ;; makes the subsequent re-dissection fail here. + (save-restriction + (mail-narrow-to-head) + (unless (mail-fetch-field "content-type") + (goto-char (point-max)) + (insert "Content-type: text/plain\n\n"))) + (setq parts (mm-dissect-buffer t)))))) ((equal subtype "signed") (unless (and (setq protocol (mm-handle-multipart-ctl-parameter ctl 'protocol)) @@ -1833,7 +1869,7 @@ If RECURSIVE, search recursively." ;; Require since we bind its variables. (require 'shr) (let ((shr-width (if shr-use-fonts - nil + shr-width fill-column)) (shr-content-function (lambda (id) (let ((handle (mm-get-content-id id))) diff --git a/lisp/gnus/mm-url.el b/lisp/gnus/mm-url.el index 3d58738d637..fd23a4e2cfb 100644 --- a/lisp/gnus/mm-url.el +++ b/lisp/gnus/mm-url.el @@ -34,8 +34,6 @@ (require 'gnus) (defvar url-current-object) -(defvar url-package-name) -(defvar url-package-version) (defgroup mm-url nil "A wrapper of url package and external url command for Gnus." diff --git a/lisp/gnus/mm-util.el b/lisp/gnus/mm-util.el index 92e04f9d2ee..a0b3288f13f 100644 --- a/lisp/gnus/mm-util.el +++ b/lisp/gnus/mm-util.el @@ -31,7 +31,7 @@ (defun mm-ucs-to-char (codepoint) "Convert Unicode codepoint to character." - (or (decode-char 'ucs codepoint) ?#)) + (or codepoint ?#)) (defvar mm-coding-system-list nil) (defun mm-get-coding-system-list () @@ -101,9 +101,9 @@ version, you could use `autoload-coding-system' here." :type '(list (repeat :inline t :tag "Other options" (cons (symbol :tag "charset") - (symbol :tag "form")))) + (symbol :tag "form")))) + :risky t :group 'mime) -(put 'mm-charset-eval-alist 'risky-local-variable t) (defvar mm-charset-override-alist) diff --git a/lisp/gnus/mm-view.el b/lisp/gnus/mm-view.el index d2a6d2cf5d3..319bc745ff8 100644 --- a/lisp/gnus/mm-view.el +++ b/lisp/gnus/mm-view.el @@ -634,12 +634,9 @@ If MODE is not set, try to find mode automatically." (context (epg-make-context 'CMS))) (prog1 (epg-verify-string context part) - (let ((result (car (epg-context-result-for context 'verify)))) + (let ((result (epg-context-result-for context 'verify))) (mm-sec-status - 'gnus-info (epg-signature-status result) - 'gnus-details - (format "%s:%s" (epg-signature-validity result) - (epg-signature-key-id result)))))))) + 'gnus-info (epg-verify-result-to-string result))))))) (with-temp-buffer (insert "MIME-Version: 1.0\n") (mm-insert-headers "application/pkcs7-mime" "base64" "smime.p7m") @@ -659,7 +656,11 @@ If MODE is not set, try to find mode automatically." ;; Use EPG/gpgsm (let ((part (base64-decode-string (buffer-string)))) (erase-buffer) - (insert (epg-decrypt-string (epg-make-context 'CMS) part))) + (insert + (let ((context (epg-make-context 'CMS))) + (prog1 + (epg-decrypt-string context part) + (mm-sec-status 'gnus-info "OK"))))) ;; Use openssl (insert "MIME-Version: 1.0\n") (mm-insert-headers "application/pkcs7-mime" "base64" "smime.p7m") diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el index 5f35e73cd7c..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 "" @@ -1409,6 +1401,13 @@ to specify options." :version "22.1" ;; Gnus 5.10.9 :group 'message) +(defcustom mml-attach-file-at-the-end nil + "If non-nil, \\[mml-attach-file] attaches files at the end of the message. +If nil, files are attached at point." + :type 'boolean + :version "29.1" + :group 'message) + ;;;###autoload (defun mml-attach-file (file &optional type description disposition) "Attach a file to the outgoing MIME message. @@ -1423,6 +1422,8 @@ specifies how the attachment is intended to be displayed. It can be either \"inline\" (displayed automatically within the message body) or \"attachment\" (separate from the body). +Also see the `mml-attach-file-at-the-end' variable. + If given a prefix interactively, no prompting will be done for the TYPE, DESCRIPTION or DISPOSITION values. Instead defaults will be computed and used." @@ -1440,8 +1441,11 @@ will be computed and used." (mml-minibuffer-read-disposition type nil file)))) (list file type description disposition))) ;; If in the message header, attach at the end and leave point unchanged. - (let ((head (unless (message-in-body-p) (point)))) - (if head (goto-char (point-max))) + (let ((at-end (and (or (not (message-in-body-p)) + mml-attach-file-at-the-end) + (point)))) + (when at-end + (goto-char (point-max))) (mml-insert-empty-tag 'part 'type type ;; icicles redefines read-file-name and returns a @@ -1451,13 +1455,13 @@ will be computed and used." 'description description) ;; When using Mail mode, make sure it does the mime encoding ;; when you send the message. - (or (eq mail-user-agent 'message-user-agent) - (setq mail-encode-mml t)) - (when head + (unless (eq mail-user-agent 'message-user-agent) + (setq mail-encode-mml t)) + (when at-end (unless (pos-visible-in-window-p) (message "The file \"%s\" has been attached at the end of the message" (file-name-nondirectory file))) - (goto-char head)))) + (goto-char at-end)))) (defun mml-dnd-attach-file (uri _action) "Attach a drag and drop file. diff --git a/lisp/gnus/nndiary.el b/lisp/gnus/nndiary.el index 133e0307a54..6f8917e2528 100644 --- a/lisp/gnus/nndiary.el +++ b/lisp/gnus/nndiary.el @@ -1308,7 +1308,7 @@ all. This may very well take some time.") (let ((minute (nndiary-max (nth 0 sched))) (hour (nndiary-max (nth 1 sched))) (year (nndiary-max (nth 4 sched))) - (time-zone (or (and (nth 6 sched) (car (nth 6 sched))) + (time-zone (or (car (nth 6 sched)) (current-time-zone)))) (when year (or minute (setq minute 59)) @@ -1405,7 +1405,7 @@ all. This may very well take some time.") t)) (dow-list (nth 5 sched)) (year (1- this-year)) - (time-zone (or (and (nth 6 sched) (car (nth 6 sched))) + (time-zone (or (car (nth 6 sched)) (current-time-zone)))) ;; Special case: an asterisk in one of the days specifications means that ;; only the other should be taken into account. If both are unspecified, diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index 6b627a4b756..b7082696b2c 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -429,8 +429,18 @@ during splitting, which may be slow." now (nnimap-last-command-time nnimap-object)))) (with-local-quit - (ignore-errors ;E.g. "buffer foo has no process". - (nnimap-send-command "NOOP"))))))))) + (ignore-errors ;E.g. "buffer foo has no process". + (nnimap-send-command "NOOP")) + ;; If our connection has died in the meantime, clean it + ;; and its buffer up. + (unless (process-live-p (get-buffer-process buffer)) + (setq nnimap-process-buffers + (delq buffer nnimap-process-buffers)) + (setq nnimap-connection-alist + (seq-filter (lambda (elt) + (null (eq buffer (cdr elt)))) + nnimap-connection-alist)) + (kill-buffer buffer))))))))) (defun nnimap-open-connection (buffer) ;; Be backwards-compatible -- the earlier value of nnimap-stream was @@ -662,10 +672,17 @@ during splitting, which may be slow." (deffoo nnimap-close-server (&optional server defs) (when (nnoo-change-server 'nnimap server defs) - (ignore-errors - (delete-process (get-buffer-process (nnimap-buffer)))) - (nnoo-close-server 'nnimap server) - t)) + (let ((buf (nnimap-buffer))) + (ignore-errors + (delete-process (get-buffer-process buf))) + (setq nnimap-process-buffers + (delq buf nnimap-process-buffers) + nnimap-connection-alist + (seq-filter (lambda (elt) + (null (eq buf (cdr elt)))) + nnimap-connection-alist)) + (nnoo-close-server 'nnimap server) + t))) (deffoo nnimap-request-close () t) @@ -1937,10 +1954,13 @@ Return the server's response to the SELECT or EXAMINE command." (when entry (if (and (buffer-live-p (cadr entry)) (get-buffer-process (cadr entry)) - (memq (process-status (get-buffer-process (cadr entry))) - '(open run))) + (process-live-p (get-buffer-process (cadr entry)))) (get-buffer-process (cadr entry)) - (setq nnimap-connection-alist (delq entry nnimap-connection-alist)) + (setq nnimap-connection-alist (delq entry nnimap-connection-alist) + nnimap-process-buffers + (delq (cadr entry) nnimap-process-buffers)) + (when (buffer-live-p (cadr entry)) + (kill-buffer (cadr entry))) nil)))) ;; Leave room for `open-network-stream' to issue a couple of IMAP diff --git a/lisp/gnus/nnrss.el b/lisp/gnus/nnrss.el index 0ac57e9e171..59a22f725a9 100644 --- a/lisp/gnus/nnrss.el +++ b/lisp/gnus/nnrss.el @@ -450,7 +450,7 @@ nnrss: %s: Not valid XML %s and libxml-parse-html-region doesn't work %s" This function handles the ISO 8601 date format described in URL `https://www.w3.org/TR/NOTE-datetime', and also the RFC 822 style which RSS 2.0 allows." - (let (case-fold-search vector year month day time zone cts given) + (let (case-fold-search vector year month day time zone given) (cond ((null date)) ; do nothing for this case ;; if the date is just digits (unix time stamp): ((string-match "^[0-9]+$" date) @@ -481,13 +481,13 @@ which RSS 2.0 allows." 0 (decoded-time-zone decoded)))))) (if month - (progn - (setq cts (current-time-string (encode-time 0 0 0 day month year))) - (format "%s, %02d %s %04d %s%s" - (substring cts 0 3) day (substring cts 4 7) year time - (if zone - (concat " " (format-time-string "%z" nil zone)) - ""))) + (concat (let ((system-time-locale "C")) + (format-time-string "%a, %d %b %Y " + (encode-time 0 0 0 day month year))) + time + (if zone + (format-time-string " %z" nil zone) + "")) (message-make-date given)))) ;;; data functions diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el index ecec705b326..0130f689991 100644 --- a/lisp/gnus/nnselect.el +++ b/lisp/gnus/nnselect.el @@ -395,8 +395,7 @@ If this variable is nil, or if the provided function returns nil, (gnus-search-run-query (list (cons 'search-query-spec - (list (cons 'query `((id . ,article))) - (cons 'criteria "") (cons 'shortcut t))) + (list (cons 'query (format "id:%s" article)))) (cons 'search-group-spec servers)))) (unless (zerop (nnselect-artlist-length artlist)) (setq @@ -779,6 +778,10 @@ Return an article list." (args (alist-get 'nnselect-args specs))) (condition-case-unless-debug err (funcall func args) + ;; Don't swallow gnus-search errors; the user should be made + ;; aware of them. + (gnus-search-error + (signal (car err) (cdr err))) (error (gnus-error 3 "nnselect-run: %s on %s gave error %s" func args err) [])))) @@ -901,7 +904,7 @@ article came from is also searched." ;; make sure (setq list (sort (map-merge - 'list list + 'alist list (alist-get type (gnus-info-marks group-info))) (lambda (elt1 elt2) (< (car elt1) (car elt2)))))) diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el index 615a3c931bf..25289655bf2 100644 --- a/lisp/gnus/nntp.el +++ b/lisp/gnus/nntp.el @@ -331,9 +331,7 @@ retried once before actually displaying the error report." (when nntp-record-commands (nntp-record-command "*** CALLED nntp-report ***")) - (nnheader-report 'nntp args) - - (apply #'error args))) + (nnheader-report 'nntp args))) (defsubst nntp-copy-to-buffer (buffer start end) "Copy string from unibyte current buffer to multibyte buffer." diff --git a/lisp/gnus/spam.el b/lisp/gnus/spam.el index d00f0a60b66..508ef5424ea 100644 --- a/lisp/gnus/spam.el +++ b/lisp/gnus/spam.el @@ -663,13 +663,13 @@ order for SpamAssassin to recognize the new registered spam." ;;; Key bindings for spam control. -(gnus-define-keys 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 - "$" gnus-summary-mark-as-spam) +(define-keymap :keymap gnus-summary-mode-map + "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 "Whether spam.el will try to cache lookups using `spam-caches'.") diff --git a/lisp/help-at-pt.el b/lisp/help-at-pt.el index 233c50504bf..8eb397bc82d 100644 --- a/lisp/help-at-pt.el +++ b/lisp/help-at-pt.el @@ -229,11 +229,11 @@ this option, or use \"In certain situations\" and specify no text properties, to enable buffer local values." never)) :initialize 'custom-initialize-default - :set #'(lambda (variable value) - (set-default variable value) - (if (eq value 'never) - (help-at-pt-cancel-timer) - (help-at-pt-set-timer))) + :set (lambda (variable value) + (set-default variable value) + (if (eq value 'never) + (help-at-pt-cancel-timer) + (help-at-pt-set-timer))) :set-after '(help-at-pt-timer-delay) :require 'help-at-pt) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 2b759a5a5c5..32698420e1f 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -249,7 +249,8 @@ handling of autoloaded functions." ;; calling that. (let ((describe-function-orig-buffer (or describe-function-orig-buffer - (current-buffer)))) + (current-buffer))) + (help-buffer-under-preparation t)) (help-setup-xref (list (lambda (function buffer) @@ -1078,7 +1079,8 @@ it is displayed along with the global value." (if (symbolp v) (symbol-name v)))) (list (if (equal val "") v (intern val))))) - (let (file-name) + (let (file-name + (help-buffer-under-preparation t)) (unless (buffer-live-p buffer) (setq buffer (current-buffer))) (unless (frame-live-p frame) (setq frame (selected-frame))) (if (not (symbolp variable)) @@ -1461,77 +1463,78 @@ If FRAME is omitted or nil, use the selected frame." (interactive (list (read-face-name "Describe face" (or (face-at-point t) 'default) t))) - (help-setup-xref (list #'describe-face face) - (called-interactively-p 'interactive)) - (unless face - (setq face 'default)) - (if (not (listp face)) - (setq face (list face))) - (with-help-window (help-buffer) - (with-current-buffer standard-output - (dolist (f face (buffer-string)) - (if (stringp f) (setq f (intern f))) - ;; We may get called for anonymous faces (i.e., faces - ;; expressed using prop-value plists). Those can't be - ;; usefully customized, so ignore them. - (when (symbolp f) - (insert "Face: " (symbol-name f)) - (if (not (facep f)) - (insert " undefined face.\n") - (let ((customize-label "customize this face") - file-name) - (insert (concat " (" (propertize "sample" 'font-lock-face f) ")")) - (princ (concat " (" customize-label ")\n")) - ;; FIXME not sure how much of this belongs here, and - ;; how much in `face-documentation'. The latter is - ;; not used much, but needs to return nil for - ;; undocumented faces. - (let ((alias (get f 'face-alias)) - (face f) - obsolete) - (when alias - (setq face alias) - (insert - (format-message - "\n %s is an alias for the face `%s'.\n%s" - f alias - (if (setq obsolete (get f 'obsolete-face)) - (format-message - " This face is obsolete%s; use `%s' instead.\n" - (if (stringp obsolete) - (format " since %s" obsolete) - "") - alias) - "")))) - (insert "\nDocumentation:\n" - (substitute-command-keys - (or (face-documentation face) - "Not documented as a face.")) - "\n\n")) - (with-current-buffer standard-output - (save-excursion - (re-search-backward - (concat "\\(" customize-label "\\)") nil t) - (help-xref-button 1 'help-customize-face f))) - (setq file-name (find-lisp-object-file-name f 'defface)) - (if (not file-name) - (setq help-mode--current-data (list :symbol f)) - (setq help-mode--current-data (list :symbol f - :file file-name)) - (princ (substitute-command-keys "Defined in `")) - (princ (help-fns-short-filename file-name)) - (princ (substitute-command-keys "'")) - ;; Make a hyperlink to the library. - (save-excursion - (re-search-backward - (substitute-command-keys "`\\([^`']+\\)'") nil t) - (help-xref-button 1 'help-face-def f file-name)) - (princ ".") - (terpri) - (terpri)))) - (terpri) - (help-fns--run-describe-functions - help-fns-describe-face-functions f frame)))))) + (let ((help-buffer-under-preparation t)) + (help-setup-xref (list #'describe-face face) + (called-interactively-p 'interactive)) + (unless face + (setq face 'default)) + (if (not (listp face)) + (setq face (list face))) + (with-help-window (help-buffer) + (with-current-buffer standard-output + (dolist (f face (buffer-string)) + (if (stringp f) (setq f (intern f))) + ;; We may get called for anonymous faces (i.e., faces + ;; expressed using prop-value plists). Those can't be + ;; usefully customized, so ignore them. + (when (symbolp f) + (insert "Face: " (symbol-name f)) + (if (not (facep f)) + (insert " undefined face.\n") + (let ((customize-label "customize this face") + file-name) + (insert (concat " (" (propertize "sample" 'font-lock-face f) ")")) + (princ (concat " (" customize-label ")\n")) + ;; FIXME not sure how much of this belongs here, and + ;; how much in `face-documentation'. The latter is + ;; not used much, but needs to return nil for + ;; undocumented faces. + (let ((alias (get f 'face-alias)) + (face f) + obsolete) + (when alias + (setq face alias) + (insert + (format-message + "\n %s is an alias for the face `%s'.\n%s" + f alias + (if (setq obsolete (get f 'obsolete-face)) + (format-message + " This face is obsolete%s; use `%s' instead.\n" + (if (stringp obsolete) + (format " since %s" obsolete) + "") + alias) + "")))) + (insert "\nDocumentation:\n" + (substitute-command-keys + (or (face-documentation face) + "Not documented as a face.")) + "\n\n")) + (with-current-buffer standard-output + (save-excursion + (re-search-backward + (concat "\\(" customize-label "\\)") nil t) + (help-xref-button 1 'help-customize-face f))) + (setq file-name (find-lisp-object-file-name f 'defface)) + (if (not file-name) + (setq help-mode--current-data (list :symbol f)) + (setq help-mode--current-data (list :symbol f + :file file-name)) + (princ (substitute-command-keys "Defined in `")) + (princ (help-fns-short-filename file-name)) + (princ (substitute-command-keys "'")) + ;; Make a hyperlink to the library. + (save-excursion + (re-search-backward + (substitute-command-keys "`\\([^`']+\\)'") nil t) + (help-xref-button 1 'help-face-def f file-name)) + (princ ".") + (terpri) + (terpri)))) + (terpri) + (help-fns--run-describe-functions + help-fns-describe-face-functions f frame))))))) (add-hook 'help-fns-describe-face-functions #'help-fns--face-custom-version-info) @@ -1561,7 +1564,7 @@ If FRAME is omitted or nil, use the selected frame." (:fontset . "Fontset") (:extend . "Extend") (:inherit . "Inherit"))) - (max-width (apply #'max (mapcar #'(lambda (x) (length (cdr x))) + (max-width (apply #'max (mapcar (lambda (x) (length (cdr x))) attrs)))) (dolist (a attrs) (let ((attr (face-attribute face (car a) frame))) @@ -1602,43 +1605,44 @@ current buffer and the selected frame, respectively." (if found (symbol-name v-or-f))))) (list (if (equal val "") (or v-or-f "") (intern val))))) - (if (not (symbolp symbol)) - (user-error "You didn't specify a function or variable")) - (unless (buffer-live-p buffer) (setq buffer (current-buffer))) - (unless (frame-live-p frame) (setq frame (selected-frame))) - (with-current-buffer (help-buffer) - ;; Push the previous item on the stack before clobbering the output buffer. - (help-setup-xref nil nil) - (let* ((docs - (nreverse - (delq nil - (mapcar (pcase-lambda (`(,name ,testfn ,descfn)) - (when (funcall testfn symbol) - ;; Don't record the current entry in the stack. - (setq help-xref-stack-item nil) - (cons name - (funcall descfn symbol buffer frame)))) - describe-symbol-backends)))) - (single (null (cdr docs)))) - (while (cdr docs) - (goto-char (point-min)) - (let ((inhibit-read-only t) - (name (caar docs)) ;Name of doc currently at BOB. - (doc (cdr (cadr docs)))) ;Doc to add at BOB. - (when doc - (insert doc) - (delete-region (point) - (progn (skip-chars-backward " \t\n") (point))) - (insert "\n\n" (make-separator-line) "\n") - (when name - (insert (symbol-name symbol) - " is also a " name "." "\n\n")))) - (setq docs (cdr docs))) - (unless single - ;; Don't record the `describe-variable' item in the stack. - (setq help-xref-stack-item nil) - (help-setup-xref (list #'describe-symbol symbol) nil)) - (goto-char (point-min))))) + (let ((help-buffer-under-preparation t)) + (if (not (symbolp symbol)) + (user-error "You didn't specify a function or variable")) + (unless (buffer-live-p buffer) (setq buffer (current-buffer))) + (unless (frame-live-p frame) (setq frame (selected-frame))) + (with-current-buffer (help-buffer) + ;; Push the previous item on the stack before clobbering the output buffer. + (help-setup-xref nil nil) + (let* ((docs + (nreverse + (delq nil + (mapcar (pcase-lambda (`(,name ,testfn ,descfn)) + (when (funcall testfn symbol) + ;; Don't record the current entry in the stack. + (setq help-xref-stack-item nil) + (cons name + (funcall descfn symbol buffer frame)))) + describe-symbol-backends)))) + (single (null (cdr docs)))) + (while (cdr docs) + (goto-char (point-min)) + (let ((inhibit-read-only t) + (name (caar docs)) ;Name of doc currently at BOB. + (doc (cdr (cadr docs)))) ;Doc to add at BOB. + (when doc + (insert doc) + (delete-region (point) + (progn (skip-chars-backward " \t\n") (point))) + (insert "\n\n" (make-separator-line) "\n") + (when name + (insert (symbol-name symbol) + " is also a " name "." "\n\n")))) + (setq docs (cdr docs))) + (unless single + ;; Don't record the `describe-variable' item in the stack. + (setq help-xref-stack-item nil) + (help-setup-xref (list #'describe-symbol symbol) nil)) + (goto-char (point-min)))))) ;;;###autoload (defun describe-syntax (&optional buffer) @@ -1647,15 +1651,16 @@ The descriptions are inserted in a help buffer, which is then displayed. BUFFER defaults to the current buffer." (interactive) (setq buffer (or buffer (current-buffer))) - (help-setup-xref (list #'describe-syntax buffer) - (called-interactively-p 'interactive)) - (with-help-window (help-buffer) - (let ((table (with-current-buffer buffer (syntax-table)))) - (with-current-buffer standard-output - (describe-vector table 'internal-describe-syntax-value) - (while (setq table (char-table-parent table)) - (insert "\nThe parent syntax table is:") - (describe-vector table 'internal-describe-syntax-value)))))) + (let ((help-buffer-under-preparation t)) + (help-setup-xref (list #'describe-syntax buffer) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) + (let ((table (with-current-buffer buffer (syntax-table)))) + (with-current-buffer standard-output + (describe-vector table 'internal-describe-syntax-value) + (while (setq table (char-table-parent table)) + (insert "\nThe parent syntax table is:") + (describe-vector table 'internal-describe-syntax-value))))))) (defun help-describe-category-set (value) (insert (cond @@ -1672,59 +1677,60 @@ The descriptions are inserted in a buffer, which is then displayed. If BUFFER is non-nil, then describe BUFFER's category table instead. BUFFER should be a buffer or a buffer name." (interactive) - (setq buffer (or buffer (current-buffer))) - (help-setup-xref (list #'describe-categories buffer) - (called-interactively-p 'interactive)) - (with-help-window (help-buffer) - (let* ((table (with-current-buffer buffer (category-table))) - (docs (char-table-extra-slot table 0))) - (if (or (not (vectorp docs)) (/= (length docs) 95)) - (error "Invalid first extra slot in this category table\n")) - (with-current-buffer standard-output - (setq-default help-button-cache (make-marker)) - (insert "Legend of category mnemonics ") - (insert-button "(longer descriptions at the bottom)" - 'action help-button-cache - 'follow-link t - 'help-echo "mouse-2, RET: show full legend") - (insert "\n") - (let ((pos (point)) (items 0) lines n) - (dotimes (i 95) - (if (aref docs i) (setq items (1+ items)))) - (setq lines (1+ (/ (1- items) 4))) - (setq n 0) + (let ((help-buffer-under-preparation t)) + (setq buffer (or buffer (current-buffer))) + (help-setup-xref (list #'describe-categories buffer) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) + (let* ((table (with-current-buffer buffer (category-table))) + (docs (char-table-extra-slot table 0))) + (if (or (not (vectorp docs)) (/= (length docs) 95)) + (error "Invalid first extra slot in this category table\n")) + (with-current-buffer standard-output + (setq-default help-button-cache (make-marker)) + (insert "Legend of category mnemonics ") + (insert-button "(longer descriptions at the bottom)" + 'action help-button-cache + 'follow-link t + 'help-echo "mouse-2, RET: show full legend") + (insert "\n") + (let ((pos (point)) (items 0) lines n) + (dotimes (i 95) + (if (aref docs i) (setq items (1+ items)))) + (setq lines (1+ (/ (1- items) 4))) + (setq n 0) + (dotimes (i 95) + (let ((elt (aref docs i))) + (when elt + (string-match ".*" elt) + (setq elt (match-string 0 elt)) + (if (>= (length elt) 17) + (setq elt (concat (substring elt 0 14) "..."))) + (if (< (point) (point-max)) + (move-to-column (* 20 (/ n lines)) t)) + (insert (+ i ?\s) ?: elt) + (if (< (point) (point-max)) + (forward-line 1) + (insert "\n")) + (setq n (1+ n)) + (if (= (% n lines) 0) + (goto-char pos)))))) + (goto-char (point-max)) + (insert "\n" + "character(s)\tcategory mnemonics\n" + "------------\t------------------") + (describe-vector table 'help-describe-category-set) + (set-marker help-button-cache (point)) + (insert "Legend of category mnemonics:\n") (dotimes (i 95) (let ((elt (aref docs i))) (when elt - (string-match ".*" elt) - (setq elt (match-string 0 elt)) - (if (>= (length elt) 17) - (setq elt (concat (substring elt 0 14) "..."))) - (if (< (point) (point-max)) - (move-to-column (* 20 (/ n lines)) t)) - (insert (+ i ?\s) ?: elt) - (if (< (point) (point-max)) - (forward-line 1) - (insert "\n")) - (setq n (1+ n)) - (if (= (% n lines) 0) - (goto-char pos)))))) - (goto-char (point-max)) - (insert "\n" - "character(s)\tcategory mnemonics\n" - "------------\t------------------") - (describe-vector table 'help-describe-category-set) - (set-marker help-button-cache (point)) - (insert "Legend of category mnemonics:\n") - (dotimes (i 95) - (let ((elt (aref docs i))) - (when elt - (if (string-match "\n" elt) - (setq elt (substring elt (match-end 0)))) - (insert (+ i ?\s) ": " elt "\n")))) - (while (setq table (char-table-parent table)) - (insert "\nThe parent category table is:") - (describe-vector table 'help-describe-category-set)))))) + (if (string-match "\n" elt) + (setq elt (substring elt (match-end 0)))) + (insert (+ i ?\s) ": " elt "\n")))) + (while (setq table (char-table-parent table)) + (insert "\nThe parent category table is:") + (describe-vector table 'help-describe-category-set))))))) (defun help-fns-find-keymap-name (keymap) "Find the name of the variable with value KEYMAP. @@ -1778,7 +1784,8 @@ keymap value." (unless (and km (keymapp (symbol-value km))) (user-error "Not a keymap: %s" km)) (list km))) - (let (used-gentemp) + (let (used-gentemp + (help-buffer-under-preparation t)) (unless (and (symbolp keymap) (boundp keymap) (keymapp (symbol-value keymap))) @@ -1844,106 +1851,107 @@ whose documentation describes the minor mode. If called from Lisp with a non-nil BUFFER argument, display documentation for the major and minor modes of that buffer." (interactive "@") - (unless buffer (setq buffer (current-buffer))) - (help-setup-xref (list #'describe-mode buffer) - (called-interactively-p 'interactive)) - ;; For the sake of help-do-xref and help-xref-go-back, - ;; don't switch buffers before calling `help-buffer'. - (with-help-window (help-buffer) - (with-current-buffer buffer - (let (minors) - ;; Older packages do not register in minor-mode-list but only in - ;; minor-mode-alist. - (dolist (x minor-mode-alist) - (setq x (car x)) - (unless (memq x minor-mode-list) - (push x minor-mode-list))) - ;; Find enabled minor mode we will want to mention. - (dolist (mode minor-mode-list) - ;; Document a minor mode if it is listed in minor-mode-alist, - ;; non-nil, and has a function definition. - (let ((fmode (or (get mode :minor-mode-function) mode))) - (and (boundp mode) (symbol-value mode) - (fboundp fmode) - (let ((pretty-minor-mode - (if (string-match "\\(\\(-minor\\)?-mode\\)?\\'" - (symbol-name fmode)) - (capitalize - (substring (symbol-name fmode) - 0 (match-beginning 0))) - fmode))) - (push (list fmode pretty-minor-mode - (format-mode-line (assq mode minor-mode-alist))) - minors))))) - ;; Narrowing is not a minor mode, but its indicator is part of - ;; mode-line-modes. - (when (buffer-narrowed-p) - (push '(narrow-to-region "Narrow" " Narrow") minors)) - (setq minors - (sort minors - (lambda (a b) (string-lessp (cadr a) (cadr b))))) - (when minors - (princ "Enabled minor modes:\n") - (make-local-variable 'help-button-cache) - (with-current-buffer standard-output - (dolist (mode minors) - (let ((mode-function (nth 0 mode)) - (pretty-minor-mode (nth 1 mode)) - (indicator (nth 2 mode))) - (save-excursion - (goto-char (point-max)) - (princ "\n\f\n") - (push (point-marker) help-button-cache) - ;; Document the minor modes fully. - (insert-text-button - pretty-minor-mode 'type 'help-function - 'help-args (list mode-function) - 'button '(t)) - (princ (format " minor mode (%s):\n" - (if (zerop (length indicator)) - "no indicator" - (format "indicator%s" - indicator)))) - (princ (help-split-fundoc (documentation mode-function) - nil 'doc))) - (insert-button pretty-minor-mode - 'action (car help-button-cache) - 'follow-link t - 'help-echo "mouse-2, RET: show full information") - (newline))) - (forward-line -1) - (fill-paragraph nil) - (forward-line 1)) - - (princ "\n(Information about these minor modes follows the major mode info.)\n\n")) - ;; Document the major mode. - (let ((mode mode-name)) - (with-current-buffer standard-output - (let ((start (point))) - (insert (format-mode-line mode nil nil buffer)) - (add-text-properties start (point) '(face bold))))) - (princ " mode") - (let* ((mode major-mode) - (file-name (find-lisp-object-file-name mode nil))) - (if (not file-name) - (setq help-mode--current-data (list :symbol mode)) - (princ (format-message " defined in `%s'" - (help-fns-short-filename file-name))) - ;; Make a hyperlink to the library. + (let ((help-buffer-under-preparation t)) + (unless buffer (setq buffer (current-buffer))) + (help-setup-xref (list #'describe-mode buffer) + (called-interactively-p 'interactive)) + ;; For the sake of help-do-xref and help-xref-go-back, + ;; don't switch buffers before calling `help-buffer'. + (with-help-window (help-buffer) + (with-current-buffer buffer + (let (minors) + ;; Older packages do not register in minor-mode-list but only in + ;; minor-mode-alist. + (dolist (x minor-mode-alist) + (setq x (car x)) + (unless (memq x minor-mode-list) + (push x minor-mode-list))) + ;; Find enabled minor mode we will want to mention. + (dolist (mode minor-mode-list) + ;; Document a minor mode if it is listed in minor-mode-alist, + ;; non-nil, and has a function definition. + (let ((fmode (or (get mode :minor-mode-function) mode))) + (and (boundp mode) (symbol-value mode) + (fboundp fmode) + (let ((pretty-minor-mode + (if (string-match "\\(\\(-minor\\)?-mode\\)?\\'" + (symbol-name fmode)) + (capitalize + (substring (symbol-name fmode) + 0 (match-beginning 0))) + fmode))) + (push (list fmode pretty-minor-mode + (format-mode-line (assq mode minor-mode-alist))) + minors))))) + ;; Narrowing is not a minor mode, but its indicator is part of + ;; mode-line-modes. + (when (buffer-narrowed-p) + (push '(narrow-to-region "Narrow" " Narrow") minors)) + (setq minors + (sort minors + (lambda (a b) (string-lessp (cadr a) (cadr b))))) + (when minors + (princ "Enabled minor modes:\n") + (make-local-variable 'help-button-cache) (with-current-buffer standard-output - (save-excursion - (re-search-backward (substitute-command-keys "`\\([^`']+\\)'") - nil t) - (setq help-mode--current-data (list :symbol mode - :file file-name)) - (help-xref-button 1 'help-function-def mode file-name))))) - (let ((fundoc (help-split-fundoc (documentation major-mode) nil 'doc))) - (with-current-buffer standard-output - (insert ":\n") - (insert fundoc) - (insert (help-fns--list-local-commands))))))) - ;; For the sake of IELM and maybe others - nil) + (dolist (mode minors) + (let ((mode-function (nth 0 mode)) + (pretty-minor-mode (nth 1 mode)) + (indicator (nth 2 mode))) + (save-excursion + (goto-char (point-max)) + (princ "\n\f\n") + (push (point-marker) help-button-cache) + ;; Document the minor modes fully. + (insert-text-button + pretty-minor-mode 'type 'help-function + 'help-args (list mode-function) + 'button '(t)) + (princ (format " minor mode (%s):\n" + (if (zerop (length indicator)) + "no indicator" + (format "indicator%s" + indicator)))) + (princ (help-split-fundoc (documentation mode-function) + nil 'doc))) + (insert-button pretty-minor-mode + 'action (car help-button-cache) + 'follow-link t + 'help-echo "mouse-2, RET: show full information") + (newline))) + (forward-line -1) + (fill-paragraph nil) + (forward-line 1)) + + (princ "\n(Information about these minor modes follows the major mode info.)\n\n")) + ;; Document the major mode. + (let ((mode mode-name)) + (with-current-buffer standard-output + (let ((start (point))) + (insert (format-mode-line mode nil nil buffer)) + (add-text-properties start (point) '(face bold))))) + (princ " mode") + (let* ((mode major-mode) + (file-name (find-lisp-object-file-name mode nil))) + (if (not file-name) + (setq help-mode--current-data (list :symbol mode)) + (princ (format-message " defined in `%s'" + (help-fns-short-filename file-name))) + ;; Make a hyperlink to the library. + (with-current-buffer standard-output + (save-excursion + (re-search-backward (substitute-command-keys "`\\([^`']+\\)'") + nil t) + (setq help-mode--current-data (list :symbol mode + :file file-name)) + (help-xref-button 1 'help-function-def mode file-name))))) + (let ((fundoc (help-split-fundoc (documentation major-mode) nil 'doc))) + (with-current-buffer standard-output + (insert ":\n") + (insert fundoc) + (insert (help-fns--list-local-commands)))))))) + ;; For the sake of IELM and maybe others + nil) (defun help-fns--list-local-commands () (let ((functions nil)) @@ -1998,7 +2006,8 @@ one of them returns non-nil." (event-end key)) ((eq key ?\C-g) (signal 'quit nil)) (t (user-error "You didn't specify a widget")))))) - (let (buf) + (let (buf + (help-buffer-under-preparation t)) ;; Allow describing a widget in a different window. (when (posnp pos) (setq buf (window-buffer (posn-window pos)) diff --git a/lisp/help-macro.el b/lisp/help-macro.el index b3c7e2393a3..ecc7ebab412 100644 --- a/lisp/help-macro.el +++ b/lisp/help-macro.el @@ -93,7 +93,8 @@ and then returns." "Help command." (interactive) (let ((line-prompt - (substitute-command-keys ,help-line))) + (substitute-command-keys ,help-line)) + (help-buffer-under-preparation t)) (when three-step-help (message "%s" line-prompt)) (let* ((help-screen ,help-text) @@ -140,6 +141,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-mode.el b/lisp/help-mode.el index 0b404fe89f1..792f2e5af33 100644 --- a/lisp/help-mode.el +++ b/lisp/help-mode.el @@ -35,6 +35,8 @@ (let ((map (make-sparse-keymap))) (set-keymap-parent map (make-composed-keymap button-buffer-map special-mode-map)) + (define-key map "n" 'help-goto-next-page) + (define-key map "p" 'help-goto-previous-page) (define-key map "l" 'help-go-back) (define-key map "r" 'help-go-forward) (define-key map "\C-c\C-b" 'help-go-back) @@ -273,6 +275,10 @@ The format is (FUNCTION ARGS...).") (when (or (< position (point-min)) (> position (point-max))) (widen)) + ;; Save mark for the old location, unless the point is not + ;; actually going to move. + (unless (= (point) position) + (push-mark nil t)) (goto-char position)) (message "Unable to find location in file"))))) @@ -372,6 +378,13 @@ The format is (FUNCTION ARGS...).") (view-buffer-other-window (find-file-noselect file)) (goto-char pos)) 'help-echo (purecopy "mouse-2, RET: show corresponding NEWS announcement")) + +;;;###autoload +(defun help-mode--add-function-link (str fun) + (make-text-button (copy-sequence str) nil + 'type 'help-function + 'help-args (list fun))) + (defvar bookmark-make-record-function) (defvar help-mode--current-data nil) @@ -631,34 +644,7 @@ that." "\\<M-x\\s-+\\(\\sw\\(\\sw\\|\\s_\\)*\\sw\\)" nil t) (let ((sym (intern-soft (match-string 1)))) (if (fboundp sym) - (help-xref-button 1 'help-function sym))))) - ;; Look for commands in whole keymap substitutions: - (save-excursion - ;; Make sure to find the first keymap. - (goto-char (point-min)) - ;; Find a header and the column at which the command - ;; name will be found. - - ;; If the keymap substitution isn't the last thing in - ;; the doc string, and if there is anything on the same - ;; line after it, this code won't recognize the end of it. - (while (re-search-forward "^key +binding\n\\(-+ +\\)-+\n\n" - nil t) - (let ((col (- (match-end 1) (match-beginning 1)))) - (while - (and (not (eobp)) - ;; Stop at a pair of blank lines. - (not (looking-at-p "\n\\s-*\n"))) - ;; Skip a single blank line. - (and (eolp) (forward-line)) - (end-of-line) - (skip-chars-backward "^ \t\n") - (if (and (>= (current-column) col) - (looking-at "\\(\\sw\\|\\s_\\)+$")) - (let ((sym (intern-soft (match-string 0)))) - (if (fboundp sym) - (help-xref-button 0 'help-function sym)))) - (forward-line)))))) + (help-xref-button 1 'help-function sym)))))) (set-syntax-table stab)) ;; Delete extraneous newlines at the end of the docstring (goto-char (point-max)) @@ -795,6 +781,26 @@ See `help-make-xrefs'." (help-xref-go-forward (current-buffer)) (user-error "No next help buffer"))) +(defun help-goto-next-page () + "Go to the next page (if any) in the current buffer. +The help buffers are divided into \"pages\" by the ^L character." + (interactive nil help-mode) + (push-mark) + (forward-page) + (unless (eobp) + (forward-line 1))) + +(defun help-goto-previous-page () + "Go to the previous page (if any) in the current buffer. +(If not at the start of a page, go to the start of the current page.) + +The help buffers are divided into \"pages\" by the ^L character." + (interactive nil help-mode) + (push-mark) + (backward-page (if (looking-back "\f\n" (- (point) 5)) 2 1)) + (unless (bobp) + (forward-line 1))) + (defun help-view-source () "View the source of the current help item." (interactive nil help-mode) diff --git a/lisp/help.el b/lisp/help.el index 941d4cfab12..5114ddefba1 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -50,6 +50,11 @@ (defvar help-window-old-frame nil "Frame selected at the time `with-help-window' is invoked.") +(defvar help-buffer-under-preparation nil + "Whether a *Help* buffer is being prepared. +This variable is bound to t during the preparation of a *Help* +buffer.") + (defvar help-map (let ((map (make-sparse-keymap))) (define-key map (char-to-string help-char) 'help-for-help) @@ -524,30 +529,31 @@ See `lossage-size' to update the number of recorded keystrokes. To record all your input, use `open-dribble-file'." (interactive) - (help-setup-xref (list #'view-lossage) - (called-interactively-p 'interactive)) - (with-help-window (help-buffer) - (princ " ") - (princ (mapconcat (lambda (key) - (cond - ((and (consp key) (null (car key))) - (format ";; %s\n" (if (symbolp (cdr key)) (cdr key) - "anonymous-command"))) - ((or (integerp key) (symbolp key) (listp key)) - (single-key-description key)) - (t - (prin1-to-string key nil)))) - (recent-keys 'include-cmds) - " ")) - (with-current-buffer standard-output - (goto-char (point-min)) - (let ((comment-start ";; ") - (comment-column 24)) - (while (not (eobp)) - (comment-indent) - (forward-line 1))) - ;; Show point near the end of "lossage", as we did in Emacs 24. - (set-marker help-window-point-marker (point))))) + (let ((help-buffer-under-preparation t)) + (help-setup-xref (list #'view-lossage) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) + (princ " ") + (princ (mapconcat (lambda (key) + (cond + ((and (consp key) (null (car key))) + (format ";; %s\n" (if (symbolp (cdr key)) (cdr key) + "anonymous-command"))) + ((or (integerp key) (symbolp key) (listp key)) + (single-key-description key)) + (t + (prin1-to-string key nil)))) + (recent-keys 'include-cmds) + " ")) + (with-current-buffer standard-output + (goto-char (point-min)) + (let ((comment-start ";; ") + (comment-column 24)) + (while (not (eobp)) + (comment-indent) + (forward-line 1))) + ;; Show point near the end of "lossage", as we did in Emacs 24. + (set-marker help-window-point-marker (point)))))) ;; Key bindings @@ -561,11 +567,13 @@ To record all your input, use `open-dribble-file'." 'font-lock-face 'help-key-binding 'face 'help-key-binding)) -(defcustom describe-bindings-outline nil +(defcustom describe-bindings-outline t "Non-nil enables outlines in the output buffer of `describe-bindings'." :type 'boolean :group 'help - :version "28.1") + :version "29.1") + +(declare-function outline-hide-subtree "outline") (defun describe-bindings (&optional prefix buffer) "Display a buffer showing a list of all defined keys, and their definitions. @@ -577,33 +585,32 @@ The optional argument BUFFER specifies which buffer's bindings to display (default, the current buffer). BUFFER can be a buffer or a buffer name." (interactive) - (or buffer (setq buffer (current-buffer))) - (help-setup-xref (list #'describe-bindings prefix buffer) - (called-interactively-p 'interactive)) - (with-help-window (help-buffer) - ;; Be aware that `describe-buffer-bindings' puts its output into - ;; the current buffer. - (with-current-buffer (help-buffer) - (describe-buffer-bindings buffer prefix) - - (when describe-bindings-outline - (setq-local outline-regexp ".*:$") - (setq-local outline-heading-end-regexp ":\n") - (setq-local outline-level (lambda () 1)) - (setq-local outline-minor-mode-cycle t - outline-minor-mode-highlight t) - (outline-minor-mode 1) - (save-excursion - (let ((inhibit-read-only t)) + (let ((help-buffer-under-preparation t)) + (or buffer (setq buffer (current-buffer))) + (help-setup-xref (list #'describe-bindings prefix buffer) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) + (with-current-buffer (help-buffer) + (describe-buffer-bindings buffer prefix) + + (when describe-bindings-outline + (setq-local outline-regexp ".*:$") + (setq-local outline-heading-end-regexp ":\n") + (setq-local outline-level (lambda () 1)) + (setq-local outline-minor-mode-cycle t + outline-minor-mode-highlight t) + (setq-local outline-minor-mode-use-buttons t) + (outline-minor-mode 1) + (save-excursion (goto-char (point-min)) - (insert (substitute-command-keys - (concat "\\<outline-minor-mode-cycle-map>Type " - "\\[outline-cycle] or \\[outline-cycle-buffer] " - "on headings to cycle their visibility.\n\n"))) - ;; Hide the longest body - (when (and (re-search-forward "Key translations" nil t) - (fboundp 'outline-cycle)) - (outline-cycle)))))))) + (let ((inhibit-read-only t)) + ;; Hide the longest body. + (when (re-search-forward "Key translations" nil t) + (outline-hide-subtree)) + ;; Hide ^Ls. + (while (search-forward "\n\f\n" nil t) + (put-text-property (1+ (match-beginning 0)) (1- (match-end 0)) + 'invisible t))))))))) (defun where-is (definition &optional insert) "Print message listing key sequences that invoke the command DEFINITION. @@ -903,7 +910,8 @@ current buffer." (let ((raw (if (numberp buffer) (this-single-command-raw-keys) buffer))) (setf (cdar (last key-list)) raw))) (setq buffer nil)) - (let* ((buf (or buffer (current-buffer))) + (let* ((help-buffer-under-preparation t) + (buf (or buffer (current-buffer))) (on-link (mapcar (lambda (kr) (let ((raw (cdr kr))) @@ -1060,6 +1068,14 @@ is currently activated with completion." result)) +(defcustom help-link-key-to-documentation t + "Non-nil means link keys to their command in *Help* buffers. +This affects \\\\=\\[command] substitutions in documentation +strings done by `substitute-command-keys'." + :type 'boolean + :version "29.1" + :group 'help) + (defun substitute-command-keys (string &optional no-face) "Substitute key descriptions for command names in STRING. Each substring of the form \\\\=[COMMAND] is replaced by either a @@ -1067,6 +1083,9 @@ keystroke sequence that invokes COMMAND, or \"M-x COMMAND\" if COMMAND is not on any keys. Keybindings will use the face `help-key-binding', unless the optional argument NO-FACE is non-nil. +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 @@ -1119,6 +1138,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 @@ -1150,9 +1186,19 @@ Otherwise, return a new string." (delete-char 1)) ;; Function is on a key. (delete-char (- end-point (point))) - (insert (if no-face - (key-description key) - (help--key-description-fontified key)))))) + + (insert + (if no-face + (key-description key) + (let ((key (help--key-description-fontified key))) + (if (and help-link-key-to-documentation + help-buffer-under-preparation + (functionp fun)) + ;; The `fboundp' fixes bootstrap. + (if (fboundp 'help-mode--add-function-link) + (help-mode--add-function-link key fun) + key) + key))))))) ;; 1D. \{foo} is replaced with a summary of the keymap ;; (symbol-value foo). ;; \<foo> just sets the keymap used for \[cmd]. @@ -1212,8 +1258,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. @@ -1239,10 +1285,7 @@ maps to look through. If MENTION-SHADOW is non-nil, then when something is shadowed by SHADOW, don't omit it; instead, mention it but say it is -shadowed. - -Any inserted text ends in two newlines (used by -`help-make-xrefs')." +shadowed." (let* ((amaps (accessible-keymaps startmap prefix)) (orig-maps (if no-menu (progn @@ -1259,17 +1302,8 @@ Any inserted text ends in two newlines (used by result)) amaps)) (maps orig-maps) - (print-title (or maps always-title))) - ;; Print title. - (when print-title - (insert (concat (if title - (concat title - (if prefix - (concat " Starting With " - (help--key-description-fontified prefix))) - ":\n")) - "key binding\n" - "--- -------\n"))) + (print-title (or maps always-title)) + (start-point (point))) ;; Describe key bindings. (setq help--keymaps-seen nil) (while (consp maps) @@ -1294,8 +1328,24 @@ Any inserted text ends in two newlines (used by (describe-map (cdr elt) elt-prefix transl partial sub-shadows no-menu mention-shadow))) (setq maps (cdr maps))) - (when print-title - (insert "\n")))) + ;; Print title... + (when (and print-title + ;; ... unless the keymap was empty. + (/= (point) start-point)) + (save-excursion + (goto-char start-point) + (when (eolp) + (delete-region (point) (1+ (point)))) + (insert + (concat + (if title + (concat title + (if prefix + (concat " Starting With " + (help--key-description-fontified prefix))) + ":\n")) + "\nKey Binding\n" + (make-separator-line))))))) (defun help--shadow-lookup (keymap key accept-default remap) "Like `lookup-key', but with command remapping. @@ -1308,48 +1358,37 @@ Return nil if the key sequence is too long." value)) (t value)))) -(defvar help--previous-description-column 0) -(defun help--describe-command (definition) - ;; Converted from describe_command in keymap.c. - ;; If column 16 is no good, go to col 32; - ;; but don't push beyond that--go to next line instead. - (let* ((column (current-column)) - (description-column (cond ((> column 30) - (insert "\n") - 32) - ((or (> column 14) - (and (> column 10) - (= help--previous-description-column 32))) - 32) - (t 16)))) - ;; Avoid using the `help-keymap' face. - (let ((op (point))) - (indent-to description-column 1) - (set-text-properties op (point) '( face nil - font-lock-face nil))) - (setq help--previous-description-column description-column) - (cond ((symbolp definition) - (insert (symbol-name definition) "\n")) - ((or (stringp definition) (vectorp definition)) - (insert "Keyboard Macro\n")) - ((keymapp definition) - (insert "Prefix Command\n")) - (t (insert "??\n"))))) - -(defun help--describe-translation (definition) - ;; Converted from describe_translation in keymap.c. - ;; Avoid using the `help-keymap' face. - (let ((op (point))) - (indent-to 16 1) - (set-text-properties op (point) '( face nil - font-lock-face nil))) +(defun help--describe-command (definition &optional translation) (cond ((symbolp definition) - (insert (symbol-name definition) "\n")) + (if (and (fboundp definition) + help-buffer-under-preparation) + (insert-text-button (symbol-name definition) + 'type 'help-function + 'help-args (list definition)) + (insert (symbol-name definition))) + (insert "\n")) ((or (stringp definition) (vectorp definition)) - (insert (key-description definition nil) "\n")) + (if translation + (insert (key-description definition nil) "\n") + (insert "Keyboard Macro\n"))) ((keymapp definition) (insert "Prefix Command\n")) - (t (insert "??\n")))) + ((byte-code-function-p definition) + (insert "[%s]\n" (buttonize "byte-code" #'disassemble definition))) + ((and (consp definition) + (memq (car definition) '(closure lambda))) + (insert (format "[%s]\n" + (buttonize + (symbol-name (car definition)) + (lambda (_) + (pp-display-expression + definition "*Help Source*" t)) + nil "View definition")))) + (t + (insert "??\n")))) + +(define-obsolete-function-alias 'help--describe-translation + #'help--describe-command "29.1") (defun help--describe-map-compare (a b) (let ((a (car a)) @@ -1363,7 +1402,8 @@ Return nil if the key sequence is too long." (string-version-lessp (symbol-name a) (symbol-name b))) (t nil)))) -(defun describe-map (map prefix transl partial shadow nomenu mention-shadow) +(defun describe-map (map &optional prefix transl partial shadow + nomenu mention-shadow) "Describe the contents of keymap MAP. Assume that this keymap itself is reached by the sequence of prefix keys PREFIX (a string or vector). @@ -1375,14 +1415,22 @@ TRANSL, PARTIAL, SHADOW, NOMENU, MENTION-SHADOW are as in (map (keymap-canonicalize map)) (tail map) (first t) - (describer (if transl - #'help--describe-translation - #'help--describe-command)) done vect) (while (and (consp tail) (not done)) (cond ((or (vectorp (car tail)) (char-table-p (car tail))) - (help--describe-vector (car tail) prefix describer partial - shadow map mention-shadow)) + (let ((columns ())) + (help--describe-vector + (car tail) prefix + (lambda (def) + (let ((start-line (line-beginning-position)) + (end-key (point)) + (column (current-column))) + (help--describe-command def transl) + (push (list column start-line end-key (1- (point))) + columns))) + partial shadow map mention-shadow) + (when columns + (describe-map--align-section columns)))) ((consp (car tail)) (let ((event (caar tail)) definition this-shadowed) @@ -1425,7 +1473,9 @@ TRANSL, PARTIAL, SHADOW, NOMENU, MENTION-SHADOW are as in (push (cons tail prefix) help--keymaps-seen))))) (setq tail (cdr tail))) ;; If we found some sparse map events, sort them. - (let ((vect (sort vect 'help--describe-map-compare))) + (let ((vect (sort vect 'help--describe-map-compare)) + (columns ()) + line-start key-end column) ;; Now output them in sorted order. (while vect (let* ((elem (car vect)) @@ -1433,10 +1483,6 @@ TRANSL, PARTIAL, SHADOW, NOMENU, MENTION-SHADOW are as in (definition (cadr elem)) (shadowed (caddr elem)) (end start)) - (when first - (setq help--previous-description-column 0) - (insert "\n") - (setq first nil)) ;; Find consecutive chars that are identically defined. (when (fixnump start) (while (and (cdr vect) @@ -1451,26 +1497,80 @@ TRANSL, PARTIAL, SHADOW, NOMENU, MENTION-SHADOW are as in (eq this-shadowed next-shadowed)))) (setq vect (cdr vect)) (setq end (caar vect)))) - ;; Now START .. END is the range to describe next. - ;; Insert the string to describe the event START. - (insert (help--key-description-fontified (vector start) prefix)) - (when (not (eq start end)) - (insert " .. " (help--key-description-fontified (vector end) prefix))) - ;; Print a description of the definition of this character. - ;; Called function will take care of spacing out far enough - ;; for alignment purposes. - (if transl - (help--describe-translation definition) - (help--describe-command definition)) - ;; Print a description of the definition of this character. - ;; elt_describer will take care of spacing out far enough for - ;; alignment purposes. - (when shadowed - (goto-char (max (1- (point)) (point-min))) - (insert "\n (this binding is currently shadowed)") - (goto-char (min (1+ (point)) (point-max))))) + (when (or (not (eq start end)) + ;; Don't output keymap prefixes. + (not (keymapp definition))) + (when first + (insert "\n") + (setq first nil)) + ;; Now START .. END is the range to describe next. + ;; Insert the string to describe the event START. + (setq line-start (point)) + (insert (help--key-description-fontified (vector start) prefix)) + (when (not (eq start end)) + (insert " .. " (help--key-description-fontified (vector end) + prefix))) + (setq key-end (point) + column (current-column)) + ;; Print a description of the definition of this character. + ;; Called function will take care of spacing out far enough + ;; for alignment purposes. + (help--describe-command definition transl) + (push (list column line-start key-end (1- (point))) columns) + ;; Print a description of the definition of this character. + ;; elt_describer will take care of spacing out far enough for + ;; alignment purposes. + (when shadowed + (goto-char (max (1- (point)) (point-min))) + (insert "\n (this binding is currently shadowed)") + (goto-char (min (1+ (point)) (point-max)))))) ;; Next item in list. - (setq vect (cdr vect)))))) + (setq vect (cdr vect))) + (when columns + (describe-map--align-section columns))))) + +(defun describe-map--align-section (columns) + (save-excursion + (let ((max-key (apply #'max (mapcar #'car columns)))) + (cond + ;; It's fine to use the minimum, so just do it, but quantize to + ;; two different widths, because having each block align slightly + ;; differently looks untidy. + ((< max-key 16) + (describe-map--fill-columns columns 16)) + ((< max-key 24) + (describe-map--fill-columns columns 24)) + ((< max-key 32) + (describe-map--fill-columns columns 32)) + ;; We have some really wide ones in this block. + (t + (let ((window-width (window-width)) + (max-def (apply #'max (mapcar + (lambda (elem) + (- (nth 3 elem) (nth 2 elem))) + columns)))) + (if (< (+ max-def (max 16 max-key)) window-width) + ;; Can we do the block without continuation lines? Then do that. + (describe-map--fill-columns columns (1+ (max 16 max-key))) + ;; No, do continuation lines for some definitions. + (dolist (elem columns) + (goto-char (caddr elem)) + (if (< (+ (car elem) (- (nth 3 elem) (nth 2 elem))) window-width) + ;; Indent. + (insert-char ?\s (- (1+ max-key) (car elem))) + ;; Continuation. + (insert "\n") + (insert-char ?\t 2)))))))))) + +(defun describe-map--fill-columns (columns width) + (dolist (elem columns) + (goto-char (caddr elem)) + (let ((tabs (- (/ width tab-width) + (/ (car elem) tab-width)))) + (insert-char ?\t tabs) + (insert-char ?\s (if (zerop tabs) + (- width (car elem)) + (mod width tab-width)))))) ;;;; This Lisp version is 100 times slower than its C equivalent: ;; @@ -1606,10 +1706,16 @@ and some others." (add-hook 'temp-buffer-show-hook 'resize-temp-buffer-window 'append) (remove-hook 'temp-buffer-show-hook 'resize-temp-buffer-window))) +(defvar resize-temp-buffer-window-inhibit nil + "Non-nil means `resize-temp-buffer-window' should not resize.") + (defun resize-temp-buffer-window (&optional window) "Resize WINDOW to fit its contents. WINDOW must be a live window and defaults to the selected one. -Do not resize if WINDOW was not created by `display-buffer'. +Do not resize if WINDOW was not created by `display-buffer'. Do +not resize either if a `window-height', `window-width' or +`window-size' entry in `display-buffer-alist' prescribes some +alternative resizing for WINDOW's buffer. If WINDOW is part of a vertical combination, restrain its new size by `temp-buffer-max-height' and do not resize if its minimum @@ -1624,27 +1730,33 @@ provided `fit-frame-to-buffer' is non-nil. This function may call `preserve-window-size' to preserve the size of WINDOW." (setq window (window-normalize-window window t)) - (let ((height (if (functionp temp-buffer-max-height) + (let* ((buffer (window-buffer window)) + (height (if (functionp temp-buffer-max-height) + (with-selected-window window + (funcall temp-buffer-max-height buffer)) + temp-buffer-max-height)) + (width (if (functionp temp-buffer-max-width) (with-selected-window window - (funcall temp-buffer-max-height (window-buffer))) - temp-buffer-max-height)) - (width (if (functionp temp-buffer-max-width) - (with-selected-window window - (funcall temp-buffer-max-width (window-buffer))) - temp-buffer-max-width)) - (quit-cadr (cadr (window-parameter window 'quit-restore)))) - ;; Resize WINDOW iff it was made by `display-buffer'. + (funcall temp-buffer-max-width buffer)) + temp-buffer-max-width)) + (quit-cadr (cadr (window-parameter window 'quit-restore)))) + ;; Resize WINDOW only if it was made by `display-buffer'. (when (or (and (eq quit-cadr 'window) (or (and (window-combined-p window) (not (eq fit-window-to-buffer-horizontally 'only)) - (pos-visible-in-window-p (point-min) window)) + (pos-visible-in-window-p + (with-current-buffer buffer (point-min)) + window) + (not resize-temp-buffer-window-inhibit)) (and (window-combined-p window t) - fit-window-to-buffer-horizontally))) + fit-window-to-buffer-horizontally + (not resize-temp-buffer-window-inhibit)))) (and (eq quit-cadr 'frame) fit-frame-to-buffer - (eq window (frame-root-window window)))) - (fit-window-to-buffer window height nil width nil t)))) + (eq window (frame-root-window window)) + (not resize-temp-buffer-window-inhibit))) + (fit-window-to-buffer window height nil width nil t)))) ;;; Help windows. (defcustom help-window-select nil @@ -1754,13 +1866,13 @@ Return VALUE." (cond ((eq help-setup 'window) ;; ... and is new, ... - "Type \"q\" to delete help window") + "Type \\<help-map>\\[help-quit] to delete help window") ((eq help-setup 'frame) ;; ... on a new frame, ... - "Type \"q\" to quit the help frame") + "Type \\<help-map>\\[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-map>\\[help-quit] to restore previous buffer")) window t)) ((and (eq (window-frame window) help-window-old-frame) (= (length (window-list nil 'no-mini)) 2)) @@ -1771,7 +1883,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-map>\\[help-quit] in help window to restore its previous buffer")) window 'other)) (t ;; The help window is not selected ... @@ -1779,10 +1891,10 @@ Return VALUE." (cond ((eq help-setup 'window) ;; ... and is new, ... - "Type \"q\" in help window to delete it") + "Type \\<help-map>\\[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-map>\\[help-quit] in help window to restore previous buffer")) window)))) ;; Return VALUE. value)) diff --git a/lisp/htmlfontify.el b/lisp/htmlfontify.el index 9fe6e825f78..8dc4cce3239 100644 --- a/lisp/htmlfontify.el +++ b/lisp/htmlfontify.el @@ -77,6 +77,7 @@ ;; Changes: moved to changelog (CHANGES) file. ;;; Code: + (eval-when-compile (require 'cl-lib)) (require 'cus-edit) @@ -2307,10 +2308,6 @@ See also `hfy-load-tags-cache'." (interactive "D source directory: ") (hfy-load-tags-cache (directory-file-name srcdir))) -;;(defun hfy-test-read-args (foo bar) -;; (interactive "D source directory: \nD target directory: ") -;; (message "foo: %S\nbar: %S" foo bar)) - (defun hfy-save-kill-buffers (buffer-list &optional dstdir) (dolist (B buffer-list) (set-buffer B) 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-mode-map>" + "\\[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-mode-map>\ +\\[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/icomplete.el b/lisp/icomplete.el index 01033474d38..f909a3b1771 100644 --- a/lisp/icomplete.el +++ b/lisp/icomplete.el @@ -380,13 +380,17 @@ if that doesn't produce a completion match." (defun icomplete-fido-backward-updir () "Delete char before or go up directory, like `ido-mode'." (interactive) - (if (and (eq (char-before) ?/) - (eq (icomplete--category) 'file)) - (save-excursion - (goto-char (1- (point))) - (when (search-backward "/" (point-min) t) - (delete-region (1+ (point)) (point-max)))) - (call-interactively 'backward-delete-char))) + (cond ((and (eq (char-before) ?/) + (eq (icomplete--category) 'file)) + (when (string-equal (icomplete--field-string) "~/") + (delete-region (icomplete--field-beg) (icomplete--field-end)) + (insert (expand-file-name "~/")) + (goto-char (line-end-position))) + (save-excursion + (goto-char (1- (point))) + (when (search-backward "/" (point-min) t) + (delete-region (1+ (point)) (point-max))))) + (t (call-interactively 'backward-delete-char)))) (defvar icomplete-fido-mode-map (let ((map (make-sparse-keymap))) @@ -716,11 +720,6 @@ See `icomplete-mode' and `minibuffer-setup-hook'." (delete-region (overlay-start rfn-eshadow-overlay) (overlay-end rfn-eshadow-overlay))) (let* ((field-string (icomplete--field-string)) - ;; Not sure why, but such requests seem to come - ;; every once in a while. It's not fully - ;; deterministic but `C-x C-f M-DEL M-DEL ...' - ;; seems to trigger it fairly often! - (while-no-input-ignore-events '(selection-request)) (text (while-no-input (icomplete-completions field-string diff --git a/lisp/ido.el b/lisp/ido.el index 7c2d2eb0d75..681c5d6bf6a 100644 --- a/lisp/ido.el +++ b/lisp/ido.el @@ -354,8 +354,8 @@ The following values are possible: Setting this variable directly does not take effect; use either \\[customize] or the function `ido-mode'." - :set #'(lambda (_symbol value) - (ido-mode (or value 0))) + :set (lambda (_symbol value) + (ido-mode (or value 0))) :initialize #'custom-initialize-default :require 'ido :link '(emacs-commentary-link "ido.el") @@ -620,9 +620,9 @@ hosts on first use of UNC path." (function-item :tag "Use `NET VIEW'" :value ido-unc-hosts-net-view) (function :tag "Your own function")) - :set #'(lambda (symbol value) - (set symbol value) - (setq ido-unc-hosts-cache t))) + :set (lambda (symbol value) + (set symbol value) + (setq ido-unc-hosts-cache t))) (defcustom ido-downcase-unc-hosts t "Non-nil if UNC host names should be downcased." @@ -920,85 +920,77 @@ The fallback command is passed as an argument to the functions." ;;;; Keymaps -(defvar ido-common-completion-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map minibuffer-local-map) - (define-key map "\C-a" 'ido-toggle-ignore) - (define-key map "\C-c" 'ido-toggle-case) - (define-key map "\C-e" 'ido-edit-input) - (define-key map "\t" 'ido-complete) - (define-key map " " 'ido-complete-space) - (define-key map "\C-j" 'ido-select-text) - (define-key map "\C-m" 'ido-exit-minibuffer) - (define-key map "\C-p" 'ido-toggle-prefix) - (define-key map "\C-r" 'ido-prev-match) - (define-key map "\C-s" 'ido-next-match) - (define-key map [?\C-.] 'ido-next-match) - (define-key map [?\C-,] 'ido-prev-match) - (define-key map "\C-t" 'ido-toggle-regexp) - (define-key map "\C-z" 'ido-undo-merge-work-directory) - (define-key map [(control ?\s)] 'ido-restrict-to-matches) - (define-key map [(meta ?\s)] 'ido-take-first-match) - (define-key map [(control ?@)] 'ido-restrict-to-matches) - (define-key map [right] 'ido-next-match) - (define-key map [left] 'ido-prev-match) - (define-key map "?" 'ido-completion-help) - (define-key map "\C-b" 'ido-magic-backward-char) - (define-key map "\C-f" 'ido-magic-forward-char) - (define-key map "\C-d" 'ido-magic-delete-char) - map) - "Keymap for all Ido commands.") - -(defvar ido-file-dir-completion-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map ido-common-completion-map) - (define-key map "\C-x\C-b" 'ido-enter-switch-buffer) - (define-key map "\C-x\C-f" 'ido-fallback-command) - (define-key map "\C-x\C-d" 'ido-enter-dired) - (define-key map [down] 'ido-next-match-dir) - (define-key map [up] 'ido-prev-match-dir) - (define-key map [(meta up)] 'ido-prev-work-directory) - (define-key map [(meta down)] 'ido-next-work-directory) - (define-key map [backspace] 'ido-delete-backward-updir) - (define-key map "\d" 'ido-delete-backward-updir) - (define-key map [remap delete-backward-char] 'ido-delete-backward-updir) ; BS - (define-key map [remap backward-kill-word] 'ido-delete-backward-word-updir) ; M-DEL - (define-key map [(control backspace)] 'ido-up-directory) - (define-key map "\C-l" 'ido-reread-directory) - (define-key map [(meta ?d)] 'ido-wide-find-dir-or-delete-dir) - (define-key map [(meta ?b)] 'ido-push-dir) - (define-key map [(meta ?v)] 'ido-push-dir-first) - (define-key map [(meta ?f)] 'ido-wide-find-file-or-pop-dir) - (define-key map [(meta ?k)] 'ido-forget-work-directory) - (define-key map [(meta ?m)] 'ido-make-directory) - (define-key map [(meta ?n)] 'ido-next-work-directory) - (define-key map [(meta ?o)] 'ido-prev-work-file) - (define-key map [(meta control ?o)] 'ido-next-work-file) - (define-key map [(meta ?p)] 'ido-prev-work-directory) - (define-key map [(meta ?s)] 'ido-merge-work-directories) - map) - "Keymap for Ido file and directory commands.") - -(defvar ido-file-completion-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map ido-file-dir-completion-map) - (define-key map "\C-k" 'ido-delete-file-at-head) - (define-key map "\C-o" 'ido-copy-current-word) - (define-key map "\C-w" 'ido-copy-current-file-name) - (define-key map [(meta ?l)] 'ido-toggle-literal) - map) - "Keymap for Ido file commands.") - -(defvar ido-buffer-completion-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map ido-common-completion-map) - (define-key map "\C-x\C-f" 'ido-enter-find-file) - (define-key map "\C-x\C-b" 'ido-fallback-command) - (define-key map "\C-k" 'ido-kill-buffer-at-head) - (define-key map [?\C-\S-b] 'ido-bury-buffer-at-head) - (define-key map "\C-o" 'ido-toggle-virtual-buffers) - map) - "Keymap for Ido buffer commands.") +(defvar-keymap ido-common-completion-map + :doc "Keymap for all Ido commands." + :parent minibuffer-local-map + "C-a" #'ido-toggle-ignore + "C-c" #'ido-toggle-case + "C-e" #'ido-edit-input + "TAB" #'ido-complete + "SPC" #'ido-complete-space + "C-j" #'ido-select-text + "C-m" #'ido-exit-minibuffer + "C-p" #'ido-toggle-prefix + "C-r" #'ido-prev-match + "C-s" #'ido-next-match + "C-." #'ido-next-match + "C-," #'ido-prev-match + "C-t" #'ido-toggle-regexp + "C-z" #'ido-undo-merge-work-directory + "C-SPC" #'ido-restrict-to-matches + "M-SPC" #'ido-take-first-match + "C-@" #'ido-restrict-to-matches + "<right>" #'ido-next-match + "<left>" #'ido-prev-match + "?" #'ido-completion-help + "C-b" #'ido-magic-backward-char + "C-f" #'ido-magic-forward-char + "C-d" #'ido-magic-delete-char) + +(defvar-keymap ido-file-dir-completion-map + :doc "Keymap for Ido file and directory commands." + :parent ido-common-completion-map + "C-x C-b" #'ido-enter-switch-buffer + "C-x C-f" #'ido-fallback-command + "C-x C-d" #'ido-enter-dired + "<down>" #'ido-next-match-dir + "<up>" #'ido-prev-match-dir + "M-<up>" #'ido-prev-work-directory + "M-<down>" #'ido-next-work-directory + "<backspace>" #'ido-delete-backward-updir + "DEL" #'ido-delete-backward-updir + "<remap> <delete-backward-char>" #'ido-delete-backward-updir + "<remap> <backward-kill-word>" #'ido-delete-backward-word-updir + "C-<backspace>" #'ido-up-directory + "C-l" #'ido-reread-directory + "M-d" #'ido-wide-find-dir-or-delete-dir + "M-b" #'ido-push-dir + "M-v" #'ido-push-dir-first + "M-f" #'ido-wide-find-file-or-pop-dir + "M-k" #'ido-forget-work-directory + "M-m" #'ido-make-directory + "M-n" #'ido-next-work-directory + "M-o" #'ido-prev-work-file + "C-M-o" #'ido-next-work-file + "M-p" #'ido-prev-work-directory + "M-s" #'ido-merge-work-directories) + +(defvar-keymap ido-file-completion-map + :doc "Keymap for Ido file commands." + :parent ido-file-dir-completion-map + "C-k" #'ido-delete-file-at-head + "C-o" #'ido-copy-current-word + "C-w" #'ido-copy-current-file-name + "M-l" #'ido-toggle-literal) + +(defvar-keymap ido-buffer-completion-map + :doc "Keymap for Ido buffer commands." + :parent ido-common-completion-map + "C-x C-f" #'ido-enter-find-file + "C-x C-b" #'ido-fallback-command + "C-k" #'ido-kill-buffer-at-head + "C-S-b" #'ido-bury-buffer-at-head + "C-o" #'ido-toggle-virtual-buffers) ;;;; Persistent variables diff --git a/lisp/ielm.el b/lisp/ielm.el index 39820a893a9..ec7f010a4d5 100644 --- a/lisp/ielm.el +++ b/lisp/ielm.el @@ -148,28 +148,28 @@ such as `edebug-defun' to work with such inputs." This variable is buffer-local.") (defvar ielm-header - "*** Welcome to IELM *** Type (describe-mode) for help.\n" + (substitute-command-keys + "*** Welcome to IELM *** Type (describe-mode) or press \ +\\[describe-mode] for help.\n") "Message to display when IELM is started.") (defvaralias 'inferior-emacs-lisp-mode-map 'ielm-map) -(defvar ielm-map - (let ((map (make-sparse-keymap))) - (define-key map "\t" 'ielm-tab) - (define-key map "\C-m" 'ielm-return) - (define-key map "\e\C-m" 'ielm-return-for-effect) - (define-key map "\C-j" 'ielm-send-input) - (define-key map "\e\C-x" 'eval-defun) ; for consistency with - (define-key map "\e\t" 'completion-at-point) ; lisp-interaction-mode - ;; These bindings are from `lisp-mode-shared-map' -- can you inherit - ;; from more than one keymap?? - (define-key map "\e\C-q" 'indent-sexp) - (define-key map "\177" 'backward-delete-char-untabify) - ;; Some convenience bindings for setting the working buffer - (define-key map "\C-c\C-b" 'ielm-change-working-buffer) - (define-key map "\C-c\C-f" 'ielm-display-working-buffer) - (define-key map "\C-c\C-v" 'ielm-print-working-buffer) - map) - "Keymap for IELM mode.") +(defvar-keymap ielm-map + :doc "Keymap for IELM mode." + "TAB" #'ielm-tab + "RET" #'ielm-return + "M-RET" #'ielm-return-for-effect + "C-j" #'ielm-send-input + "C-M-x" #'eval-defun ; for consistency with + "M-TAB" #'completion-at-point ; lisp-interaction-mode + ;; These bindings are from `lisp-mode-shared-map' -- can you inherit + ;; from more than one keymap?? + "C-M-q" #'indent-sexp + "DEL" #'backward-delete-char-untabify + ;; Some convenience bindings for setting the working buffer + "C-c C-b" #'ielm-change-working-buffer + "C-c C-f" #'ielm-display-working-buffer + "C-c C-v" #'ielm-print-working-buffer) (easy-menu-define ielm-menu ielm-map "IELM mode menu." diff --git a/lisp/image-dired.el b/lisp/image-dired.el index 3ac44dac9fb..6ca0cd8831d 100644 --- a/lisp/image-dired.el +++ b/lisp/image-dired.el @@ -1,7 +1,7 @@ ;;; image-dired.el --- use dired to browse and manipulate your images -*- lexical-binding: t -*- -;; + ;; Copyright (C) 2005-2021 Free Software Foundation, Inc. -;; + ;; Version: 0.4.11 ;; Keywords: multimedia ;; Author: Mathias Dahl <mathias.rem0veth1s.dahl@gmail.com> @@ -22,7 +22,7 @@ ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: -;; + ;; BACKGROUND ;; ========== ;; @@ -59,19 +59,22 @@ ;; PREREQUISITES ;; ============= ;; -;; * The ImageMagick package. Currently, `convert' and `mogrify' are -;; used. Find it here: https://www.imagemagick.org. +;; * The GraphicsMagick or ImageMagick package; Image-Dired uses +;; whichever is available. +;; +;; A) For GraphicsMagick, `gm' is used. +;; Find it here: http://www.graphicsmagick.org/ +;; +;; B) For ImageMagick, `convert' and `mogrify' are used. +;; Find it here: https://www.imagemagick.org. ;; ;; * For non-lossy rotation of JPEG images, the JpegTRAN program is -;; needed. +;; needed. ;; -;; * For `image-dired-get-exif-data' and `image-dired-set-exif-data' to work, -;; the command line tool `exiftool' is needed. It can be found here: -;; https://exiftool.org/. These two functions are, among other -;; things, used for writing comments to image files using -;; `image-dired-thumbnail-set-image-description' and to create -;; "unique" file names using `image-dired-get-exif-file-name' (used by -;; `image-dired-copy-with-exif-file-name'). +;; * For `image-dired-set-exif-data' to work, the command line tool `exiftool' is +;; needed. It can be found here: https://exiftool.org/. This +;; function is, among other things, used for writing comments to +;; image files using `image-dired-thumbnail-set-image-description'. ;; ;; ;; USAGE @@ -89,73 +92,60 @@ ;; =========== ;; ;; * Supports all image formats that Emacs and convert supports, but -;; the thumbnails are hard-coded to JPEG format. +;; the thumbnails are hard-coded to JPEG or PNG format. It uses +;; JPEG by default, but can optionally follow the Thumbnail Managing +;; Standard (v0.9.0, Dec 2020), which mandates PNG. See the user +;; option `image-dired-thumbnail-storage'. ;; ;; * WARNING: The "database" format used might be changed so keep a -;; backup of `image-dired-db-file' when testing new versions. -;; -;; * `image-dired-display-image-mode' does not support animation +;; backup of `image-dired-db-file' when testing new versions. ;; ;; TODO ;; ==== ;; -;; * Support gallery creation when using per-directory thumbnail -;; storage. -;; -;; * Some sort of auto-rotate function based on rotate info in the -;; EXIF data. -;; ;; * Investigate if it is possible to also write the tags to the image -;; files. +;; files. ;; ;; * From thumbs.el: Add an option for clean-up/max-size functionality ;; for thumbnail directory. ;; ;; * From thumbs.el: Add setroot function. ;; -;; * From thumbs.el: Add image resizing, if useful (image-dired's automatic -;; "image fit" might be enough) -;; -;; * From thumbs.el: Add the "modify" commands (emboss, negate, -;; monochrome etc). -;; -;; * Add `image-dired-display-thumbs-ring' and functions to cycle that. Find -;; out which is best, saving old batch just before inserting new, or -;; saving the current batch in the ring when inserting it. Adding it -;; probably needs rewriting `image-dired-display-thumbs' to be more general. +;; * Add `image-dired-display-thumbs-ring' and functions to cycle that. Find out +;; which is best, saving old batch just before inserting new, or +;; saving the current batch in the ring when inserting it. Adding +;; it probably needs rewriting `image-dired-display-thumbs' to be more general. ;; ;; * Find some way of toggling on and off really nice keybindings in -;; dired (for example, using C-n or <down> instead of C-S-n). Richard -;; suggested that we could keep C-t as prefix for image-dired commands -;; as it is currently not used in dired. He also suggested that -;; `dired-next-line' and `dired-previous-line' figure out if -;; image-dired is enabled in the current buffer and, if it is, call -;; `image-dired-dired-next-line' and -;; `image-dired-dired-previous-line', respectively. Update: This is -;; partly done; some bindings have now been added to dired. -;; -;; * Enhanced gallery creation with basic CSS-support and pagination -;; of tag pages with many pictures. -;; -;; * Rewrite `image-dired-modify-mark-on-thumb-original-file' to be -;; less ugly. +;; Dired (for example, using C-n or <down> instead of C-S-n). +;; Richard suggested that we could keep C-t as prefix for +;; image-dired commands as it is currently not used in Dired. He +;; also suggested that `dired-next-line' and `dired-previous-line' +;; figure out if image-dired is enabled in the current buffer and, +;; if it is, call `image-dired-dired-next-line' and `image-dired-dired-previous-line', +;; respectively. Update: This is partly done; some bindings have +;; now been added to Dired. ;; ;; * In some way keep track of buffers and windows and stuff so that -;; it works as the user expects. -;; -;; * More/better documentation -;; +;; it works as the user expects. ;; +;; * More/better documentation. + ;;; Code: (require 'dired) +(require 'exif) (require 'image-mode) (require 'widget) +(require 'xdg) (eval-when-compile (require 'cl-lib) (require 'wid-edit)) + +;;; Customizable variables + (defgroup image-dired nil "Use Dired to browse your images as thumbnails, and more." :prefix "image-dired-" @@ -165,108 +155,105 @@ (defcustom image-dired-dir (locate-user-emacs-file "image-dired/") "Directory where thumbnail images are stored. -The value of this option will be ignored if Image Dired is +The value of this option will be ignored if Image-Dired is customized to use the Thumbnail Managing Standard; they will be saved in \"$XDG_CACHE_HOME/thumbnails/\" instead. See `image-dired-thumbnail-storage'." :type 'directory) (defcustom image-dired-thumbnail-storage 'use-image-dired-dir - "How to store image-dired's thumbnail files. -Image-Dired can store thumbnail files in one of two ways and this is -controlled by this variable. \"Use image-dired dir\" means that the -thumbnails are stored in a central directory. \"Per directory\" -means that each thumbnail is stored in a subdirectory called -\".image-dired\" in the same directory where the image file is. -\"Thumbnail Managing Standard\" means that the thumbnails are -stored and generated according to the Thumbnail Managing Standard -that allows sharing of thumbnails across different programs." + "How `image-dired' stores thumbnail files. +There are two ways that Image-Dired can store and generate +thumbnails. If you set this variable to one of the two following +values, they will be stored in the JPEG format: + +- `use-image-dired-dir' means that the thumbnails are stored in a + central directory. + +- `per-directory' means that each thumbnail is stored in a + subdirectory called \".image-dired\" in the same directory + where the image file is. + +It can also use the \"Thumbnail Managing Standard\", which allows +sharing of thumbnails across different programs. Thumbnails will +be stored in \"$XDG_CACHE_HOME/thumbnails/\" instead of in +`image-dired-dir'. Thumbnails are saved in the PNG format, and +can be one of the following sizes: + +- `standard' means use thumbnails sized 128x128. +- `standard-large' means use thumbnails sized 256x256. +- `standard-x-large' means use thumbnails sized 512x512. +- `standard-xx-large' means use thumbnails sized 1024x1024. + +For more information on the Thumbnail Managing Standard, see: +https://specifications.freedesktop.org/thumbnail-spec/thumbnail-spec-latest.html" :type '(choice :tag "How to store thumbnail files" (const :tag "Use image-dired-dir" use-image-dired-dir) - (const :tag "Thumbnail Managing Standard (normal 128x128)" standard) - (const :tag "Thumbnail Managing Standard (large 256x256)" standard-large) - (const :tag "Per-directory" per-directory))) + (const :tag "Thumbnail Managing Standard (normal 128x128)" + standard) + (const :tag "Thumbnail Managing Standard (large 256x256)" + standard-large) + (const :tag "Thumbnail Managing Standard (larger 512x512)" + standard-x-large) + (const :tag "Thumbnail Managing Standard (extra large 1024x1024)" + standard-xx-large) + (const :tag "Per-directory" per-directory)) + :version "29.1") + +(defconst image-dired--thumbnail-standard-sizes + '( standard standard-large + standard-x-large standard-xx-large) + "List of symbols representing thumbnail sizes in Thumbnail Managing Standard.") (defcustom image-dired-db-file (expand-file-name ".image-dired_db" image-dired-dir) "Database file where file names and their associated tags are stored." :type 'file) -(defcustom image-dired-temp-image-file - (expand-file-name ".image-dired_temp" image-dired-dir) - "Name of temporary image file used by various commands." - :type 'file) - -(defcustom image-dired-gallery-dir - (expand-file-name ".image-dired_gallery" image-dired-dir) - "Directory to store generated gallery html pages. -This path needs to be \"shared\" to the public so that it can access -the index.html page that image-dired creates." - :type 'directory) - -(defcustom image-dired-gallery-image-root-url -"https://your.own.server/image-diredpics" - "URL where the full size images are to be found. -Note that this path has to be configured in your web server. Image-Dired -expects to find pictures in this directory." - :type 'string) - -(defcustom image-dired-gallery-thumb-image-root-url -"https://your.own.server/image-diredthumbs" - "URL where the thumbnail images are to be found. -Note that this path has to be configured in your web server. Image-Dired -expects to find pictures in this directory." - :type 'string) - (defcustom image-dired-cmd-create-thumbnail-program - "convert" + (if (executable-find "gm") "gm" "convert") "Executable used to create thumbnail. Used together with `image-dired-cmd-create-thumbnail-options'." - :type 'file) + :type 'file + :version "29.1") (defcustom image-dired-cmd-create-thumbnail-options - '("-size" "%wx%h" "%f[0]" "-resize" "%wx%h>" "-strip" "jpeg:%t") + (let ((opts '("-size" "%wx%h" "%f[0]" + "-resize" "%wx%h>" + "-strip" "jpeg:%t"))) + (if (executable-find "gm") (cons "convert" opts) opts)) "Options of command used to create thumbnail image. Used with `image-dired-cmd-create-thumbnail-program'. Available format specifiers are: %w which is replaced by `image-dired-thumb-width', %h which is replaced by `image-dired-thumb-height', %f which is replaced by the file name of the original image and %t which is replaced by the file name of the thumbnail file." - :version "26.1" - :type '(repeat (string :tag "Argument"))) - -(defcustom image-dired-cmd-create-temp-image-program "convert" - "Executable used to create temporary image. -Used together with `image-dired-cmd-create-temp-image-options'." - :type 'file) - -(defcustom image-dired-cmd-create-temp-image-options - '("-size" "%wx%h" "%f[0]" "-resize" "%wx%h>" "-strip" "jpeg:%t") - "Options of command used to create temporary image for display window. -Used together with `image-dired-cmd-create-temp-image-program', -Available format specifiers are: %w and %h which are replaced by -the calculated max size for width and height in the image display window, -%f which is replaced by the file name of the original image and %t which -is replaced by the file name of the temporary file." - :version "26.1" + :version "29.1" :type '(repeat (string :tag "Argument"))) (defcustom image-dired-cmd-pngnq-program - (or (executable-find "pngnq") - (executable-find "pngnq-s9")) - "The file name of the `pngnq' program. + ;; Prefer pngquant to pngnq-s9 as it is faster on my machine. + ;; The project also seems more active than the alternatives. + ;; Prefer pngnq-s9 to pngnq as it fixes bugs in pngnq. + ;; The pngnq project seems dead (?) since 2011 or so. + (or (executable-find "pngquant") + (executable-find "pngnq-s9") + (executable-find "pngnq")) + "The file name of the `pngquant' or `pngnq' program. It quantizes colors of PNG images down to 256 colors or fewer using the NeuQuant algorithm." - :version "26.1" + :version "29.1" :type '(choice (const :tag "Not Set" nil) file)) (defcustom image-dired-cmd-pngnq-options - '("-f" "%t") + (if (executable-find "pngquant") + '("--ext" "-nq8.png" "%t") ; same extension as "pngnq" + '("-f" "%t")) "Arguments to pass `image-dired-cmd-pngnq-program'. Available format specifiers are the same as in `image-dired-cmd-create-thumbnail-options'." - :version "26.1" - :type '(repeat (string :tag "Argument"))) + :type '(repeat (string :tag "Argument")) + :version "29.1") (defcustom image-dired-cmd-pngcrush-program (executable-find "pngcrush") "The file name of the `pngcrush' program. @@ -321,23 +308,6 @@ Available format specifiers are the same as in :version "26.1" :type '(repeat (string :tag "Argument"))) -(defcustom image-dired-cmd-rotate-thumbnail-program - "mogrify" - "Executable used to rotate thumbnail. -Used together with `image-dired-cmd-rotate-thumbnail-options'." - :type 'file) - -(defcustom image-dired-cmd-rotate-thumbnail-options - '("-rotate" "%d" "%t") - "Arguments of command used to rotate thumbnail image. -Used with `image-dired-cmd-rotate-thumbnail-program'. -Available format specifiers are: %d which is replaced by the -number of (positive) degrees to rotate the image, normally 90 or 270 -\(for 90 degrees right and left), %t which is replaced by the file name -of the thumbnail file." - :version "26.1" - :type '(repeat (string :tag "Argument"))) - (defcustom image-dired-cmd-rotate-original-program "jpegtran" "Executable used to rotate original image. @@ -383,37 +353,18 @@ which is replaced by the tag value." :version "26.1" :type '(repeat (string :tag "Argument"))) -(defcustom image-dired-cmd-read-exif-data-program - "exiftool" - "Program used to read EXIF data to image. -Used together with `image-dired-cmd-read-exif-data-options'." - :type 'file) - -(defcustom image-dired-cmd-read-exif-data-options - '("-s" "-s" "-s" "-%t" "%f") - "Arguments of command used to read EXIF data. -Used with `image-dired-cmd-read-exif-data-program'. -Available format specifiers are: %f which is replaced -by the image file name and %t which is replaced by the tag name." - :version "26.1" - :type '(repeat (string :tag "Argument"))) - -(defcustom image-dired-gallery-hidden-tags - (list "private" "hidden" "pending") - "List of \"hidden\" tags. -Used by `image-dired-gallery-generate' to leave out \"hidden\" images." - :type '(repeat string)) - (defcustom image-dired-thumb-size (cond ((eq 'standard image-dired-thumbnail-storage) 128) ((eq 'standard-large image-dired-thumbnail-storage) 256) + ((eq 'standard-x-large image-dired-thumbnail-storage) 512) + ((eq 'standard-xx-large image-dired-thumbnail-storage) 1024) (t 100)) "Size of thumbnails, in pixels. This is the default size for both `image-dired-thumb-width' and `image-dired-thumb-height'. -The value of this option will be ignored if Image Dired is +The value of this option will be ignored if Image-Dired is customized to use the Thumbnail Managing Standard; the standard sizes will be used instead. See `image-dired-thumbnail-storage'." :type 'integer) @@ -436,17 +387,28 @@ This is where you see the cursor." :type 'integer) (defcustom image-dired-thumb-visible-marks t - "Make marks visible in thumbnail buffer. + "Make marks and flags visible in thumbnail buffer. If non-nil, apply the `image-dired-thumb-mark' face to marked -images." +images and `image-dired-thumb-flagged' to images flagged for +deletion." :type 'boolean :version "28.1") (defface image-dired-thumb-mark - '((t (:background "orange"))) - "Background-color for marked images in thumbnail buffer." - :group 'image-dired - :version "28.1") + '((((class color) (min-colors 16)) :background "DarkOrange") + (((class color)) :foreground "yellow")) + "Face for marked images in thumbnail buffer." + :version "29.1") + +(defface image-dired-thumb-flagged + '((((class color) (min-colors 88) (background light)) :background "Red3") + (((class color) (min-colors 88) (background dark)) :background "Pink") + (((class color) (min-colors 16) (background light)) :background "Red3") + (((class color) (min-colors 16) (background dark)) :background "Pink") + (((class color) (min-colors 8)) :background "red") + (t :inverse-video t)) + "Face for images flagged for deletion in thumbnail buffer." + :version "29.1") (defcustom image-dired-line-up-method 'dynamic "Default method for line-up of thumbnails in thumbnail buffer. @@ -465,18 +427,6 @@ and No line-up means that no automatic line-up will be done." "Number of thumbnails to display per row in thumb buffer." :type 'integer) -(defcustom image-dired-display-window-width-correction 1 - "Number to be used to correct image display window width. -Change if the default (1) does not work (i.e. if the image does not -completely fit)." - :type 'integer) - -(defcustom image-dired-display-window-height-correction 0 - "Number to be used to correct image display window height. -Change if the default (0) does not work (i.e. if the image does not -completely fit)." - :type 'integer) - (defcustom image-dired-track-movement t "The current state of the tracking and mirroring. For more information, see the documentation for @@ -522,15 +472,45 @@ Including parameters. Used when displaying original image from :type '(choice string (const :tag "Not Set" nil))) -(defcustom image-dired-main-image-directory "~/pics/" +(defcustom image-dired-main-image-directory + (or (xdg-user-dir "PICTURES") "~/pics/") "Name of main image directory, if any. Used by `image-dired-copy-with-exif-file-name'." - :type 'string) + :type 'string + :version "29.1") + +(defcustom image-dired-show-all-from-dir-max-files 500 + "Maximum number of files in directory before prompting. + +If there are more image files than this in a selected directory, +the `image-dired-show-all-from-dir' command will ask for +confirmation before creating the thumbnail buffer. If this +variable is nil, it will never ask." + :type '(choice integer + (const :tag "Disable warning" nil)) + :version "29.1") + +(defcustom image-dired-marking-shows-next t + "If non-nil, marking, unmarking or flagging an image shows the next image. + +This affects the following commands: +\\<image-dired-thumbnail-mode-map> + `image-dired-flag-thumb-original-file' (bound to \\[image-dired-flag-thumb-original-file]) + `image-dired-mark-thumb-original-file' (bound to \\[image-dired-mark-thumb-original-file]) + `image-dired-unmark-thumb-original-file' (bound to \\[image-dired-unmark-thumb-original-file])" + :type 'boolean + :version "29.1") -(defcustom image-dired-show-all-from-dir-max-files 50 - "Maximum number of files to show using `image-dired-show-all-from-dir' -before warning." - :type 'integer) + +;;; Util functions + +(defvar image-dired-debug nil + "Non-nil means enable debug messages.") + +(defun image-dired-debug-message (&rest args) + "Display debug message ARGS when `image-dired-debug' is non-nil." + (when image-dired-debug + (apply #'message args))) (defmacro image-dired--with-db-file (&rest body) "Run BODY in a temp buffer containing `image-dired-db-file'. @@ -542,14 +522,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) @@ -562,7 +542,7 @@ Create the thumbnails directory if it does not exist." (defun image-dired-get-thumbnail-image (file) "Return the image descriptor for a thumbnail of image file FILE." - (unless (string-match (image-file-name-regexp) file) + (unless (string-match-p (image-file-name-regexp) file) (error "%s is not a valid image file" file)) (let* ((thumb-file (image-dired-thumb-name file)) (thumb-attr (file-attributes thumb-file))) @@ -571,11 +551,7 @@ Create the thumbnails directory if it does not exist." (file-attribute-modification-time (file-attributes file)))) (image-dired-create-thumb file thumb-file)) - (create-image thumb-file) -;; (list 'image :type 'jpeg -;; :file thumb-file -;; :relief image-dired-thumb-relief :margin image-dired-thumb-margin) - )) + (create-image thumb-file))) (defun image-dired-insert-thumbnail (file original-file-name associated-dired-buffer) @@ -583,13 +559,19 @@ Create the thumbnails directory if it does not exist." Add text properties ORIGINAL-FILE-NAME and ASSOCIATED-DIRED-BUFFER." (let (beg end) (setq beg (point)) - (image-dired-insert-image file - ;; TODO: this should depend on the real file type - (if (memq image-dired-thumbnail-storage - '(standard standard-large)) - 'png 'jpeg) - image-dired-thumb-relief - image-dired-thumb-margin) + (image-dired-insert-image + file + ;; Thumbnails are created asynchronously, so we might not yet + ;; have a file. But if it exists, it might have been cached from + ;; before and we should use it instead of our current settings. + (or (and (file-exists-p file) + (image-type-from-file-header file)) + (and (memq image-dired-thumbnail-storage + image-dired--thumbnail-standard-sizes) + 'png) + 'jpeg) + image-dired-thumb-relief + image-dired-thumb-margin) (setq end (point)) (add-text-properties beg end @@ -601,35 +583,39 @@ Add text properties ORIGINAL-FILE-NAME and ASSOCIATED-DIRED-BUFFER." 'comment (image-dired-get-comment original-file-name))))) (defun image-dired-thumb-name (file) - "Return thumbnail file name for FILE. -Depending on the value of `image-dired-thumbnail-storage', the file -name will vary. For central thumbnail file storage, make a -MD5-hash of the image file's directory name and add that to make -the thumbnail file name unique. For per-directory storage, just -add a subdirectory. For standard storage, produce the file name -according to the Thumbnail Managing Standard." - (cond ((memq image-dired-thumbnail-storage '(standard standard-large)) - (let* ((xdg (getenv "XDG_CACHE_HOME")) - (dir (if (and xdg (file-name-absolute-p xdg)) - xdg "~/.cache")) - (thumbdir (cl-case image-dired-thumbnail-storage - (standard "thumbnails/normal") - (standard-large "thumbnails/large")))) + "Return absolute file name for thumbnail FILE. +Depending on the value of `image-dired-thumbnail-storage', the +file name of the thumbnail will vary: +- For `use-image-dired-dir', make a SHA1-hash of the image file's + directory name and add that to make the thumbnail file name + unique. +- For `per-directory' storage, just add a subdirectory. +- For `standard' storage, produce the file name according to the + Thumbnail Managing Standard. Among other things, an MD5-hash + of the image file's directory name will be added to the + filename. +See also `image-dired-thumbnail-storage'." + (cond ((memq image-dired-thumbnail-storage + image-dired--thumbnail-standard-sizes) + (let ((thumbdir (cl-case image-dired-thumbnail-storage + (standard "thumbnails/normal") + (standard-large "thumbnails/large") + (standard-x-large "thumbnails/x-large") + (standard-xx-large "thumbnails/xx-large")))) (expand-file-name + ;; MD5 is mandated by the Thumbnail Managing Standard. (concat (md5 (concat "file://" (expand-file-name file))) ".png") - (expand-file-name thumbdir dir)))) + (expand-file-name thumbdir (xdg-cache-home))))) ((eq 'use-image-dired-dir image-dired-thumbnail-storage) (let* ((f (expand-file-name file)) - (md5-hash - ;; Is MD5 hashes fast enough? The checksum of a - ;; thumbnail file name need not be that - ;; "cryptographically" good so a faster one could - ;; be used here. - (md5 (file-name-as-directory (file-name-directory f))))) + (hash + ;; SHA1 is slightly faster than MD5, so let's use it. + ;; (We don't need anything crytographically strong.) + (sha1 (file-name-as-directory (file-name-directory f))))) (format "%s%s%s.thumb.%s" (file-name-as-directory (expand-file-name (image-dired-dir))) (file-name-base f) - (if md5-hash (concat "_" md5-hash) "") + (if hash (concat "_" hash) "") (file-name-extension f)))) ((eq 'per-directory image-dired-thumbnail-storage) (let ((f (expand-file-name file))) @@ -642,16 +628,24 @@ according to the Thumbnail Managing Standard." (unless (executable-find (symbol-value executable)) (error "Executable %S not found" executable))) + +;;; Creating thumbnails + (defun image-dired-thumb-size (dimension) "Return thumb size depending on `image-dired-thumbnail-storage'. DIMENSION should be either the symbol `width' or `height'." (cond ((eq 'standard image-dired-thumbnail-storage) 128) ((eq 'standard-large image-dired-thumbnail-storage) 256) + ((eq 'standard-x-large image-dired-thumbnail-storage) 512) + ((eq 'standard-xx-large image-dired-thumbnail-storage) 1024) (t (cl-ecase dimension (width image-dired-thumb-width) (height image-dired-thumb-height))))) +(defvar image-dired--generate-thumbs-start nil + "Time when `display-thumbs' was called.") + (defvar image-dired-queue nil "List of items in the queue. Each item has the form (ORIGINAL-FILE TARGET-FILE).") @@ -659,11 +653,12 @@ Each item has the form (ORIGINAL-FILE TARGET-FILE).") (defvar image-dired-queue-active-jobs 0 "Number of active jobs in `image-dired-queue'.") -(defvar image-dired-queue-active-limit 2 +(defvar image-dired-queue-active-limit (min 4 (max 2 (/ (num-processors) 2))) "Maximum number of concurrent jobs permitted for generating images. -Increase at own risk.") - -(defvar image-dired-tag-history nil "Variable holding the tag history.") +Increase at own risk. If you want to experiment with this, +consider setting `image-dired-debug' to a non-nil value to see +the time spent on generating thumbnails. Run `image-clear-cache' +and remove the cached thumbnail files between each trial run.") (defun image-dired-pngnq-thumb (spec) "Quantize thumbnail described by format SPEC with pngnq(1)." @@ -750,9 +745,9 @@ Increase at own risk.") (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'. @@ -762,7 +757,7 @@ Increase at own risk.") (mapcar (lambda (arg) (format-spec arg spec)) (if (memq image-dired-thumbnail-storage - '(standard standard-large)) + image-dired--thumbnail-standard-sizes) image-dired-cmd-create-standard-thumbnail-options image-dired-cmd-create-thumbnail-options)))) @@ -771,6 +766,12 @@ Increase at own risk.") ;; Trigger next in queue once a thumbnail has been created (cl-decf image-dired-queue-active-jobs) (image-dired-thumb-queue-run) + (when (= image-dired-queue-active-jobs 0) + (image-dired-debug-message + (format-time-string + "Generated thumbnails in %s.%3N seconds" + (time-subtract nil + image-dired--generate-thumbs-start)))) (if (not (and (eq (process-status process) 'exit) (zerop (process-exit-status process)))) (message "Thumb could not be created for %s: %s" @@ -781,7 +782,7 @@ Increase at own risk.") ;; PNG thumbnail has been created since we are ;; following the XDG thumbnail spec, so try to optimize (when (memq image-dired-thumbnail-storage - '(standard standard-large)) + image-dired--thumbnail-standard-sizes) (cond ((and image-dired-cmd-pngnq-program (executable-find image-dired-cmd-pngnq-program)) @@ -895,7 +896,7 @@ Otherwise, delete overlays." (interactive) (setq image-dired-append-when-browsing (not image-dired-append-when-browsing)) - (message "Append browsing %s." + (message "Append browsing %s" (if image-dired-append-when-browsing "on" "off"))) @@ -934,15 +935,6 @@ Otherwise, delete overlays." (defvar image-dired-display-image-buffer "*image-dired-display-image*" "Where larger versions of the images are display.") -(defun image-dired-create-display-image-buffer () - "Create image display buffer and set `image-dired-display-image-mode'." - (let ((buf (get-buffer-create image-dired-display-image-buffer))) - (with-current-buffer buf - (setq buffer-read-only t) - (if (not (eq major-mode 'image-dired-display-image-mode)) - (image-dired-display-image-mode))) - buf)) - (defvar image-dired-saved-window-configuration nil "Saved window configuration.") @@ -966,7 +958,7 @@ The current window configuration is saved and can be restored by calling `image-dired-restore-window-configuration'." (interactive "DDirectory: \nP") (let ((buf (image-dired-create-thumbnail-buffer)) - (buf2 (image-dired-create-display-image-buffer))) + (buf2 (get-buffer-create image-dired-display-image-buffer))) (setq image-dired-saved-window-configuration (current-window-configuration)) (dired dir) @@ -985,7 +977,7 @@ calling `image-dired-restore-window-configuration'." "Restore window configuration. Restore any changes to the window configuration made by calling `image-dired-dired-with-window-configuration'." - (interactive) + (interactive nil image-dired-thumbnail-mode) (if image-dired-saved-window-configuration (set-window-configuration image-dired-saved-window-configuration) (message "No saved window configuration"))) @@ -1025,6 +1017,7 @@ used or not. If non-nil, use `display-buffer' instead of `image-dired-previous-line-and-display' where we do not want the thumbnail buffer to be selected." (interactive "P") + (setq image-dired--generate-thumbs-start (current-time)) (let ((buf (image-dired-create-thumbnail-buffer)) thumb-name files dired-buf) (if arg @@ -1048,30 +1041,38 @@ thumbnail buffer to be selected." ;;;###autoload (defun image-dired-show-all-from-dir (dir) - "Make a preview buffer for all images in DIR and display it. -If the number of files in DIR matching `image-file-name-regexp' -exceeds `image-dired-show-all-from-dir-max-files', a warning will be -displayed." - (interactive "DImage Dired: ") + "Make a thumbnail buffer for all images in DIR and display it. +Any file matching `image-file-name-regexp' is considered an image +file. + +If the number of image files in DIR exceeds +`image-dired-show-all-from-dir-max-files', ask for confirmation +before creating the thumbnail buffer. If that variable is nil, +never ask for confirmation." + (interactive "DImage-Dired: ") (dired dir) (dired-mark-files-regexp (image-file-name-regexp)) - (let ((files (dired-get-marked-files))) - (if (or (<= (length files) image-dired-show-all-from-dir-max-files) - (and (> (length files) image-dired-show-all-from-dir-max-files) - (y-or-n-p - (format - "Directory contains more than %d image files. Proceed? " - image-dired-show-all-from-dir-max-files)))) - (progn - (image-dired-display-thumbs) - (pop-to-buffer image-dired-thumbnail-buffer)) - (message "Canceled.")))) + (let ((files (dired-get-marked-files nil nil nil t))) + (cond ((and (null (cdr files))) + (message "No image files in directory")) + ((or (not image-dired-show-all-from-dir-max-files) + (<= (length (cdr files)) image-dired-show-all-from-dir-max-files) + (and (> (length (cdr files)) image-dired-show-all-from-dir-max-files) + (y-or-n-p + (format + "Directory contains more than %d image files. Proceed?" + image-dired-show-all-from-dir-max-files)))) + (image-dired-display-thumbs) + (pop-to-buffer image-dired-thumbnail-buffer) + (setq default-directory dir) + (image-dired-unmark-all-marks)) + (t (message "Image-Dired canceled"))))) ;;;###autoload (defalias 'image-dired 'image-dired-show-all-from-dir) -;;;###autoload -(define-obsolete-function-alias 'tumme 'image-dired "24.4") + +;;; Tags (defun image-dired-sane-db-file () "Check if `image-dired-db-file' exists. @@ -1091,6 +1092,8 @@ Signal error if there are problems creating it." (file-exists-p image-dired-db-file)) (error "Could not create %s" image-dired-db-file))) +(defvar image-dired-tag-history nil "Variable holding the tag history.") + (defun image-dired-write-tags (file-tags) "Write file tags to database. Write each file and tag in FILE-TAGS to the database. @@ -1211,6 +1214,9 @@ With prefix argument ARG, remove tag from file at point." (image-dired-update-property 'tags (image-dired-list-tags (image-dired-original-file-name)))))) + +;;; Thumbnail mode (cont.) + (defun image-dired-original-file-name () "Get original file name for thumbnail or display image at point." (get-text-property (point) 'original-file-name)) @@ -1254,7 +1260,7 @@ around in the thumbnail or dired buffer will find the matching position in the other buffer." (interactive) (setq image-dired-track-movement (not image-dired-track-movement)) - (message "Tracking %s" (if image-dired-track-movement "on" "off"))) + (message "Movement tracking %s" (if image-dired-track-movement "on" "off"))) (defun image-dired-track-thumbnail () "Track current Dired file's thumb in `image-dired-thumbnail-buffer'. @@ -1276,7 +1282,7 @@ but the other way around." (when found (if (setq window (image-dired-thumbnail-window)) (set-window-point window (point))) - (image-dired-display-thumb-properties)))))) + (image-dired-update-header-line)))))) (defun image-dired-dired-next-line (&optional arg) "Call `dired-next-line', then track thumbnail. @@ -1296,51 +1302,59 @@ With prefix argument, move ARG lines." (if image-dired-track-movement (image-dired-track-thumbnail))) -(defun image-dired-forward-image (&optional arg) +(defun image-dired--display-thumb-properties-fun () + (let ((old-buf (current-buffer)) + (old-point (point))) + (lambda () + (when (and (equal (current-buffer) old-buf) + (= (point) old-point)) + (ignore-errors + (image-dired-update-header-line)))))) + +(defun image-dired-forward-image (&optional arg wrap-around) "Move to next image and display properties. -Optional prefix ARG says how many images to move; default is one -image." +Optional prefix ARG says how many images to move; the default is +one image. Negative means move backwards. +On reaching end or beginning of buffer, stop and show a message. + +If optional argument WRAP-AROUND is non-nil, wrap around: if +point is on the last image, move to the last one and vice versa." (interactive "p") - (let (pos (steps (or arg 1))) - (dotimes (_ steps) - (if (and (not (eobp)) + (setq arg (or arg 1)) + (let (pos) + (dotimes (_ (abs arg)) + (if (and (not (if (> arg 0) (eobp) (bobp))) (save-excursion - (forward-char) - (while (and (not (eobp)) + (forward-char (if (> arg 0) 1 -1)) + (while (and (not (if (> arg 0) (eobp) (bobp))) (not (image-dired-image-at-point-p))) - (forward-char)) + (forward-char (if (> arg 0) 1 -1))) (setq pos (point)) (image-dired-image-at-point-p))) - (goto-char pos) - (error "At last image")))) + (progn (goto-char pos) + (image-dired-update-header-line)) + (if wrap-around + (progn (goto-char (if (> arg 0) + (point-min) + ;; There are two spaces after the last image. + (- (point-max) 2))) + (image-dired-update-header-line)) + (message "At %s image" (if (> arg 0) "last" "first")) + (run-at-time 1 nil (image-dired--display-thumb-properties-fun)))))) (when image-dired-track-movement - (image-dired-track-original-file)) - (image-dired-display-thumb-properties)) + (image-dired-track-original-file))) (defun image-dired-backward-image (&optional arg) "Move to previous image and display properties. -Optional prefix ARG says how many images to move; default is one -image." +Optional prefix ARG says how many images to move; the default is +one image. Negative means move forward. +On reaching end or beginning of buffer, stop and show a message." (interactive "p") - (let (pos (steps (or arg 1))) - (dotimes (_ steps) - (if (and (not (bobp)) - (save-excursion - (backward-char) - (while (and (not (bobp)) - (not (image-dired-image-at-point-p))) - (backward-char)) - (setq pos (point)) - (image-dired-image-at-point-p))) - (goto-char pos) - (error "At first image")))) - (when image-dired-track-movement - (image-dired-track-original-file)) - (image-dired-display-thumb-properties)) + (image-dired-forward-image (- (or arg 1)))) (defun image-dired-next-line () "Move to next line and display properties." - (interactive) + (interactive nil image-dired-thumbnail-mode) (let ((goal-column (current-column))) (forward-line 1) (move-to-column goal-column)) @@ -1349,12 +1363,12 @@ image." (image-dired-backward-image)) (if image-dired-track-movement (image-dired-track-original-file)) - (image-dired-display-thumb-properties)) + (image-dired-update-header-line)) (defun image-dired-previous-line () "Move to previous line and display properties." - (interactive) + (interactive nil image-dired-thumbnail-mode) (let ((goal-column (current-column))) (forward-line -1) (move-to-column goal-column)) @@ -1366,7 +1380,29 @@ image." (image-dired-backward-image)) (if image-dired-track-movement (image-dired-track-original-file)) - (image-dired-display-thumb-properties)) + (image-dired-update-header-line)) + +(defun image-dired-beginning-of-buffer () + "Move to the first image in the buffer and display properties." + (interactive nil image-dired-thumbnail-mode) + (goto-char (point-min)) + (while (and (not (image-at-point-p)) + (not (eobp))) + (forward-char 1)) + (when image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-update-header-line)) + +(defun image-dired-end-of-buffer () + "Move to the last image in the buffer and display properties." + (interactive nil image-dired-thumbnail-mode) + (goto-char (point-max)) + (while (and (not (image-at-point-p)) + (not (bobp))) + (forward-char -1)) + (when image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-update-header-line)) (defun image-dired-format-properties-string (buf file props comment) "Format display properties. @@ -1381,77 +1417,115 @@ comment." (cons ?t (or props "")) (cons ?c (or comment ""))))) -(defun image-dired-display-thumb-properties () - "Display thumbnail properties in the echo area." - (if (not (eobp)) - (let ((file-name (file-name-nondirectory (image-dired-original-file-name))) - (dired-buf (buffer-name (image-dired-associated-dired-buffer))) - (props (mapconcat #'identity (get-text-property (point) 'tags) ", ")) - (comment (get-text-property (point) 'comment)) - (message-log-max nil)) - (if file-name - (message "%s" - (image-dired-format-properties-string - dired-buf - file-name - props - comment)))))) - -(defun image-dired-dired-file-marked-p () - "Check whether file on current line is marked or not." +(defun image-dired-update-header-line () + "Update image information in the header line." + (when (and (not (eobp)) + (memq major-mode '(image-dired-thumbnail-mode + image-dired-display-image-mode))) + (let ((file-name (file-name-nondirectory (image-dired-original-file-name))) + (dired-buf (buffer-name (image-dired-associated-dired-buffer))) + (props (mapconcat #'identity (get-text-property (point) 'tags) ", ")) + (comment (get-text-property (point) 'comment)) + (message-log-max nil)) + (if file-name + (setq header-line-format + (image-dired-format-properties-string + dired-buf + file-name + props + comment)))))) + +(defun image-dired-dired-file-marked-p (&optional marker) + "In Dired, return t if file on current line is marked. +If optional argument MARKER is non-nil, it is a character to look +for. The default is to look for `dired-marker-char'." + (setq marker (or marker dired-marker-char)) (save-excursion (beginning-of-line) - (looking-at-p dired-re-mark))) - -(defun image-dired-modify-mark-on-thumb-original-file (command) - "Modify mark in Dired buffer. -COMMAND is one of `mark' for marking file in Dired, `unmark' for -unmarking file in Dired or `flag' for flagging file for delete in -Dired." - (let ((file-name (image-dired-original-file-name)) - (dired-buf (image-dired-associated-dired-buffer))) - (if (not (and dired-buf file-name)) - (message "No image, or image with correct properties, at point.") - (with-current-buffer dired-buf - (message "%s" file-name) - (when (dired-goto-file file-name) - (cond ((eq command 'mark) (dired-mark 1)) - ((eq command 'unmark) (dired-unmark 1)) - ((eq command 'toggle) - (if (image-dired-dired-file-marked-p) - (dired-unmark 1) - (dired-mark 1))) - ((eq command 'flag) (dired-flag-file-deletion 1))) - (image-dired-thumb-update-marks)))))) + (and (looking-at dired-re-mark) + (= (aref (match-string 0) 0) marker)))) + +(defun image-dired-dired-file-flagged-p () + "In Dired, return t if file on current line is flagged for deletion." + (image-dired-dired-file-marked-p dired-del-marker)) + +(defmacro image-dired--with-thumbnail-buffer (&rest body) + (declare (indent defun) (debug t)) + `(if-let ((buf (get-buffer image-dired-thumbnail-buffer))) + (with-current-buffer buf + (if-let ((win (get-buffer-window buf))) + (with-selected-window win + ,@body) + ,@body)) + (user-error "No such buffer: %s" image-dired-thumbnail-buffer))) + +(defmacro image-dired--on-file-in-dired-buffer (&rest body) + "Run BODY with point on file at point in Dired buffer. +Should be called from commands in `image-dired-thumbnail-mode'." + (declare (indent defun) (debug t)) + `(let ((file-name (image-dired-original-file-name)) + (dired-buf (image-dired-associated-dired-buffer))) + (if (not (and dired-buf file-name)) + (message "No image, or image with correct properties, at point.") + (with-current-buffer dired-buf + (when (dired-goto-file file-name) + ,@body + (image-dired-thumb-update-marks)))))) + +(defmacro image-dired--do-mark-command (maybe-next &rest body) + "Helper macro for the mark, unmark and flag commands. +Run BODY in Dired buffer. +If optional argument MAYBE-NEXT is non-nil, show next image +according to `image-dired-marking-shows-next'." + (declare (indent defun) (debug t)) + `(image-dired--with-thumbnail-buffer + (image-dired--on-file-in-dired-buffer + ,@body) + ,(when maybe-next + '(if image-dired-marking-shows-next + (image-dired-display-next-thumbnail-original) + (image-dired-next-line))))) (defun image-dired-mark-thumb-original-file () "Mark original image file in associated Dired buffer." - (interactive) - (image-dired-modify-mark-on-thumb-original-file 'mark) - (image-dired-forward-image)) + (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--do-mark-command t + (dired-mark 1))) (defun image-dired-unmark-thumb-original-file () "Unmark original image file in associated Dired buffer." - (interactive) - (image-dired-modify-mark-on-thumb-original-file 'unmark) - (image-dired-forward-image)) + (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--do-mark-command t + (dired-unmark 1))) (defun image-dired-flag-thumb-original-file () "Flag original image file for deletion in associated Dired buffer." - (interactive) - (image-dired-modify-mark-on-thumb-original-file 'flag) - (image-dired-forward-image)) + (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--do-mark-command t + (dired-flag-file-deletion 1))) (defun image-dired-toggle-mark-thumb-original-file () "Toggle mark on original image file in associated Dired buffer." - (interactive) - (image-dired-modify-mark-on-thumb-original-file 'toggle)) + (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--do-mark-command nil + (if (image-dired-dired-file-marked-p) + (dired-unmark 1) + (dired-mark 1)))) + +(defun image-dired-unmark-all-marks () + "Remove all marks from all files in associated Dired buffer. +Also update the marks in the thumbnail buffer." + (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--do-mark-command nil + (dired-unmark-all-marks)) + (image-dired--with-thumbnail-buffer + (image-dired-thumb-update-marks))) (defun image-dired-jump-original-dired-buffer () "Jump to the Dired buffer associated with the current image file. You probably want to use this together with `image-dired-track-original-file'." - (interactive) + (interactive nil image-dired-thumbnail-mode) (let ((buf (image-dired-associated-dired-buffer)) window frame) (setq window (image-dired-get-buffer-window buf)) @@ -1478,236 +1552,213 @@ You probably want to use this together with (defvar image-dired-thumbnail-mode-line-up-map (let ((map (make-sparse-keymap))) ;; map it to "g" so that the user can press it more quickly - (define-key map "g" 'image-dired-line-up-dynamic) + (define-key map "g" #'image-dired-line-up-dynamic) ;; "f" for "fixed" number of thumbs per row - (define-key map "f" 'image-dired-line-up) + (define-key map "f" #'image-dired-line-up) ;; "i" for "interactive" - (define-key map "i" 'image-dired-line-up-interactive) + (define-key map "i" #'image-dired-line-up-interactive) map) "Keymap for line-up commands in `image-dired-thumbnail-mode'.") (defvar image-dired-thumbnail-mode-tag-map (let ((map (make-sparse-keymap))) ;; map it to "t" so that the user can press it more quickly - (define-key map "t" 'image-dired-tag-thumbnail) + (define-key map "t" #'image-dired-tag-thumbnail) ;; "r" for "remove" - (define-key map "r" 'image-dired-tag-thumbnail-remove) + (define-key map "r" #'image-dired-tag-thumbnail-remove) map) "Keymap for tag commands in `image-dired-thumbnail-mode'.") (defvar image-dired-thumbnail-mode-map (let ((map (make-sparse-keymap))) - (define-key map [right] 'image-dired-forward-image) - (define-key map [left] 'image-dired-backward-image) - (define-key map [up] 'image-dired-previous-line) - (define-key map [down] 'image-dired-next-line) - (define-key map "\C-f" 'image-dired-forward-image) - (define-key map "\C-b" 'image-dired-backward-image) - (define-key map "\C-p" 'image-dired-previous-line) - (define-key map "\C-n" 'image-dired-next-line) - - (define-key map "d" 'image-dired-flag-thumb-original-file) - (define-key map [delete] 'image-dired-flag-thumb-original-file) - (define-key map "m" 'image-dired-mark-thumb-original-file) - (define-key map "u" 'image-dired-unmark-thumb-original-file) - (define-key map "." 'image-dired-track-original-file) - (define-key map [tab] 'image-dired-jump-original-dired-buffer) + (define-key map [right] #'image-dired-forward-image) + (define-key map [left] #'image-dired-backward-image) + (define-key map [up] #'image-dired-previous-line) + (define-key map [down] #'image-dired-next-line) + (define-key map "\C-f" #'image-dired-forward-image) + (define-key map "\C-b" #'image-dired-backward-image) + (define-key map "\C-p" #'image-dired-previous-line) + (define-key map "\C-n" #'image-dired-next-line) + + (define-key map "<" #'image-dired-beginning-of-buffer) + (define-key map ">" #'image-dired-end-of-buffer) + (define-key map (kbd "M-<") #'image-dired-beginning-of-buffer) + (define-key map (kbd "M->") #'image-dired-end-of-buffer) + + (define-key map "d" #'image-dired-flag-thumb-original-file) + (define-key map [delete] #'image-dired-flag-thumb-original-file) + (define-key map "m" #'image-dired-mark-thumb-original-file) + (define-key map "u" #'image-dired-unmark-thumb-original-file) + (define-key map "U" #'image-dired-unmark-all-marks) + (define-key map "." #'image-dired-track-original-file) + (define-key map [tab] #'image-dired-jump-original-dired-buffer) ;; add line-up map (define-key map "g" image-dired-thumbnail-mode-line-up-map) ;; add tag map (define-key map "t" image-dired-thumbnail-mode-tag-map) - (define-key map "\C-m" 'image-dired-display-thumbnail-original-image) - (define-key map [C-return] 'image-dired-thumbnail-display-external) + (define-key map "\C-m" #'image-dired-display-thumbnail-original-image) + (define-key map [C-return] #'image-dired-thumbnail-display-external) - (define-key map "l" 'image-dired-rotate-thumbnail-left) - (define-key map "r" 'image-dired-rotate-thumbnail-right) - (define-key map "L" 'image-dired-rotate-original-left) - (define-key map "R" 'image-dired-rotate-original-right) + (define-key map "L" #'image-dired-rotate-original-left) + (define-key map "R" #'image-dired-rotate-original-right) - (define-key map "D" 'image-dired-thumbnail-set-image-description) - (define-key map "\C-d" 'image-dired-delete-char) - (define-key map " " 'image-dired-display-next-thumbnail-original) - (define-key map (kbd "DEL") 'image-dired-display-previous-thumbnail-original) - (define-key map "c" 'image-dired-comment-thumbnail) + (define-key map "D" #'image-dired-thumbnail-set-image-description) + (define-key map "S" #'image-dired-slideshow-start) + (define-key map "\C-d" #'image-dired-delete-char) + (define-key map " " #'image-dired-display-next-thumbnail-original) + (define-key map (kbd "DEL") #'image-dired-display-previous-thumbnail-original) + (define-key map "c" #'image-dired-comment-thumbnail) ;; Mouse - (define-key map [mouse-2] 'image-dired-mouse-display-image) - (define-key map [mouse-1] 'image-dired-mouse-select-thumbnail) + (define-key map [mouse-2] #'image-dired-mouse-display-image) + (define-key map [mouse-1] #'image-dired-mouse-select-thumbnail) + (define-key map [mouse-3] #'image-dired-mouse-select-thumbnail) + (define-key map [down-mouse-1] #'image-dired-mouse-select-thumbnail) + (define-key map [down-mouse-2] #'image-dired-mouse-select-thumbnail) + (define-key map [down-mouse-3] #'image-dired-mouse-select-thumbnail) ;; Seems I must first set C-down-mouse-1 to undefined, or else it ;; will trigger the buffer menu. If I try to instead bind ;; C-down-mouse-1 to `image-dired-mouse-toggle-mark', I get a message ;; about C-mouse-1 not being defined afterwards. Annoying, but I ;; probably do not completely understand mouse events. - (define-key map [C-down-mouse-1] 'undefined) - (define-key map [C-mouse-1] 'image-dired-mouse-toggle-mark) - - ;; Menu - (easy-menu-define nil map - "Menu for `image-dired-thumbnail-mode'." - '("Image-Dired" - ["Display image" image-dired-display-thumbnail-original-image] - ["Display in external viewer" image-dired-thumbnail-display-external] - - ["Mark original" image-dired-mark-thumb-original-file] - ["Unmark original" image-dired-unmark-thumb-original-file] - ["Flag original for deletion" image-dired-flag-thumb-original-file] - - ["Track original" image-dired-track-original-file] - ["Jump to dired buffer" image-dired-jump-original-dired-buffer] - - ["Toggle movement tracking on/off" image-dired-toggle-movement-tracking] - - ["Rotate original right" image-dired-rotate-original-right] - ["Rotate original left" image-dired-rotate-original-left] - ["Rotate thumbnail right" image-dired-rotate-thumbnail-right] - ["Rotate thumbnail left" image-dired-rotate-thumbnail-left] - - ["Line up thumbnails" image-dired-line-up] - ["Dynamic line up" image-dired-line-up-dynamic] - ["Refresh thumb" image-dired-refresh-thumb] - ["Comment thumbnail" image-dired-comment-thumbnail] - ["Tag current or marked thumbnails" image-dired-tag-thumbnail] - ["Remove tag from current or marked thumbnails" - image-dired-tag-thumbnail-remove] - ["Delete marked images" image-dired-delete-marked] - ["Delete thumbnail from buffer" image-dired-delete-char] - ["Quit" quit-window])) + (define-key map [C-down-mouse-1] #'undefined) + (define-key map [C-mouse-1] #'image-dired-mouse-toggle-mark) map) "Keymap for `image-dired-thumbnail-mode'.") +(easy-menu-define image-dired-thumbnail-mode-menu image-dired-thumbnail-mode-map + "Menu for `image-dired-thumbnail-mode'." + '("Image-Dired" + ["Display image" image-dired-display-thumbnail-original-image] + ["Display in external viewer" image-dired-thumbnail-display-external] + ["Jump to Dired buffer" image-dired-jump-original-dired-buffer] + "---" + ["Mark image" image-dired-mark-thumb-original-file] + ["Unmark image" image-dired-unmark-thumb-original-file] + ["Unmark all images" image-dired-unmark-all-marks] + ["Flag for deletion" image-dired-flag-thumb-original-file] + ["Delete marked images" image-dired-delete-marked] + "---" + ["Rotate original right" image-dired-rotate-original-right] + ["Rotate original left" image-dired-rotate-original-left] + "---" + ["Comment thumbnail" image-dired-comment-thumbnail] + ["Tag current or marked thumbnails" image-dired-tag-thumbnail] + ["Remove tag from current or marked thumbnails" + image-dired-tag-thumbnail-remove] + ["Start slideshow" image-dired-slideshow-start] + "---" + ("View Options" + ["Toggle movement tracking" image-dired-toggle-movement-tracking + :style toggle + :selected image-dired-track-movement] + "---" + ["Line up thumbnails" image-dired-line-up] + ["Dynamic line up" image-dired-line-up-dynamic] + ["Refresh thumb" image-dired-refresh-thumb]) + ["Quit" quit-window])) + (defvar image-dired-display-image-mode-map (let ((map (make-sparse-keymap))) - ;; `image-mode-map' has bindings that do not make sense in image-dired - ;; (set-keymap-parent map image-mode-map) - (define-key map "f" 'image-dired-display-current-image-full) - (define-key map "s" 'image-dired-display-current-image-sized) - (define-key map "g" nil) - - ;; Useful bindings from `image-mode-map' - (define-key map [remap forward-char] 'image-forward-hscroll) - (define-key map [remap backward-char] 'image-backward-hscroll) - (define-key map [remap right-char] 'image-forward-hscroll) - (define-key map [remap left-char] 'image-backward-hscroll) - (define-key map [remap previous-line] 'image-previous-line) - (define-key map [remap next-line] 'image-next-line) - (define-key map [remap scroll-up] 'image-scroll-up) - (define-key map [remap scroll-down] 'image-scroll-down) - (define-key map [remap scroll-up-command] 'image-scroll-up) - (define-key map [remap scroll-down-command] 'image-scroll-down) - (define-key map [remap scroll-left] 'image-scroll-left) - (define-key map [remap scroll-right] 'image-scroll-right) - (define-key map [remap move-beginning-of-line] 'image-bol) - (define-key map [remap move-end-of-line] 'image-eol) - (define-key map [remap beginning-of-buffer] 'image-bob) - (define-key map [remap end-of-buffer] 'image-eob) - - (easy-menu-define nil map - "Menu for `image-dired-display-image-mode-map'." - '("Image-Dired" - ["Display original, full size" image-dired-display-current-image-full] - ["Display original, sized to fit" image-dired-display-current-image-sized] - ["Quit" quit-window])) + (define-key map "S" #'image-dired-slideshow-start) + (define-key map (kbd "SPC") #'image-dired-display-next-thumbnail-original) + (define-key map (kbd "DEL") #'image-dired-display-previous-thumbnail-original) + (define-key map "n" #'image-dired-display-next-thumbnail-original) + (define-key map "p" #'image-dired-display-previous-thumbnail-original) + (define-key map "m" #'image-dired-mark-thumb-original-file) + (define-key map "d" #'image-dired-flag-thumb-original-file) + (define-key map "u" #'image-dired-unmark-thumb-original-file) + (define-key map "U" #'image-dired-unmark-all-marks) + ;; Disable keybindings from `image-mode-map' that doesn't make sense here. + (define-key map "o" nil) ; image-save map) "Keymap for `image-dired-display-image-mode'.") -(defun image-dired-display-current-image-full () - "Display current image in full size." - (interactive) - (let ((file (image-dired-original-file-name))) - (if file - (progn - (image-dired-display-image file t) - (message "Full size image displayed")) - (error "No original file name at point")))) - -(defun image-dired-display-current-image-sized () - "Display current image in sized to fit window dimensions." - (interactive) - (let ((file (image-dired-original-file-name))) - (if file - (progn - (image-dired-display-image file) - (message "Fitted image displayed")) - (error "No original file name at point")))) - (define-derived-mode image-dired-thumbnail-mode special-mode "image-dired-thumbnail" "Browse and manipulate thumbnail images using Dired. Use `image-dired-minor-mode' to get a nice setup." + :interactive nil (buffer-disable-undo) - (add-hook 'file-name-at-point-functions 'image-dired-file-name-at-point nil t)) + (add-hook 'file-name-at-point-functions 'image-dired-file-name-at-point nil t) + (setq-local window-resize-pixelwise t) + (setq-local bookmark-make-record-function #'image-dired-bookmark-make-record) + ;; Use approximately as much vertical spacing as horizontal. + (setq-local line-spacing (frame-char-width))) + + +;;; Display image mode (define-derived-mode image-dired-display-image-mode - special-mode "image-dired-image-display" + image-mode "image-dired-image-display" "Mode for displaying and manipulating original image. Resized or in full-size." - (buffer-disable-undo) - (image-mode-setup-winprops) - (setq cursor-type nil) - (add-hook 'file-name-at-point-functions 'image-dired-file-name-at-point nil t)) + :interactive nil + (add-hook 'file-name-at-point-functions #'image-dired-file-name-at-point nil t)) (defvar image-dired-minor-mode-map (let ((map (make-sparse-keymap))) ;; (set-keymap-parent map dired-mode-map) ;; Hijack previous and next line movement. Let C-p and C-b be ;; though... - (define-key map "p" 'image-dired-dired-previous-line) - (define-key map "n" 'image-dired-dired-next-line) - (define-key map [up] 'image-dired-dired-previous-line) - (define-key map [down] 'image-dired-dired-next-line) - - (define-key map (kbd "C-S-n") 'image-dired-next-line-and-display) - (define-key map (kbd "C-S-p") 'image-dired-previous-line-and-display) - (define-key map (kbd "C-S-m") 'image-dired-mark-and-display-next) - - (define-key map "\C-td" 'image-dired-display-thumbs) - (define-key map [tab] 'image-dired-jump-thumbnail-buffer) - (define-key map "\C-ti" 'image-dired-dired-display-image) - (define-key map "\C-tx" 'image-dired-dired-display-external) - (define-key map "\C-ta" 'image-dired-display-thumbs-append) - (define-key map "\C-t." 'image-dired-display-thumb) - (define-key map "\C-tc" 'image-dired-dired-comment-files) - (define-key map "\C-tf" 'image-dired-mark-tagged-files) - - ;; Menu for dired - (easy-menu-define nil map - "Menu for `image-dired-minor-mode'." - '("Image-dired" - ["Display thumb for next file" image-dired-next-line-and-display] - ["Display thumb for previous file" image-dired-previous-line-and-display] - ["Mark and display next" image-dired-mark-and-display-next] - - ["Create thumbnails for marked files" image-dired-create-thumbs] - - ["Display thumbnails append" image-dired-display-thumbs-append] - ["Display this thumbnail" image-dired-display-thumb] - ["Display image" image-dired-dired-display-image] - ["Display in external viewer" image-dired-dired-display-external] - - ["Toggle display properties" image-dired-toggle-dired-display-properties] - ["Toggle append browsing" image-dired-toggle-append-browsing] - ["Toggle movement tracking" image-dired-toggle-movement-tracking] - - ["Jump to thumbnail buffer" image-dired-jump-thumbnail-buffer] - ["Mark tagged files" image-dired-mark-tagged-files] - ["Comment files" image-dired-dired-comment-files] - ["Copy with EXIF file name" image-dired-copy-with-exif-file-name])) + (define-key map "p" #'image-dired-dired-previous-line) + (define-key map "n" #'image-dired-dired-next-line) + (define-key map [up] #'image-dired-dired-previous-line) + (define-key map [down] #'image-dired-dired-next-line) + + (define-key map (kbd "C-S-n") #'image-dired-next-line-and-display) + (define-key map (kbd "C-S-p") #'image-dired-previous-line-and-display) + (define-key map (kbd "C-S-m") #'image-dired-mark-and-display-next) + + (define-key map "\C-td" #'image-dired-display-thumbs) + (define-key map [tab] #'image-dired-jump-thumbnail-buffer) + (define-key map "\C-ti" #'image-dired-dired-display-image) + (define-key map "\C-tx" #'image-dired-dired-display-external) + (define-key map "\C-ta" #'image-dired-display-thumbs-append) + (define-key map "\C-t." #'image-dired-display-thumb) + (define-key map "\C-tc" #'image-dired-dired-comment-files) + (define-key map "\C-tf" #'image-dired-mark-tagged-files) map) "Keymap for `image-dired-minor-mode'.") +(easy-menu-define image-dired-minor-mode-menu image-dired-minor-mode-map + "Menu for `image-dired-minor-mode'." + '("Image-dired" + ["Display thumb for next file" image-dired-next-line-and-display] + ["Display thumb for previous file" image-dired-previous-line-and-display] + ["Mark and display next" image-dired-mark-and-display-next] + "---" + ["Create thumbnails for marked files" image-dired-create-thumbs] + "---" + ["Display thumbnails append" image-dired-display-thumbs-append] + ["Display this thumbnail" image-dired-display-thumb] + ["Display image" image-dired-dired-display-image] + ["Display in external viewer" image-dired-dired-display-external] + "---" + ["Toggle display properties" image-dired-toggle-dired-display-properties + :style toggle + :selected image-dired-dired-disp-props] + ["Toggle append browsing" image-dired-toggle-append-browsing + :style toggle + :selected image-dired-append-when-browsing] + ["Toggle movement tracking" image-dired-toggle-movement-tracking + :style toggle + :selected image-dired-track-movement] + "---" + ["Jump to thumbnail buffer" image-dired-jump-thumbnail-buffer] + ["Mark tagged files" image-dired-mark-tagged-files] + ["Comment files" image-dired-dired-comment-files] + ["Copy with EXIF file name" image-dired-copy-with-exif-file-name])) + ;;;###autoload (define-minor-mode image-dired-minor-mode "Setup easy-to-use keybindings for the commands to be used in Dired mode. Note that n, p and <down> and <up> will be hijacked and bound to -`image-dired-dired-x-line'." +`image-dired-dired-next-line' and `image-dired-dired-previous-line'." :keymap image-dired-minor-mode-map) -;;;###autoload -(define-obsolete-function-alias 'image-dired-setup-dired-keybindings 'image-dired-minor-mode - "26.1") - (declare-function clear-image-cache "image.c" (&optional filter)) (defun image-dired-create-thumbs (&optional arg) @@ -1727,46 +1778,69 @@ With prefix argument ARG, create thumbnails even if they already exist arg) (image-dired-create-thumb curr-file thumb-name))))) -(defvar image-dired-slideshow-timer nil - "Slideshow timer.") + +;;; Slideshow -(defvar image-dired-slideshow-count 0 - "Keeping track on number of images in slideshow.") +(defcustom image-dired-slideshow-delay 5.0 + "Seconds to wait before showing the next image in a slideshow. +This is used by `image-dired-slideshow-start'." + :type 'float + :version "29.1") -(defvar image-dired-slideshow-times 0 - "Number of pictures to display in slideshow.") +(define-obsolete-variable-alias 'image-dired-slideshow-timer + 'image-dired--slideshow-timer "29.1") +(defvar image-dired--slideshow-timer nil + "Slideshow timer.") + +(defvar image-dired--slideshow-initial nil) (defun image-dired-slideshow-step () - "Step to next file, if `image-dired-slideshow-times' has not been reached." - (if (< image-dired-slideshow-count image-dired-slideshow-times) - (progn - (message "%s" (1+ image-dired-slideshow-count)) - (setq image-dired-slideshow-count (1+ image-dired-slideshow-count)) - (image-dired-next-line-and-display)) + "Step to next image in a slideshow." + (if-let ((buf (get-buffer image-dired-thumbnail-buffer))) + (with-current-buffer buf + (image-dired-display-next-thumbnail-original)) (image-dired-slideshow-stop))) -(defun image-dired-slideshow-start () - "Start slideshow. -Ask user for number of images to show and the delay in between." - (interactive) - (setq image-dired-slideshow-count 0) - (setq image-dired-slideshow-times (string-to-number (read-string "How many: "))) - (let ((repeat (string-to-number - (read-string - "Delay, in seconds. Decimals are accepted : " "1")))) - (setq image-dired-slideshow-timer +(defun image-dired-slideshow-start (&optional arg) + "Start a slideshow, waiting `image-dired-slideshow-delay' between images. + +With prefix argument ARG, wait that many seconds before going to +the next image. + +With a negative prefix argument, prompt user for the delay." + (interactive "P" image-dired-thumbnail-mode image-dired-display-image-mode) + (let ((delay (if (not arg) + image-dired-slideshow-delay + (if (> arg 0) + arg + (string-to-number + (let ((delay (number-to-string image-dired-slideshow-delay))) + (read-string + (format-prompt "Delay, in seconds. Decimals are accepted" delay)) + delay)))))) + (setq image-dired--slideshow-timer (run-with-timer - 0 repeat - 'image-dired-slideshow-step)))) + 0 delay + 'image-dired-slideshow-step)) + (add-hook 'post-command-hook 'image-dired-slideshow-stop) + (setq image-dired--slideshow-initial t) + (message "Running slideshow; use any command to stop"))) (defun image-dired-slideshow-stop () "Cancel slideshow." - (interactive) - (cancel-timer image-dired-slideshow-timer)) + ;; Make sure we don't immediately stop after + ;; `image-dired-slideshow-start'. + (unless image-dired--slideshow-initial + (remove-hook 'post-command-hook 'image-dired-slideshow-stop) + (cancel-timer image-dired--slideshow-timer)) + (setq image-dired--slideshow-initial nil)) + + +;;; Thumbnail mode (cont. 3) (defun image-dired-delete-char () "Remove current thumbnail from thumbnail buffer and line up." - (interactive) + (interactive nil image-dired-thumbnail-mode) (let ((inhibit-read-only t)) (delete-char 1) (when (= (following-char) ?\s) @@ -1799,18 +1873,26 @@ See also `image-dired-line-up-dynamic'." (not (eobp))) (delete-char 1))) (goto-char (point-min)) - (let ((count 0)) + (let ((seen 0) + (thumb-prev-pos 0) + (thumb-width-chars + (ceiling (/ (+ (* 2 image-dired-thumb-relief) + (* 2 image-dired-thumb-margin) + (image-dired-thumb-size 'width)) + (float (frame-char-width)))))) (while (not (eobp)) (forward-char) (if (= image-dired-thumbs-per-row 1) (insert "\n") - (insert " ") - (setq count (1+ count)) - (when (and (= count (- image-dired-thumbs-per-row 1)) + (cl-incf thumb-prev-pos thumb-width-chars) + (insert (propertize " " 'display `(space :align-to ,thumb-prev-pos))) + (cl-incf seen) + (when (and (= seen (- image-dired-thumbs-per-row 1)) (not (eobp))) (forward-char) (insert "\n") - (setq count 0))))) + (setq seen 0) + (setq thumb-prev-pos 0))))) (goto-char (point-min)))) (defun image-dired-line-up-dynamic () @@ -1860,11 +1942,6 @@ Ask user how many thumbnails should be displayed per row." "Calculate WINDOW width in pixels." (* (window-width window) (frame-char-width))) -(defun image-dired-window-height-pixels (window) - "Calculate WINDOW height in pixels." - ;; Note: The mode-line consumes one line - (* (- (window-height window) 1) (frame-char-height))) - (defun image-dired-display-window () "Return window where `image-dired-display-image-buffer' is visible." (get-window-with-predicate @@ -1890,59 +1967,24 @@ Ask user how many thumbnails should be displayed per row." (equal (window-buffer window) buf)))) (error "No thumbnail image at point")))) -(defun image-dired-display-window-width (window) - "Return width, in pixels, of WINDOW." - (- (image-dired-window-width-pixels window) - image-dired-display-window-width-correction)) - -(defun image-dired-display-window-height (window) - "Return height, in pixels, of WINDOW." - (- (image-dired-window-height-pixels window) - image-dired-display-window-height-correction)) - -(defun image-dired-display-image (file &optional original-size) +(defun image-dired-display-image (file &optional _ignored) "Display image FILE in image buffer. -Use this when you want to display the image, semi sized, in a new -window. The image is sized to fit the display window (using a -temporary file, don't worry). Because of this, it will not be as -quick as opening it directly, but on most modern systems it -should feel snappy enough. - -If optional argument ORIGINAL-SIZE is non-nil, display image in its -original size." - (image-dired--check-executable-exists - 'image-dired-cmd-create-temp-image-program) - (let ((new-file (expand-file-name image-dired-temp-image-file)) - (window (image-dired-display-window)) - (image-type 'jpeg)) - (setq file (expand-file-name file)) - (if (not original-size) - (let* ((spec - (list - (cons ?p image-dired-cmd-create-temp-image-program) - (cons ?w (image-dired-display-window-width window)) - (cons ?h (image-dired-display-window-height window)) - (cons ?f file) - (cons ?t new-file))) - (ret - (apply #'call-process - image-dired-cmd-create-temp-image-program nil nil nil - (mapcar - (lambda (arg) (format-spec arg spec)) - image-dired-cmd-create-temp-image-options)))) - (when (not (zerop ret)) - (error "Could not resize image"))) - (setq image-type (image-type-from-file-name file)) - (copy-file file new-file t)) - (with-current-buffer (image-dired-create-display-image-buffer) - (let ((inhibit-read-only t)) - (erase-buffer) - (clear-image-cache) - (image-dired-insert-image image-dired-temp-image-file image-type 0 0) - (goto-char (point-min)) - (set-window-vscroll window 0) - (set-window-hscroll window 0) - (image-dired-update-property 'original-file-name file))))) +Use this when you want to display the image, in a new window. +The window will use `image-dired-display-image-mode' which is +based on `image-mode'." + (declare (advertised-calling-convention (file) "29.1")) + (setq file (expand-file-name file)) + (when (not (file-exists-p file)) + (error "No such file: %s" file)) + (let ((buf (get-buffer image-dired-display-image-buffer)) + (cur-win (selected-window))) + (when buf + (kill-buffer buf)) + (when-let ((buf (find-file-other-window file))) + (display-buffer buf) + (rename-buffer image-dired-display-image-buffer) + (image-dired-display-image-mode) + (select-window cur-win)))) (defun image-dired-display-thumbnail-original-image (&optional arg) "Display current thumbnail's original image in display buffer. @@ -1956,8 +1998,6 @@ With prefix argument ARG, display image in its original size." (message "No thumbnail at point") (if (not file) (message "No original file name found") - (image-dired-create-display-image-buffer) - (display-buffer image-dired-display-image-buffer) (image-dired-display-image file arg)))))) @@ -1967,41 +2007,15 @@ With prefix argument ARG, display image in its original size." See documentation for `image-dired-display-image' for more information. With prefix argument ARG, display image in its original size." (interactive "P") - (image-dired-create-display-image-buffer) - (display-buffer image-dired-display-image-buffer) (image-dired-display-image (dired-get-filename) arg)) (defun image-dired-image-at-point-p () "Return non-nil if there is an `image-dired' thumbnail at point." (get-text-property (point) 'image-dired-thumbnail)) -(defun image-dired-rotate-thumbnail (degrees) - "Rotate thumbnail DEGREES degrees." - (image-dired--check-executable-exists - 'image-dired-cmd-rotate-thumbnail-program) - (if (not (image-dired-image-at-point-p)) - (message "No thumbnail at point") - (let* ((file (image-dired-thumb-name (image-dired-original-file-name))) - (thumb (expand-file-name file)) - (spec (list (cons ?d degrees) (cons ?t thumb)))) - (apply #'call-process image-dired-cmd-rotate-thumbnail-program nil nil nil - (mapcar (lambda (arg) (format-spec arg spec)) - image-dired-cmd-rotate-thumbnail-options)) - (clear-image-cache thumb)))) - -(defun image-dired-rotate-thumbnail-left () - "Rotate thumbnail left (counter clockwise) 90 degrees." - (interactive) - (image-dired-rotate-thumbnail "270")) - -(defun image-dired-rotate-thumbnail-right () - "Rotate thumbnail counter right (clockwise) 90 degrees." - (interactive) - (image-dired-rotate-thumbnail "90")) - (defun image-dired-refresh-thumb () "Force creation of new image for current thumbnail." - (interactive) + (interactive nil image-dired-thumbnail-mode) (let* ((file (image-dired-original-file-name)) (thumb (expand-file-name (image-dired-thumb-name file)))) (clear-image-cache (expand-file-name thumb)) @@ -2020,7 +2034,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)) @@ -2054,6 +2068,9 @@ overwritten. This confirmation can be turned off using (interactive) (image-dired-rotate-original "90")) + +;;; EXIF support + (defun image-dired-get-exif-file-name (file) "Use the image's EXIF information to return a unique file name. The file name should be unique as long as you do not take more than @@ -2068,8 +2085,8 @@ YYYY_MM_DD_HH_MM_DD_ORIG_FILE_NAME.jpg. Used from "%Y:%m:%d %H:%M:%S" (file-attribute-modification-time (file-attributes (expand-file-name file))))) - (setq data (image-dired-get-exif-data (expand-file-name file) - "DateTimeOriginal"))) + (setq data (exif-field 'date-time (exif-parse-file + (expand-file-name file))))) (while (string-match "[ :]" data) (setq data (replace-match "_" nil nil data))) (format "%s%s%s" data @@ -2086,7 +2103,7 @@ default value at the prompt." (if (not (image-dired-image-at-point-p)) (message "No thumbnail at point") (let* ((file (image-dired-original-file-name)) - (old-value (image-dired-get-exif-data file "ImageDescription"))) + (old-value (or (exif-field 'description (exif-parse-file file)) ""))) (if (eq 0 (image-dired-set-exif-data file "ImageDescription" (read-string "Value of ImageDescription: " @@ -2107,33 +2124,9 @@ default value at the prompt." (mapcar (lambda (arg) (format-spec arg spec)) image-dired-cmd-write-exif-data-options)))) -(defun image-dired-get-exif-data (file tag-name) - "From FILE, return EXIF tag TAG-NAME." - (image-dired--check-executable-exists - 'image-dired-cmd-read-exif-data-program) - (let ((buf (get-buffer-create "*image-dired-get-exif-data*")) - (spec (list (cons ?f file) (cons ?t tag-name))) - tag-value) - (with-current-buffer buf - (delete-region (point-min) (point-max)) - (if (not (eq (apply #'call-process image-dired-cmd-read-exif-data-program - nil t nil - (mapcar - (lambda (arg) (format-spec arg spec)) - image-dired-cmd-read-exif-data-options)) - 0)) - (error "Could not get EXIF tag") - (goto-char (point-min)) - ;; Clean buffer from newlines and carriage returns before - ;; getting final info - (while (search-forward-regexp "[\n\r]" nil t) - (replace-match "" nil t)) - (setq tag-value (buffer-substring (point-min) (point-max))))) - tag-value)) - (defun image-dired-copy-with-exif-file-name () "Copy file with unique name to main image directory. -Copy current or all marked files in dired to a new file in your +Copy current or all marked files in Dired to a new file in your main image directory, using a file name generated by `image-dired-get-exif-file-name'. A typical usage for this if when copying images from a digital camera into the image directory. @@ -2158,17 +2151,24 @@ function. The result is a couple of new files in (copy-file curr-file new-name)) files))) -(defun image-dired-display-next-thumbnail-original () - "In thumbnail buffer, move to next thumbnail and display the image." - (interactive) - (image-dired-forward-image) - (image-dired-display-thumbnail-original-image)) +;;; Thumbnail mode (cont.) -(defun image-dired-display-previous-thumbnail-original () - "Move to previous thumbnail and display image." - (interactive) - (image-dired-backward-image) - (image-dired-display-thumbnail-original-image)) +(defun image-dired-display-next-thumbnail-original (&optional arg) + "Move to the next image in the thumbnail buffer and display it. +With prefix ARG, move that many thumbnails." + (interactive "p" image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--with-thumbnail-buffer + (image-dired-forward-image arg t) + (image-dired-display-thumbnail-original-image))) + +(defun image-dired-display-previous-thumbnail-original (arg) + "Move to the previous image in the thumbnail buffer and display it. +With prefix ARG, move that many thumbnails." + (interactive "p" image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired-display-next-thumbnail-original (- arg))) + + +;;; Image Comments (defun image-dired-write-comments (file-comments) "Write file comments to database. @@ -2233,7 +2233,7 @@ FILE-COMMENTS is an alist on the following form: (comment (image-dired-read-comment file))) (image-dired-write-comments (list (cons file comment))) (image-dired-update-property 'comment comment)) - (image-dired-display-thumb-properties)) + (image-dired-update-header-line)) (defun image-dired-read-comment (&optional file) "Read comment for an image. @@ -2296,6 +2296,10 @@ matching tag will be marked in the Dired buffer." (dired-mark 1)))) (message "%d files with matching tag marked." hits))) + + +;;; Mouse support + (defun image-dired-mouse-display-image (event) "Use mouse EVENT, call `image-dired-display-image' to display image. Track this in associated Dired buffer if `image-dired-track-movement' is @@ -2303,12 +2307,12 @@ non-nil." (interactive "e") (mouse-set-point event) (goto-char (posn-point (event-end event))) + (unless (image-at-point-p) + (image-dired-backward-image)) (let ((file (image-dired-original-file-name))) (when file (if image-dired-track-movement (image-dired-track-original-file)) - (image-dired-create-display-image-buffer) - (display-buffer image-dired-display-image-buffer) (image-dired-display-image file)))) (defun image-dired-mouse-select-thumbnail (event) @@ -2318,19 +2322,33 @@ non-nil." (interactive "e") (mouse-set-point event) (goto-char (posn-point (event-end event))) + (unless (image-at-point-p) + (image-dired-backward-image)) (if image-dired-track-movement (image-dired-track-original-file)) - (image-dired-display-thumb-properties)) + (image-dired-update-header-line)) + + + +;;; Dired marks and tags -(defun image-dired-thumb-file-marked-p () - "Check if file is marked in associated Dired buffer." +(defun image-dired-thumb-file-marked-p (&optional flagged) + "Check if file is marked in associated Dired buffer. +If optional argument FLAGGED is non-nil, check if file is flagged +for deletion instead." (let ((file-name (image-dired-original-file-name)) (dired-buf (image-dired-associated-dired-buffer))) (when (and dired-buf file-name) (with-current-buffer dired-buf (save-excursion (when (dired-goto-file file-name) - (image-dired-dired-file-marked-p))))))) + (if flagged + (image-dired-dired-file-flagged-p) + (image-dired-dired-file-marked-p)))))))) + +(defun image-dired-thumb-file-flagged-p () + "Check if file is flagged for deletion in associated Dired buffer." + (image-dired-thumb-file-marked-p t)) (defun image-dired-delete-marked () "Delete current or marked thumbnails and associated images." @@ -2351,11 +2369,14 @@ non-nil." (let ((inhibit-read-only t)) (while (not (eobp)) (with-silent-modifications - (if (image-dired-thumb-file-marked-p) - (add-face-text-property (point) (1+ (point)) - 'image-dired-thumb-mark) - (remove-text-properties (point) (1+ (point)) - '(face image-dired-thumb-mark)))) + (cond ((image-dired-thumb-file-marked-p) + (add-face-text-property (point) (1+ (point)) + 'image-dired-thumb-mark)) + ((image-dired-thumb-file-flagged-p) + (add-face-text-property (point) (1+ (point)) + 'image-dired-thumb-flagged)) + (t (remove-text-properties (point) (1+ (point)) + '(face image-dired-thumb-mark))))) (forward-char))))))) (defun image-dired-mouse-toggle-mark-1 () @@ -2402,6 +2423,53 @@ Track this in associated Dired buffer if props comment))))) + + +;;; Gallery support + +;; TODO: +;; * Support gallery creation when using per-directory thumbnail +;; storage. +;; * Enhanced gallery creation with basic CSS-support and pagination +;; of tag pages with many pictures. + +(defgroup image-dired-gallery nil + "Image-Dired support for generating a HTML gallery." + :prefix "image-dired-" + :group 'image-dired + :version "29.1") + +(defcustom image-dired-gallery-dir + (expand-file-name ".image-dired_gallery" image-dired-dir) + "Directory to store generated gallery html pages. +The name of this directory needs to be \"shared\" to the public +so that it can access the index.html page that image-dired creates." + :type 'directory) + +(defcustom image-dired-gallery-image-root-url + "https://example.org/image-diredpics" + "URL where the full size images are to be found on your web server. +Note that this URL has to be configured on your web server. +Image-Dired expects to find pictures in this directory. +This is used by `image-dired-gallery-generate'." + :type 'string + :version "29.1") + +(defcustom image-dired-gallery-thumb-image-root-url + "https://example.org/image-diredthumbs" + "URL where the thumbnail images are to be found on your web server. +Note that URL path has to be configured on your web server. +Image-Dired expects to find pictures in this directory. +This is used by `image-dired-gallery-generate'." + :type 'string + :version "29.1") + +(defcustom image-dired-gallery-hidden-tags + (list "private" "hidden" "pending") + "List of \"hidden\" tags. +Used by `image-dired-gallery-generate' to leave out \"hidden\" images." + :type '(repeat string)) + (defvar image-dired-tag-file-list nil "List to store tag-file structure.") @@ -2411,19 +2479,8 @@ Track this in associated Dired buffer if (defvar image-dired-file-comment-list nil "List to store file comments.") -(defun image-dired-add-to-tag-file-list (tag file) - "Add relation between TAG and FILE." - (let (curr) - (if image-dired-tag-file-list - (if (setq curr (assoc tag image-dired-tag-file-list)) - (if (not (member file curr)) - (setcdr curr (cons file (cdr curr)))) - (setcdr image-dired-tag-file-list - (cons (list tag file) (cdr image-dired-tag-file-list)))) - (setq image-dired-tag-file-list (list (list tag file)))))) - -(defun image-dired-add-to-tag-file-lists (tag file) - "Helper function used from `image-dired-create-gallery-lists'. +(defun image-dired--add-to-tag-file-lists (tag file) + "Helper function used from `image-dired--create-gallery-lists'. Add TAG to FILE in one list and FILE to TAG in the other. @@ -2457,8 +2514,8 @@ image-dired-tag-file-list: (cons (list tag file) (cdr image-dired-tag-file-list)))) (setq image-dired-tag-file-list (list (list tag file)))))) -(defun image-dired-add-to-file-comment-list (file comment) - "Helper function used from `image-dired-create-gallery-lists'. +(defun image-dired--add-to-file-comment-list (file comment) + "Helper function used from `image-dired--create-gallery-lists'. For FILE, add COMMENT to list. @@ -2476,7 +2533,7 @@ image-dired-file-comment-list: (cdr image-dired-file-comment-list)))) (setq image-dired-file-comment-list (list (cons file comment))))) -(defun image-dired-create-gallery-lists () +(defun image-dired--create-gallery-lists () "Create temporary lists used by `image-dired-gallery-generate'." (image-dired-sane-db-file) (image-dired--with-db-file @@ -2497,15 +2554,15 @@ image-dired-file-comment-list: (setq file (car row-tags)) (dolist (x (cdr row-tags)) (if (not (string-match "^comment:\\(.*\\)" x)) - (image-dired-add-to-tag-file-lists x file) - (image-dired-add-to-file-comment-list file (match-string 1 x))))))) + (image-dired--add-to-tag-file-lists x file) + (image-dired--add-to-file-comment-list file (match-string 1 x))))))) ;; Sort tag-file list (setq image-dired-tag-file-list (sort image-dired-tag-file-list (lambda (x y) (string< (car x) (car y)))))) -(defun image-dired-hidden-p (file) +(defun image-dired--hidden-p (file) "Return t if image FILE has a \"hidden\" tag." (cl-loop for tag in (cdr (assoc file image-dired-file-tag-list)) if (member tag image-dired-gallery-hidden-tags) return t)) @@ -2519,7 +2576,7 @@ it easier to generate, then HTML-files are created in (if (eq 'per-directory image-dired-thumbnail-storage) (error "Currently, gallery generation is not supported \ when using per-directory thumbnail file storage")) - (image-dired-create-gallery-lists) + (image-dired--create-gallery-lists) (let ((tags image-dired-tag-file-list) (index-file (format "%s/index.html" image-dired-gallery-dir)) count tag tag-file @@ -2601,6 +2658,9 @@ when using per-directory thumbnail file storage")) (insert " </body>\n") (insert "</html>")))) + +;;; Tag support + (defvar image-dired-widget-list nil "List to keep track of meta data in edit buffer.") @@ -2702,6 +2762,285 @@ tags to their respective image file. Internal function used by (dolist (tag tag-list) (push (cons file tag) lst)))))) + +;;; bookmark.el support + +(declare-function bookmark-make-record-default + "bookmark" (&optional no-file no-context posn)) +(declare-function bookmark-prop-get "bookmark" (bookmark prop)) + +(defun image-dired-bookmark-name () + "Create a default bookmark name for the current EWW buffer." + (file-name-nondirectory + (directory-file-name + (file-name-directory (image-dired-original-file-name))))) + +(defun image-dired-bookmark-make-record () + "Create a bookmark for the current EWW buffer." + `(,(image-dired-bookmark-name) + ,@(bookmark-make-record-default t) + (location . ,(file-name-directory (image-dired-original-file-name))) + (image-dired-file . ,(file-name-nondirectory (image-dired-original-file-name))) + (handler . image-dired-bookmark-jump))) + +;;;###autoload +(defun image-dired-bookmark-jump (bookmark) + "Default bookmark handler for Image-Dired buffers." + ;; User already cached thumbnails, so disable any checking. + (let ((image-dired-show-all-from-dir-max-files nil)) + (image-dired (bookmark-prop-get bookmark 'location)) + ;; TODO: Go to the bookmarked file, if it exists. + ;; (bookmark-prop-get bookmark 'image-dired-file) + (goto-char (point-min)))) + + +;;; Obsolete + +;;;###autoload +(define-obsolete-function-alias 'tumme #'image-dired "24.4") + +;;;###autoload +(define-obsolete-function-alias 'image-dired-setup-dired-keybindings + #'image-dired-minor-mode "26.1") + +(defcustom image-dired-temp-image-file + (expand-file-name ".image-dired_temp" image-dired-dir) + "Name of temporary image file used by various commands." + :type 'file) +(make-obsolete-variable 'image-dired-temp-image-file + "no longer used." "29.1") + +(defcustom image-dired-cmd-create-temp-image-program + (if (executable-find "gm") "gm" "convert") + "Executable used to create temporary image. +Used together with `image-dired-cmd-create-temp-image-options'." + :type 'file + :version "29.1") +(make-obsolete-variable 'image-dired-cmd-create-temp-image-program + "no longer used." "29.1") + +(defcustom image-dired-cmd-create-temp-image-options + (let ((opts '("-size" "%wx%h" "%f[0]" + "-resize" "%wx%h>" + "-strip" "jpeg:%t"))) + (if (executable-find "gm") (cons "convert" opts) opts)) + "Options of command used to create temporary image for display window. +Used together with `image-dired-cmd-create-temp-image-program', +Available format specifiers are: %w and %h which are replaced by +the calculated max size for width and height in the image display window, +%f which is replaced by the file name of the original image and %t which +is replaced by the file name of the temporary file." + :version "29.1" + :type '(repeat (string :tag "Argument"))) +(make-obsolete-variable 'image-dired-cmd-create-temp-image-options + "no longer used." "29.1") + +(defcustom image-dired-display-window-width-correction 1 + "Number to be used to correct image display window width. +Change if the default (1) does not work (i.e. if the image does not +completely fit)." + :type 'integer) +(make-obsolete-variable 'image-dired-display-window-width-correction + "no longer used." "29.1") + +(defcustom image-dired-display-window-height-correction 0 + "Number to be used to correct image display window height. +Change if the default (0) does not work (i.e. if the image does not +completely fit)." + :type 'integer) +(make-obsolete-variable 'image-dired-display-window-height-correction + "no longer used." "29.1") + +(defun image-dired-display-window-width (window) + "Return width, in pixels, of WINDOW." + (declare (obsolete nil "29.1")) + (- (image-dired-window-width-pixels window) + image-dired-display-window-width-correction)) + +(defun image-dired-display-window-height (window) + "Return height, in pixels, of WINDOW." + (declare (obsolete nil "29.1")) + (- (image-dired-window-height-pixels window) + image-dired-display-window-height-correction)) + +(defun image-dired-window-height-pixels (window) + "Calculate WINDOW height in pixels." + (declare (obsolete nil "29.1")) + ;; Note: The mode-line consumes one line + (* (- (window-height window) 1) (frame-char-height))) + +(defcustom image-dired-cmd-read-exif-data-program "exiftool" + "Program used to read EXIF data to image. +Used together with `image-dired-cmd-read-exif-data-options'." + :type 'file) +(make-obsolete-variable 'image-dired-cmd-read-exif-data-program + "use `exif-parse-file' and `exif-field' instead." "29.1") + +(defcustom image-dired-cmd-read-exif-data-options '("-s" "-s" "-s" "-%t" "%f") + "Arguments of command used to read EXIF data. +Used with `image-dired-cmd-read-exif-data-program'. +Available format specifiers are: %f which is replaced +by the image file name and %t which is replaced by the tag name." + :version "26.1" + :type '(repeat (string :tag "Argument"))) +(make-obsolete-variable 'image-dired-cmd-read-exif-data-options + "use `exif-parse-file' and `exif-field' instead." "29.1") + +(defun image-dired-get-exif-data (file tag-name) + "From FILE, return EXIF tag TAG-NAME." + (declare (obsolete "use `exif-parse-file' and `exif-field' instead." "29.1")) + (image-dired--check-executable-exists + 'image-dired-cmd-read-exif-data-program) + (let ((buf (get-buffer-create "*image-dired-get-exif-data*")) + (spec (list (cons ?f file) (cons ?t tag-name))) + tag-value) + (with-current-buffer buf + (delete-region (point-min) (point-max)) + (if (not (eq (apply #'call-process image-dired-cmd-read-exif-data-program + nil t nil + (mapcar + (lambda (arg) (format-spec arg spec)) + image-dired-cmd-read-exif-data-options)) + 0)) + (error "Could not get EXIF tag") + (goto-char (point-min)) + ;; Clean buffer from newlines and carriage returns before + ;; getting final info + (while (search-forward-regexp "[\n\r]" nil t) + (replace-match "" nil t)) + (setq tag-value (buffer-substring (point-min) (point-max))))) + tag-value)) + +(defcustom image-dired-cmd-rotate-thumbnail-program + (if (executable-find "gm") "gm" "mogrify") + "Executable used to rotate thumbnail. +Used together with `image-dired-cmd-rotate-thumbnail-options'." + :type 'file + :version "29.1") +(make-obsolete-variable 'image-dired-cmd-rotate-thumbnail-program nil "29.1") + +(defcustom image-dired-cmd-rotate-thumbnail-options + (let ((opts '("-rotate" "%d" "%t"))) + (if (executable-find "gm") (cons "mogrify" opts) opts)) + "Arguments of command used to rotate thumbnail image. +Used with `image-dired-cmd-rotate-thumbnail-program'. +Available format specifiers are: %d which is replaced by the +number of (positive) degrees to rotate the image, normally 90 or 270 +\(for 90 degrees right and left), %t which is replaced by the file name +of the thumbnail file." + :version "29.1" + :type '(repeat (string :tag "Argument"))) +(make-obsolete-variable 'image-dired-cmd-rotate-thumbnail-options nil "29.1") + +(defun image-dired-rotate-thumbnail (degrees) + "Rotate thumbnail DEGREES degrees." + (declare (obsolete image-dired-refresh-thumb "29.1")) + (image-dired--check-executable-exists + 'image-dired-cmd-rotate-thumbnail-program) + (if (not (image-dired-image-at-point-p)) + (message "No thumbnail at point") + (let* ((file (image-dired-thumb-name (image-dired-original-file-name))) + (thumb (expand-file-name file)) + (spec (list (cons ?d degrees) (cons ?t thumb)))) + (apply #'call-process image-dired-cmd-rotate-thumbnail-program nil nil nil + (mapcar (lambda (arg) (format-spec arg spec)) + image-dired-cmd-rotate-thumbnail-options)) + (clear-image-cache thumb)))) + +(defun image-dired-rotate-thumbnail-left () + "Rotate thumbnail left (counter clockwise) 90 degrees." + (declare (obsolete image-dired-refresh-thumb "29.1")) + (interactive) + (with-suppressed-warnings ((obsolete image-dired-rotate-thumbnail)) + (image-dired-rotate-thumbnail "270"))) + +(defun image-dired-rotate-thumbnail-right () + "Rotate thumbnail counter right (clockwise) 90 degrees." + (declare (obsolete image-dired-refresh-thumb "29.1")) + (interactive) + (with-suppressed-warnings ((obsolete image-dired-rotate-thumbnail)) + (image-dired-rotate-thumbnail "90"))) + +(defun image-dired-modify-mark-on-thumb-original-file (command) + "Modify mark in Dired buffer. +COMMAND is one of `mark' for marking file in Dired, `unmark' for +unmarking file in Dired or `flag' for flagging file for delete in +Dired." + (declare (obsolete image-dired--on-file-in-dired-buffer "29.1")) + (let ((file-name (image-dired-original-file-name)) + (dired-buf (image-dired-associated-dired-buffer))) + (if (not (and dired-buf file-name)) + (message "No image, or image with correct properties, at point.") + (with-current-buffer dired-buf + (message "%s" file-name) + (when (dired-goto-file file-name) + (cond ((eq command 'mark) (dired-mark 1)) + ((eq command 'unmark) (dired-unmark 1)) + ((eq command 'toggle) + (if (image-dired-dired-file-marked-p) + (dired-unmark 1) + (dired-mark 1))) + ((eq command 'flag) (dired-flag-file-deletion 1))) + (image-dired-thumb-update-marks)))))) + +(defun image-dired-display-current-image-full () + "Display current image in full size." + (declare (obsolete image-transform-original "29.1")) + (interactive nil image-dired-thumbnail-mode) + (let ((file (image-dired-original-file-name))) + (if file + (progn + (image-dired-display-image file) + (with-current-buffer image-dired-display-image-buffer + (image-transform-original))) + (error "No original file name at point")))) + +(defun image-dired-display-current-image-sized () + "Display current image in sized to fit window dimensions." + (declare (obsolete image-mode-fit-frame "29.1")) + (interactive nil image-dired-thumbnail-mode) + (let ((file (image-dired-original-file-name))) + (if file + (progn + (image-dired-display-image file)) + (error "No original file name at point")))) + +(defun image-dired-add-to-tag-file-list (tag file) + "Add relation between TAG and FILE." + (declare (obsolete nil "29.1")) + (let (curr) + (if image-dired-tag-file-list + (if (setq curr (assoc tag image-dired-tag-file-list)) + (if (not (member file curr)) + (setcdr curr (cons file (cdr curr)))) + (setcdr image-dired-tag-file-list + (cons (list tag file) (cdr image-dired-tag-file-list)))) + (setq image-dired-tag-file-list (list (list tag file)))))) + +(defun image-dired-display-thumb-properties () + "Display thumbnail properties in the echo area." + (declare (obsolete image-dired-update-header-line "29.1")) + (image-dired-update-header-line)) + +(defvar image-dired-slideshow-count 0 + "Keeping track on number of images in slideshow.") +(make-obsolete-variable 'image-dired-slideshow-count "no longer used." "29.1") + +(defvar image-dired-slideshow-times 0 + "Number of pictures to display in slideshow.") +(make-obsolete-variable 'image-dired-slideshow-times "no longer used." "29.1") + +(define-obsolete-function-alias 'image-dired-create-display-image-buffer + #'ignore "29.1") +(define-obsolete-function-alias 'image-dired-create-gallery-lists + #'image-dired--create-gallery-lists "29.1") +(define-obsolete-function-alias 'image-dired-add-to-file-comment-list + #'image-dired--add-to-file-comment-list "29.1") +(define-obsolete-function-alias 'image-dired-add-to-tag-file-lists + #'image-dired--add-to-tag-file-lists "29.1") +(define-obsolete-function-alias 'image-dired-hidden-p + #'image-dired--hidden-p "29.1") + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;; TEST-SECTION ;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -2733,23 +3072,6 @@ tags to their respective image file. Internal function used by ;; (setq dirsize (- dirsize (car (cdar files)))) ;; (setq files (cdr files))))) -;;;;;;;;;;;;;;;;;;;;;;, - -;; (defun dired-speedbar-buttons (dired-buffer) -;; (when (and (boundp 'image-dired-use-speedbar) -;; image-dired-use-speedbar) -;; (let ((filename (with-current-buffer dired-buffer -;; (dired-get-filename)))) -;; (when (and (not (string-equal filename (buffer-string))) -;; (string-match (image-file-name-regexp) filename)) -;; (erase-buffer) -;; (insert (propertize -;; filename -;; 'display -;; (image-dired-get-thumbnail-image filename))))))) - -;; (setq image-dired-use-speedbar t) - (provide 'image-dired) ;;; image-dired.el ends here diff --git a/lisp/image-file.el b/lisp/image-file.el index fbc9eaaf94e..6df43f737dd 100644 --- a/lisp/image-file.el +++ b/lisp/image-file.el @@ -37,7 +37,7 @@ ;;;###autoload (defcustom image-file-name-extensions - (purecopy '("png" "jpeg" "jpg" "gif" "tiff" "tif" "xbm" "xpm" "pbm" "pgm" "ppm" "pnm" "svg")) + (purecopy '("png" "jpeg" "jpg" "gif" "tiff" "tif" "xbm" "xpm" "pbm" "pgm" "ppm" "pnm" "svg" "webp")) "A list of image-file filename extensions. Filenames having one of these extensions are considered image files, in addition to those matching `image-file-name-regexps'. diff --git a/lisp/image-mode.el b/lisp/image-mode.el index 4a326cdc693..6ff7859c835 100644 --- a/lisp/image-mode.el +++ b/lisp/image-mode.el @@ -58,16 +58,25 @@ It is called with one argument, the initial WINPROPS.") "Non-nil to resize the image upon first display. Its value should be one of the following: - nil, meaning no resizing. - - t, meaning to fit the image to the window height and width. - - `fit-height', meaning to fit the image to the window height. - - `fit-width', meaning to fit the image to the window width. - - A number, which is a scale factor (the default size is 1)." + - t, meaning to scale the image down to fit in the window. + - `fit-window', meaning to fit the image to the window. + - A number, which is a scale factor (the default size is 1). + +Resizing will always preserve the aspect ratio of the image." :type '(choice (const :tag "No resizing" nil) - (other :tag "Fit height and width" t) - (const :tag "Fit height" fit-height) - (const :tag "Fit width" fit-width) + (const :tag "Fit to window" fit-window) + (other :tag "Scale down to fit window" t) (number :tag "Scale factor" 1)) - :version "27.1" + :version "29.1" + :group 'image) + +(defcustom image-auto-resize-max-scale-percent nil + "Max size (in percent) to scale up to when `image-auto-resize' is `fit-window'. +Can be either a number larger than 100, or nil, which means no +max size." + :type '(choice (const :tag "No max" nil) + natnum) + :version "29.1" :group 'image) (defcustom image-auto-resize-on-window-resize 1 @@ -82,12 +91,18 @@ resizing according to the value specified in `image-auto-resize'." (defvar-local image-transform-resize nil "The image resize operation. +Non-nil to resize the image upon first display. Its value should be one of the following: - nil, meaning no resizing. - - t, meaning to fit the image to the window height and width. + - t, meaning to scale the image down to fit in the window. + - `fit-window', meaning to fit the image to the window. + - A number, which is a scale factor (the default size is 1). + +There is also support for these values, obsolete since Emacs 29.1: - `fit-height', meaning to fit the image to the window height. - `fit-width', meaning to fit the image to the window width. - - A number, which is a scale factor (the default size is 1).") + +Resizing will always preserve the aspect ratio of the image.") (defvar-local image-transform-scale 1.0 "The scale factor of the image being displayed.") @@ -440,6 +455,15 @@ call." ;;; Image Mode setup +(defcustom image-text-based-formats '(svg xpm) + "List of image formats that use a plain text format. +For such formats, display a message that explains how to edit the +image as text, when opening such images in `image-mode'." + :type '(choice (const :tag "Disable completely" nil) + (repeat :tag "List of formats" sexp)) + :version "29.1" + :group 'image) + (defvar-local image-type nil "The image type for the current Image mode buffer.") @@ -455,8 +479,9 @@ call." ;; Transformation keys (define-key map "sf" 'image-mode-fit-frame) + (define-key map "sw" 'image-transform-fit-to-window) (define-key map "sh" 'image-transform-fit-to-height) - (define-key map "sw" 'image-transform-fit-to-width) + (define-key map "si" 'image-transform-fit-to-width) (define-key map "sb" 'image-transform-fit-both) (define-key map "ss" 'image-transform-set-scale) (define-key map "sr" 'image-transform-set-rotation) @@ -511,12 +536,10 @@ call." "--" ["Fit Frame to Image" image-mode-fit-frame :active t :help "Resize frame to match image"] - ["Fit Image to Window (Best Fit)" image-transform-fit-both - :help "Resize image to match the window height and width"] - ["Fit to Window Height" image-transform-fit-to-height - :help "Resize image to match the window height"] - ["Fit to Window Width" image-transform-fit-to-width - :help "Resize image to match the window width"] + ["Fit Image to Window" image-transform-fit-to-window + :help "Resize image to match the window height and width"] + ["Fit Image to Window (Scale down only)" image-transform-fit-both + :help "Scale image down to match the window height and width"] ["Zoom In" image-increase-size :help "Enlarge the image"] ["Zoom Out" image-decrease-size @@ -605,8 +628,9 @@ call." ;;;###autoload (defun image-mode () "Major mode for image files. -You can use \\<image-mode-map>\\[image-toggle-display] or \\<image-mode-map>\\[image-toggle-hex-display] -to toggle between display as an image and display as text or hex. +You can use \\<image-mode-map>\\[image-toggle-display] or \ +\\[image-toggle-hex-display] to toggle between display +as an image and display as text or hex. Key bindings: \\{image-mode-map}" @@ -678,12 +702,10 @@ Key bindings: (run-mode-hooks 'image-mode-hook) (let ((image (image-get-display-property)) - (msg1 (substitute-command-keys - "Type \\[image-toggle-display] or \\[image-toggle-hex-display] to view the image as ")) - animated) + msg animated) (cond ((null image) - (message "%s" (concat msg1 "an image."))) + (setq msg "an image")) ((setq animated (image-multi-frame-p image)) (setq image-multi-frame t mode-line-process @@ -701,10 +723,13 @@ Key bindings: keymap (down-mouse-1 . image-next-frame) (down-mouse-3 . image-previous-frame))))))) - (message "%s" - (concat msg1 "text. This image has multiple frames."))) + (setq msg "text. This image has multiple frames")) (t - (message "%s" (concat msg1 "text or hex.")))))) + (setq msg "text"))) + (when (memq (plist-get (cdr image) :type) image-text-based-formats) + (message (substitute-command-keys + "Type \\[image-toggle-display] to view the image as %s") + msg)))) ;;;###autoload (define-minor-mode image-minor-mode @@ -751,11 +776,11 @@ on these modes." (image-mode-to-text) ;; Turn on hexl-mode (hexl-mode) - (message "%s" (concat - (substitute-command-keys - "Type \\[image-toggle-hex-display] or \\[image-toggle-display] to view the image as ") - (if (image-get-display-property) - "hex" "an image or text") "."))) + (message (substitute-command-keys + "Type \\[image-toggle-hex-display] or \ +\\[image-toggle-display] to view the image as %s") + (if (image-get-display-property) + "hex" "an image or text"))) (defun image-mode-as-text () "Set a non-image mode as major mode in combination with image minor mode. @@ -771,11 +796,10 @@ See commands `image-mode' and `image-minor-mode' for more information on these modes." (interactive) (image-mode-to-text) - (message "%s" (concat - (substitute-command-keys - "Type \\[image-toggle-display] or \\[image-toggle-hex-display] to view the image as ") - (if (image-get-display-property) - "text" "an image or hex") "."))) + (message (substitute-command-keys + "Type \\[image-toggle-display] to view the image as %s") + (if (image-get-display-property) + "text" "an image"))) (defun image-toggle-display-text () "Show the image file as text. @@ -803,6 +827,21 @@ Remove text properties that display the image." (defvar tar-superior-buffer) (declare-function image-flush "image.c" (spec &optional frame)) +(defun image--scale-within-limits-p (image) + "Return t if `fit-window' will scale image within the customized limits. +The limits are given by the user option +`image-auto-resize-max-scale-percent'." + (or (not image-auto-resize-max-scale-percent) + (let ((scale (/ image-auto-resize-max-scale-percent 100)) + (mw (plist-get (cdr image) :max-width)) + (mh (plist-get (cdr image) :max-height)) + ;; Note: `image-size' looks up and thus caches the + ;; untransformed image. There's no easy way to + ;; prevent that. + (size (image-size image t))) + (or (<= mw (* (car size) scale)) + (<= mh (* (cdr size) scale)))))) + (defun image-toggle-display-image () "Show the image of the image file. Turn the image data into a real image, but only if the whole file @@ -837,7 +876,8 @@ was inserted." filename)) ;; If we have a `fit-width' or a `fit-height', don't limit ;; the size of the image to the window size. - (edges (when (eq image-transform-resize t) + (edges (when (or (eq image-transform-resize t) + (eq image-transform-resize 'fit-window)) (window-inside-pixel-edges (get-buffer-window)))) (max-width (when edges (- (nth 2 edges) (nth 0 edges)))) @@ -884,6 +924,14 @@ was inserted." ;; Type hint. :format (and filename data-p)))) + ;; Handle `fit-window'. + (when (and (eq image-transform-resize 'fit-window) + (image--scale-within-limits-p image)) + (setq image + (cons (car image) + (plist-put (cdr image) :width + (plist-get (cdr image) :max-width))))) + ;; Discard any stale image data before looking it up again. (image-flush image) (setq image (append image (image-transform-properties image))) @@ -1494,21 +1542,29 @@ return value is suitable for appending to an image spec." (defun image-transform-fit-to-height () "Fit the current image to the height of the current window." (interactive) + (declare (obsolete nil "29.1")) (setq image-transform-resize 'fit-height) (image-toggle-display-image)) (defun image-transform-fit-to-width () "Fit the current image to the width of the current window." + (declare (obsolete nil "29.1")) (interactive) (setq image-transform-resize 'fit-width) (image-toggle-display-image)) (defun image-transform-fit-both () - "Fit the current image both to the height and width of the current window." + "Scale the current image down to fit in the current window." (interactive) (setq image-transform-resize t) (image-toggle-display-image)) +(defun image-transform-fit-to-window () + "Fit the current image to the height and width of the current window." + (interactive) + (setq image-transform-resize 'fit-window) + (image-toggle-display-image)) + (defun image-transform-set-rotation (rotation) "Prompt for an angle ROTATION, and rotate the image by that amount. ROTATION should be in degrees." diff --git a/lisp/image.el b/lisp/image.el index 6e1dbbdf5cd..702985f41ff 100644 --- a/lisp/image.el +++ b/lisp/image.el @@ -27,6 +27,8 @@ (defgroup image () "Image support." + :prefix "image-" + :link '(info-link "(emacs) Image Mode") :group 'multimedia) (declare-function image-flush "image.c" (spec &optional frame)) @@ -48,6 +50,7 @@ static \\(unsigned \\)?char \\1_bits" . xbm) ("\\`\\(?:MM\0\\*\\|II\\*\0\\)" . tiff) ("\\`[\t\n\r ]*%!PS" . postscript) ("\\`\xff\xd8" . jpeg) ; used to be (image-jpeg-p . jpeg) + ("\\`RIFF....WEBPVP8" . webp) (,(let* ((incomment-re "\\(?:[^-]\\|-[^-]\\)") (comment-re (concat "\\(?:!--" incomment-re "*-->[ \t\r\n]*<\\)"))) (concat "\\(?:<\\?xml[ \t\r\n]+[^>]*>\\)?[ \t\r\n]*<" @@ -55,7 +58,7 @@ static \\(unsigned \\)?char \\1_bits" . xbm) "\\(?:!DOCTYPE[ \t\r\n]+[^>]*>[ \t\r\n]*<[ \t\r\n]*" comment-re "*\\)?" "[Ss][Vv][Gg]")) . svg) - ) + ("\\`....ftyp\\(heic\\|heix\\|hevc\\|heim\\|heis\\|hevm\\|hevs\\|mif1\\|msf1\\)" . heic)) "Alist of (REGEXP . IMAGE-TYPE) pairs used to auto-detect image types. When the first bytes of an image file match REGEXP, it is assumed to be of image type IMAGE-TYPE if IMAGE-TYPE is a symbol. If not a symbol, @@ -67,6 +70,7 @@ a non-nil value, TYPE is the image's type.") '(("\\.png\\'" . png) ("\\.gif\\'" . gif) ("\\.jpe?g\\'" . jpeg) + ("\\.webp\\'" . webp) ("\\.bmp\\'" . bmp) ("\\.xpm\\'" . xpm) ("\\.pbm\\'" . pbm) @@ -74,7 +78,7 @@ a non-nil value, TYPE is the image's type.") ("\\.ps\\'" . postscript) ("\\.tiff?\\'" . tiff) ("\\.svgz?\\'" . svg) - ) + ("\\.hei[cf]s?\\'" . heic)) "Alist of (REGEXP . IMAGE-TYPE) pairs used to identify image files. When the name of an image file match REGEXP, it is assumed to be of image type IMAGE-TYPE.") @@ -92,7 +96,9 @@ be of image type IMAGE-TYPE.") (jpeg . maybe) (tiff . maybe) (svg . maybe) - (postscript . nil)) + (webp . maybe) + (postscript . nil) + (heic . maybe)) "Alist of (IMAGE-TYPE . AUTODETECT) pairs used to auto-detect image files. \(See `image-type-auto-detected-p'). @@ -556,7 +562,12 @@ If VALUE is nil, PROPERTY is removed from IMAGE." (declare (gv-setter image--set-property)) (plist-get (cdr image) property)) -(defun image-compute-scaling-factor (scaling) +(defun image-compute-scaling-factor (&optional scaling) + "Compute the scaling factor based on SCALING. +If a number, use that. If it's `auto', compute the factor. +If nil, use the `image-scaling-factor' variable." + (unless scaling + (setq scaling image-scaling-factor)) (cond ((numberp scaling) scaling) ((eq scaling 'auto) @@ -600,7 +611,7 @@ means display it in the right marginal area." ;;;###autoload -(defun insert-image (image &optional string area slice) +(defun insert-image (image &optional string area slice inhibit-isearch) "Insert IMAGE into current buffer at point. IMAGE is displayed by inserting STRING into the current buffer with a `display' property whose value is the image. @@ -617,7 +628,11 @@ SLICE specifies slice of IMAGE to insert. SLICE nil or omitted means insert whole image. SLICE is a list (X Y WIDTH HEIGHT) specifying the X and Y positions and WIDTH and HEIGHT of image area to insert. A float value 0.0 - 1.0 means relative to the width or -height of the image; integer values are taken as pixel values." +height of the image; integer values are taken as pixel values. + +Normally `isearch' is able to search for STRING in the buffer +even if it's hidden behind a displayed image. If INHIBIT-ISEARCH +is non-nil, this is inhibited." ;; Use a space as least likely to cause trouble when it's a hidden ;; character in the buffer. (unless string (setq string " ")) @@ -641,6 +656,7 @@ height of the image; integer values are taken as pixel values." (list (cons 'slice slice) image) image) rear-nonsticky t + inhibit-isearch ,inhibit-isearch keymap ,image-map)))) @@ -791,7 +807,7 @@ Example: (defimage test-image ((:type xpm :file \"~/test1.xpm\") (:type xbm :file \"~/test1.xbm\")))" - (declare (doc-string 3)) + (declare (doc-string 3) (indent defun)) `(defvar ,symbol (find-image ',specs) ,doc)) @@ -823,15 +839,18 @@ in which case you might want to use `image-default-frame-delay'." (make-obsolete 'image-animated-p 'image-multi-frame-p "24.4") -;; "Destructively"? -(defun image-animate (image &optional index limit) +(defun image-animate (image &optional index limit position) "Start animating IMAGE. Animation occurs by destructively altering the IMAGE spec list. With optional INDEX, begin animating from that animation frame. LIMIT specifies how long to animate the image. If omitted or nil, play the animation until the end. If t, loop forever. If a -number, play until that number of seconds has elapsed." +number, play until that number of seconds has elapsed. + +If POSITION (which should be buffer position where the image is +displayed), stop the animation if the image is no longer +displayed." (let ((animation (image-multi-frame-p image)) timer) (when animation @@ -839,6 +858,9 @@ number, play until that number of seconds has elapsed." (cancel-timer timer)) (plist-put (cdr image) :animate-buffer (current-buffer)) (plist-put (cdr image) :animate-tardiness 0) + (when position + (plist-put (cdr image) :animate-position + (set-marker (make-marker) position (current-buffer)))) ;; Stash the data about the animation here so that we don't ;; trigger image recomputation unnecessarily later. (plist-put (cdr image) :animate-multi-frame-data animation) @@ -912,40 +934,54 @@ for the animation speed. A negative value means to animate in reverse." (plist-put (cdr image) :animate-tardiness (+ (* (plist-get (cdr image) :animate-tardiness) 0.9) (float-time (time-since target-time)))) - (when (and (buffer-live-p (plist-get (cdr image) :animate-buffer)) - ;; Cumulatively delayed two seconds more than expected. - (or (< (plist-get (cdr image) :animate-tardiness) 2) - (progn - (message "Stopping animation; animation possibly too big") - nil))) - (image-show-frame image n t) - (let* ((speed (image-animate-get-speed image)) - (time (current-time)) - (time-to-load-image (time-since time)) - (stated-delay-time - (/ (or (cdr (plist-get (cdr image) :animate-multi-frame-data)) - image-default-frame-delay) - (float (abs speed)))) - ;; Subtract off the time we took to load the image from the - ;; stated delay time. - (delay (max (float-time (time-subtract stated-delay-time - time-to-load-image)) - image-minimum-frame-delay)) - done) - (setq n (if (< speed 0) - (1- n) - (1+ n))) - (if limit - (cond ((>= n count) (setq n 0)) - ((< n 0) (setq n (1- count)))) - (and (or (>= n count) (< n 0)) (setq done t))) - (setq time-elapsed (+ delay time-elapsed)) - (if (numberp limit) - (setq done (>= time-elapsed limit))) - (unless done - (run-with-timer delay nil #'image-animate-timeout - image n count time-elapsed limit - (+ (float-time) delay)))))) + (let ((buffer (plist-get (cdr image) :animate-buffer)) + (position (plist-get (cdr image) :animate-position))) + (when (and (buffer-live-p buffer) + ;; If we have a :animate-position setting, the caller + ;; has requested that the animation be stopped if the + ;; image is no longer displayed in the buffer. + (or (null position) + (with-current-buffer buffer + (let ((disp (get-text-property position 'display))) + (and (consp disp) + (eq (car disp) 'image) + ;; We can't check `eq'-ness of the image + ;; itself, since that may change. + (eq position + (plist-get (cdr disp) :animate-position)))))) + ;; Cumulatively delayed two seconds more than expected. + (or (< (plist-get (cdr image) :animate-tardiness) 2) + (progn + (message "Stopping animation; animation possibly too big") + nil))) + (let* ((time (prog1 (current-time) + (image-show-frame image n t))) + (speed (image-animate-get-speed image)) + (time-to-load-image (time-since time)) + (stated-delay-time + (/ (or (cdr (plist-get (cdr image) :animate-multi-frame-data)) + image-default-frame-delay) + (float (abs speed)))) + ;; Subtract off the time we took to load the image from the + ;; stated delay time. + (delay (max (float-time (time-subtract stated-delay-time + time-to-load-image)) + image-minimum-frame-delay)) + done) + (setq n (if (< speed 0) + (1- n) + (1+ n))) + (if limit + (cond ((>= n count) (setq n 0)) + ((< n 0) (setq n (1- count)))) + (and (or (>= n count) (< n 0)) (setq done t))) + (setq time-elapsed (+ delay time-elapsed)) + (if (numberp limit) + (setq done (>= time-elapsed limit))) + (unless done + (run-with-timer delay nil #'image-animate-timeout + image n count time-elapsed limit + (+ (float-time) delay))))))) (defvar imagemagick-types-inhibit) @@ -1137,6 +1173,13 @@ default is 20%." (error "No image under point")) image)) +;;;###autoload +(defun image-at-point-p () + "Return non-nil if there is an image at point." + (condition-case nil + (prog1 t (image--get-image)) + (error nil))) + (defun image--get-imagemagick-and-warn (&optional position) (declare-function image-transforms-p "image.c" (&optional frame)) (unless (or (fboundp 'imagemagick-types) (image-transforms-p)) diff --git a/lisp/image/exif.el b/lisp/image/exif.el index c2cf2346408..372e2d25553 100644 --- a/lisp/image/exif.el +++ b/lisp/image/exif.el @@ -58,6 +58,9 @@ ;; (:tag 306 :tag-name date-time :format 2 :format-type ascii ;; :value "2019:09:21 16:22:13") ;; ...) +;; +;; (exif-field 'date-time (exif-parse-file "test.jpg")) => +;; "2022:09:14 18:46:19" ;;; Code: @@ -65,6 +68,7 @@ (defvar exif-tag-alist '((11 processing-software) + (270 description) (271 make) (272 model) (274 orientation) @@ -73,7 +77,8 @@ (296 resolution-unit) (305 software) (306 date-time) - (315 artist)) + (315 artist) + (33432 copyright)) "Alist of tag values and their names.") (defconst exif--orientation @@ -122,13 +127,20 @@ If the data is invalid, an `exif-error' is signaled." (when-let ((app1 (cdr (assq #xffe1 (exif--parse-jpeg))))) (exif--parse-exif-chunk app1)))))) +(defun exif-field (field data) + "Return raw FIELD from EXIF. +If FIELD is not present in the data, return nil. +FIELD is a symbol in the cdr of `exif-tag-alist'. +DATA is the result of calling `exif-parse-file'." + (plist-get (seq-find (lambda (e) + (eq field (plist-get e :tag-name))) + data) + :value)) + (defun exif-orientation (exif) "Return the orientation (in degrees) in EXIF. If the orientation isn't present in the data, return nil." - (let ((code (plist-get (cl-find 'orientation exif - :key (lambda (e) - (plist-get e :tag-name))) - :value))) + (let ((code (exif-field 'orientation exif))) (cadr (assq code exif--orientation)))) (defun exif--parse-jpeg () diff --git a/lisp/image/gravatar.el b/lisp/image/gravatar.el index f6f056a2baf..87726a9b8c8 100644 --- a/lisp/image/gravatar.el +++ b/lisp/image/gravatar.el @@ -277,7 +277,7 @@ where GRAVATAR is either an image descriptor, or the symbol ;; Store the image in the cache. (when image (setf (gethash mail-address gravatar--cache) - (cons (time-convert (current-time) 'integer) + (cons (time-convert nil 'integer) image))) (prog1 (apply callback (if data image 'error) cbargs) @@ -286,7 +286,7 @@ where GRAVATAR is either an image descriptor, or the symbol (defun gravatar--prune-cache () (let ((expired nil) - (time (- (time-convert (current-time) 'integer) + (time (- (time-convert nil 'integer) ;; Twelve hours. (* 12 60 60)))) (maphash (lambda (key val) 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-look.el b/lisp/info-look.el index cc6a806f56f..48120359193 100644 --- a/lisp/info-look.el +++ b/lisp/info-look.el @@ -43,6 +43,7 @@ (require 'info) (eval-when-compile (require 'subr-x)) +(eval-when-compile (require 'cl-lib)) (defgroup info-lookup nil "Major mode sensitive help agent." @@ -123,6 +124,14 @@ OTHER-MODES is a list of cross references to other help modes.") (defsubst info-lookup->mode-value (topic mode) (assoc mode (info-lookup->topic-value topic))) +(defun info-lookup--expand-info (info) + ;; We have a dynamic doc-spec function. + (when (and (null (nth 3 info)) + (nth 6 info)) + (setf (nth 3 info) (funcall (nth 6 info)) + (nth 6 info) nil)) + info) + (defsubst info-lookup->regexp (topic mode) (nth 1 (info-lookup->mode-value topic mode))) @@ -145,7 +154,11 @@ Function arguments are specified as keyword/argument pairs: (KEYWORD . ARGUMENT) KEYWORD is either `:topic', `:mode', `:regexp', `:ignore-case', - `:doc-spec', `:parse-rule', or `:other-modes'. + `:doc-spec', `:parse-rule', `:other-modes' or `:doc-spec-function'. + `:doc-spec-function' is used to compute a `:doc-spec', but instead of + doing so at load time, this is done when the user asks for info on + the mode in question. + ARGUMENT has a value as explained in the documentation of the variable `info-lookup-alist'. @@ -161,7 +174,8 @@ for more details." (defun info-lookup-add-help* (maybe &rest arg) (let (topic mode regexp ignore-case doc-spec - parse-rule other-modes keyword value) + parse-rule other-modes keyword value + doc-spec-function) (setq topic 'symbol mode major-mode regexp "\\w+") @@ -184,6 +198,8 @@ for more details." (setq ignore-case value)) ((eq keyword :doc-spec) (setq doc-spec value)) + ((eq keyword :doc-spec-function) + (setq doc-spec-function value)) ((eq keyword :parse-rule) (setq parse-rule value)) ((eq keyword :other-modes) @@ -191,7 +207,8 @@ for more details." (t (error "Unknown keyword \"%S\"" keyword)))) (or (and maybe (info-lookup->mode-value topic mode)) - (let* ((data (list regexp ignore-case doc-spec parse-rule other-modes)) + (let* ((data (list regexp ignore-case doc-spec parse-rule other-modes + doc-spec-function)) (topic-cell (or (assoc topic info-lookup-alist) (car (setq info-lookup-alist (cons (cons topic nil) @@ -341,11 +358,22 @@ If optional argument QUERY is non-nil, query for the help mode." (error "No %s help available for `%s'" topic mode)) (setq info-lookup-mode mode))) +(defun info-lookup--item-to-mode (item mode) + (let ((spec (cons mode (car (split-string (if (stringp item) + item + (symbol-name item)) + "-"))))) + (if (assoc spec (cdr (assq 'symbol info-lookup-alist))) + spec + mode))) + (defun info-lookup (topic item mode) "Display the documentation of a help item." (or mode (setq mode (info-lookup-select-mode))) - (or (info-lookup->mode-value topic mode) - (error "No %s help available for `%s'" topic mode)) + (setq mode (info-lookup--item-to-mode item mode)) + (if-let ((info (info-lookup->mode-value topic mode))) + (info-lookup--expand-info info) + (error "No %s help available for `%s'" topic mode)) (let* ((completions (info-lookup->completions topic mode)) (ignore-case (info-lookup->ignore-case topic mode)) (entry (or (assoc (if ignore-case (downcase item) item) completions) @@ -724,6 +752,8 @@ Return nil if there is nothing appropriate in the buffer near point." (defun info-complete (topic mode) "Try to complete a help item." (barf-if-buffer-read-only) + (when-let ((info (info-lookup->mode-value topic mode))) + (info-lookup--expand-info info)) (let ((data (info-lookup-completions-at-point topic mode))) (if (null data) (error "No %s completion available for `%s' at point" topic mode) @@ -904,9 +934,16 @@ Return nil if there is nothing appropriate in the buffer near point." (info-lookup-maybe-add-help :mode 'python-mode - :doc-spec `((,(if (Info-find-file "python3.9" t) - "(python3.9)Index" - "(python)Index")))) + ;; Debian includes Python info files, but they're version-named + ;; instead of having a symlink. + :doc-spec-function (lambda () + (list + (list + (cl-loop for version from 20 downto 7 + for name = (format "python3.%d" version) + if (Info-find-file name t) + return (format "(%s)Index" name) + finally return "(python)Index"))))) (info-lookup-maybe-add-help :mode 'cperl-mode @@ -944,6 +981,67 @@ Return nil if there is nothing appropriate in the buffer near point." ("(cl)Function Index" nil "^ -+ .*: " "\\( \\|$\\)") ("(cl)Variable Index" nil "^ -+ .*: " "\\( \\|$\\)"))) +(mapc + (lambda (elem) + (let* ((prefix (car elem))) + (info-lookup-add-help + :mode (cons 'emacs-lisp-mode prefix) + :regexp (concat "\\b" prefix "-[^][()`'‘’,\" \t\n]+") + :doc-spec (cl-loop for node in (cdr elem) + collect + (list (if (string-match-p "^(" node) + node + (format "(%s)%s" prefix node)) + nil "^ -+ .*: " "\\( \\|$\\)"))))) + ;; Below we have a list of prefixes (used to match on symbols in + ;; `emacs-lisp-mode') and the nodes where the function/variable + ;; indices live. If the prefix is different than the name of the + ;; manual, then the full "(manual)Node" name has to be used. + '(("auth" "Function Index" "Variable Index") + ("autotype" "Command Index" "Variable Index") + ("calc" "Lisp Function Index" "Variable Index") + ;;("cc-mode" "Variable Index" "Command and Function Index") + ("dbus" "Index") + ("ediff" "Index") + ("eieio" "Function Index") + ("gnutls" "(emacs-gnutls)Variable Index" "(emacs-gnutls)Function Index") + ("mm" "(emacs-mime)Index") + ("epa" "Variable Index" "Function Index") + ("ert" "Index") + ("eshell" "Function and Variable Index") + ("eudc" "Index") + ("eww" "Variable Index" "Lisp Function Index") + ("flymake" "Index") + ("forms" "Index") + ("gnus" "Index") + ("htmlfontify" "Functions" "Variables & Customization") + ("idlwave" "Index") + ("ido" "Variable Index" "Function Index") + ("info" "Index") + ("mairix" "(mairix-el)Variable Index" "(mairix-el)Function Index") + ("message" "Index") + ("mh" "(mh-e)Option Index" "(mh-e)Command Index") + ("newsticker" "Index") + ("octave" "(octave-mode)Variable Index" "(octave-mode)Lisp Function Index") + ("org" "Variable Index" "Command and Function Index") + ("pgg" "Variable Index" "Function Index") + ("rcirc" "Variable Index" "Index") + ("reftex" "Index") + ("sasl" "Variable Index" "Function Index") + ("sc" "Variable Index") + ("semantic" "Index") + ("ses" "Index") + ("sieve" "Index") + ("smtpmail" "Function and Variable Index") + ("srecode" "Index") + ("tramp" "Variable Index" "Function Index") + ("url" "Variable Index" "Function Index") + ("vhdl" "(vhdl-mode)Variable Index" "(vhdl-mode)Command Index") + ("viper" "Variable Index" "Function Index") + ("widget" "Index") + ("wisent" "Index") + ("woman" "Variable Index" "Command Index"))) + ;; docstrings talk about elisp, so have apropos-mode follow emacs-lisp-mode (info-lookup-maybe-add-help :mode 'apropos-mode diff --git a/lisp/info.el b/lisp/info.el index 8c08eaec3c8..559460e8d2c 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -115,7 +115,9 @@ The Lisp code is executed when the node is selected.") (defface info-menu-star '((((class color)) :foreground "red1") (t :underline t)) - "Face for every third `*' in an Info menu.") + "Face used to emphasize `*' in an Info menu. +The face is assigned to the third, sixth, and ninth `*' for easier +orientation. See `Info-nth-menu-item'.") (defface info-xref '((t :inherit link)) @@ -1792,7 +1794,46 @@ of NODENAME; if none is found it then tries a case-insensitive match (if trim (setq nodename (substring nodename 0 trim)))) (if transient-mark-mode (deactivate-mark)) (Info-find-node (if (equal filename "") nil filename) - (if (equal nodename "") "Top" nodename) nil strict-case))) + (if (equal nodename "") "Top" nodename) nil strict-case))) + +(defun Info-goto-node-web (node) + "Use `browse-url' to go to the gnu.org web server's version of NODE. +By default, go to the current Info node." + (interactive (list (Info-read-node-name + "Go to node (default current page): " Info-current-node)) + Info-mode) + (browse-url-button-open-url + (Info-url-for-node (format "(%s)%s" (file-name-sans-extension + (file-name-nondirectory + Info-current-file)) + node)))) + +(defun Info-url-for-node (node) + "Return a URL for NODE, a node in the GNU Emacs or Elisp manual. +NODE should be a string on the form \"(manual)Node\". Only emacs +and elisp manuals are supported." + (unless (string-match "\\`(\\(.+\\))\\(.+\\)\\'" node) + (error "Invalid node name %s" node)) + (let ((manual (match-string 1 node)) + (node (match-string 2 node))) + (unless (member manual '("emacs" "elisp")) + (error "Only emacs/elisp manuals are supported")) + ;; Encode a bunch of characters the way that makeinfo does. + (setq node + (mapconcat (lambda (ch) + (if (or (< ch 32) ; ^@^A-^Z^[^\^]^^^- + (<= 33 ch 47) ; !"#$%&'()*+,-./ + (<= 58 ch 64) ; :;<=>?@ + (<= 91 ch 96) ; [\]_` + (<= 123 ch 127)) ; {|}~ DEL + (format "_00%x" ch) + (char-to-string ch))) + node + "")) + (concat "https://www.gnu.org/software/emacs/manual/html_node/" + manual "/" + (url-hexify-string (string-replace " " "-" node)) + ".html"))) (defvar Info-read-node-completion-table) @@ -1877,7 +1918,7 @@ See `completing-read' for a description of arguments and usage." code Info-read-node-completion-table string predicate)))) ;; Arrange to highlight the proper letters in the completion list buffer. -(defun Info-read-node-name (prompt) +(defun Info-read-node-name (prompt &optional default) "Read an Info node name with completion, prompting with PROMPT. A node name can have the form \"NODENAME\", referring to a node in the current Info file, or \"(FILENAME)NODENAME\", referring to @@ -1885,7 +1926,8 @@ a node in FILENAME. \"(FILENAME)\" is a short format to go to the Top node in FILENAME." (let* ((completion-ignore-case t) (Info-read-node-completion-table (Info-build-node-completions)) - (nodename (completing-read prompt #'Info-read-node-name-1 nil t))) + (nodename (completing-read prompt #'Info-read-node-name-1 nil t nil + 'Info-minibuf-history default))) (if (equal nodename "") (Info-read-node-name prompt) nodename))) @@ -2604,12 +2646,9 @@ new buffer." (if (eq (length completions) 1) (setq default (car completions))) (if completions - (let ((input (completing-read (if default - (concat - "Follow reference named (default " - default "): ") - "Follow reference named: ") - completions nil t))) + (let ((input (completing-read (format-prompt "Follow reference named" + default) + completions nil t))) (list (if (equal input "") default input) current-prefix-arg)) @@ -4049,6 +4088,7 @@ If FORK is non-nil, it is passed to `Info-goto-node'." (define-key map "e" 'end-of-buffer) (define-key map "f" 'Info-follow-reference) (define-key map "g" 'Info-goto-node) + (define-key map "G" 'Info-goto-node-web) (define-key map "h" 'Info-help) ;; This is for compatibility with standalone info (>~ version 5.2). ;; Though for some time, standalone info had H and h reversed. @@ -4858,9 +4898,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/ccl.el b/lisp/international/ccl.el index 629cd4c2879..883b0b60fc9 100644 --- a/lisp/international/ccl.el +++ b/lisp/international/ccl.el @@ -1553,7 +1553,7 @@ MAP := MAP-IDs := MAP-ID ... MAP-SET := MAP-IDs | (MAP-IDs) MAP-SET MAP-ID := integer" - (declare (doc-string 3)) + (declare (doc-string 3) (indent defun)) `(let ((prog ,(unwind-protect (progn ;; To make ,(charset-id CHARSET) works well. diff --git a/lisp/international/characters.el b/lisp/international/characters.el index 5aefda23283..a2156ee01aa 100644 --- a/lisp/international/characters.el +++ b/lisp/international/characters.el @@ -1493,6 +1493,9 @@ Setup `char-width-table' appropriate for non-CJK language environment." (aset char-acronym-table #x202D "LRO") ; LEFT-TO-RIGHT OVERRIDE (aset char-acronym-table #x202E "RLO") ; RIGHT-TO-LEFT OVERRIDE (aset char-acronym-table #x2060 "WJ") ; WORD JOINER +(aset char-acronym-table #x2066 "LRI") ; LEFT-TO-RIGHT ISOLATE +(aset char-acronym-table #x2067 "RLI") ; RIGHT-TO-LEFT ISOLATE +(aset char-acronym-table #x2069 "PDI") ; POP DIRECTIONAL ISOLATE (aset char-acronym-table #x206A "ISS") ; INHIBIT SYMMETRIC SWAPPING (aset char-acronym-table #x206B "ASS") ; ACTIVATE SYMMETRIC SWAPPING (aset char-acronym-table #x206C "IAFS") ; INHIBIT ARABIC FORM SHAPING @@ -1517,18 +1520,32 @@ Setup `char-width-table' appropriate for non-CJK language environment." (aset char-acronym-table (+ #xE0021 i) (format " %c TAG" (+ 33 i)))) (aset char-acronym-table #xE007F "->|TAG") ; CANCEL TAG +;; We can't use the \N{name} things here, because this file is used +;; too early in the build process. +(defvar glyphless--bidi-control-characters + '(#x202a ; ?\N{left-to-right embedding} + #x202b ; ?\N{right-to-left embedding} + #x202d ; ?\N{left-to-right override} + #x202e ; ?\N{right-to-left override} + #x2066 ; ?\N{left-to-right isolate} + #x2067 ; ?\N{right-to-left isolate} + #x2068 ; ?\N{first strong isolate} + #x202c ; ?\N{pop directional formatting} + #x2069)) ; ?\N{pop directional isolate}) + (defun update-glyphless-char-display (&optional variable value) "Make the setting of `glyphless-char-display-control' take effect. This function updates the char-table `glyphless-char-display', and is intended to be used in the `:set' attribute of the option `glyphless-char-display'." - (when value + (when variable (set-default variable value)) (dolist (elt value) (let ((target (car elt)) (method (cdr elt))) - (or (memq method '(zero-width thin-space empty-box acronym hex-code)) - (error "Invalid glyphless character display method: %s" method)) + (unless (memq method '( zero-width thin-space empty-box + acronym hex-code bidi-control)) + (error "Invalid glyphless character display method: %s" method)) (cond ((eq target 'c0-control) (glyphless-set-char-table-range glyphless-char-display #x00 #x1F method) @@ -1543,24 +1560,29 @@ option `glyphless-char-display'." ((eq target 'variation-selectors) (glyphless-set-char-table-range glyphless-char-display #xFE00 #xFE0F method)) - ((eq target 'format-control) + ((or (eq target 'format-control) + (eq target 'bidi-control)) (when unicode-category-table (map-char-table (lambda (char category) - (if (eq category 'Cf) - (let ((this-method method) - from to) - (if (consp char) - (setq from (car char) to (cdr char)) - (setq from char to char)) - (while (<= from to) - (when (/= from #xAD) - (if (eq method 'acronym) - (setq this-method - (aref char-acronym-table from))) + (when (eq category 'Cf) + (let ((this-method method) + from to) + (if (consp char) + (setq from (car char) to (cdr char)) + (setq from char to char)) + (while (<= from to) + (when (/= from #xAD) + (when (eq method 'acronym) + (setq this-method + (or (aref char-acronym-table from) + "UNK"))) + (when (or (eq target 'format-control) + (memq from + glyphless--bidi-control-characters)) (set-char-table-range glyphless-char-display - from this-method)) - (setq from (1+ from)))))) + from this-method))) + (setq from (1+ from)))))) unicode-category-table))) ((eq target 'no-font) (set-char-table-extra-slot glyphless-char-display 0 method)) @@ -1576,6 +1598,19 @@ option `glyphless-char-display'." (set-char-table-range chartable (cons from to) method))) ;;; Control of displaying glyphless characters. +(define-widget 'glyphless-char-display-method 'lazy + "Display method for glyphless characters." + :group 'mule + :format "%v" + :value 'thin-space + :type + '(choice + (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))) + (defcustom glyphless-char-display-control '((format-control . thin-space) (variation-selectors . thin-space) @@ -1594,12 +1629,17 @@ 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'. + `bidi-control': A subset of `format-control', but only characters + that are relevant for bidirectional formatting control, + like U+2069 (PDI) and U+202B (RLE). + `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. @@ -1617,36 +1657,12 @@ function (`update-glyphless-char-display'), which updates :version "28.1" :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) - (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) - (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) - (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) - (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) - (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)))) + :options '((c0-control glyphless-char-display-method) + (c1-control glyphless-char-display-method) + (format-control glyphless-char-display-method) + (bidi-control glyphless-char-display-method) + (variation-selectors glyphless-char-display-method) + (no-font (glyphless-char-display-method :value hex-code))) :set 'update-glyphless-char-display :group 'display) diff --git a/lisp/international/emoji.el b/lisp/international/emoji.el new file mode 100644 index 00000000000..b78e122aa19 --- /dev/null +++ b/lisp/international/emoji.el @@ -0,0 +1,688 @@ +;;; emoji.el --- Inserting emojis -*- lexical-binding:t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; Author: Lars Ingebrigtsen <larsi@gnus.org> +;; Keywords: fun + +;; Package-Requires: ((emacs "28.0") (transient "0.3.7")) +;; Package-Version: 0.1 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'cl-lib) +(require 'cl-extra) +(require 'transient) +(require 'multisession) + +(defgroup emoji nil + "Inserting Emojis." + :version "29.1" + :group 'play) + +(defface emoji-list-header + '((default :weight bold :inherit variable-pitch)) + "Face for emoji list headers." + :version "29.1") + +(defface emoji + '((t :height 2.0)) + "Face used when displaying an emoji." + :version "29.1") + +(defface emoji-with-derivations + '((((background dark)) + (:background "#202020" :inherit emoji)) + (((background light)) + (:background "#e0e0e0" :inherit emoji))) + "Face for emojis that have derivations." + :version "29.1") + +(defvar emoji--labels nil) +(defvar emoji--all-bases nil) +(defvar emoji--derived nil) +(defvar emoji--names (make-hash-table :test #'equal)) +(defvar emoji--done-derived nil) +(define-multisession-variable emoji--recent (list "😀" "😖")) +(defvar emoji--insert-buffer) + +;;;###autoload +(defun emoji-insert (&optional text) + "Choose and insert an emoji glyph. +If TEXT (interactively, the prefix argument), choose the emoji +by typing its Unicode Standard name (with completion), instead +of selecting from emoji display." + (interactive "*P") + (emoji--init) + (if text + (emoji--choose-emoji) + (unless (fboundp 'emoji--command-Emoji) + (emoji--define-transient)) + (funcall (intern "emoji--command-Emoji")))) + +;;;###autoload +(defun emoji-recent () + "Choose and insert one of the recently-used emoji glyphs." + (interactive "*") + (emoji--init) + (unless (fboundp 'emoji--command-Emoji) + (emoji--define-transient)) + (funcall (emoji--define-transient + (cons "Recent" (multisession-value emoji--recent)) t))) + +;;;###autoload +(defun emoji-search () + "Choose and insert an emoji glyph by typing its Unicode name. +This command prompts for an emoji name, with completion, and inserts it. +It recognizes the Unicode Standard names of emoji." + (interactive "*") + (emoji--init) + (emoji--choose-emoji)) + +;;;###autoload +(defun emoji-list () + "List emojis and insert the one that's selected. +Select the emoji by typing \\<emoji-list-mode-map>\\[emoji-list-select] on its picture. +The glyph will be inserted into the buffer that was current +when the command was invoked." + (interactive "*") + (let ((buf (current-buffer))) + (emoji--init) + (switch-to-buffer (get-buffer-create "*Emoji*")) + ;; Don't regenerate the buffer if it already exists -- this will + ;; leave point where it was the last time it was used. + (when (zerop (buffer-size)) + (let ((inhibit-read-only t)) + (emoji-list-mode) + (setq-local emoji--insert-buffer buf) + (emoji--list-generate nil (cons nil emoji--labels)) + (goto-char (point-min)))))) + +;;;###autoload +(defun emoji-describe (glyph &optional interactive) + "Display the name of the grapheme cluster composed from GLYPH. +GLYPH should be a string of one or more characters which together +produce an emoji. Interactively, GLYPH is the emoji at point (it +could also be any character, not just emoji). + +If called from Lisp, return the name as a string; return nil if +the name is not known." + (interactive + (list (if (eobp) + (error "No glyph under point") + (let ((comp (find-composition (point) (1+ (point))))) + (if comp + (buffer-substring-no-properties (car comp) (cadr comp)) + (buffer-substring-no-properties (point) (1+ (point)))))) + t)) + (require 'emoji-labels) + (if (not interactive) + ;; Don't return a name for non-compositions when called + ;; non-interactively. + (gethash glyph emoji--names) + ;; Give a name for (pretty much) any glyph, including non-emojis. + (let ((name (emoji--name glyph))) + (if (not name) + (message "No known name for \"%s\"" glyph) + (message "The name of \"%s\" is \"%s\"" glyph name))))) + +(defun emoji--list-generate (name alist) + (let ((width (/ (window-width) 5)) + (mname (pop alist))) + (if (consp (car alist)) + ;; Recurse. + (mapcar (lambda (elem) + (emoji--list-generate (if name + (concat name " > " mname) + mname) + elem)) + alist) + ;; Output this block of emojis. + (insert (propertize + (if (zerop (length name)) + mname + (concat name " > " mname)) + 'face 'emoji-list-header) + "\n\n") + (cl-loop for i from 0 + for glyph in alist + do + (when (and (cl-plusp i) + (zerop (mod i width))) + (insert "\n")) + (insert + (propertize + (emoji--fontify-glyph glyph) + 'emoji-glyph glyph + 'help-echo (emoji--name glyph)))) + (insert "\n\n")))) + +(defun emoji--fontify-glyph (glyph &optional inhibit-derived) + (propertize glyph 'face + (if (and (not inhibit-derived) + (or (null emoji--done-derived) + (not (gethash glyph emoji--done-derived))) + (gethash glyph emoji--derived)) + ;; If this emoji has derivations, use a special face + ;; to tell the user. + 'emoji-with-derivations + ;; Normal emoji. + 'emoji))) + +(defun emoji--name (glyph) + (or (gethash glyph emoji--names) + (get-char-code-property (aref glyph 0) 'name))) + +(defvar-keymap emoji-list-mode-map + "RET" #'emoji-list-select + "<mouse-2>" #'emoji-list-select + "h" #'emoji-list-help + "<follow-link>" 'mouse-face) + +(define-derived-mode emoji-list-mode special-mode "Emoji" + "Mode to display emojis." + :interactive nil + (setq-local truncate-lines t)) + +(defun emoji-list-select (event) + "Select the emoji under point." + (interactive (list last-nonmenu-event) emoji-list-mode) + (mouse-set-point event) + (let ((glyph (get-text-property (point) 'emoji-glyph))) + (unless glyph + (error "No emoji under point")) + (let ((derived (gethash glyph emoji--derived)) + (end-func + (lambda () + (let ((buf emoji--insert-buffer)) + (quit-window) + (if (buffer-live-p buf) + (switch-to-buffer buf) + (error "Buffer disappeared")))))) + (if (not derived) + ;; Glyph without derivations. + (progn + (emoji--add-recent glyph) + (funcall end-func) + (insert glyph)) + ;; Pop up a transient to choose between derivations. + (let ((emoji--done-derived (make-hash-table :test #'equal))) + (setf (gethash glyph emoji--done-derived) t) + (funcall + (emoji--define-transient (cons "Choose Emoji" (cons glyph derived)) + nil end-func))))))) + +(defun emoji-list-help () + "Display the name of the emoji at point." + (interactive nil emoji-list-mode) + (let ((glyph (get-text-property (point) 'emoji-glyph))) + (unless glyph + (error "No emoji here")) + (let ((name (emoji--name glyph))) + (if (not name) + (error "Emoji name is unknown") + (message "%s" name))))) + +(defun emoji--init (&optional force inhibit-adjust) + (when (or (not emoji--labels) + force) + (unless force + (ignore-errors (require 'emoji-labels))) + ;; The require should define the variable, but in case the .el + ;; file doesn't exist (yet), parse the file now. + (when (or force + (not emoji--labels)) + (setq emoji--derived (make-hash-table :test #'equal)) + (emoji--parse-emoji-test))) + (when (and (not inhibit-adjust) + (not emoji--all-bases)) + (setq emoji--all-bases (make-hash-table :test #'equal)) + (emoji--adjust-displayable (cons "Emoji" emoji--labels)))) + +(defvar emoji--font nil) + +(defun emoji--adjust-displayable (alist) + "Remove glyphs we don't have fonts for." + (let ((emoji--font nil)) + (emoji--adjust-displayable-1 alist))) + +(defun emoji--adjust-displayable-1 (alist) + (if (consp (caddr alist)) + (dolist (child (cdr alist)) + (emoji--adjust-displayable-1 child)) + (while (cdr alist) + (let ((glyph (cadr alist))) + ;; Store all the emojis for later retrieval by + ;; the search feature. + (when-let ((name (emoji--name glyph))) + (setf (gethash (downcase name) emoji--all-bases) glyph)) + (if (display-graphic-p) + ;; Remove glyphs we don't have in graphical displays. + (if (let ((char (elt glyph 0))) + (if emoji--font + (font-has-char-p emoji--font char) + (when-let ((font (car (internal-char-font nil char)))) + (setq emoji--font font)))) + (setq alist (cdr alist)) + ;; Remove the element. + (setcdr alist (cddr alist))) + ;; We don't have font info on non-graphical displays. + (if (let ((char (elt glyph 0))) + ;; FIXME. Some grapheme clusters display more or less + ;; correctly in the terminal, but we don't really know + ;; which ones. None of these display totally + ;; correctly, though, so should they be filtered out? + (char-displayable-p char)) + (setq alist (cdr alist)) + ;; Remove the element. + (setcdr alist (cddr alist)))))))) + +(defun emoji--parse-emoji-test () + (setq emoji--labels nil) + (with-temp-buffer + (insert-file-contents (expand-file-name "../admin/unidata/emoji-test.txt" + data-directory)) + (unless (re-search-forward "^# +group:" nil t) + (error "Can't find start of data")) + (beginning-of-line) + (setq emoji--names (make-hash-table :test #'equal)) + (let ((derivations (make-hash-table :test #'equal)) + (case-fold-search t) + (glyphs nil) + group subgroup) + (while (not (eobp)) + (cond + ((looking-at "# +group: \\(.*\\)") + (setq group (match-string 1) + subgroup nil)) + ((looking-at "# +subgroup: \\(.*\\)") + (setq subgroup (match-string 1))) + ((looking-at + "\\([[:xdigit:] \t]+\\); *\\([^ \t]+\\)[ \t]+#.*?E[.0-9]+ +\\(.*\\)") + (let* ((codes (match-string 1)) + (qualification (match-string 2)) + (name (match-string 3)) + (glyph (mapconcat + (lambda (code) + (string (string-to-number code 16))) + (split-string codes)))) + (push (list name qualification group subgroup glyph) glyphs)))) + (forward-line 1)) + ;; We sort the data so that the "person foo" variant comes + ;; first, so that that becomes the key. + (setq glyphs + (sort (nreverse glyphs) + (lambda (g1 g2) + (and (equal (nth 2 g1) (nth 2 g2)) + (equal (nth 3 g1) (nth 3 g2)) + (< (emoji--score (car g1)) + (emoji--score (car g2))))))) + ;; Get the derivations. + (cl-loop for (name qualification group subgroup glyph) in glyphs + for base = (emoji--base-name name derivations) + do + ;; Special-case flags. + (when (equal base "flag") + (setq base name)) + ;; Register all glyphs to that we can look up their names + ;; later. + (setf (gethash glyph emoji--names) name) + ;; For the interface, we only care about the fully qualified + ;; emojis. + (when (equal qualification "fully-qualified") + (when (equal base name) + (emoji--add-to-group group subgroup glyph)) + ;; Create mapping from base glyph name to name of + ;; derived glyphs. + (setf (gethash base derivations) + (nconc (gethash base derivations) (list glyph))))) + ;; Finally create the mapping from the base glyphs to derived ones. + (setq emoji--derived (make-hash-table :test #'equal)) + (maphash (lambda (_k v) + (setf (gethash (car v) emoji--derived) + (cdr v))) + derivations)))) + +(defun emoji--score (string) + (if (string-match-p "person\\|people" + (replace-regexp-in-string ":.*" "" string)) + 0 + 1)) + +(defun emoji--add-to-group (group subgroup glyph) + ;; "People & Body" is very large; split it up. + (cond + ((equal group "People & Body") + (if (or (string-match "\\`person" subgroup) + (equal subgroup "family")) + (emoji--add-glyph glyph "People" + (if (equal subgroup "family") + (list subgroup) + ;; Avoid "Person person". + (cdr (emoji--split-subgroup subgroup)))) + (emoji--add-glyph glyph "Body" (emoji--split-subgroup subgroup)))) + ;; "Smileys & Emotion" also seems sub-optimal. + ((equal group "Smileys & Emotion") + (if (equal subgroup "emotion") + (emoji--add-glyph glyph "Emotion" nil) + (let ((subs (emoji--split-subgroup subgroup))) + ;; Remove one level of menus in the face case. + (when (equal (car subs) "face") + (pop subs)) + (emoji--add-glyph glyph "Smileys" subs)))) + ;; Don't modify the rest. + (t + (emoji--add-glyph glyph group (emoji--split-subgroup subgroup))))) + +(defun emoji--generate-file (&optional file) + "Generate an .el file with emoji mapping data and write it to FILE." + ;; Running from Makefile. + (unless file + (setq file (pop command-line-args-left))) + (emoji--init t t) + ;; Weed out the elements that are empty. + (let ((glyphs nil)) + (maphash (lambda (k v) + (unless v + (push k glyphs))) + emoji--derived) + (dolist (glyph glyphs) + (remhash glyph emoji--derived))) + (with-temp-buffer + (insert ";; Generated file -- do not edit. -*- lexical-binding:t -*- +;; Copyright © 1991-2021 Unicode, Inc. +;; Generated from Unicode data files by emoji.el. +;; The source for this file is found in the admin/unidata/emoji-test.txt +;; file in the Emacs sources. The Unicode data files are used under the +;; Unicode Terms of Use, as contained in the file copyright.html in that +;; same directory.\n\n") + (dolist (var '(emoji--labels emoji--derived emoji--names)) + (insert (format "(defconst %s '" var)) + (pp (symbol-value var) (current-buffer)) + (insert (format "\n) ;; End %s\n\n" var))) + (insert ";; Local" " Variables: +;; coding: utf-8 +;; version-control: never +;; no-byte-" + ;; Obfuscate to not inhibit compilation of this file, too. + "compile: t +;; no-update-autoloads: t +;; End: + +\(provide 'emoji-labels) + +\;;; emoji-labels.el ends here\n") + (write-region (point-min) (point-max) file))) + +(defun emoji--base-name (name derivations) + (let* ((base (replace-regexp-in-string ":.*" "" name))) + (catch 'found + ;; If we have (for instance) "person golfing", and we're adding + ;; "man golfing", make the latter a derivation of the former. + (let ((non-binary (replace-regexp-in-string + "\\`\\(m[ae]n\\|wom[ae]n\\) " "" base))) + (dolist (prefix '("person " "people " "")) + (let ((key (concat prefix non-binary))) + (when (gethash key derivations) + (throw 'found key))))) + ;; We can also have the gender at the end of the string, like + ;; "merman" and "pregnant woman". + (let ((non-binary (replace-regexp-in-string + "\\(m[ae]n\\|wom[ae]n\\|maid\\)\\'" "" base))) + (dolist (suffix '(" person" "person" "")) + (let ((key (concat non-binary suffix))) + (when (gethash key derivations) + (throw 'found key))))) + ;; Just return the base. + base))) + +(defun emoji--split-subgroup (subgroup) + (let ((prefixes '("face" "hand" "person" "animal" "plant" + "food" "place"))) + (cond + ((string-match (concat "\\`" (regexp-opt prefixes) "-") subgroup) + ;; Split these subgroups into hierarchies. + (list (substring subgroup 0 (1- (match-end 0))) + (substring subgroup (match-end 0)))) + ((equal subgroup "person") + (list "person" "age")) + (t + (list subgroup))))) + +(defun emoji--add-glyph (glyph main subs) + (let (parent elem) + ;; Useless category. + (unless (member main '("Component")) + (unless (setq parent (assoc main emoji--labels)) + (setq emoji--labels (append emoji--labels + (list (setq parent (list main)))))) + (setq elem parent) + (while subs + (unless (setq elem (assoc (car subs) parent)) + (nconc parent (list (setq elem (list (car subs)))))) + (pop subs) + (setq parent elem)) + (nconc elem (list glyph))))) + +(defun emoji--define-transient (&optional alist inhibit-derived + end-function) + (unless alist + (setq alist (cons "Emoji" emoji--labels))) + (let* ((mname (pop alist)) + (name (intern (format "emoji--command-%s" mname))) + (emoji--done-derived (or emoji--done-derived + (make-hash-table :test #'equal))) + (has-subs (consp (cadr alist))) + (layout + (if has-subs + ;; Define sub-maps. + (cl-loop for entry in + (emoji--compute-prefix + (if (equal mname "Emoji") + (cons (list "Recent") alist) + alist)) + collect (list + (car entry) + (emoji--compute-name (cdr entry)) + (if (equal (cadr entry) "Recent") + (emoji--recent-transient end-function) + (emoji--define-transient + (cons (concat mname " > " (cadr entry)) + (cddr entry)))))) + ;; Insert an emoji. + (cl-loop for glyph in alist + for i in (append (number-sequence ?a ?z) + (number-sequence ?A ?Z) + (number-sequence ?0 ?9) + (number-sequence ?! ?/)) + collect (let ((this-glyph glyph)) + (list + (string i) + (emoji--fontify-glyph + glyph inhibit-derived) + (let ((derived + (and (not inhibit-derived) + (not (gethash glyph + emoji--done-derived)) + (gethash glyph emoji--derived)))) + (if derived + ;; We have a derived glyph, so add + ;; another level. + (progn + (setf (gethash glyph + emoji--done-derived) + t) + (emoji--define-transient + (cons (concat mname " " glyph) + (cons glyph derived)) + t end-function)) + ;; Insert the emoji. + (lambda () + (interactive nil not-a-mode) + ;; Allow switching to the correct + ;; buffer. + (when end-function + (funcall end-function)) + (emoji--add-recent this-glyph) + (insert this-glyph))))))))) + (args (apply #'vector mname + (emoji--columnize layout + (if has-subs 2 8))))) + ;; There's probably a better way to do this... + (setf (symbol-function name) + (lambda () + (interactive nil not-a-mode) + (transient-setup name))) + (pcase-let ((`(,class ,slots ,suffixes ,docstr ,_body) + (transient--expand-define-args (list args)))) + (put name 'interactive-only t) + (put name 'function-documentation docstr) + (put name 'transient--prefix + (apply (or class 'transient-prefix) :command name + (cons :variable-pitch (cons t slots)))) + (put name 'transient--layout + (cl-mapcan (lambda (s) (transient--parse-child name s)) + suffixes))) + name)) + +(defun emoji--recent-transient (end-function) + "Create a function to display a dynamically generated menu." + (lambda () + (interactive) + (funcall (emoji--define-transient + (cons "Recent" (multisession-value emoji--recent)) + t end-function)))) + +(defun emoji--add-recent (glyph) + "Add GLYPH to the set of recently used emojis." + (let ((recent (multisession-value emoji--recent))) + (setq recent (delete glyph recent)) + (push glyph recent) + ;; Shorten the list. + (when-let ((tail (nthcdr 30 recent))) + (setcdr tail nil)) + (setf (multisession-value emoji--recent) recent))) + +(defun emoji--columnize (list columns) + "Split LIST into COLUMN columns." + (cl-loop with length = (ceiling (/ (float (length list)) columns)) + for i upto columns + for part on list by (lambda (l) (nthcdr length l)) + collect (apply #'vector (seq-take part length)))) + +(defun emoji--compute-prefix (alist) + "Compute characters to use for entries in ALIST. +We prefer the earliest unique letter." + (cl-loop with taken = (make-hash-table) + for entry in alist + for name = (car entry) + collect (cons (cl-loop for char across (concat + (downcase name) + (upcase name)) + while (gethash char taken) + finally (progn + (setf (gethash char taken) t) + (cl-return (string char)))) + entry))) + +(defun emoji--compute-name (entry) + "Add example emojis to the name." + (let* ((name (concat (car entry) " ")) + (children (emoji--flatten entry)) + (length (length name)) + (max 30)) + (cl-loop for i from 0 upto 20 + ;; Choose from all the children. + while (< length max) + do (cl-loop for child in children + for glyph = (elt child i) + while (< length max) + when glyph + do (setq name (concat name glyph) + length (+ length 2)))) + (if (= (length name) max) + ;; Make an ellipsis signal that we've not exhausted the + ;; possibilities. + (concat name "…") + name))) + +(defun emoji--flatten (alist) + (pop alist) + (if (consp (cadr alist)) + (cl-loop for child in alist + append (emoji--flatten child)) + (list alist))) + +(defun emoji--split-long-lists (alist) + (let ((whole alist)) + (pop alist) + (if (consp (cadr alist)) + ;; Descend. + (cl-loop for child in alist + do (emoji--split-long-lists child)) + ;; We have a list. + (when (length> alist 77) + (setcdr whole + (cl-loop for prefix from ?a + for bit on alist by (lambda (l) (nthcdr 77 l)) + collect (cons (concat (string prefix) "-group") + (seq-take bit 77)))))))) + +(defun emoji--choose-emoji () + ;; Use the list of names. + (let ((name + (completing-read + "Insert emoji: " + (lambda (string pred action) + (if (eq action 'metadata) + (list 'metadata + (cons + 'affixation-function + ;; Add the glyphs to the start of the displayed + ;; strings when TAB-ing. + (lambda (strings) + (mapcar + (lambda (name) + (list name + (concat + (or (gethash name emoji--all-bases) " ") + "\t") + "")) + strings)))) + (complete-with-action action emoji--all-bases string pred))) + nil t))) + (when (cl-plusp (length name)) + (let* ((glyph (gethash name emoji--all-bases)) + (derived (gethash glyph emoji--derived))) + (if (not derived) + ;; Simple glyph with no derivations. + (progn + (emoji--add-recent glyph) + (insert glyph)) + ;; Choose a derived version. + (let ((emoji--done-derived (make-hash-table :test #'equal))) + (setf (gethash glyph emoji--done-derived) t) + (funcall + (emoji--define-transient + (cons "Choose Emoji" (cons glyph derived)))))))))) + +(provide 'emoji) + +;;; emoji.el ends here diff --git a/lisp/international/fontset.el b/lisp/international/fontset.el index fcd22e09d29..7c3a7cd1a9e 100644 --- a/lisp/international/fontset.el +++ b/lisp/international/fontset.el @@ -816,11 +816,16 @@ (#x1D7EC #x1D7F5 mathematical-sans-serif-bold) (#x1D7F6 #x1D7FF mathematical-monospace))) (let ((slot (assq (nth 2 math-subgroup) script-representative-chars))) + ;; Add both ends of each subgroup to help filter out some + ;; incomplete fonts, e.g. those that cover MATHEMATICAL SCRIPT + ;; CAPITAL glyphs but not MATHEMATICAL SCRIPT SMALL ones. (if slot - (if (vectorp (cdr slot)) - (setcdr slot (vconcat (cdr slot) (vector (car math-subgroup)))) - (setcdr slot (vector (cadr slot) (car math-subgroup)))) - (setq slot (list (nth 2 math-subgroup) (car math-subgroup))) + (setcdr slot (append (list (nth 0 math-subgroup) + (nth 1 math-subgroup)) + (cdr slot))) + (setq slot (list (nth 2 math-subgroup) + (nth 0 math-subgroup) + (nth 1 math-subgroup))) (nconc script-representative-chars (list slot)))) (set-fontset-font "fontset-default" diff --git a/lisp/international/iso-transl.el b/lisp/international/iso-transl.el index 2c7da2b7cdf..aea12179170 100644 --- a/lisp/international/iso-transl.el +++ b/lisp/international/iso-transl.el @@ -86,33 +86,46 @@ ("\"y" . [?ÿ]) ("''" . [?´]) ("'A" . [?Á]) + ("'C" . [?Ć]) ("'E" . [?É]) ("'I" . [?Í]) + ("'N" . [?Ń]) ("'O" . [?Ó]) + ("'S" . [?Ś]) ("'U" . [?Ú]) ("'Y" . [?Ý]) + ("'Z" . [?Ź]) ("'a" . [?á]) + ("'c" . [?ć]) ("'e" . [?é]) ("'i" . [?í]) + ("'n" . [?ń]) ("'o" . [?ó]) + ("'s" . [?ś]) ("'u" . [?ú]) ("'y" . [?ý]) + ("'z" . [?ź]) ("*$" . [?¤]) ("$" . [?¤]) ("*+" . [?±]) ("+" . [?±]) (",," . [?¸]) + (",A" . [?Ą]) (",C" . [?Ç]) + (",a" . [?ą]) (",c" . [?ç]) ("*-" . [?]) ("-" . [?]) ("*." . [?·]) - ("." . [?·]) + (".." . [?·]) + (".z" . [?ż]) ("//" . [?÷]) ("/A" . [?Å]) + ("/L" . [?Ł]) ("/E" . [?Æ]) ("/O" . [?Ø]) ("/a" . [?å]) + ("/l" . [?ł]) ("/e" . [?æ]) ("/o" . [?ø]) ("1/2" . [?½]) @@ -294,6 +307,14 @@ sequence VECTOR. (VECTOR is normally one character long.)") (setq alist (cdr alist)))) (defun iso-transl-set-language (lang) + "Set shorter key bindings for some characters relevant for LANG. +This affects the `C-x 8' prefix. + +Note that only a few languages are supported, and for more +rigorous support it is recommended to use an input method +instead. Also note that many of these characters can be input +with the regular `C-x 8' map without having to specify a language +here." (interactive (list (let ((completion-ignore-case t)) (completing-read "Set which language? " iso-transl-language-alist nil t)))) diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index 2b52d4bf86a..fa1381df094 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))) + :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 @@ -1638,30 +1638,31 @@ If `default-transient-input-method' was not yet defined, prompt for it." (interactive (list (read-input-method-name (format-prompt "Describe input method" current-input-method)))) - (if (and input-method (symbolp input-method)) - (setq input-method (symbol-name input-method))) - (help-setup-xref (list #'describe-input-method - (or input-method current-input-method)) - (called-interactively-p 'interactive)) - - (if (null input-method) - (describe-current-input-method) - (let ((current current-input-method)) - (condition-case nil - (progn - (save-excursion - (activate-input-method input-method) - (describe-current-input-method)) - (activate-input-method current)) - (error - (activate-input-method current) - (help-setup-xref (list #'describe-input-method input-method) - (called-interactively-p 'interactive)) - (with-output-to-temp-buffer (help-buffer) - (let ((elt (assoc input-method input-method-alist))) - (princ (format-message - "Input method: %s (`%s' in mode line) for %s\n %s\n" - input-method (nth 3 elt) (nth 1 elt) (nth 4 elt)))))))))) + (let ((help-buffer-under-preparation t)) + (if (and input-method (symbolp input-method)) + (setq input-method (symbol-name input-method))) + (help-setup-xref (list #'describe-input-method + (or input-method current-input-method)) + (called-interactively-p 'interactive)) + + (if (null input-method) + (describe-current-input-method) + (let ((current current-input-method)) + (condition-case nil + (progn + (save-excursion + (activate-input-method input-method) + (describe-current-input-method)) + (activate-input-method current)) + (error + (activate-input-method current) + (help-setup-xref (list #'describe-input-method input-method) + (called-interactively-p 'interactive)) + (with-output-to-temp-buffer (help-buffer) + (let ((elt (assoc input-method input-method-alist))) + (princ (format-message + "Input method: %s (`%s' in mode line) for %s\n %s\n" + input-method (nth 3 elt) (nth 1 elt) (nth 4 elt))))))))))) (defun describe-current-input-method () "Describe the input method currently in use. @@ -2162,89 +2163,90 @@ See `set-language-info-alist' for use in programs." (list (read-language-name 'documentation (format-prompt "Describe language environment" current-language-environment)))) - (if (null language-name) - (setq language-name current-language-environment)) - (if (or (null language-name) - (null (get-language-info language-name 'documentation))) - (error "No documentation for the specified language")) - (if (symbolp language-name) - (setq language-name (symbol-name language-name))) - (dolist (feature (get-language-info language-name 'features)) - (require feature)) - (let ((doc (get-language-info language-name 'documentation))) - (help-setup-xref (list #'describe-language-environment language-name) - (called-interactively-p 'interactive)) - (with-output-to-temp-buffer (help-buffer) - (with-current-buffer standard-output - (insert language-name " language environment\n\n") - (if (stringp doc) - (insert (substitute-command-keys doc) "\n\n")) - (condition-case nil - (let ((str (eval (get-language-info language-name 'sample-text)))) - (if (stringp str) - (insert "Sample text:\n " - (string-replace "\n" "\n " str) - "\n\n"))) - (error nil)) - (let ((input-method (get-language-info language-name 'input-method)) - (l (copy-sequence input-method-alist)) - (first t)) - (when (and input-method - (setq input-method (assoc input-method l))) - (insert "Input methods (default " (car input-method) ")\n") - (setq l (cons input-method (delete input-method l)) - first nil)) - (dolist (elt l) - (when (or (eq input-method elt) - (eq t (compare-strings language-name nil nil - (nth 1 elt) nil nil t))) - (when first - (insert "Input methods:\n") - (setq first nil)) - (insert " " (car elt)) - (search-backward (car elt)) - (help-xref-button 0 'help-input-method (car elt)) - (goto-char (point-max)) - (insert " (\"" - (if (stringp (nth 3 elt)) (nth 3 elt) (car (nth 3 elt))) - "\" in mode line)\n"))) - (or first - (insert "\n"))) - (insert "Character sets:\n") - (let ((l (get-language-info language-name 'charset))) - (if (null l) - (insert " nothing specific to " language-name "\n") - (while l - (insert " " (symbol-name (car l))) - (search-backward (symbol-name (car l))) - (help-xref-button 0 'help-character-set (car l)) - (goto-char (point-max)) - (insert ": " (charset-description (car l)) "\n") - (setq l (cdr l))))) - (insert "\n") - (insert "Coding systems:\n") - (let ((l (get-language-info language-name 'coding-system))) - (if (null l) - (insert " nothing specific to " language-name "\n") - (while l - (insert " " (symbol-name (car l))) - (search-backward (symbol-name (car l))) - (help-xref-button 0 'help-coding-system (car l)) - (goto-char (point-max)) - (insert (substitute-command-keys " (`") - (coding-system-mnemonic (car l)) - (substitute-command-keys "' in mode line):\n\t") - (substitute-command-keys - (coding-system-doc-string (car l))) - "\n") - (let ((aliases (coding-system-aliases (car l)))) - (when aliases - (insert "\t(alias:") - (while aliases - (insert " " (symbol-name (car aliases))) - (setq aliases (cdr aliases))) - (insert ")\n"))) - (setq l (cdr l))))))))) + (let ((help-buffer-under-preparation t)) + (if (null language-name) + (setq language-name current-language-environment)) + (if (or (null language-name) + (null (get-language-info language-name 'documentation))) + (error "No documentation for the specified language")) + (if (symbolp language-name) + (setq language-name (symbol-name language-name))) + (dolist (feature (get-language-info language-name 'features)) + (require feature)) + (let ((doc (get-language-info language-name 'documentation))) + (help-setup-xref (list #'describe-language-environment language-name) + (called-interactively-p 'interactive)) + (with-output-to-temp-buffer (help-buffer) + (with-current-buffer standard-output + (insert language-name " language environment\n\n") + (if (stringp doc) + (insert (substitute-command-keys doc) "\n\n")) + (condition-case nil + (let ((str (eval (get-language-info language-name 'sample-text)))) + (if (stringp str) + (insert "Sample text:\n " + (string-replace "\n" "\n " str) + "\n\n"))) + (error nil)) + (let ((input-method (get-language-info language-name 'input-method)) + (l (copy-sequence input-method-alist)) + (first t)) + (when (and input-method + (setq input-method (assoc input-method l))) + (insert "Input methods (default " (car input-method) ")\n") + (setq l (cons input-method (delete input-method l)) + first nil)) + (dolist (elt l) + (when (or (eq input-method elt) + (eq t (compare-strings language-name nil nil + (nth 1 elt) nil nil t))) + (when first + (insert "Input methods:\n") + (setq first nil)) + (insert " " (car elt)) + (search-backward (car elt)) + (help-xref-button 0 'help-input-method (car elt)) + (goto-char (point-max)) + (insert " (\"" + (if (stringp (nth 3 elt)) (nth 3 elt) (car (nth 3 elt))) + "\" in mode line)\n"))) + (or first + (insert "\n"))) + (insert "Character sets:\n") + (let ((l (get-language-info language-name 'charset))) + (if (null l) + (insert " nothing specific to " language-name "\n") + (while l + (insert " " (symbol-name (car l))) + (search-backward (symbol-name (car l))) + (help-xref-button 0 'help-character-set (car l)) + (goto-char (point-max)) + (insert ": " (charset-description (car l)) "\n") + (setq l (cdr l))))) + (insert "\n") + (insert "Coding systems:\n") + (let ((l (get-language-info language-name 'coding-system))) + (if (null l) + (insert " nothing specific to " language-name "\n") + (while l + (insert " " (symbol-name (car l))) + (search-backward (symbol-name (car l))) + (help-xref-button 0 'help-coding-system (car l)) + (goto-char (point-max)) + (insert (substitute-command-keys " (`") + (coding-system-mnemonic (car l)) + (substitute-command-keys "' in mode line):\n\t") + (substitute-command-keys + (coding-system-doc-string (car l))) + "\n") + (let ((aliases (coding-system-aliases (car l)))) + (when aliases + (insert "\t(alias:") + (while aliases + (insert " " (symbol-name (car aliases))) + (setq aliases (cdr aliases))) + (insert ")\n"))) + (setq l (cdr l)))))))))) ;;; Locales. @@ -2665,6 +2667,20 @@ For example, translate \"swedish\" into \"sv_SE.ISO8859-1\"." locale)) locale)) +(defvar current-locale-environment nil + "The currently set locale environment.") + +(defmacro with-locale-environment (locale-name &rest body) + "Execute BODY with the locale set to LOCALE-NAME." + (declare (indent 1) (debug (sexp def-body))) + (let ((current (gensym))) + `(let ((,current current-locale-environment)) + (unwind-protect + (progn + (set-locale-environment ,locale-name) + ,@body) + (set-locale-environment ,current))))) + (defun set-locale-environment (&optional locale-name frame) "Set up multilingual environment for using LOCALE-NAME. This sets the language environment, the coding system priority, @@ -2690,6 +2706,10 @@ If FRAME is non-nil, only set the keyboard coding system and the terminal coding system for the terminal of that frame, and don't touch session-global parameters like the language environment. +This function sets the `current-locale-environment' variable. To +change the locale temporarily, `with-locale-environment' can be +used. + See also `locale-charset-language-names', `locale-language-names', `locale-preferred-coding-systems' and `locale-coding-system'." (interactive (list (completing-read "Set environment for locale: " @@ -2723,6 +2743,7 @@ See also `locale-charset-language-names', `locale-language-names', (when locale (setq locale (locale-translate locale)) + (setq current-locale-environment locale) ;; Leave the system locales alone if the caller did not specify ;; an explicit locale name, as their defaults are set from @@ -2927,6 +2948,7 @@ Optional 3rd argument DOCSTRING is a documentation string of the property. See also the documentation of `get-char-code-property' and `put-char-code-property'." + (declare (indent defun)) (or (symbolp name) (error "Not a symbol: %s" name)) (if (char-table-p table) @@ -3055,22 +3077,6 @@ on encoding." 0)) (substring enc2 i0 i2))))) -;; Backwards compatibility. These might be better with :init-value t, -;; but that breaks loadup. -(define-minor-mode unify-8859-on-encoding-mode - "Exists only for backwards compatibility." - :group 'mule - :global t) -;; Doc said "obsolete" in 23.1, this statement only added in 24.1. -(make-obsolete 'unify-8859-on-encoding-mode "don't use it." "23.1") - -(define-minor-mode unify-8859-on-decoding-mode - "Exists only for backwards compatibility." - :group 'mule - :global t) -;; Doc said "obsolete" in 23.1, this statement only added in 24.1. -(make-obsolete 'unify-8859-on-decoding-mode "don't use it." "23.1") - (defvar ucs-names nil "Hash table of cached CHAR-NAME keys to CHAR-CODE values.") @@ -3238,5 +3244,116 @@ as names, not numbers." (define-obsolete-function-alias 'ucs-insert 'insert-char "24.3") (define-key ctl-x-map "8\r" 'insert-char) +(define-key ctl-x-map "8e" + (define-keymap + "e" #'emoji-insert + "i" #'emoji-insert + "s" #'emoji-search + "d" #'emoji-describe + "r" #'emoji-recent + "l" #'emoji-list)) + +(defface confusingly-reordered + '((((supports :underline (:style wave))) + :underline (:style wave :color "Red1")) + (t + :inherit warning)) + "Face for highlighting text that was bidi-reordered in confusing ways." + :version "29.1") + +(defvar reorder-starters "[\u202A\u202B\u202D\u202E\u2066-\u2068]+" + "Regular expression for characters that start forced-reordered text.") +(defvar reorder-enders "[\u202C\u2069]+\\|\n" + "Regular expression for characters that end forced-reordered text.") + +(autoload 'text-property-search-forward "text-property-search") +(autoload 'prop-match-beginning "text-property-search") +(autoload 'prop-match-end "text-property-search") + +(defun highlight-confusing-reorderings (beg end &optional remove) + "Highlight text in region that might be bidi-reordered in suspicious ways. +This command find and highlights segments of buffer text that could have +been reordered on display by using directional control characters, such +as RLO and LRI, in a way that their display is deliberately meant to +confuse the reader. These techniques can be used for obfuscating +malicious source code. The suspicious stretches of buffer text are +highlighted using the `confusingly-reordered' face. + +If the region is active, check the text inside the region. Otherwise +check the entire buffer. When called from Lisp, pass BEG and END to +specify the portion of the buffer to check. + +Optional argument REMOVE, if non-nil (interactively, prefix argument), +means remove the highlighting from the region between BEG and END, +or the active region if that is set." + (interactive + (if (use-region-p) + (list (region-beginning) (region-end) current-prefix-arg) + (list (point-min) (point-max) current-prefix-arg))) + (save-excursion + (if remove + (let (prop-match) + (goto-char beg) + (while (and + (setq prop-match + (text-property-search-forward 'font-lock-face + 'confusingly-reordered t)) + (< (prop-match-beginning prop-match) end)) + (with-silent-modifications + (remove-list-of-text-properties (prop-match-beginning prop-match) + (prop-match-end prop-match) + '(font-lock-face face mouse-face + help-echo))))) + (let ((count 0) + next) + (goto-char beg) + (while (setq next + (bidi-find-overridden-directionality + (point) end nil + (current-bidi-paragraph-direction))) + (goto-char next) + ;; We detect the problematic parts by watching directional + ;; properties of strong L2R and R2L characters. But + ;; malicious reordering in source buffers can, and usuually + ;; does, include syntactically-important punctuation + ;; characters. Those have "weak" directionality, so we + ;; cannot easily detect when they are affected in malicious + ;; ways. Therefore, once we find a strong directional + ;; character whose directionality was tweaked, we highlight + ;; the text around it, between the first bidi control + ;; character we find before it that starts an + ;; override/embedding/isolate, and the first control after + ;; it that ends these. This could sometimes highlight only + ;; part of the affected text. An alternative would be to + ;; find the first "starter" following BOL and the last + ;; "ender" before EOL, and highlight everything in between + ;; them -- this could sometimes highlight too much. + (let ((start + (save-excursion + (re-search-backward reorder-starters nil t))) + (finish + (save-excursion + (let ((fin (re-search-forward reorder-enders nil t))) + (if fin (1- fin) + (point-max)))))) + (with-silent-modifications + (add-text-properties start finish + '(font-lock-face + confusingly-reordered + face confusingly-reordered + mouse-face highlight + help-echo "\ +This text is reordered on display in a way that could change its semantics; +use \\[forward-char] and \\[backward-char] to see the actual order of characters."))) + (goto-char finish) + (setq count (1+ count)))) + (message + (if (> count 0) + (ngettext + "Highlighted %d confusingly-reordered text string" + "Highlighted %d confusingly-reordered text strings" + count) + "No confusingly-reordered text strings were found") + count))))) ;;; mule-cmds.el ends here diff --git a/lisp/international/mule-conf.el b/lisp/international/mule-conf.el index 9a68fce2e81..ec027e9a932 100644 --- a/lisp/international/mule-conf.el +++ b/lisp/international/mule-conf.el @@ -148,6 +148,7 @@ (defmacro define-iso-single-byte-charset (symbol iso-symbol name nickname iso-ir iso-final emacs-mule-id map) + (declare (indent defun)) `(progn (define-charset ,symbol ,name diff --git a/lisp/international/mule-diag.el b/lisp/international/mule-diag.el index 862c577bd5d..efb9296c110 100644 --- a/lisp/international/mule-diag.el +++ b/lisp/international/mule-diag.el @@ -299,65 +299,66 @@ meanings of these arguments." (defun describe-character-set (charset) "Display information about built-in character set CHARSET." (interactive (list (read-charset "Charset: "))) - (or (charsetp charset) - (error "Invalid charset: %S" charset)) - (help-setup-xref (list #'describe-character-set charset) - (called-interactively-p 'interactive)) - (with-output-to-temp-buffer (help-buffer) - (with-current-buffer standard-output - (insert "Character set: " (symbol-name charset)) - (let ((name (get-charset-property charset :name))) - (if (not (eq name charset)) - (insert " (alias of " (symbol-name name) ?\)))) - (insert "\n\n" (charset-description charset) "\n\n") - (insert "Number of contained characters: ") - (dotimes (i (charset-dimension charset)) - (unless (= i 0) - (insert ?x)) - (insert (format "%d" (charset-chars charset (1+ i))))) - (insert ?\n) - (let ((char (charset-iso-final-char charset))) - (when (> char 0) - (insert "Final char of ISO2022 designation sequence: ") - (insert (format-message "`%c'\n" char)))) - (let (aliases) - (dolist (c charset-list) - (if (and (not (eq c charset)) - (eq charset (get-charset-property c :name))) - (push c aliases))) - (if aliases - (insert "Aliases: " (mapconcat #'symbol-name aliases ", ") ?\n))) - - (dolist (elt `((:ascii-compatible-p "ASCII compatible." nil) - (:map "Map file: " identity) - (:unify-map "Unification map file: " identity) - (:invalid-code - nil - ,(lambda (c) - (format "Invalid character: %c (code %d)" c c))) - (:emacs-mule-id "Id in emacs-mule coding system: " - number-to-string) - (:parents "Parents: " - (lambda (parents) - (mapconcat ,(lambda (elt) - (format "%s" elt)) - parents - ", "))) - (:code-space "Code space: " ,(lambda (c) - (format "%s" c))) - (:code-offset "Code offset: " number-to-string) - (:iso-revision-number "ISO revision number: " - number-to-string) - (:supplementary-p - "Used only as a parent or a subset of some other charset, + (let ((help-buffer-under-preparation t)) + (or (charsetp charset) + (error "Invalid charset: %S" charset)) + (help-setup-xref (list #'describe-character-set charset) + (called-interactively-p 'interactive)) + (with-output-to-temp-buffer (help-buffer) + (with-current-buffer standard-output + (insert "Character set: " (symbol-name charset)) + (let ((name (get-charset-property charset :name))) + (if (not (eq name charset)) + (insert " (alias of " (symbol-name name) ?\)))) + (insert "\n\n" (charset-description charset) "\n\n") + (insert "Number of contained characters: ") + (dotimes (i (charset-dimension charset)) + (unless (= i 0) + (insert ?x)) + (insert (format "%d" (charset-chars charset (1+ i))))) + (insert ?\n) + (let ((char (charset-iso-final-char charset))) + (when (> char 0) + (insert "Final char of ISO2022 designation sequence: ") + (insert (format-message "`%c'\n" char)))) + (let (aliases) + (dolist (c charset-list) + (if (and (not (eq c charset)) + (eq charset (get-charset-property c :name))) + (push c aliases))) + (if aliases + (insert "Aliases: " (mapconcat #'symbol-name aliases ", ") ?\n))) + + (dolist (elt `((:ascii-compatible-p "ASCII compatible." nil) + (:map "Map file: " identity) + (:unify-map "Unification map file: " identity) + (:invalid-code + nil + ,(lambda (c) + (format "Invalid character: %c (code %d)" c c))) + (:emacs-mule-id "Id in emacs-mule coding system: " + number-to-string) + (:parents "Parents: " + (lambda (parents) + (mapconcat ,(lambda (elt) + (format "%s" elt)) + parents + ", "))) + (:code-space "Code space: " ,(lambda (c) + (format "%s" c))) + (:code-offset "Code offset: " number-to-string) + (:iso-revision-number "ISO revision number: " + number-to-string) + (:supplementary-p + "Used only as a parent or a subset of some other charset, or provided just for backward compatibility." nil))) - (let ((val (get-charset-property charset (car elt)))) - (when val - (if (cadr elt) (insert (cadr elt))) - (if (nth 2 elt) - (let ((print-length 10) (print-level 2)) - (princ (funcall (nth 2 elt) val) (current-buffer)))) - (insert ?\n))))))) + (let ((val (get-charset-property charset (car elt)))) + (when val + (if (cadr elt) (insert (cadr elt))) + (if (nth 2 elt) + (let ((print-length 10) (print-level 2)) + (princ (funcall (nth 2 elt) val) (current-buffer)))) + (insert ?\n)))))))) ;;; CODING-SYSTEM @@ -406,89 +407,90 @@ or provided just for backward compatibility." nil))) (defun describe-coding-system (coding-system) "Display information about CODING-SYSTEM." (interactive "zDescribe coding system (default current choices): ") - (if (null coding-system) - (describe-current-coding-system) - (help-setup-xref (list #'describe-coding-system coding-system) - (called-interactively-p 'interactive)) - (with-output-to-temp-buffer (help-buffer) - (print-coding-system-briefly coding-system 'doc-string) - (let ((type (coding-system-type coding-system)) - ;; Fixme: use this - ;; (extra-spec (coding-system-plist coding-system)) - ) - (princ "Type: ") - (princ type) - (cond ((eq type 'undecided) - (princ " (do automatic conversion)")) - ((eq type 'utf-8) - (princ " (UTF-8: Emacs internal multibyte form)")) - ((eq type 'utf-16) - ;; (princ " (UTF-16)") - ) - ((eq type 'shift-jis) - (princ " (Shift-JIS, MS-KANJI)")) - ((eq type 'iso-2022) - (princ " (variant of ISO-2022)\n") - (princ "Initial designations:\n") - (print-designation (coding-system-get coding-system - :designation)) - - (when (coding-system-get coding-system :flags) - (princ "Other specifications: \n ") - (apply #'print-list - (coding-system-get coding-system :flags)))) - ((eq type 'charset) - (princ " (charset)")) - ((eq type 'ccl) - (princ " (do conversion by CCL program)")) - ((eq type 'raw-text) - (princ " (text with random binary characters)")) - ((eq type 'emacs-mule) - (princ " (Emacs 21 internal encoding)")) - ((eq type 'big5)) - (t (princ ": invalid coding-system."))) - (princ "\nEOL type: ") - (let ((eol-type (coding-system-eol-type coding-system))) - (cond ((vectorp eol-type) - (princ "Automatic selection from:\n\t") - (princ eol-type) - (princ "\n")) - ((or (null eol-type) (eq eol-type 0)) (princ "LF\n")) - ((eq eol-type 1) (princ "CRLF\n")) - ((eq eol-type 2) (princ "CR\n")) - (t (princ "invalid\n"))))) - (let ((postread (coding-system-get coding-system :post-read-conversion))) - (when postread - (princ "After decoding text normally,") - (princ " perform post-conversion using the function: ") - (princ "\n ") - (princ postread) - (princ "\n"))) - (let ((prewrite (coding-system-get coding-system :pre-write-conversion))) - (when prewrite - (princ "Before encoding text normally,") - (princ " perform pre-conversion using the function: ") - (princ "\n ") - (princ prewrite) - (princ "\n"))) - (with-current-buffer standard-output - (let ((charsets (coding-system-charset-list coding-system))) - (when (and (not (eq (coding-system-base coding-system) 'raw-text)) - charsets) - (cond - ((eq charsets 'iso-2022) - (insert "This coding system can encode all ISO 2022 charsets.")) - ((eq charsets 'emacs-mule) - (insert "This coding system can encode all emacs-mule charsets\ + (let ((help-buffer-under-preparation t)) + (if (null coding-system) + (describe-current-coding-system) + (help-setup-xref (list #'describe-coding-system coding-system) + (called-interactively-p 'interactive)) + (with-output-to-temp-buffer (help-buffer) + (print-coding-system-briefly coding-system 'doc-string) + (let ((type (coding-system-type coding-system)) + ;; Fixme: use this + ;; (extra-spec (coding-system-plist coding-system)) + ) + (princ "Type: ") + (princ type) + (cond ((eq type 'undecided) + (princ " (do automatic conversion)")) + ((eq type 'utf-8) + (princ " (UTF-8: Emacs internal multibyte form)")) + ((eq type 'utf-16) + ;; (princ " (UTF-16)") + ) + ((eq type 'shift-jis) + (princ " (Shift-JIS, MS-KANJI)")) + ((eq type 'iso-2022) + (princ " (variant of ISO-2022)\n") + (princ "Initial designations:\n") + (print-designation (coding-system-get coding-system + :designation)) + + (when (coding-system-get coding-system :flags) + (princ "Other specifications: \n ") + (apply #'print-list + (coding-system-get coding-system :flags)))) + ((eq type 'charset) + (princ " (charset)")) + ((eq type 'ccl) + (princ " (do conversion by CCL program)")) + ((eq type 'raw-text) + (princ " (text with random binary characters)")) + ((eq type 'emacs-mule) + (princ " (Emacs 21 internal encoding)")) + ((eq type 'big5)) + (t (princ ": invalid coding-system."))) + (princ "\nEOL type: ") + (let ((eol-type (coding-system-eol-type coding-system))) + (cond ((vectorp eol-type) + (princ "Automatic selection from:\n\t") + (princ eol-type) + (princ "\n")) + ((or (null eol-type) (eq eol-type 0)) (princ "LF\n")) + ((eq eol-type 1) (princ "CRLF\n")) + ((eq eol-type 2) (princ "CR\n")) + (t (princ "invalid\n"))))) + (let ((postread (coding-system-get coding-system :post-read-conversion))) + (when postread + (princ "After decoding text normally,") + (princ " perform post-conversion using the function: ") + (princ "\n ") + (princ postread) + (princ "\n"))) + (let ((prewrite (coding-system-get coding-system :pre-write-conversion))) + (when prewrite + (princ "Before encoding text normally,") + (princ " perform pre-conversion using the function: ") + (princ "\n ") + (princ prewrite) + (princ "\n"))) + (with-current-buffer standard-output + (let ((charsets (coding-system-charset-list coding-system))) + (when (and (not (eq (coding-system-base coding-system) 'raw-text)) + charsets) + (cond + ((eq charsets 'iso-2022) + (insert "This coding system can encode all ISO 2022 charsets.")) + ((eq charsets 'emacs-mule) + (insert "This coding system can encode all emacs-mule charsets\ .""")) - (t - (insert "This coding system encodes the following charsets:\n ") - (while charsets - (insert " " (symbol-name (car charsets))) - (search-backward (symbol-name (car charsets))) - (help-xref-button 0 'help-character-set (car charsets)) - (goto-char (point-max)) - (setq charsets (cdr charsets))))))))))) + (t + (insert "This coding system encodes the following charsets:\n ") + (while charsets + (insert " " (symbol-name (car charsets))) + (search-backward (symbol-name (car charsets))) + (help-xref-button 0 'help-character-set (car charsets)) + (goto-char (point-max)) + (setq charsets (cdr charsets)))))))))))) ;;;###autoload (defun describe-current-coding-system-briefly () @@ -833,7 +835,7 @@ The IGNORED argument is ignored." "Display information about a font whose name is FONTNAME." (interactive (list (completing-read - "Font name (default current choice for ASCII chars): " + (format-prompt "Font name" "current choice for ASCII chars") (and window-system ;; Implied by `window-system'. (fboundp 'x-list-fonts) @@ -845,7 +847,8 @@ The IGNORED argument is ignored." (or (and window-system (fboundp 'fontset-list)) (error "No fonts being used")) (let ((xref-item (list #'describe-font fontname)) - font-info) + font-info + (help-buffer-under-preparation t)) (if (or (not fontname) (= (length fontname) 0)) (setq fontname (face-attribute 'default :font))) (setq font-info (font-info fontname)) @@ -1004,16 +1007,17 @@ This shows which font is used for which character(s)." (mapcar 'cdr fontset-alias-alist))) (completion-ignore-case t)) (list (completing-read - "Fontset (default used by the current frame): " + (format-prompt "Fontset" "used by the current frame") fontset-list nil t))))) - (if (= (length fontset) 0) - (setq fontset (face-attribute 'default :fontset)) - (setq fontset (query-fontset fontset))) - (help-setup-xref (list #'describe-fontset fontset) - (called-interactively-p 'interactive)) - (with-output-to-temp-buffer (help-buffer) - (with-current-buffer standard-output - (print-fontset fontset t)))) + (let ((help-buffer-under-preparation t)) + (if (= (length fontset) 0) + (setq fontset (face-attribute 'default :fontset)) + (setq fontset (query-fontset fontset))) + (help-setup-xref (list #'describe-fontset fontset) + (called-interactively-p 'interactive)) + (with-output-to-temp-buffer (help-buffer) + (with-current-buffer standard-output + (print-fontset fontset t))))) (declare-function fontset-plain-name "fontset" (fontset)) @@ -1024,39 +1028,41 @@ This shows the name, size, and style of each fontset. With prefix arg, also list the fonts contained in each fontset; see the function `describe-fontset' for the format of the list." (interactive "P") - (if (not (and window-system (fboundp 'fontset-list))) - (error "No fontsets being used") - (help-setup-xref (list #'list-fontsets arg) - (called-interactively-p 'interactive)) - (with-output-to-temp-buffer (help-buffer) - (with-current-buffer standard-output - ;; This code is duplicated near the end of mule-diag. - (let ((fontsets - (sort (fontset-list) - (lambda (x y) - (string< (fontset-plain-name x) - (fontset-plain-name y)))))) - (while fontsets - (if arg - (print-fontset (car fontsets) nil) - (insert "Fontset: " (car fontsets) "\n")) - (setq fontsets (cdr fontsets)))))))) + (let ((help-buffer-under-preparation t)) + (if (not (and window-system (fboundp 'fontset-list))) + (error "No fontsets being used") + (help-setup-xref (list #'list-fontsets arg) + (called-interactively-p 'interactive)) + (with-output-to-temp-buffer (help-buffer) + (with-current-buffer standard-output + ;; This code is duplicated near the end of mule-diag. + (let ((fontsets + (sort (fontset-list) + (lambda (x y) + (string< (fontset-plain-name x) + (fontset-plain-name y)))))) + (while fontsets + (if arg + (print-fontset (car fontsets) nil) + (insert "Fontset: " (car fontsets) "\n")) + (setq fontsets (cdr fontsets))))))))) ;;;###autoload (defun list-input-methods () "Display information about all input methods." (interactive) - (help-setup-xref '(list-input-methods) - (called-interactively-p 'interactive)) - (with-output-to-temp-buffer (help-buffer) - (list-input-methods-1) - (with-current-buffer standard-output - (save-excursion - (goto-char (point-min)) - (while (re-search-forward - (substitute-command-keys "^ \\([^ ]+\\) (`.*' in mode line)$") - nil t) - (help-xref-button 1 'help-input-method (match-string 1))))))) + (let ((help-buffer-under-preparation t)) + (help-setup-xref '(list-input-methods) + (called-interactively-p 'interactive)) + (with-output-to-temp-buffer (help-buffer) + (list-input-methods-1) + (with-current-buffer standard-output + (save-excursion + (goto-char (point-min)) + (while (re-search-forward + (substitute-command-keys "^ \\([^ ]+\\) (`.*' in mode line)$") + nil t) + (help-xref-button 1 'help-input-method (match-string 1)))))))) (defun list-input-methods-1 () (if (not input-method-alist) diff --git a/lisp/international/mule.el b/lisp/international/mule.el index 5022a17db5a..3e45a64dc9a 100644 --- a/lisp/international/mule.el +++ b/lisp/international/mule.el @@ -218,6 +218,7 @@ corresponding Unicode character code. If it is a string, it is a name of file that contains the above information. The file format is the same as what described for `:map' attribute." + (declare (indent defun)) (when (vectorp (car props)) ;; Old style code: ;; (define-charset CHARSET-ID CHARSET-SYMBOL INFO-VECTOR) @@ -890,6 +891,7 @@ non-nil. VALUE non-nil means Emacs prefers UTF-8 on code detection for non-ASCII files. This attribute is meaningful only when `:coding-type' is `undecided'." + (declare (indent defun)) (let* ((common-attrs (mapcar 'list '(:mnemonic :coding-type @@ -2320,6 +2322,7 @@ This function sets properties `translation-table' and `translation-table-id' of SYMBOL to the created table itself and the identification number of the table respectively. It also registers the table in `translation-table-vector'." + (declare (indent defun)) (let ((table (if (and (char-table-p (car args)) (eq (char-table-subtype (car args)) 'translation-table)) @@ -2394,6 +2397,7 @@ Value is what BODY returns." Analogous to `define-translation-table', but updates `translation-hash-table-vector' and the table is for use in the CCL `lookup-integer' and `lookup-character' functions." + (declare (indent defun)) (unless (and (symbolp symbol) (hash-table-p table)) (error "Bad args to define-translation-hash-table")) diff --git a/lisp/international/quail.el b/lisp/international/quail.el index ee935b11ec0..5cdd6d6242b 100644 --- a/lisp/international/quail.el +++ b/lisp/international/quail.el @@ -917,7 +917,7 @@ The format of KBD-LAYOUT is the same as `quail-keyboard-layout'." The variable `quail-keyboard-layout-type' holds the currently selected keyboard type." (interactive - (list (completing-read "Keyboard type (default current choice): " + (list (completing-read (format-prompt "Keyboard type" "current choice") quail-keyboard-layout-alist nil t))) (or (and keyboard-type (> (length keyboard-type) 0)) diff --git a/lisp/international/robin.el b/lisp/international/robin.el index c38cd822693..4c498d7f923 100644 --- a/lisp/international/robin.el +++ b/lisp/international/robin.el @@ -529,10 +529,10 @@ Use the longest match method to select a rule." (insert (cadr tree)) (delete-char (- end begin))))) -;; for backward compatibility - -(fset 'robin-transliterate-region 'robin-convert-region) -(fset 'robin-transliterate-buffer 'robin-convert-buffer) +(define-obsolete-function-alias 'robin-transliterate-region + #'robin-convert-region "29.1") +(define-obsolete-function-alias 'robin-transliterate-buffer + #'robin-convert-buffer "29.1") ;;; Reverse conversion 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 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) - "Normalize the string STR by the Unicode NFC." + "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)) -;;;###autoload (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 c382d0ad2a0..9e144ac2729 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 \\<isearch-help-map>\\[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, @@ -2063,7 +2063,7 @@ The command then executes BODY and updates the isearch prompt." #',function)) (setq isearch-regexp nil))) ,@body - (setq isearch-success t isearch-adjusted t) + (setq isearch-success t isearch-adjusted 'toggle) (isearch-update)) (define-key isearch-mode-map ,key #',command-name) ,@(when (and function (symbolp function)) @@ -2478,8 +2478,8 @@ The arguments passed to `highlight-regexp' are the regexp from the last search and the face from `hi-lock-read-face-name'." (interactive) (isearch--highlight-regexp-or-lines - #'(lambda (regexp face lighter) - (highlight-regexp regexp face nil lighter)))) + (lambda (regexp face lighter) + (highlight-regexp regexp face nil lighter)))) (defun isearch-highlight-lines-matching-regexp () "Exit Isearch mode and call `highlight-lines-matching-regexp'. @@ -2487,8 +2487,8 @@ The arguments passed to `highlight-lines-matching-regexp' are the regexp from the last search and the face from `hi-lock-read-face-name'." (interactive) (isearch--highlight-regexp-or-lines - #'(lambda (regexp face _lighter) - (highlight-lines-matching-regexp regexp face)))) + (lambda (regexp face _lighter) + (highlight-lines-matching-regexp regexp face)))) (defun isearch-delete-char () @@ -2504,6 +2504,11 @@ If no input items have been entered yet, just beep." (if (null (cdr isearch-cmds)) (ding) (isearch-pop-state)) + ;; When going back to the hidden match, reopen it. + (when (and (eq search-invisible 'open) isearch-hide-immediately + isearch-other-end) + (isearch-range-invisible (min (point) isearch-other-end) + (max (point) isearch-other-end))) (isearch-update)) (defun isearch-del-char (&optional arg) @@ -3412,7 +3417,7 @@ the word mode." ;; If currently failing, display no ellipsis. (or isearch-success (setq ellipsis nil)) (let ((m (concat (if isearch-success "" "failing ") - (if isearch-adjusted "pending " "") + (if (eq isearch-adjusted t) "pending " "") (if (and isearch-wrapped (not isearch-wrap-function) (if isearch-forward @@ -3516,10 +3521,10 @@ Can be changed via `isearch-search-fun-function' for special needs." ;; (Bug#35802). (regexp (cond (isearch-regexp-function - (let ((lax (and (not bound) + (let ((lax (and (not bound) ; not lazy-highlight (isearch--lax-regexp-function-p)))) (when lax - (setq isearch-adjusted t)) + (setq isearch-adjusted 'lax)) (if (functionp isearch-regexp-function) (funcall isearch-regexp-function string lax) (word-search-regexp string lax)))) @@ -3787,8 +3792,9 @@ Isearch, at least partially, as determined by `isearch-range-invisible'. If `search-invisible' is t, which allows Isearch matches inside invisible text, this function will always return non-nil, regardless of what `isearch-range-invisible' says." - (or (eq search-invisible t) - (not (isearch-range-invisible beg end)))) + (and (not (text-property-not-all beg end 'inhibit-isearch nil)) + (or (eq search-invisible t) + (not (isearch-range-invisible beg end))))) ;; General utilities diff --git a/lisp/keymap.el b/lisp/keymap.el new file mode 100644 index 00000000000..25288013cf8 --- /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 <https://www.gnu.org/licenses/>. + +;;; 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 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) + ;; If we're binding this key to another key, then parse that other + ;; key, too. + (when (stringp definition) + (keymap--check definition) + (setq definition (key-parse definition))) + (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)" + ;; 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 "")) + (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 "<as df>". + (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 key. +A key is a string consisting of one or more key strokes. +The key strokes are separated by space characters. + +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-<left>\" (the key named \"left\" with the hyper modifier) + \"M-RET\" (the \"return\" key with a meta modifier) + \"C-M-<space>\" (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 <M-C-down>. + (= (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 position) + (error "Can't pass in both keymap and position")) + (if keymap + (let ((value (lookup-key keymap (key-parse key) accept-default))) + (if (and (not no-remap) + (symbolp value)) + (or (command-remapping value) 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/language/cyril-util.el b/lisp/language/cyril-util.el index 04e681d743d..e404288ddca 100644 --- a/lisp/language/cyril-util.el +++ b/lisp/language/cyril-util.el @@ -60,7 +60,7 @@ If the argument is nil, we return the display table to its standard state." (list (let* ((completion-ignore-case t)) (completing-read - "Cyrillic language (default nil): " + (format-prompt "Cyrillic language" "nil") cyrillic-language-alist nil t nil nil nil)))) (or standard-display-table diff --git a/lisp/language/hanja-util.el b/lisp/language/hanja-util.el index 9e9213536cb..fe6323d42ba 100644 --- a/lisp/language/hanja-util.el +++ b/lisp/language/hanja-util.el @@ -6573,8 +6573,8 @@ The value is a hanja character that is selected interactively." (hanja-filter (lambda (x) (car x)) (mapcar (lambda (c) (if (listp c) - (cons (decode-char 'ucs (car c)) (cdr c)) - (list (decode-char 'ucs c)))) + (cons (car c) (cdr c)) + (list c))) (aref hanja-table char))))) (unwind-protect (when (aref hanja-conversions 2) diff --git a/lisp/language/lao.el b/lisp/language/lao.el index c699d57c15a..93849461eae 100644 --- a/lisp/language/lao.el +++ b/lisp/language/lao.el @@ -59,11 +59,11 @@ (let* ((chars (car l)) (len (length chars)) ;; Replace `c', `t', `v' to consonant, tone, and vowel. - (regexp (mapconcat #'(lambda (c) - (cond ((= c ?c) consonant) - ((= c ?t) tone) - ((= c ?v) vowel-upper-lower) - (t (string c)))) + (regexp (mapconcat (lambda (c) + (cond ((= c ?c) consonant) + ((= c ?t) tone) + ((= c ?v) vowel-upper-lower) + (t (string c)))) (cdr l) "")) ;; Element of composition-function-table. (elt (list (vector regexp 1 #'lao-composition-function) diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el index 58de4c0cc4a..0fbae8508a0 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: @@ -338,11 +339,22 @@ usage: (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...) (autoload 'align "align" "\ Attempt to align a region based on a set of alignment rules. -BEG and END mark the region. If BEG and END are specifically set to -nil (this can only be done programmatically), the beginning and end of -the current alignment section will be calculated based on the location -of point, and the value of `align-region-separate' (or possibly each -rule's `separate' attribute). +Interactively, BEG and END are the mark/point of the current region. + +Many modes define specific alignment rules, and some of these +rules in some modes react to the current prefix argument. For +instance, in `text-mode', `M-x align' will align into columns +based on space delimiters, while `C-u - M-x align' will align +into columns based on the \"$\" character. See the +`align-rules-list' variable definition for the specific rules. + +Also see `align-regexp', which will guide you through various +parameters for aligning text. + +Non-interactively, if BEG and END are nil, the beginning and end +of the current alignment section will be calculated based on the +location of point, and the value of `align-region-separate' (or +possibly each rule's `separate' attribute). If SEPARATE is non-nil, it overrides the value of `align-region-separate' for all rules, except those that have their @@ -360,6 +372,15 @@ Align the current region using an ad-hoc rule read from the minibuffer. BEG and END mark the limits of the region. Interactively, this function prompts for the regular expression REGEXP to align with. +Interactively, if you specify a prefix argument, the function +will guide you through entering the full regular expression, and +then prompts for which subexpression parenthesis GROUP (default +1) within REGEXP to modify, the amount of SPACING (default +`align-default-spacing') to use, and whether or not to REPEAT the +rule throughout the line. + +See `align-rules-list' for more information about these options. + For example, let's say you had a list of phone numbers, and wanted to align them so that the opening parentheses would line up: @@ -379,15 +400,8 @@ regular expression after you enter it. Interactively, you only need to supply the characters to be lined up, and any preceding whitespace is replaced. -Non-interactively (or if you specify a prefix argument), you must -enter the full regular expression, including the subexpression. -Interactively, the function also then prompts for which -subexpression parenthesis GROUP (default 1) within REGEXP to -modify, the amount of SPACING (default `align-default-spacing') -to use, and whether or not to REPEAT the rule throughout the -line. - -See `align-rules-list' for more information about these options. +Non-interactively, you must enter the full regular expression, +including the subexpression. The non-interactive form of the previous example would look something like: (align-regexp (point-min) (point-max) \"\\\\(\\\\s-*\\\\)(\") @@ -1665,6 +1679,8 @@ or if CONDITION had no actions, after all other CONDITIONs. \(fn CONDITION ACTION &optional AFTER)" nil nil) +(function-put 'define-auto-insert 'lisp-indent-function 'defun) + (defvar auto-insert-mode nil "\ Non-nil if Auto-Insert mode is enabled. See the `auto-insert-mode' command @@ -2366,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" "\ @@ -2800,6 +2811,13 @@ used instead of `browse-url-new-window-flag'. (make-obsolete 'browse-url-galeon 'nil '"25.1") +(autoload 'browse-url-webpositive "browse-url" "\ +Ask the WebPositive WWW browser to load URL. +Default to the URL around or before point. +The optional argument NEW-WINDOW is not used. + +\(fn URL &optional NEW-WINDOW)" t nil) + (autoload 'browse-url-emacs "browse-url" "\ Ask Emacs to load URL into a buffer and show it in another window. Optional argument SAME-WINDOW non-nil means show the URL in the @@ -3082,6 +3100,11 @@ disabled. (put 'byte-compile-warnings 'safe-local-variable (lambda (v) (or (symbolp v) (null (delq nil (mapcar (lambda (x) (not (symbolp x))) v)))))) +(autoload 'byte-compile-warning-enabled-p "bytecomp" "\ +Return non-nil if WARNING is enabled, according to `byte-compile-warnings'. + +\(fn WARNING &optional SYMBOL)" nil nil) + (autoload 'byte-compile-disable-warning "bytecomp" "\ Change `byte-compile-warnings' to disable WARNING. If `byte-compile-warnings' is t, set it to `(not WARNING)'. @@ -3438,6 +3461,8 @@ See Info node `(calc)Defining Functions'. (function-put 'defmath 'doc-string-elt '3) +(function-put 'defmath 'lisp-indent-function 'defun) + (register-definition-prefixes "calc" '("calc" "defcalcmodevar" "inexact-result" "math-" "var-")) ;;;*** @@ -4467,6 +4492,8 @@ MAP-ID := integer (function-put 'define-ccl-program 'doc-string-elt '3) +(function-put 'define-ccl-program 'lisp-indent-function 'defun) + (autoload 'check-ccl-program "ccl" "\ Check validity of CCL-PROGRAM. If CCL-PROGRAM is a symbol denoting a CCL program, return @@ -4753,6 +4780,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. @@ -7409,6 +7444,8 @@ See Info node `(elisp)Derived Modes' for more details. (function-put 'define-derived-mode 'doc-string-elt '4) +(function-put 'define-derived-mode 'lisp-indent-function 'defun) + (autoload 'derived-mode-init-mode-variables "derived" "\ Initialize variables for a new MODE. Right now, if they don't already exist, set up a blank keymap, an @@ -8801,6 +8838,8 @@ INIT-VALUE LIGHTER KEYMAP. (function-put 'define-minor-mode 'doc-string-elt '2) +(function-put 'define-minor-mode 'lisp-indent-function 'defun) + (defalias 'easy-mmode-define-global-mode #'define-globalized-minor-mode) (defalias 'define-global-minor-mode #'define-globalized-minor-mode) @@ -8838,6 +8877,8 @@ on if the hook has explicitly disabled it. (function-put 'define-globalized-minor-mode 'doc-string-elt '2) +(function-put 'define-globalized-minor-mode 'lisp-indent-function 'defun) + (autoload 'easy-mmode-define-keymap "easy-mmode" "\ Return a keymap built from bindings BS. BS must be a list of (KEY . BINDING) where @@ -10487,6 +10528,40 @@ Emerge two RCS revisions of a file, with another revision as ancestor. ;;;*** +;;;### (autoloads nil "emoji" "international/emoji.el" (0 0 0 0)) +;;; Generated autoloads from international/emoji.el + +(autoload 'emoji-insert "emoji" "\ +Choose and insert an emoji glyph. +If TEXT (interactively, the prefix), use a textual search instead +of a visual interface. + +\(fn &optional TEXT)" t nil) + +(autoload 'emoji-recent "emoji" "\ +Choose and insert a recently used emoji glyph." t nil) + +(autoload 'emoji-search "emoji" "\ +Choose and insert an emoji glyph by searching for an emoji name." t nil) + +(autoload 'emoji-list "emoji" "\ +List emojis and insert the one that's selected. +The character will be inserted into the buffer that was selected +when the command was issued." t nil) + +(autoload 'emoji-describe "emoji" "\ +Say what the name of the composed grapheme cluster GLYPH is. +If it's not known, this function returns nil. + +Interactively, it will message what the name of the emoji (or +character) under point is. + +\(fn GLYPH &optional INTERACTIVE)" t nil) + +(register-definition-prefixes "emoji" '("emoji-")) + +;;;*** + ;;;### (autoloads nil "enriched" "textmodes/enriched.el" (0 0 0 0)) ;;; Generated autoloads from textmodes/enriched.el @@ -10929,7 +11004,7 @@ Look at CONFIG and try to expand GROUP. ;;;### (autoloads nil "erc" "erc/erc.el" (0 0 0 0)) ;;; Generated autoloads from erc/erc.el -(push (purecopy '(erc 5 4)) package--builtin-versions) +(push (purecopy '(erc 5 4 1)) package--builtin-versions) (autoload 'erc-select-read-args "erc" "\ Prompt the user for values of nick, server, port, and password." nil nil) @@ -11076,6 +11151,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) @@ -11108,11 +11186,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) @@ -11135,6 +11210,22 @@ Kill all test buffers that are still live." t nil) ;;;*** +;;;### (autoloads nil "erts-mode" "progmodes/erts-mode.el" (0 0 0 +;;;;;; 0)) +;;; Generated autoloads from progmodes/erts-mode.el + +(autoload 'erts-mode "erts-mode" "\ +Major mode for editing erts (Emacs testing) files. +This mode mainly provides some font locking. + +\\{erts-mode-map} + +\(fn)" t nil) + +(register-definition-prefixes "erts-mode" '("erts-")) + +;;;*** + ;;;### (autoloads nil "esh-arg" "eshell/esh-arg.el" (0 0 0 0)) ;;; Generated autoloads from eshell/esh-arg.el @@ -11479,7 +11570,7 @@ See documentation of variable `tags-file-name'. (make-obsolete 'find-tag-regexp 'xref-find-apropos '"25.1") -(defalias 'pop-tag-mark 'xref-pop-marker-stack) +(defalias 'pop-tag-mark 'xref-go-back) (defalias 'next-file 'tags-next-file) @@ -11956,14 +12047,14 @@ Fetch URL and render the page. If the input doesn't look like an URL or a domain name, the word(s) will be searched for via `eww-search-prefix'. -If called with a prefix ARG, use a new buffer instead of reusing -the default EWW buffer. +If NEW-BUFFER is non-nil (interactively, the prefix arg), use a +new buffer instead of reusing the default EWW buffer. If BUFFER, the data to be rendered is in that buffer. In that case, this function doesn't actually fetch URL. BUFFER will be killed after rendering. -\(fn URL &optional ARG BUFFER)" t nil) +\(fn URL &optional NEW-BUFFER BUFFER)" t nil) (defalias 'browse-web 'eww) (autoload 'eww-open-file "eww" "\ @@ -14456,7 +14547,7 @@ CLEAN is obsolete and ignored. (autoload 'gnus-article-prepare-display "gnus-art" "\ Make the current buffer look like a nice article." nil nil) -(register-definition-prefixes "gnus-art" '("article-" "gnus-")) +(register-definition-prefixes "gnus-art" '(":keymap" "article-" "gnus-")) ;;;*** @@ -14764,7 +14855,7 @@ The arguments have the same meaning as those of \(fn IDS &optional WINDOW-CONF)" t nil) -(register-definition-prefixes "gnus-group" '("gnus-")) +(register-definition-prefixes "gnus-group" '(":keymap" "gnus-")) ;;;*** @@ -14991,7 +15082,7 @@ Like `message-reply'. (define-mail-user-agent 'gnus-user-agent 'gnus-msg-mail 'message-send-and-exit 'message-kill-buffer 'message-send-hook) -(register-definition-prefixes "gnus-msg" '("gnus-")) +(register-definition-prefixes "gnus-msg" '(":prefix" "gnus-")) ;;;*** @@ -15205,7 +15296,7 @@ BOOKMARK is a bookmark name or a bookmark record. \(fn BOOKMARK)" nil nil) -(register-definition-prefixes "gnus-sum" '("gnus-")) +(register-definition-prefixes "gnus-sum" '(":keymap" "gnus-")) ;;;*** @@ -16232,6 +16323,11 @@ gives the window that lists the options.") ;;;### (autoloads nil "help-mode" "help-mode.el" (0 0 0 0)) ;;; Generated autoloads from help-mode.el +(autoload 'help-mode--add-function-link "help-mode" "\ + + +\(fn STR FUN)" nil nil) + (autoload 'help-mode "help-mode" "\ Major mode for viewing help text and navigating references in it. Entry to this mode runs the normal hook `help-mode-hook'. @@ -18256,7 +18352,11 @@ specifying the X and Y positions and WIDTH and HEIGHT of image area to insert. A float value 0.0 - 1.0 means relative to the width or height of the image; integer values are taken as pixel values. -\(fn IMAGE &optional STRING AREA SLICE)" nil nil) +Normally `isearch' is able to search for STRING in the buffer +even if it's hidden behind a displayed image. If INHIBIT-ISEARCH +is non-nil, this is inhibited. + +\(fn IMAGE &optional STRING AREA SLICE INHIBIT-ISEARCH)" nil nil) (autoload 'insert-sliced-image "image" "\ Insert IMAGE into current buffer at point. @@ -18325,6 +18425,8 @@ Example: (function-put 'defimage 'doc-string-elt '3) +(function-put 'defimage 'lisp-indent-function 'defun) + (autoload 'imagemagick-register-types "image" "\ Register file types that can be handled by ImageMagick. This function is called at startup, after loading the init file. @@ -18337,6 +18439,9 @@ recognizes these files as having image type `imagemagick'. If Emacs is compiled without ImageMagick support, this does nothing." nil nil) +(autoload 'image-at-point-p "image" "\ +Return non-nil if there is an image at point." nil nil) + (register-definition-prefixes "image" '("find-image--cache" "image" "unknown-image-type")) ;;;*** @@ -18406,17 +18511,19 @@ thumbnail buffer to be selected. \(fn &optional ARG APPEND DO-NOT-POP)" t nil) (autoload 'image-dired-show-all-from-dir "image-dired" "\ -Make a preview buffer for all images in DIR and display it. -If the number of files in DIR matching `image-file-name-regexp' -exceeds `image-dired-show-all-from-dir-max-files', a warning will be -displayed. +Make a thumbnail buffer for all images in DIR and display it. +Any file matching `image-file-name-regexp' is considered an image +file. + +If the number of image files in DIR exceeds +`image-dired-show-all-from-dir-max-files', ask for confirmation +before creating the thumbnail buffer. If that variable is nil, +never ask for confirmation. \(fn DIR)" t nil) (defalias 'image-dired 'image-dired-show-all-from-dir) -(define-obsolete-function-alias 'tumme 'image-dired "24.4") - (autoload 'image-dired-tag-files "image-dired" "\ Tag marked file(s) in Dired. With prefix ARG, tag file at point. @@ -18434,7 +18541,7 @@ Jump to thumbnail buffer." t nil) (autoload 'image-dired-minor-mode "image-dired" "\ Setup easy-to-use keybindings for the commands to be used in Dired mode. Note that n, p and <down> and <up> will be hijacked and bound to -`image-dired-dired-x-line'. +`image-dired-dired-next-line' and `image-dired-dired-previous-line'. This is a minor mode. If called interactively, toggle the `Image-Dired minor mode' mode. If the prefix argument is positive, @@ -18452,8 +18559,6 @@ disabled. \(fn &optional ARG)" t nil) -(define-obsolete-function-alias 'image-dired-setup-dired-keybindings 'image-dired-minor-mode "26.1") - (autoload 'image-dired-display-thumbs-append "image-dired" "\ Append thumbnails to `image-dired-thumbnail-buffer'." t nil) @@ -18486,6 +18591,15 @@ Edit comment and tags of current or marked image files. Edit comment and tags for all marked image files in an easy-to-use form." t nil) +(autoload 'image-dired-bookmark-jump "image-dired" "\ +Default bookmark handler for Image-Dired buffers. + +\(fn BOOKMARK)" nil nil) + +(define-obsolete-function-alias 'tumme #'image-dired "24.4") + +(define-obsolete-function-alias 'image-dired-setup-dired-keybindings #'image-dired-minor-mode "26.1") + (register-definition-prefixes "image-dired" '("image-dired-")) ;;;*** @@ -18493,7 +18607,7 @@ easy-to-use form." t nil) ;;;### (autoloads nil "image-file" "image-file.el" (0 0 0 0)) ;;; Generated autoloads from image-file.el -(defvar image-file-name-extensions (purecopy '("png" "jpeg" "jpg" "gif" "tiff" "tif" "xbm" "xpm" "pbm" "pgm" "ppm" "pnm" "svg")) "\ +(defvar image-file-name-extensions (purecopy '("png" "jpeg" "jpg" "gif" "tiff" "tif" "xbm" "xpm" "pbm" "pgm" "ppm" "pnm" "svg" "webp")) "\ A list of image-file filename extensions. Filenames having one of these extensions are considered image files, in addition to those matching `image-file-name-regexps'. @@ -19440,24 +19554,24 @@ Display a list of the options available when a misspelling is encountered. 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." nil nil) +\\`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 nil) (autoload 'ispell-kill-ispell "ispell" "\ Kill current Ispell process (so that you may start a fresh one). @@ -19564,8 +19678,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: @@ -19725,7 +19839,7 @@ one of the aforementioned options instead of using this mode. (dolist (name (list "node" "nodejs" "gjs" "rhino")) (add-to-list 'interpreter-mode-alist (cons (purecopy name) 'js-mode))) -(register-definition-prefixes "js" '("js-" "with-js")) +(register-definition-prefixes "js" '("js-")) ;;;*** @@ -20922,6 +21036,12 @@ current header, calls `mail-complete-function' and passes prefix ARG if any. ;;;### (autoloads nil "mailcap" "net/mailcap.el" (0 0 0 0)) ;;; Generated autoloads from net/mailcap.el +(autoload 'mailcap-mime-type-to-extension "mailcap" "\ +Return a file name extension based on a MIME-TYPE. +For instance, `image/png' will result in `png'. + +\(fn MIME-TYPE)" nil nil) + (register-definition-prefixes "mailcap" '("mailcap-")) ;;;*** @@ -21659,7 +21779,7 @@ perform the operation on all messages in that region. \(fn)" t nil) -(register-definition-prefixes "mh-folder" '("mh-")) +(register-definition-prefixes "mh-folder" '(":keymap" "mh-")) ;;;*** @@ -21695,7 +21815,7 @@ perform the operation on all messages in that region. ;;;### (autoloads nil "mh-letter" "mh-e/mh-letter.el" (0 0 0 0)) ;;; Generated autoloads from mh-e/mh-letter.el -(register-definition-prefixes "mh-letter" '("mh-")) +(register-definition-prefixes "mh-letter" '(":keymap" "mh-")) ;;;*** @@ -21730,7 +21850,7 @@ perform the operation on all messages in that region. ;;;### (autoloads nil "mh-search" "mh-e/mh-search.el" (0 0 0 0)) ;;; Generated autoloads from mh-e/mh-search.el -(register-definition-prefixes "mh-search" '("mh-")) +(register-definition-prefixes "mh-search" '(":keymap" "mh-")) ;;;*** @@ -21744,14 +21864,14 @@ perform the operation on all messages in that region. ;;;### (autoloads nil "mh-show" "mh-e/mh-show.el" (0 0 0 0)) ;;; Generated autoloads from mh-e/mh-show.el -(register-definition-prefixes "mh-show" '("mh-")) +(register-definition-prefixes "mh-show" '(":keymap" "mh-")) ;;;*** ;;;### (autoloads nil "mh-speed" "mh-e/mh-speed.el" (0 0 0 0)) ;;; Generated autoloads from mh-e/mh-speed.el -(register-definition-prefixes "mh-speed" '("mh-")) +(register-definition-prefixes "mh-speed" '(":keymap" "mh-")) ;;;*** @@ -22214,6 +22334,8 @@ specifies how the attachment is intended to be displayed. It can be either \"inline\" (displayed automatically within the message body) or \"attachment\" (separate from the body). +Also see the `mml-attach-file-at-the-end' variable. + If given a prefix interactively, no prompting will be done for the TYPE, DESCRIPTION or DISPOSITION values. Instead defaults will be computed and used. @@ -25758,6 +25880,14 @@ they are not by default assigned to keys." t nil) ;;;*** +;;;### (autoloads nil "pixel-fill" "textmodes/pixel-fill.el" (0 0 +;;;;;; 0 0)) +;;; Generated autoloads from textmodes/pixel-fill.el + +(register-definition-prefixes "pixel-fill" '("pixel-fill-")) + +;;;*** + ;;;### (autoloads nil "pixel-scroll" "pixel-scroll.el" (0 0 0 0)) ;;; Generated autoloads from pixel-scroll.el @@ -25790,6 +25920,38 @@ disabled. \(fn &optional ARG)" t nil) +(defvar pixel-scroll-precision-mode nil "\ +Non-nil if Pixel-Scroll-Precision mode is enabled. +See the `pixel-scroll-precision-mode' command +for a description of this minor mode. +Setting this variable directly does not take effect; +either customize it (see the info node `Easy Customization') +or call the function `pixel-scroll-precision-mode'.") + +(custom-autoload 'pixel-scroll-precision-mode "pixel-scroll" nil) + +(autoload 'pixel-scroll-precision-mode "pixel-scroll" "\ +Toggle pixel scrolling. +When enabled, this minor mode allows to scroll the display +precisely, according to the turning of the mouse wheel. + +This is a minor mode. If called interactively, toggle the +`Pixel-Scroll-Precision mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable the +mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the +mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='pixel-scroll-precision-mode)'. + +The mode's hook is called both when the mode is enabled and when it is +disabled. + +\(fn &optional ARG)" t nil) + (register-definition-prefixes "pixel-scroll" '("pixel-")) ;;;*** @@ -25870,10 +26032,26 @@ Prettify the current buffer with printed representation of a Lisp object." t nil Output the pretty-printed representation of OBJECT, any Lisp object. Quoting characters are printed as needed to make output that `read' can handle, whenever this is possible. + +This function does not apply special formatting rules for Emacs +Lisp code. See `pp-emacs-lisp-code' instead. + +By default, this function won't limit the line length of lists +and vectors. Bind `pp-use-max-width' to a non-nil value to do so. + Output stream is STREAM, or value of `standard-output' (which see). \(fn OBJECT &optional STREAM)" nil nil) +(autoload 'pp-display-expression "pp" "\ +Prettify and display EXPRESSION in an appropriate way, depending on length. +If LISP, format with `pp-emacs-lisp-code'; use `pp' otherwise. + +If a temporary buffer is needed for representation, it will be named +after OUT-BUFFER-NAME. + +\(fn EXPRESSION OUT-BUFFER-NAME &optional LISP)" nil nil) + (autoload 'pp-eval-expression "pp" "\ Evaluate EXPRESSION and pretty-print its value. Also add the value to the front of the list in the variable `values'. @@ -25899,6 +26077,12 @@ Ignores leading comment characters. \(fn ARG)" t nil) +(autoload 'pp-emacs-lisp-code "pp" "\ +Insert SEXP into the current buffer, formatted as Emacs Lisp code. +Use the `pp-max-width' variable to control the desired line length. + +\(fn SEXP)" nil nil) + (register-definition-prefixes "pp" '("pp-")) ;;;*** @@ -26573,13 +26757,25 @@ pattern to search for. Visit a file (with completion) in the current project. The filename at point (determined by `thing-at-point'), if any, -is available as part of \"future history\"." t nil) +is available as part of \"future history\". + +If INCLUDE-ALL is non-nil, or with prefix argument when called +interactively, include all files under the project root, except +for VCS directories listed in `vc-directory-exclusion-list'. + +\(fn &optional INCLUDE-ALL)" t nil) (autoload 'project-or-external-find-file "project" "\ Visit a file (with completion) in the current project or external roots. The filename at point (determined by `thing-at-point'), if any, -is available as part of \"future history\"." t nil) +is available as part of \"future history\". + +If INCLUDE-ALL is non-nil, or with prefix argument when called +interactively, include all files under the project root, except +for VCS directories listed in `vc-directory-exclusion-list'. + +\(fn &optional INCLUDE-ALL)" t nil) (autoload 'project-find-dir "project" "\ Start Dired in a directory inside the current project." t nil) @@ -27536,11 +27732,11 @@ If ARG is non-nil, instead prompt for connection parameters. (autoload 'rcirc-connect "rcirc" "\ 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. -\(fn SERVER &optional PORT NICK USER-NAME FULL-NAME STARTUP-CHANNELS PASSWORD ENCRYPTION SERVER-ALIAS)" nil nil) +\(fn SERVER &optional PORT NICK USER-NAME FULL-NAME STARTUP-CHANNELS PASSWORD ENCRYPTION CERTFP SERVER-ALIAS)" nil nil) (defvar rcirc-track-minor-mode nil "\ Non-nil if Rcirc-Track minor mode is enabled. @@ -30272,6 +30468,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-")) ;;;*** @@ -30608,7 +30827,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")) ;;;*** @@ -30748,6 +30967,8 @@ SKELETON is as defined under `skeleton-insert'. (function-put 'define-skeleton 'doc-string-elt '2) +(function-put 'define-skeleton 'lisp-indent-function 'defun) + (autoload 'skeleton-proxy-new "skeleton" "\ Insert SKELETON. Prefix ARG allows wrapping around words or regions (see `skeleton-insert'). @@ -31460,7 +31681,7 @@ installed through `spam-necessary-extra-headers'. \(fn &rest SYMBOLS)" t nil) -(register-definition-prefixes "spam" '("spam-")) +(register-definition-prefixes "spam" '(":keymap" "spam-")) ;;;*** @@ -32344,7 +32565,43 @@ If OMIT-NULLS, empty lines will be removed from the results. \(fn STRING &optional OMIT-NULLS)" nil nil) -(register-definition-prefixes "subr-x" '("and-let*" "hash-table-" "if-let*" "internal--" "named-let" "replace-region-contents" "string-" "thread-" "when-let*")) +(autoload 'ensure-empty-lines "subr-x" "\ +Ensure that there are LINES number of empty lines before point. +If LINES is nil or omitted, ensure that there is a single empty +line before point. + +If called interactively, LINES is given by the prefix argument. + +If there are more than LINES empty lines before point, the number +of empty lines is reduced to LINES. + +If point is not at the beginning of a line, a newline character +is inserted before adjusting the number of empty lines. + +\(fn &optional LINES)" t nil) + +(autoload 'string-pixel-width "subr-x" "\ +Return the width of STRING in pixels. + +\(fn STRING)" nil nil) + +(autoload 'string-glyph-split "subr-x" "\ +Split STRING into a list of strings representing separate glyphs. +This takes into account combining characters and grapheme clusters. + +\(fn STRING)" nil nil) + +(autoload 'add-display-text-property "subr-x" "\ +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. + +\(fn START END PROP VALUE &optional OBJECT)" nil nil) + +(register-definition-prefixes "subr-x" '("and-let*" "hash-table-" "if-let*" "internal--" "named-let" "replace-region-contents" "string-" "thread-" "when-let*" "with-memoization")) ;;;*** @@ -34978,7 +35235,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-")) ;;;*** @@ -35064,7 +35321,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-")) @@ -35387,65 +35644,25 @@ 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. - -\(fn FROM TO)" t nil) - -(autoload 'ucs-normalize-NFD-string "ucs-normalize" "\ -Normalize the string STR by the Unicode NFD. - -\(fn STR)" nil nil) - -(autoload 'ucs-normalize-NFC-region "ucs-normalize" "\ -Normalize the current region by the Unicode NFC. - -\(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. +(autoload 'string-glyph-compose "ucs-normalize" "\ +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: -\(fn STR)" nil nil) + (string-glyph-compose \"Å\") => \"Å\" -(autoload 'ucs-normalize-HFS-NFC-region "ucs-normalize" "\ -Normalize the current region by the Unicode NFC and Mac OS's HFS Plus. +\(fn STRING)" nil nil) -\(fn FROM TO)" t nil) +(autoload 'string-glyph-decompose "ucs-normalize" "\ +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: -(autoload 'ucs-normalize-HFS-NFC-string "ucs-normalize" "\ -Normalize the string STR by the Unicode NFC and Mac OS's HFS Plus. + (ucs-normalize-NFD-string \"Å\") => \"Å\" -\(fn STR)" nil nil) +\(fn STRING)" nil nil) (register-definition-prefixes "ucs-normalize" '("ucs-normalize-" "utf-8-hfs")) @@ -36309,7 +36526,7 @@ Report an ERROR that occurred while unlocking a file. \(fn ERROR)" nil nil) -(register-definition-prefixes "userlock" '("ask-user-about-" "file-" "userlock--")) +(register-definition-prefixes "userlock" '("ask-user-about-" "file-" "userlock--check-content-unchanged")) ;;;*** @@ -36439,6 +36656,10 @@ For old-style locking-based version control systems, like RCS: If every file is locked by you and unchanged, unlock them. If every file is locked by someone else, offer to steal the lock. +When using this command to register a new file (or files), it +will automatically deduce which VC repository to register it +with, using the most specific one. + \(fn VERBOSE)" t nil) (autoload 'vc-register "vc" "\ @@ -37093,7 +37314,7 @@ Key bindings: ;;;### (autoloads nil "verilog-mode" "progmodes/verilog-mode.el" ;;;;;; (0 0 0 0)) ;;; Generated autoloads from progmodes/verilog-mode.el -(push (purecopy '(verilog-mode 2021 9 23 89128420)) package--builtin-versions) +(push (purecopy '(verilog-mode 2021 10 14 127365406)) package--builtin-versions) (autoload 'verilog-mode "verilog-mode" "\ Major mode for editing Verilog code. @@ -39018,7 +39239,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'. \(fn &optional PREFIX MODIFIERS)" t nil) @@ -39241,15 +39462,24 @@ If LIMIT is non-nil, then do not consider characters beyond LIMIT. ;;;### (autoloads nil "xref" "progmodes/xref.el" (0 0 0 0)) ;;; Generated autoloads from progmodes/xref.el -(push (purecopy '(xref 1 3 0)) package--builtin-versions) +(push (purecopy '(xref 1 3 2)) package--builtin-versions) (autoload 'xref-find-backend "xref" nil nil nil) -(autoload 'xref-pop-marker-stack "xref" "\ -Pop back to where \\[xref-find-definitions] was last invoked." t nil) +(define-obsolete-function-alias 'xref-pop-marker-stack #'xref-go-back "29.1") + +(autoload 'xref-go-back "xref" "\ +Go back to the previous position in xref history. +To undo, use \\[xref-go-forward]." t nil) + +(autoload 'xref-go-forward "xref" "\ +Got to the point where a previous \\[xref-go-back] was invoked." t nil) (autoload 'xref-marker-stack-empty-p "xref" "\ -Return t if the marker stack is empty; nil otherwise." nil nil) +Whether the xref back-history is empty." nil nil) + +(autoload 'xref-forward-history-empty-p "xref" "\ +Whether the xref forward-history is empty." nil nil) (autoload 'xref-find-definitions "xref" "\ Find the definition of the identifier at point. @@ -39261,7 +39491,7 @@ definition for IDENTIFIER, display it in the selected window. Otherwise, display the list of the possible definitions in a buffer where the user can select from the list. -Use \\[xref-pop-marker-stack] to return back to where you invoked this command. +Use \\[xref-go-back] to return back to where you invoked this command. \(fn IDENTIFIER)" t nil) @@ -39305,7 +39535,8 @@ output of this command when the backend is etags. \(fn PATTERN)" t nil) (define-key esc-map "." #'xref-find-definitions) - (define-key esc-map "," #'xref-pop-marker-stack) + (define-key esc-map "," #'xref-go-back) + (define-key esc-map [?\C-,] #'xref-go-forward) (define-key esc-map "?" #'xref-find-references) (define-key esc-map [?\C-.] #'xref-find-apropos) (define-key ctl-x-4-map "." #'xref-find-definitions-other-window) @@ -39415,6 +39646,33 @@ Interactively, URL defaults to the string looking like a url around point. ;;;*** +;;;### (autoloads nil "yank-media" "yank-media.el" (0 0 0 0)) +;;; Generated autoloads from yank-media.el + +(autoload 'yank-media "yank-media" "\ +Yank media (images, HTML and the like) from the clipboard. +This command depends on the current major mode having support for +accepting the media type. The mode has to register itself using +the `yank-media-handler' mechanism. + +Also see `yank-media-types' for a command that lets you explore +all the different selection types." t nil) + +(autoload 'yank-media-handler "yank-media" "\ +Register HANDLER for dealing with `yank-media' actions for TYPES. +TYPES should be a MIME media type symbol, a regexp, or a list +that can contain both symbols and regexps. + +HANDLER is a function that will be called with two arguments: The +MIME type (a symbol on the form `image/png') and the selection +data (a string). + +\(fn TYPES HANDLER)" nil nil) + +(register-definition-prefixes "yank-media" '("yank-media-")) + +;;;*** + ;;;### (autoloads nil "yenc" "mail/yenc.el" (0 0 0 0)) ;;; Generated autoloads from mail/yenc.el @@ -39449,12 +39707,10 @@ Zone out, completely." t nil) ;;;### (autoloads nil nil ("abbrev.el" "bindings.el" "buff-menu.el" ;;;;;; "button.el" "calc/calc-aent.el" "calc/calc-embed.el" "calc/calc-misc.el" -;;;;;; "calc/calc-yank.el" "calendar/cal-loaddefs.el" "calendar/diary-loaddefs.el" -;;;;;; "calendar/hol-loaddefs.el" "case-table.el" "cedet/ede/base.el" -;;;;;; "cedet/ede/config.el" "cedet/ede/cpp-root.el" "cedet/ede/custom.el" -;;;;;; "cedet/ede/dired.el" "cedet/ede/emacs.el" "cedet/ede/files.el" -;;;;;; "cedet/ede/generic.el" "cedet/ede/linux.el" "cedet/ede/locate.el" -;;;;;; "cedet/ede/make.el" "cedet/ede/shell.el" "cedet/ede/speedbar.el" +;;;;;; "calc/calc-yank.el" "case-table.el" "cedet/ede/cpp-root.el" +;;;;;; "cedet/ede/custom.el" "cedet/ede/dired.el" "cedet/ede/emacs.el" +;;;;;; "cedet/ede/files.el" "cedet/ede/generic.el" "cedet/ede/linux.el" +;;;;;; "cedet/ede/locate.el" "cedet/ede/make.el" "cedet/ede/speedbar.el" ;;;;;; "cedet/ede/system.el" "cedet/ede/util.el" "cedet/semantic/analyze.el" ;;;;;; "cedet/semantic/analyze/complete.el" "cedet/semantic/analyze/refs.el" ;;;;;; "cedet/semantic/bovine.el" "cedet/semantic/bovine/c-by.el" @@ -39486,8 +39742,8 @@ Zone out, completely." t nil) ;;;;;; "cedet/srecode/insert.el" "cedet/srecode/java.el" "cedet/srecode/map.el" ;;;;;; "cedet/srecode/mode.el" "cedet/srecode/srt-wy.el" "cedet/srecode/srt.el" ;;;;;; "cedet/srecode/template.el" "cedet/srecode/texi.el" "composite.el" -;;;;;; "cus-face.el" "cus-start.el" "custom.el" "dired-aux.el" "dired-x.el" -;;;;;; "electric.el" "emacs-lisp/backquote.el" "emacs-lisp/byte-run.el" +;;;;;; "cus-face.el" "cus-load.el" "cus-start.el" "custom.el" "dired-aux.el" +;;;;;; "dired-x.el" "electric.el" "emacs-lisp/backquote.el" "emacs-lisp/byte-run.el" ;;;;;; "emacs-lisp/cl-extra.el" "emacs-lisp/cl-macs.el" "emacs-lisp/cl-preloaded.el" ;;;;;; "emacs-lisp/cl-seq.el" "emacs-lisp/easymenu.el" "emacs-lisp/eieio-compat.el" ;;;;;; "emacs-lisp/eieio-custom.el" "emacs-lisp/eieio-opt.el" "emacs-lisp/float-sup.el" @@ -39509,44 +39765,46 @@ Zone out, completely." t nil) ;;;;;; "eshell/em-ls.el" "eshell/em-pred.el" "eshell/em-prompt.el" ;;;;;; "eshell/em-rebind.el" "eshell/em-script.el" "eshell/em-smart.el" ;;;;;; "eshell/em-term.el" "eshell/em-tramp.el" "eshell/em-unix.el" -;;;;;; "eshell/em-xtra.el" "faces.el" "files.el" "font-core.el" -;;;;;; "font-lock.el" "format.el" "frame.el" "help.el" "hfy-cmap.el" -;;;;;; "ibuf-ext.el" "indent.el" "international/characters.el" "international/charprop.el" +;;;;;; "eshell/em-xtra.el" "eshell/esh-groups.el" "faces.el" "files.el" +;;;;;; "finder-inf.el" "font-core.el" "font-lock.el" "format.el" +;;;;;; "frame.el" "help.el" "hfy-cmap.el" "ibuf-ext.el" "indent.el" +;;;;;; "international/characters.el" "international/charprop.el" ;;;;;; "international/charscript.el" "international/cp51932.el" -;;;;;; "international/emoji-zwj.el" "international/eucjp-ms.el" -;;;;;; "international/iso-transl.el" "international/mule-cmds.el" -;;;;;; "international/mule-conf.el" "international/mule.el" "international/uni-bidi.el" -;;;;;; "international/uni-brackets.el" "international/uni-category.el" -;;;;;; "international/uni-combining.el" "international/uni-comment.el" -;;;;;; "international/uni-decimal.el" "international/uni-decomposition.el" -;;;;;; "international/uni-digit.el" "international/uni-lowercase.el" -;;;;;; "international/uni-mirrored.el" "international/uni-name.el" -;;;;;; "international/uni-numeric.el" "international/uni-old-name.el" -;;;;;; "international/uni-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" -;;;;;; "language/chinese.el" "language/cyrillic.el" "language/czech.el" -;;;;;; "language/english.el" "language/ethiopic.el" "language/european.el" -;;;;;; "language/georgian.el" "language/greek.el" "language/hebrew.el" -;;;;;; "language/indian.el" "language/japanese.el" "language/khmer.el" -;;;;;; "language/korean.el" "language/lao.el" "language/misc-lang.el" -;;;;;; "language/romanian.el" "language/sinhala.el" "language/slovak.el" -;;;;;; "language/tai-viet.el" "language/thai.el" "language/tibetan.el" -;;;;;; "language/utf-8-lang.el" "language/vietnamese.el" "ldefs-boot.el" -;;;;;; "leim/ja-dic/ja-dic.el" "leim/leim-list.el" "leim/quail/4Corner.el" -;;;;;; "leim/quail/ARRAY30.el" "leim/quail/CCDOSPY.el" "leim/quail/CTLau-b5.el" -;;;;;; "leim/quail/CTLau.el" "leim/quail/ECDICT.el" "leim/quail/ETZY.el" -;;;;;; "leim/quail/PY-b5.el" "leim/quail/PY.el" "leim/quail/Punct-b5.el" -;;;;;; "leim/quail/Punct.el" "leim/quail/QJ-b5.el" "leim/quail/QJ.el" -;;;;;; "leim/quail/SW.el" "leim/quail/TONEPY.el" "leim/quail/ZIRANMA.el" -;;;;;; "leim/quail/ZOZY.el" "leim/quail/arabic.el" "leim/quail/cham.el" -;;;;;; "leim/quail/compose.el" "leim/quail/croatian.el" "leim/quail/cyril-jis.el" -;;;;;; "leim/quail/cyrillic.el" "leim/quail/czech.el" "leim/quail/georgian.el" -;;;;;; "leim/quail/greek.el" "leim/quail/hanja-jis.el" "leim/quail/hanja.el" -;;;;;; "leim/quail/hanja3.el" "leim/quail/hebrew.el" "leim/quail/ipa-praat.el" -;;;;;; "leim/quail/latin-alt.el" "leim/quail/latin-ltx.el" "leim/quail/latin-post.el" -;;;;;; "leim/quail/latin-pre.el" "leim/quail/persian.el" "leim/quail/programmer-dvorak.el" +;;;;;; "international/emoji-labels.el" "international/emoji-zwj.el" +;;;;;; "international/eucjp-ms.el" "international/iso-transl.el" +;;;;;; "international/mule-cmds.el" "international/mule-conf.el" +;;;;;; "international/mule.el" "international/uni-bidi.el" "international/uni-brackets.el" +;;;;;; "international/uni-category.el" "international/uni-combining.el" +;;;;;; "international/uni-comment.el" "international/uni-decimal.el" +;;;;;; "international/uni-decomposition.el" "international/uni-digit.el" +;;;;;; "international/uni-lowercase.el" "international/uni-mirrored.el" +;;;;;; "international/uni-name.el" "international/uni-numeric.el" +;;;;;; "international/uni-old-name.el" "international/uni-special-lowercase.el" +;;;;;; "international/uni-special-titlecase.el" "international/uni-special-uppercase.el" +;;;;;; "international/uni-titlecase.el" "international/uni-uppercase.el" +;;;;;; "isearch.el" "jit-lock.el" "jka-cmpr-hook.el" "keymap.el" +;;;;;; "language/burmese.el" "language/cham.el" "language/chinese.el" +;;;;;; "language/cyrillic.el" "language/czech.el" "language/english.el" +;;;;;; "language/ethiopic.el" "language/european.el" "language/georgian.el" +;;;;;; "language/greek.el" "language/hebrew.el" "language/indian.el" +;;;;;; "language/japanese.el" "language/khmer.el" "language/korean.el" +;;;;;; "language/lao.el" "language/misc-lang.el" "language/romanian.el" +;;;;;; "language/sinhala.el" "language/slovak.el" "language/tai-viet.el" +;;;;;; "language/thai.el" "language/tibetan.el" "language/utf-8-lang.el" +;;;;;; "language/vietnamese.el" "ldefs-boot.el" "leim/ja-dic/ja-dic.el" +;;;;;; "leim/leim-list.el" "leim/quail/4Corner.el" "leim/quail/ARRAY30.el" +;;;;;; "leim/quail/CCDOSPY.el" "leim/quail/CTLau-b5.el" "leim/quail/CTLau.el" +;;;;;; "leim/quail/ECDICT.el" "leim/quail/ETZY.el" "leim/quail/PY-b5.el" +;;;;;; "leim/quail/PY.el" "leim/quail/Punct-b5.el" "leim/quail/Punct.el" +;;;;;; "leim/quail/QJ-b5.el" "leim/quail/QJ.el" "leim/quail/SW.el" +;;;;;; "leim/quail/TONEPY.el" "leim/quail/ZIRANMA.el" "leim/quail/ZOZY.el" +;;;;;; "leim/quail/arabic.el" "leim/quail/cham.el" "leim/quail/compose.el" +;;;;;; "leim/quail/croatian.el" "leim/quail/cyril-jis.el" "leim/quail/cyrillic.el" +;;;;;; "leim/quail/czech.el" "leim/quail/georgian.el" "leim/quail/greek.el" +;;;;;; "leim/quail/hanja-jis.el" "leim/quail/hanja.el" "leim/quail/hanja3.el" +;;;;;; "leim/quail/hebrew.el" "leim/quail/ipa-praat.el" "leim/quail/latin-alt.el" +;;;;;; "leim/quail/latin-ltx.el" "leim/quail/latin-post.el" "leim/quail/latin-pre.el" +;;;;;; "leim/quail/persian.el" "leim/quail/programmer-dvorak.el" ;;;;;; "leim/quail/py-punct.el" "leim/quail/pypunct-b5.el" "leim/quail/quick-b5.el" ;;;;;; "leim/quail/quick-cns.el" "leim/quail/rfc1345.el" "leim/quail/sami.el" ;;;;;; "leim/quail/sgml-input.el" "leim/quail/slovak.el" "leim/quail/symbol-ksc.el" @@ -39555,14 +39813,13 @@ Zone out, completely." t nil) ;;;;;; "loadup.el" "mail/blessmail.el" "mail/rmailedit.el" "mail/rmailkwd.el" ;;;;;; "mail/rmailmm.el" "mail/rmailmsc.el" "mail/rmailsort.el" ;;;;;; "mail/rmailsum.el" "mail/undigest.el" "menu-bar.el" "mh-e/mh-gnus.el" -;;;;;; "mh-e/mh-loaddefs.el" "minibuffer.el" "mouse.el" "net/tramp-loaddefs.el" -;;;;;; "newcomment.el" "obarray.el" "org/ob-core.el" "org/ob-lob.el" -;;;;;; "org/ob-matlab.el" "org/ob-tangle.el" "org/ob.el" "org/ol-bbdb.el" -;;;;;; "org/ol-irc.el" "org/ol.el" "org/org-archive.el" "org/org-attach.el" -;;;;;; "org/org-clock.el" "org/org-colview.el" "org/org-compat.el" -;;;;;; "org/org-datetree.el" "org/org-duration.el" "org/org-element.el" -;;;;;; "org/org-feed.el" "org/org-footnote.el" "org/org-goto.el" -;;;;;; "org/org-id.el" "org/org-indent.el" "org/org-install.el" +;;;;;; "minibuffer.el" "mouse.el" "newcomment.el" "obarray.el" "org/ob-core.el" +;;;;;; "org/ob-lob.el" "org/ob-matlab.el" "org/ob-tangle.el" "org/ob.el" +;;;;;; "org/ol-bbdb.el" "org/ol-irc.el" "org/ol.el" "org/org-archive.el" +;;;;;; "org/org-attach.el" "org/org-clock.el" "org/org-colview.el" +;;;;;; "org/org-compat.el" "org/org-datetree.el" "org/org-duration.el" +;;;;;; "org/org-element.el" "org/org-feed.el" "org/org-footnote.el" +;;;;;; "org/org-goto.el" "org/org-id.el" "org/org-indent.el" "org/org-install.el" ;;;;;; "org/org-keys.el" "org/org-lint.el" "org/org-list.el" "org/org-macs.el" ;;;;;; "org/org-mobile.el" "org/org-num.el" "org/org-plot.el" "org/org-refile.el" ;;;;;; "org/org-table.el" "org/org-timer.el" "org/ox-ascii.el" "org/ox-beamer.el" diff --git a/lisp/leim/quail/hangul.el b/lisp/leim/quail/hangul.el index c03e86b33c0..d069b5b68e1 100644 --- a/lisp/leim/quail/hangul.el +++ b/lisp/leim/quail/hangul.el @@ -429,7 +429,7 @@ When a Korean input method is off, convert the following hangul character." (hangul3-input-method-jong char)) (t (setq hangul-queue (make-vector 6 0)) - (insert (decode-char 'ucs char)) + (insert char) (move-overlay quail-overlay (point) (point)))))) (defun hangul3-input-method (key) @@ -476,7 +476,7 @@ When a Korean input method is off, convert the following hangul character." (hangul3-input-method-jong char)) (t (setq hangul-queue (make-vector 6 0)) - (insert (decode-char 'ucs char)) + (insert char) (move-overlay quail-overlay (point) (point)))))) (defun hangul390-input-method (key) diff --git a/lisp/leim/quail/ipa.el b/lisp/leim/quail/ipa.el index c25687574ed..ba6ea938425 100644 --- a/lisp/leim/quail/ipa.el +++ b/lisp/leim/quail/ipa.el @@ -278,10 +278,10 @@ string." (list (apply #'vector (mapcar - #'(lambda (entry) - (cl-assert (char-or-string-p entry) t) - (format "%s%s" to-prepend - (if (integerp entry) (string entry) entry))) + (lambda (entry) + (cl-assert (char-or-string-p entry) t) + (format "%s%s" to-prepend + (if (integerp entry) (string entry) entry))) quail-keymap)))) (defun ipa-x-sampa-underscore-implosive (input-string length) diff --git a/lisp/leim/quail/latin-post.el b/lisp/leim/quail/latin-post.el index 8329fff82ed..0e1afba1a34 100644 --- a/lisp/leim/quail/latin-post.el +++ b/lisp/leim/quail/latin-post.el @@ -215,7 +215,15 @@ Doubling the postfix separates the letter and postfix: e.g. a\\='\\=' -> a\\=' others | / | s/ -> ß Doubling the postfix separates the letter and postfix: e.g. a\\='\\=' -> a\\=' -" nil t nil nil nil nil nil nil nil nil t) +" + '(("\C-?" . quail-delete-last-char) + (">" . quail-next-translation) + ("\C-f" . quail-next-translation) + ([right] . quail-next-translation) + ("<" . quail-prev-translation) + ("\C-b" . quail-prev-translation) + ([left] . quail-prev-translation)) + t nil nil nil nil nil nil nil nil t) (quail-define-rules ("A'" ?Á) @@ -246,9 +254,9 @@ Doubling the postfix separates the letter and postfix: e.g. a\\='\\=' -> a\\=' ("R'" ?Ŕ) ("R~" ?Ř) ("S'" ?Ś) - ("S," ?Ş) + ("S," "ŞȘ") ; the second variant is for Romanian ("S~" ?Š) - ("T," ?Ţ) + ("T," "ŢȚ") ; the second variant is for Romanian ("T~" ?Ť) ("U'" ?Ú) ("U:" ?Ű) @@ -286,10 +294,10 @@ Doubling the postfix separates the letter and postfix: e.g. a\\='\\=' -> a\\=' ("r'" ?ŕ) ("r~" ?ř) ("s'" ?ś) - ("s," ?ş) + ("s," "şș") ; the second variant is for Romanian ("s/" ?ß) ("s~" ?š) - ("t," ?ţ) + ("t," "ţț") ; the second variant is for Romanian ("t~" ?ť) ("u'" ?ú) ("u:" ?ű) diff --git a/lisp/leim/quail/latin-pre.el b/lisp/leim/quail/latin-pre.el index 3b9c942a8c1..3492de5fbae 100644 --- a/lisp/leim/quail/latin-pre.el +++ b/lisp/leim/quail/latin-pre.el @@ -497,7 +497,15 @@ Key translation rules are: cedilla | \\=` | \\=`c -> ç \\=`e -> ?ę misc | \\=' \\=` ~ | \\='d -> đ \\=`l -> ł \\=`z -> ż ~o -> ő ~u -> ű symbol | ~ | \\=`. -> ˙ ~~ -> ˘ ~. -> ?¸ -" nil t nil nil nil nil nil nil nil nil t) +" + '(("\C-?" . quail-delete-last-char) + (">" . quail-next-translation) + ("\C-f" . quail-next-translation) + ([right] . quail-next-translation) + ("<" . quail-prev-translation) + ("\C-b" . quail-prev-translation) + ([left] . quail-prev-translation)) + t nil nil nil nil nil nil nil nil t) (quail-define-rules ("'A" ?Á) @@ -532,15 +540,15 @@ Key translation rules are: ("`C" ?Ç) ("`E" ?Ę) ("`L" ?Ł) - ("`S" ?Ş) - ("`T" ?Ţ) + ("`S" "ŞȘ") + ("`T" "ŢȚ") ; the second variant is for Romanian ("`Z" ?Ż) ("`a" ?ą) ("`l" ?ł) ("`c" ?ç) ("`e" ?ę) - ("`s" ?ş) - ("`t" ?ţ) + ("`s" "şș") + ("`t" "ţț") ; the second variant is for Romanian ("`z" ?ż) ("``" ?Ş) ("`." ?˙) diff --git a/lisp/loadup.el b/lisp/loadup.el index 4da0ff73851..b87c0550fc5 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 @@ -334,6 +340,13 @@ (load "international/mule-util") (load "international/ucs-normalize") (load "term/ns-win")))) +(if (featurep 'pgtk) + (progn + (load "term/common-win") + ;; Don't load ucs-normalize.el unless uni-*.el files were + ;; already produced, because it needs uni-*.el files that might + ;; not be built early enough during bootstrap. + (load "term/pgtk-win"))) (if (fboundp 'x-create-frame) ;; Do it after loading term/foo-win.el since the value of the ;; mouse-wheel-*-event vars depends on those files being loaded or not. @@ -559,6 +572,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/ls-lisp.el b/lisp/ls-lisp.el index 82153ff0adb..25d196392ab 100644 --- a/lisp/ls-lisp.el +++ b/lisp/ls-lisp.el @@ -337,18 +337,7 @@ are also supported; unsupported long options are silently ignored." (ls-lisp-insert-directory file switches (ls-lisp-time-index switches) nil full-directory-p)) - (signal (car err) (cdr err))))) - ;; Try to insert the amount of free space. - (save-excursion - (goto-char (point-min)) - ;; First find the line to put it on. - (when (re-search-forward "^total" nil t) - (let ((available (get-free-disk-space "."))) - (when available - ;; Replace "total" with "total used", to avoid confusion. - (replace-match "total used in directory") - (end-of-line) - (insert " available " available))))))))) + (signal (car err) (cdr err))))))))) (advice-add 'insert-directory :around #'ls-lisp--insert-directory) (defun ls-lisp-insert-directory diff --git a/lisp/mail/feedmail.el b/lisp/mail/feedmail.el index fe686cb6f86..32edc292619 100644 --- a/lisp/mail/feedmail.el +++ b/lisp/mail/feedmail.el @@ -2336,19 +2336,14 @@ mapped to mostly alphanumerics for safety." ;; from a similar function in mail-utils.el (defun feedmail-rfc822-time-zone (time) + (declare (obsolete format-time-string "29.1")) (feedmail-say-debug ">in-> feedmail-rfc822-time-zone %s" time) - (let* ((sec (or (car (current-time-zone time)) 0)) - (absmin (/ (abs sec) 60))) - (format "%c%02d%02d" (if (< sec 0) ?- ?+) (/ absmin 60) (% absmin 60)))) + (format-time-string "%z" time)) (defun feedmail-rfc822-date (arg-time) (feedmail-say-debug ">in-> feedmail-rfc822-date %s" arg-time) - (let ((time (or arg-time (current-time))) - (system-time-locale "C")) - (concat - (format-time-string "%a, %e %b %Y %T " time) - (feedmail-rfc822-time-zone time) - ))) + (let ((system-time-locale "C")) + (format-time-string "%a, %e %b %Y %T %z" arg-time))) (defun feedmail-send-it-immediately-wrapper () "Wrapper to catch skip-me-i." @@ -2847,10 +2842,9 @@ probably not appropriate for you." (if (and (not feedmail-queue-use-send-time-for-message-id) maybe-file) (setq date-time (file-attribute-modification-time (file-attributes maybe-file)))) - (format "<%d-%s%s%s>" + (format "<%d-%s%s>" (mod (random) 10000) - (format-time-string "%a%d%b%Y%H%M%S" date-time) - (feedmail-rfc822-time-zone date-time) + (format-time-string "%a%d%b%Y%H%M%S%z" date-time) end-stuff)) ) 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/mail-utils.el b/lisp/mail/mail-utils.el index 3eb3ccb93de..f1b0590bec7 100644 --- a/lisp/mail/mail-utils.el +++ b/lisp/mail/mail-utils.el @@ -368,19 +368,12 @@ matches may be returned from the message body." labels) (defun mail-rfc822-time-zone (time) - (let* ((sec (or (car (current-time-zone time)) 0)) - (absmin (/ (abs sec) 60))) - (format "%c%02d%02d" (if (< sec 0) ?- ?+) (/ absmin 60) (% absmin 60)))) + (declare (obsolete format-time-string "29.1")) + (format-time-string "%z" time)) (defun mail-rfc822-date () - (let* ((time (current-time)) - (s (current-time-string time))) - (string-match "[^ ]+ +\\([^ ]+\\) +\\([^ ]+\\) \\([^ ]+\\) \\([^ ]+\\)" s) - (concat (substring s (match-beginning 2) (match-end 2)) " " - (substring s (match-beginning 1) (match-end 1)) " " - (substring s (match-beginning 4) (match-end 4)) " " - (substring s (match-beginning 3) (match-end 3)) " " - (mail-rfc822-time-zone time)))) + (let ((system-time-locale "C")) + (format-time-string "%-d %b %Y %T %z"))) (defun mail-mbox-from () "Return an mbox \"From \" line for the current message. diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el index 9fbc9ba180f..47fd28c18ef 100644 --- a/lisp/mail/rmail.el +++ b/lisp/mail/rmail.el @@ -41,8 +41,6 @@ (require 'rfc2047) (require 'auth-source) -(require 'rmail-loaddefs) - (declare-function compilation--message->loc "compile" (cl-x) t) (declare-function epa--find-coding-system-for-mime-charset "epa" (mime-charset)) @@ -4125,10 +4123,8 @@ typically for purposes of moderating a list." "A regexp that matches the separator before the text of a failed message.") (defvar mail-mime-unsent-header "^Content-Type: message/rfc822 *$" - "A regexp that matches the header of a MIME body part with a failed message.") + "A regexp that matches the header of a MIME body part with a failed message.") -;; This is a cut-down version of rmail-clear-headers from Emacs 22. -;; It doesn't have the same functionality, hence the name change. (defun rmail-delete-headers (regexp) "Delete any mail headers matching REGEXP. The message should be narrowed to just the headers." @@ -4136,10 +4132,6 @@ The message should be narrowed to just the headers." (goto-char (point-min)) (while (re-search-forward regexp nil t) (beginning-of-line) - ;; This code from Emacs 22 doesn't seem right, since r-n-h is - ;; just for display. -;;; (if (looking-at rmail-nonignored-headers) -;;; (forward-line 1) (delete-region (point) (save-excursion (if (re-search-forward "\n[^ \t]" nil t) diff --git a/lisp/mail/rmailedit.el b/lisp/mail/rmailedit.el index fd24bdceccc..18859f2b28d 100644 --- a/lisp/mail/rmailedit.el +++ b/lisp/mail/rmailedit.el @@ -484,8 +484,4 @@ HEADER-DIFF should be a return value from `rmail-edit-diff-headers'." (provide 'rmailedit) -;; Local Variables: -;; generated-autoload-file: "rmail-loaddefs.el" -;; End: - ;;; rmailedit.el ends here diff --git a/lisp/mail/rmailkwd.el b/lisp/mail/rmailkwd.el index 58a8eb7a370..7efbfde27d1 100644 --- a/lisp/mail/rmailkwd.el +++ b/lisp/mail/rmailkwd.el @@ -74,12 +74,9 @@ according to the choice made, and returns a symbol." (rmail-summary-exists) (and (setq old (rmail-get-keywords)) (mapc #'rmail-make-label (split-string old ", ")))) - (completing-read (concat prompt - (if rmail-last-label - (concat " (default " - (symbol-name rmail-last-label) - "): ") - ": ")) + (completing-read (format-prompt prompt + (and rmail-last-label + (symbol-name rmail-last-label))) rmail-label-obarray nil nil)))) @@ -191,8 +188,4 @@ With prefix argument N moves forward N messages with these labels." (provide 'rmailkwd) -;; Local Variables: -;; generated-autoload-file: "rmail-loaddefs.el" -;; End: - ;;; rmailkwd.el ends here diff --git a/lisp/mail/rmailmm.el b/lisp/mail/rmailmm.el index 99bff66657b..563ce9d0b82 100644 --- a/lisp/mail/rmailmm.el +++ b/lisp/mail/rmailmm.el @@ -254,7 +254,7 @@ TRUNCATED is non-nil if the text of this entity was truncated.")) (unless (y-or-n-p "This entity is truncated; save anyway? ") (error "Aborted"))) (setq filename (expand-file-name - (read-file-name (format "Save as (default: %s): " filename) + (read-file-name (format-prompt "Save as" filename) directory (expand-file-name filename directory)) directory)) @@ -1569,8 +1569,4 @@ This is the usual value of `rmail-insert-mime-forwarded-message-function'." (provide 'rmailmm) -;; Local Variables: -;; generated-autoload-file: "rmail-loaddefs.el" -;; End: - ;;; rmailmm.el ends here diff --git a/lisp/mail/rmailmsc.el b/lisp/mail/rmailmsc.el index 673b2c5a7e5..f5e89f8f17c 100644 --- a/lisp/mail/rmailmsc.el +++ b/lisp/mail/rmailmsc.el @@ -54,8 +54,4 @@ This applies only to the current session." (setq rmail-inbox-list inbox-list))) (rmail-show-message-1 rmail-current-message)) -;; Local Variables: -;; generated-autoload-file: "rmail-loaddefs.el" -;; End: - ;;; rmailmsc.el ends here diff --git a/lisp/mail/rmailout.el b/lisp/mail/rmailout.el index 91f86a234d4..1f5bb2d9f1b 100644 --- a/lisp/mail/rmailout.el +++ b/lisp/mail/rmailout.el @@ -107,9 +107,8 @@ error: %S\n" (read-file (expand-file-name (read-file-name - (concat "Output message to mail file (default " - (file-name-nondirectory default-file) - "): ") + (format-prompt "Output message to mail file" + (file-name-nondirectory default-file)) (file-name-directory default-file) (abbreviate-file-name default-file)) (file-name-directory default-file)))) diff --git a/lisp/mail/rmailsort.el b/lisp/mail/rmailsort.el index 1669c8cd7bb..8c790116a3b 100644 --- a/lisp/mail/rmailsort.el +++ b/lisp/mail/rmailsort.el @@ -250,8 +250,4 @@ Numeric keys are sorted numerically, all others as strings." (provide 'rmailsort) -;; Local Variables: -;; generated-autoload-file: "rmail-loaddefs.el" -;; End: - ;;; rmailsort.el ends here diff --git a/lisp/mail/rmailsum.el b/lisp/mail/rmailsum.el index 9dd9573a9fc..ef172bc106f 100644 --- a/lisp/mail/rmailsum.el +++ b/lisp/mail/rmailsum.el @@ -1480,13 +1480,11 @@ argument says to read a file name and use that file as the inbox." (declare-function rmail-output-read-file-name "rmailout" ()) (declare-function mail-send-and-exit "sendmail" (&optional arg)) -(defvar rmail-summary-edit-map nil) -(if rmail-summary-edit-map - nil - (setq rmail-summary-edit-map - (nconc (make-sparse-keymap) text-mode-map)) - (define-key rmail-summary-edit-map "\C-c\C-c" 'rmail-cease-edit) - (define-key rmail-summary-edit-map "\C-c\C-]" 'rmail-abort-edit)) +(defvar rmail-summary-edit-map + (let ((map (nconc (make-sparse-keymap) text-mode-map))) + (define-key map "\C-c\C-c" #'rmail-cease-edit) + (define-key map "\C-c\C-]" #'rmail-abort-edit) + map)) (defun rmail-summary-edit-current-message () "Edit the contents of this message." @@ -1879,8 +1877,4 @@ the summary is only showing a subset of messages." (provide 'rmailsum) -;; Local Variables: -;; generated-autoload-file: "rmail-loaddefs.el" -;; End: - ;;; rmailsum.el ends here diff --git a/lisp/mail/sendmail.el b/lisp/mail/sendmail.el index d0aff093dfe..d1e8a2f3c69 100644 --- a/lisp/mail/sendmail.el +++ b/lisp/mail/sendmail.el @@ -1391,8 +1391,7 @@ just append to the file, in Babyl format if necessary." (unless (markerp header-end) (error "Value of `header-end' must be a marker")) (let (fcc-list - (mailbuf (current-buffer)) - (time (current-time))) + (mailbuf (current-buffer))) (save-excursion (goto-char (point-min)) (let ((case-fold-search t)) @@ -1408,14 +1407,11 @@ just append to the file, in Babyl format if necessary." (with-temp-buffer ;; This initial newline is not written out if we create a new ;; file (see below). - (insert "\nFrom " (user-login-name) " " (current-time-string time) "\n") - ;; Insert the time zone before the year. - (forward-char -1) - (forward-word-strictly -1) (require 'mail-utils) - (insert (mail-rfc822-time-zone time) " ") - (goto-char (point-max)) - (insert "Date: " (message-make-date) "\n") + (insert "\nFrom " (user-login-name) " " + (let ((system-time-locale "C")) + (format-time-string "%a %b %e %T %z %Y")) + "\nDate: " (message-make-date) "\n") (insert-buffer-substring mailbuf) ;; Make sure messages are separated. (goto-char (point-max)) 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/mail/uce.el b/lisp/mail/uce.el index 0a488e176f6..4347ff14022 100644 --- a/lisp/mail/uce.el +++ b/lisp/mail/uce.el @@ -30,26 +30,8 @@ ;; uce-reply-to-uce. Please let me know about your changes so I can ;; incorporate them. I'd appreciate it. -;; -- !!! NOTE !!! --------------------------------------------- -;; -;; Replying to spam is at best pointless, but most likely actively -;; harmful. -;; -;; - You will confirm that your email address is valid, thus ensuring -;; you get more spam. -;; -;; - You will leak information and open yourself up for further -;; attack. For example, they could use your \"geolocation\" to find -;; your home address and phone number. -;; -;; - The sender address is likely fake. -;; -;; - You help them refine their methods of spamming. -;; -;; Therefore, we strongly recommend that you do not use this package. -;; Use a spam filter instead, or just delete the spam. -;; -;; ------------------------------------------------------------- +;; NOTE: We don't recommend using this feature; see the message in +;; 'uce-reply-to-uce' for the reasons. ;; The command uce-reply-to-uce, if called when the current message ;; buffer is a UCE, will setup a reply *mail* buffer as follows. It @@ -234,6 +216,8 @@ These are mostly meant for headers that prevent delivery errors reporting." (declare-function rmail-maybe-set-message-counters "rmail" ()) (declare-function rmail-toggle-header "rmail" (&optional arg)) +(defvar uce--usage-warning-displayed nil) + ;;;###autoload (defun uce-reply-to-uce (&optional _ignored) "Compose a reply to unsolicited commercial email (UCE). @@ -379,7 +363,32 @@ You might need to set `uce-mail-reader' before using this." ;; Run hooks before we leave buffer for editing. Reasonable usage ;; might be to set up special key bindings, replace standard ;; functions in mail-mode, etc. - (run-hooks 'mail-setup-hook 'uce-setup-hook)))) + (run-hooks 'mail-setup-hook 'uce-setup-hook))) + (unless uce--usage-warning-displayed + (setq uce--usage-warning-displayed t) + (pop-to-buffer (get-buffer-create "uce-reply-to-uce warning")) + (insert "\ +-- !!! NOTE !!! --------------------------------------------- + +Replying to spam is at best pointless, but most likely actively +harmful. + +- You will confirm that your email address is valid, thus ensuring + you get more spam. + +- You will leak information and open yourself up for further + attack. For example, they could use your \"geolocation\" to find + your home address and phone number. + +- The sender address is likely fake. + +- You help them refine their methods of spamming. + +Therefore, we strongly recommend that you do not use this package. +Use a spam filter instead, or just delete the spam. + +------------------------------------------------------------- +"))) (defun uce-insert-ranting (&optional _ignored) "Insert text of the usual reply to UCE into current buffer." diff --git a/lisp/man.el b/lisp/man.el index 4ef2deac4f3..fff31baa5f3 100644 --- a/lisp/man.el +++ b/lisp/man.el @@ -1334,7 +1334,7 @@ default type, `Man-xref-man-page' is used for the buttons." (defun Man-highlight-references0 (start-section regexp button-pos target type) ;; Based on `Man-build-references-alist' - (when (or (null start-section) ;; Search regardless of sections. + (when (or (null start-section) ;; Search regardless of sections. ;; Section header is in this chunk. (Man-find-section start-section)) (let ((end (if start-section @@ -1347,18 +1347,24 @@ default type, `Man-xref-man-page' is used for the buttons." (goto-char (point-min)) nil))) (while (re-search-forward regexp end t) - ;; An overlay button is preferable because the underlying text - ;; may have text property highlights (Bug#7881). - (make-button - (match-beginning button-pos) - (match-end button-pos) - 'type type - 'Man-target-string (cond - ((numberp target) - (match-string target)) - ((functionp target) - target) - (t nil))))))) + (let ((b (match-beginning button-pos)) + (e (match-end button-pos)) + (match (match-string button-pos))) + ;; Some lists of references end with ", and ...". Chop the + ;; "and" bit off before making a button. + (when (string-match "\\`and +" match) + (setq b (+ b (- (match-end 0) (match-beginning 0))))) + ;; An overlay button is preferable because the underlying text + ;; may have text property highlights (Bug#7881). + (make-button + b e + 'type type + 'Man-target-string (cond + ((numberp target) + (match-string target)) + ((functionp target) + target) + (t nil)))))))) (defun Man-cleanup-manpage (&optional interactive) "Remove overstriking and underlining from the current buffer. @@ -1786,7 +1792,7 @@ Returns t if section is found, nil otherwise." Man--last-section (car Man--sections))) (completion-ignore-case t) - (prompt (concat "Go to section (default " default "): ")) + (prompt (format-prompt "Go to section" default)) (chosen (completing-read prompt Man--sections nil nil nil nil default))) (list chosen)) @@ -1850,7 +1856,7 @@ Specify which REFERENCE to use; default is based on word at point." (defaults (mapcar 'substring-no-properties (cons default Man--refpages))) - (prompt (concat "Refer to (default " default "): ")) + (prompt (format-prompt "Refer to" default)) (chosen (completing-read prompt Man--refpages nil nil nil nil defaults))) chosen))) diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el index da79aae5295..bd110226618 100644 --- a/lisp/menu-bar.el +++ b/lisp/menu-bar.el @@ -413,8 +413,14 @@ (bindings--define-key menu [separator-tag-file] '(menu-item "--" nil :visible (menu-bar-goto-uses-etags-p))) + (bindings--define-key menu [xref-forward] + '(menu-item "Forward" xref-go-forward + :visible (and (featurep 'xref) + (not (xref-forward-history-empty-p))) + :help "Forward to the position gone Back from")) + (bindings--define-key menu [xref-pop] - '(menu-item "Back" xref-pop-marker-stack + '(menu-item "Back" xref-go-back :visible (and (featurep 'xref) (not (xref-marker-stack-empty-p))) :help "Back to the position of the last search")) @@ -514,7 +520,11 @@ (cdr yank-menu) kill-ring)) (not buffer-read-only)))) - :help "Paste (yank) text most recently cut/copied")) + :help "Paste (yank) text most recently cut/copied" + :keys ,(lambda () + (if cua-mode + "\\[cua-paste]" + "\\[yank]")))) (bindings--define-key menu [copy] ;; ns-win.el said: Substitute a Copy function that works better ;; under X (for GNUstep). @@ -523,14 +533,23 @@ 'kill-ring-save) :enable mark-active :help "Copy text in region between mark and current position" - :keys ,(if (featurep 'ns) - "\\[ns-copy-including-secondary]" - "\\[kill-ring-save]"))) + :keys ,(lambda () + (cond + ((featurep 'ns) + "\\[ns-copy-including-secondary]") + ((and cua-mode mark-active) + "\\[cua-copy-handler]") + (t + "\\[kill-ring-save]"))))) (bindings--define-key menu [cut] - '(menu-item "Cut" kill-region + `(menu-item "Cut" kill-region :enable (and mark-active (not buffer-read-only)) :help - "Cut (kill) text in region between mark and current position")) + "Cut (kill) text in region between mark and current position" + :keys ,(lambda () + (if (and cua-mode mark-active) + "\\[cua-cut-handler]" + "\\[kill-region]")))) ;; ns-win.el said: Separate undo from cut/paste section. (if (featurep 'ns) (bindings--define-key menu [separator-undo] menu-bar-separator)) @@ -1328,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)) @@ -1918,10 +1936,7 @@ key, a click, or a menu-item")) (let* ((default (thing-at-point 'sexp)) (topic (read-from-minibuffer - (format "Subject to look up%s: " - (if default - (format " (default \"%s\")" default) - "")) + (format-prompt "Subject to look up" default) nil nil nil nil default))) (list (if (zerop (length topic)) default @@ -2163,6 +2178,12 @@ otherwise it could decide to silently do nothing." :type 'integer :group 'menu) +(defcustom yank-menu-max-items 60 + "Maximum number of entries to display in the `yank-menu'." + :type 'integer + :group 'menu + :version "29.1") + (defun menu-bar-update-yank-menu (string old) (let ((front (car (cdr yank-menu))) (menu-string (if (<= (length string) yank-menu-length) @@ -2186,8 +2207,9 @@ otherwise it could decide to silently do nothing." (cons (cons string (cons menu-string 'menu-bar-select-yank)) (cdr yank-menu))))) - (if (> (length (cdr yank-menu)) kill-ring-max) - (setcdr (nthcdr kill-ring-max yank-menu) nil))) + (let ((max-items (min yank-menu-max-items kill-ring-max))) + (if (> (length (cdr yank-menu)) max-items) + (setcdr (nthcdr max-items yank-menu) nil)))) (put 'menu-bar-select-yank 'apropos-inhibit t) (defun menu-bar-select-yank () @@ -2517,6 +2539,8 @@ 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." @@ -2642,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 @@ -2653,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 diff --git a/lisp/mh-e/mh-acros.el b/lisp/mh-e/mh-acros.el index 8fdcf3c62b4..25fff6a8e1b 100644 --- a/lisp/mh-e/mh-acros.el +++ b/lisp/mh-e/mh-acros.el @@ -47,19 +47,20 @@ ;;;###mh-autoload (defmacro mh-do-in-gnu-emacs (&rest body) "Execute BODY if in GNU Emacs." - (declare (debug t) (indent defun)) + (declare (obsolete progn "29.1") (debug t) (indent defun)) (unless (featurep 'xemacs) `(progn ,@body))) ;;;###mh-autoload (defmacro mh-do-in-xemacs (&rest body) "Execute BODY if in XEmacs." - (declare (debug t) (indent defun)) + (declare (obsolete ignore "29.1") (debug t) (indent defun)) (when (featurep 'xemacs) `(progn ,@body))) ;;;###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 :-( @@ -72,7 +73,8 @@ "Create function NAME. If FUNCTION exists, then NAME becomes an alias for FUNCTION. Otherwise, create function NAME with ARG-LIST and BODY." - (declare (indent defun) (doc-string 4) + (declare (obsolete defun "29.1") + (indent defun) (doc-string 4) (debug (&define name symbolp sexp def-body))) `(defalias ',name (if (fboundp ',function) @@ -84,7 +86,8 @@ Otherwise, create function NAME with ARG-LIST and BODY." "Create macro NAME. If MACRO exists, then NAME becomes an alias for MACRO. Otherwise, create macro NAME with ARG-LIST and BODY." - (declare (indent defun) (doc-string 4) + (declare (obsolete defmacro "29.1") + (indent defun) (doc-string 4) (debug (&define name symbolp sexp def-body))) (let ((defined-p (fboundp macro))) (if defined-p @@ -99,22 +102,20 @@ Otherwise, create macro NAME with ARG-LIST and BODY." "Make HOOK local if needed. XEmacs and versions of GNU Emacs before 21.1 require `make-local-hook' to be called." + (declare (obsolete nil "29.1")) (when (and (fboundp 'make-local-hook) (not (get 'make-local-hook 'byte-obsolete-info))) `(make-local-hook ,hook))) ;;;###mh-autoload (defmacro mh-mark-active-p (check-transient-mark-mode-flag) - "A macro that expands into appropriate code in XEmacs and nil in GNU Emacs. -In GNU Emacs if CHECK-TRANSIENT-MARK-MODE-FLAG is non-nil then -check if variable `transient-mark-mode' is active." - (cond ((featurep 'xemacs) ;XEmacs - '(and (boundp 'zmacs-regions) zmacs-regions (region-active-p))) - ((not check-transient-mark-mode-flag) ;GNU Emacs - '(and (boundp 'mark-active) mark-active)) - (t ;GNU Emacs - '(and (boundp 'transient-mark-mode) transient-mark-mode - (boundp 'mark-active) mark-active)))) + "If CHECK-TRANSIENT-MARK-MODE-FLAG is non-nil then check if +variable `transient-mark-mode' is active." + (declare (obsolete nil "29.1")) + (cond ((not check-transient-mark-mode-flag) + 'mark-active) + (t + '(and transient-mark-mode mark-active)))) ;;;###mh-autoload (defmacro with-mh-folder-updating (save-modification-flag &rest body) @@ -164,12 +165,8 @@ preserved." (original-position (make-symbol "original-position")) (modified-flag (make-symbol "modified-flag"))) `(save-excursion - (let* ((,event-window - (or (mh-funcall-if-exists posn-window (event-start ,event)) - (mh-funcall-if-exists event-window ,event))) - (,event-position - (or (mh-funcall-if-exists posn-point (event-start ,event)) - (mh-funcall-if-exists event-closest-point ,event))) + (let* ((,event-window (posn-window (event-start ,event))) + (,event-position (posn-point (event-start ,event))) (,original-window (selected-window)) (,original-position (progn (set-buffer (window-buffer ,event-window)) diff --git a/lisp/mh-e/mh-alias.el b/lisp/mh-e/mh-alias.el index 37fdb166011..d2666211002 100644 --- a/lisp/mh-e/mh-alias.el +++ b/lisp/mh-e/mh-alias.el @@ -67,8 +67,7 @@ Return t if any file listed in the Aliasfile MH profile component has been modified since the timestamp. If ARG is non-nil, set timestamp with the current time." (if arg - (let ((time (current-time))) - (setq mh-alias-tstamp (list (nth 0 time) (nth 1 time)))) + (setq mh-alias-tstamp (current-time)) (let ((stamp)) (car (memq t (mapcar (lambda (file) @@ -112,10 +111,10 @@ COMMA-SEPARATOR is non-nil." (setq res (match-string 1 res))) ;; Replace "&" with capitalized username (if (string-search "&" res) - (setq res (mh-replace-regexp-in-string "&" (capitalize username) res))) + (setq res (replace-regexp-in-string "&" (capitalize username) res))) ;; Remove " character (if (string-search "\"" res) - (setq res (mh-replace-regexp-in-string "\"" "" res))) + (setq res (replace-regexp-in-string "\"" "" res))) ;; If empty string, use username instead (if (string-equal "" res) (setq res username)) @@ -155,7 +154,7 @@ Exclude all aliases already in `mh-alias-alist' from \"ali\"" (if (string-equal username realname) (concat "<" username ">") (concat realname " <" username ">")))) - (when (not (mh-assoc-string alias-name mh-alias-alist t)) + (when (not (assoc-string alias-name mh-alias-alist t)) (setq passwd-alist (cons (list alias-name alias-translation) passwd-alist))))))) (forward-line 1))) @@ -184,12 +183,12 @@ been loaded." (cond ((looking-at "^[ \t]")) ;Continuation line ((looking-at "\\(.+\\): .+: .*$") ; A new -blind- MH alias - (when (not (mh-assoc-string (match-string 1) mh-alias-blind-alist t)) + (when (not (assoc-string (match-string 1) mh-alias-blind-alist t)) (setq mh-alias-blind-alist (cons (list (match-string 1)) mh-alias-blind-alist)) (setq mh-alias-alist (cons (list (match-string 1)) mh-alias-alist)))) ((looking-at "\\(.+\\): .*$") ; A new MH alias - (when (not (mh-assoc-string (match-string 1) mh-alias-alist t)) + (when (not (assoc-string (match-string 1) mh-alias-alist t)) (setq mh-alias-alist (cons (list (match-string 1)) mh-alias-alist))))) (forward-line 1))) @@ -200,7 +199,7 @@ been loaded." user) (while local-users (setq user (car local-users)) - (if (not (mh-assoc-string (car user) mh-alias-alist t)) + (if (not (assoc-string (car user) mh-alias-alist t)) (setq mh-alias-alist (append mh-alias-alist (list user)))) (setq local-users (cdr local-users))))) (run-hooks 'mh-alias-reloaded-hook) @@ -239,16 +238,16 @@ done here." "Return expansion for ALIAS. Blind aliases or users from /etc/passwd are not expanded." (cond - ((mh-assoc-string alias mh-alias-blind-alist t) + ((assoc-string alias mh-alias-blind-alist t) alias) ; Don't expand a blind alias - ((mh-assoc-string alias mh-alias-passwd-alist t) - (cadr (mh-assoc-string alias mh-alias-passwd-alist t))) + ((assoc-string alias mh-alias-passwd-alist t) + (cadr (assoc-string alias mh-alias-passwd-alist t))) (t (mh-alias-ali alias)))) (eval-and-compile - (mh-require 'crm nil t) ; completing-read-multiple - (mh-require 'multi-prompt nil t)) + (require 'crm nil t) ; completing-read-multiple + (require 'multi-prompt nil t)) ;;;###mh-autoload (defun mh-read-address (prompt) @@ -258,15 +257,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 @@ -281,7 +272,7 @@ Blind aliases or users from /etc/passwd are not expanded." (let* ((case-fold-search t) (beg (mh-beginning-of-word)) (the-name (buffer-substring-no-properties beg (point)))) - (if (mh-assoc-string the-name mh-alias-alist t) + (if (assoc-string the-name mh-alias-alist t) (message "%s -> %s" the-name (mh-alias-expand the-name)) ;; Check if it was a single word likely to be an alias (if (and (equal mh-alias-flash-on-comma 1) @@ -313,7 +304,7 @@ Blind aliases or users from /etc/passwd are not expanded." res) res))) ((t) (all-completions string mh-alias-alist pred)) - ((lambda) (mh-test-completion string mh-alias-alist pred))))))))) + ((lambda) (test-completion string mh-alias-alist pred))))))))) ;;; Alias File Updating diff --git a/lisp/mh-e/mh-comp.el b/lisp/mh-e/mh-comp.el index e44c42e2800..a47a6f9cca9 100644 --- a/lisp/mh-e/mh-comp.el +++ b/lisp/mh-e/mh-comp.el @@ -177,9 +177,8 @@ Used by the \\[mh-edit-again] and \\[mh-extract-rejected-mail] commands.") "Messages annotated, either a sequence name or a list of message numbers. This variable can be used by `mh-annotate-msg-hook'.") -(defvar mh-insert-auto-fields-done-local nil +(defvar-local mh-insert-auto-fields-done-local nil "Buffer-local variable set when `mh-insert-auto-fields' called successfully.") -(make-variable-buffer-local 'mh-insert-auto-fields-done-local) @@ -304,21 +303,7 @@ message and scan line." (let ((draft-buffer (current-buffer)) (file-name buffer-file-name) (config mh-previous-window-config) - ;; FIXME this is subtly different to select-message-coding-system. - (coding-system-for-write - (if (fboundp 'select-message-coding-system) - (select-message-coding-system) ; Emacs has this since at least 21.1 - (if (and (local-variable-p 'buffer-file-coding-system - (current-buffer)) ;XEmacs needs two args - ;; We're not sure why, but buffer-file-coding-system - ;; tends to get set to undecided-unix. - (not (memq buffer-file-coding-system - '(undecided undecided-unix undecided-dos)))) - buffer-file-coding-system - (or (and (boundp 'sendmail-coding-system) sendmail-coding-system) - (and (default-boundp 'buffer-file-coding-system) - (default-value 'buffer-file-coding-system)) - 'utf-8))))) + (coding-system-for-write (select-message-coding-system))) ;; Older versions of spost do not support -msgid and -mime. (unless mh-send-uses-spost-flag ;; Adding a Message-ID field looks good, makes it easier to search for @@ -433,7 +418,7 @@ See also `mh-send'." (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil) (mh-insert-header-separator) ;; Merge in components - (mh-mapc + (mapc (lambda (header-field) (let ((field (car header-field)) (value (cdr header-field)) @@ -593,11 +578,12 @@ See also `mh-compose-forward-as-mime-flag', (goto-char (point-min)) ;; Set the local value of mh-mail-header-separator according to what is ;; present in the buffer... - (set (make-local-variable 'mh-mail-header-separator) - (save-excursion - (goto-char (mh-mail-header-end)) - (buffer-substring-no-properties (point) (mh-line-end-position)))) - (set (make-local-variable 'mail-header-separator) mh-mail-header-separator) ;override sendmail.el + (setq-local mh-mail-header-separator + (save-excursion + (goto-char (mh-mail-header-end)) + (buffer-substring-no-properties (point) + (line-end-position)))) + (setq-local mail-header-separator mh-mail-header-separator) ;override sendmail.el ;; If using MML, translate MH-style directive (if (equal mh-compose-insertion 'mml) (save-excursion @@ -699,7 +685,7 @@ message and scan line." ;; For "From", the first value wins, with the identity's "From" ;; trumping anything in the distcomps file. (let ((components-file (mh-bare-components mh-dist-formfile))) - (mh-mapc + (mapc (lambda (header-field) (let ((field (car header-field)) (value (cdr header-field)) @@ -1079,7 +1065,6 @@ letter." ;; Insert identity. (mh-insert-identity mh-identity-default t) (mh-identity-make-menu) - (mh-identity-add-menu) ;; Cleanup possibly RFC2047 encoded subject header (mh-decode-message-subject) @@ -1098,7 +1083,6 @@ letter." (setq mh-previous-window-config config) (setq mode-line-buffer-identification (list " {%b}")) (mh-logo-display) - (mh-make-local-hook 'kill-buffer-hook) (add-hook 'kill-buffer-hook #'mh-tidy-draft-buffer nil t) (run-hook-with-args 'mh-compose-letter-function to subject cc)) @@ -1109,18 +1093,8 @@ The versions of MH-E, Emacs, and MH are shown." ;; Lazily initialize mh-x-mailer-string. (when (and mh-insert-x-mailer-flag (null mh-x-mailer-string)) (setq mh-x-mailer-string - (format "MH-E %s; %s; %sEmacs %s" - mh-version mh-variant-in-use - (if (featurep 'xemacs) "X" "GNU ") - (cond ((not (featurep 'xemacs)) - (string-match "[0-9]+\\.[0-9]+\\(\\.[0-9]+\\)?" - emacs-version) - (match-string 0 emacs-version)) - ((string-match "[0-9.]*\\( +([ a-z]+[0-9]+)\\)?" - emacs-version) - (match-string 0 emacs-version)) - (t (format "%s.%s" emacs-major-version - emacs-minor-version)))))) + (format "MH-E %s; %s; Emacs %s" + mh-version mh-variant-in-use emacs-version))) ;; Insert X-Mailer, but only if it doesn't already exist. (save-excursion (when (and mh-insert-x-mailer-flag @@ -1247,7 +1221,7 @@ discarded." (cond ((and overwrite-flag (mh-goto-header-field (concat field ":"))) (insert " " value) - (delete-region (point) (mh-line-end-position))) + (delete-region (point) (line-end-position))) ((and (not overwrite-flag) (mh-regexp-in-field-p (concat "\\b" (regexp-quote value) "\\b") field)) ;; Already there, do nothing. @@ -1290,11 +1264,8 @@ discarded." (set-syntax-table old-syntax-table)))) (defun mh-ascii-buffer-p () - "Check if current buffer is entirely composed of ASCII. -The function doesn't work for XEmacs since `find-charset-region' -doesn't exist there." - (cl-loop for charset in (mh-funcall-if-exists - find-charset-region (point-min) (point-max)) + "Check if current buffer is entirely composed of ASCII." + (cl-loop for charset in (find-charset-region (point-min) (point-max)) unless (eq charset 'ascii) return nil finally return t)) diff --git a/lisp/mh-e/mh-compat.el b/lisp/mh-e/mh-compat.el index ade80e8b95e..23dc48a574c 100644 --- a/lisp/mh-e/mh-compat.el +++ b/lisp/mh-e/mh-compat.el @@ -34,53 +34,21 @@ ;; Please use mh-gnus.el when providing compatibility with different ;; versions of Gnus. -;; Items are listed alphabetically (except for mh-require which is -;; needed sooner it would normally appear). +;; Items are listed alphabetically. (eval-when-compile (require 'mh-acros)) -(mh-do-in-gnu-emacs - (defalias 'mh-require #'require)) - -(mh-do-in-xemacs - (defun mh-require (feature &optional filename noerror) - "If feature FEATURE is not loaded, load it from FILENAME. -If FEATURE is not a member of the list `features', then the feature -is not loaded; so load the file FILENAME. -If FILENAME is omitted, the printname of FEATURE is used as the file name. -If the optional third argument NOERROR is non-nil, -then return nil if the file is not found instead of signaling an error. - -Simulate NOERROR argument in XEmacs which lacks it." - (if (not (featurep feature)) - (if filename - (load filename noerror t) - (load (format "%s" feature) noerror t))))) - -(defun-mh mh-assoc-string assoc-string (key list case-fold) - "Like `assoc' but specifically for strings. -Case is ignored if CASE-FOLD is non-nil. -This function is used by Emacs versions that lack `assoc-string', -introduced in Emacs 22." - ;; Test for fboundp is solely to silence compiler for Emacs >= 22.1. - (if (and case-fold (fboundp 'assoc-ignore-case)) - (assoc-ignore-case key list) - (assoc key list))) - -;; For XEmacs. -(defalias 'mh-cancel-timer - (if (fboundp 'cancel-timer) - 'cancel-timer - 'delete-itimer)) +(define-obsolete-function-alias 'mh-require #'require "29.1") +(define-obsolete-function-alias 'mh-assoc-string #'assoc-string "29.1") +(define-obsolete-function-alias 'mh-cancel-timer #'cancel-timer "29.1") ;; Emacs 24 made flet obsolete and suggested either cl-flet or ;; 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) @@ -90,17 +58,8 @@ the function cell of FUNCs rather than their value cell. ,@body) `(flet ,bindings ,@body))) -(defun mh-display-color-cells (&optional display) - "Return the number of color cells supported by DISPLAY. -This function is used by XEmacs to return 2 when `device-color-cells' -or `display-color-cells' returns nil. This happens when compiling or -running on a tty and causes errors since `display-color-cells' is -expected to return an integer." - (cond ((fboundp 'display-color-cells) ; GNU Emacs, XEmacs 21.5b28 - (or (display-color-cells display) 2)) - ((fboundp 'device-color-cells) ; XEmacs 21.4 - (or (device-color-cells display) 2)) - (t 2))) +(define-obsolete-function-alias 'mh-display-color-cells + #'display-color-cells "29.1") (defmacro mh-display-completion-list (completions &optional common-substring) "Display the list of COMPLETIONS. @@ -110,209 +69,54 @@ The optional argument COMMON-SUBSTRING, if non-nil, should be a string specifying a common substring for adding the faces `completions-first-difference' and `completions-common-part' to the completions." - (cond ((< emacs-major-version 22) `(display-completion-list ,completions)) - ((fboundp 'completion-hilit-commonality) ; Emacs 23.1 and later - `(display-completion-list - (completion-hilit-commonality ,completions - ,(length common-substring) nil))) - (t ; Emacs 22 - `(display-completion-list ,completions ,common-substring)))) - -(defmacro mh-face-foreground (face &optional frame inherit) - "Return the foreground color name of FACE, or nil if unspecified. -See documentation for `face-foreground' for a description of the -arguments FACE, FRAME, and perhaps INHERIT. -This macro is used by Emacs versions that lack an INHERIT argument, -introduced in Emacs 22." - (if (< emacs-major-version 22) - `(face-foreground ,face ,frame) - `(face-foreground ,face ,frame ,inherit))) - -(defmacro mh-face-background (face &optional frame inherit) - "Return the background color name of face, or nil if unspecified. -See documentation for `face-background' for a description of the -arguments FACE, FRAME, and INHERIT. -This macro is used by Emacs versions that lack an INHERIT argument, -introduced in Emacs 22." - (if (< emacs-major-version 22) - `(face-background ,face ,frame) - `(face-background ,face ,frame ,inherit))) - -(defun-mh mh-font-lock-add-keywords font-lock-add-keywords - (_mode _keywords &optional _how) - "XEmacs does not have `font-lock-add-keywords'. -This function returns nil on that system.") - -(defun-mh mh-image-load-path-for-library - image-load-path-for-library (library image &optional path no-error) - "Return a suitable search path for images used by LIBRARY. - -It searches for IMAGE in `image-load-path' (excluding -\"`data-directory'/images\") and `load-path', followed by a path -suitable for LIBRARY, which includes \"../../etc/images\" and -\"../etc/images\" relative to the library file itself, and then -in \"`data-directory'/images\". - -Then this function returns a list of directories which contains -first the directory in which IMAGE was found, followed by the -value of `load-path'. If PATH is given, it is used instead of -`load-path'. - -If NO-ERROR is non-nil and a suitable path can't be found, don't -signal an error. Instead, return a list of directories as before, -except that nil appears in place of the image directory. - -Here is an example that uses a common idiom to provide -compatibility with versions of Emacs that lack the variable -`image-load-path': - - ;; Shush compiler. - (defvar image-load-path) - - (let* ((load-path (image-load-path-for-library \"mh-e\" \"mh-logo.xpm\")) - (image-load-path (cons (car load-path) - (when (boundp \\='image-load-path) - image-load-path)))) - (mh-tool-bar-folder-buttons-init))" - (unless library (error "No library specified")) - (unless image (error "No image specified")) - (let (image-directory image-directory-load-path) - ;; Check for images in image-load-path or load-path. - (let ((img image) - (dir (or - ;; Images in image-load-path. - (mh-image-search-load-path image) - ;; Images in load-path. - (locate-library image))) - parent) - ;; Since the image might be in a nested directory (for - ;; example, mail/attach.pbm), adjust `image-directory' - ;; accordingly. - (when dir - (setq dir (file-name-directory dir)) - (while (setq parent (file-name-directory img)) - (setq img (directory-file-name parent) - dir (expand-file-name "../" dir)))) - (setq image-directory-load-path dir)) - - ;; If `image-directory-load-path' isn't Emacs's image directory, - ;; it's probably a user preference, so use it. Then use a - ;; relative setting if possible; otherwise, use - ;; `image-directory-load-path'. - (cond - ;; User-modified image-load-path? - ((and image-directory-load-path - (not (equal image-directory-load-path - (file-name-as-directory - (expand-file-name "images" data-directory))))) - (setq image-directory image-directory-load-path)) - ;; Try relative setting. - ((let (library-name d1ei d2ei) - ;; First, find library in the load-path. - (setq library-name (locate-library library)) - (if (not library-name) - (error "Cannot find library %s in load-path" library)) - ;; And then set image-directory relative to that. - (setq - ;; Go down 2 levels. - d2ei (file-name-as-directory - (expand-file-name - (concat (file-name-directory library-name) "../../etc/images"))) - ;; Go down 1 level. - d1ei (file-name-as-directory - (expand-file-name - (concat (file-name-directory library-name) "../etc/images")))) - (setq image-directory - ;; Set it to nil if image is not found. - (cond ((file-exists-p (expand-file-name image d2ei)) d2ei) - ((file-exists-p (expand-file-name image d1ei)) d1ei))))) - ;; Use Emacs's image directory. - (image-directory-load-path - (setq image-directory image-directory-load-path)) - (no-error - (message "Could not find image %s for library %s" image library)) - (t - (error "Could not find image %s for library %s" image library))) - - ;; Return an augmented `path' or `load-path'. - (nconc (list image-directory) - (delete image-directory (copy-sequence (or path load-path)))))) - -(defun-mh mh-image-search-load-path - image-search-load-path (_file &optional _path) - "Emacs 21 and XEmacs don't have `image-search-load-path'. -This function returns nil on those systems." - nil) - -;; For XEmacs. -(defalias 'mh-line-beginning-position - (if (fboundp 'line-beginning-position) - 'line-beginning-position - 'point-at-bol)) - -;; For XEmacs. -(defalias 'mh-line-end-position - (if (fboundp 'line-end-position) - 'line-end-position - 'point-at-eol)) - -(mh-require 'mailabbrev nil t) -(defun-mh mh-mail-abbrev-make-syntax-table - mail-abbrev-make-syntax-table () - "Emacs 21 and XEmacs don't have `mail-abbrev-make-syntax-table'. -This function returns nil on those systems." - nil) - -(defmacro mh-define-obsolete-variable-alias - (obsolete-name current-name &optional when docstring) - "Make OBSOLETE-NAME a variable alias for CURRENT-NAME and mark it obsolete. -See documentation for `define-obsolete-variable-alias' for a description -of the arguments OBSOLETE-NAME, CURRENT-NAME, and perhaps WHEN -and DOCSTRING. This macro is used by XEmacs that lacks WHEN and -DOCSTRING arguments." - (if (featurep 'xemacs) - `(define-obsolete-variable-alias ,obsolete-name ,current-name) - `(define-obsolete-variable-alias ,obsolete-name ,current-name ,when ,docstring))) - -(defmacro mh-make-obsolete-variable (obsolete-name current-name &optional when access-type) - "Make the byte-compiler warn that OBSOLETE-NAME is obsolete. -See documentation for `make-obsolete-variable' for a description -of the arguments OBSOLETE-NAME, CURRENT-NAME, and perhaps WHEN -and ACCESS-TYPE. This macro is used by XEmacs that lacks WHEN and -ACCESS-TYPE arguments and by Emacs versions that lack ACCESS-TYPE, -introduced in Emacs 24." - (if (featurep 'xemacs) - `(make-obsolete-variable ,obsolete-name ,current-name) - (if (< emacs-major-version 24) - `(make-obsolete-variable ,obsolete-name ,current-name ,when) - `(make-obsolete-variable ,obsolete-name ,current-name ,when ,access-type)))) - -(defun-mh mh-match-string-no-properties - match-string-no-properties (num &optional _string) - "Return string of text matched by last search, without text properties. -This function is used by XEmacs that lacks `match-string-no-properties'. -The function `buffer-substring-no-properties' is used instead. -The argument STRING is ignored." - (buffer-substring-no-properties - (match-beginning num) (match-end num))) - -(defun-mh mh-replace-regexp-in-string replace-regexp-in-string - (regexp rep string &optional _fixedcase literal _subexp _start) - "Replace REGEXP with REP everywhere in STRING and return result. -This function is used by XEmacs that lacks `replace-regexp-in-string'. -The function `replace-in-string' is used instead. -The arguments FIXEDCASE, SUBEXP, and START, used by -`replace-in-string' are ignored." - (if (featurep 'xemacs) ; silence Emacs compiler - (replace-in-string string regexp rep literal))) - -(defun-mh mh-test-completion - test-completion (_string _collection &optional _predicate) - "Return non-nil if STRING is a valid completion. -XEmacs does not have `test-completion'. This function returns nil -on that system." nil) - -;; Copy of constant from url-util.el in Emacs 22; needed by Emacs 21. + `(display-completion-list + (completion-hilit-commonality ,completions + ,(length common-substring) nil))) + +(define-obsolete-function-alias 'mh-face-foreground + #'face-foreground "29.1") + +(define-obsolete-function-alias 'mh-face-background + #'face-background "29.1") + +(define-obsolete-function-alias 'mh-font-lock-add-keywords + #'font-lock-add-keywords "29.1") + +;; Not preloaded in without-x builds. +(declare-function image-load-path-for-library "image") +(define-obsolete-function-alias 'mh-image-load-path-for-library + #'image-load-path-for-library "29.1") + +;; Not preloaded in without-x builds. +(declare-function image-search-load-path "image") +(define-obsolete-function-alias 'mh-image-search-load-path + #'image-search-load-path "29.1") + +(define-obsolete-function-alias 'mh-line-beginning-position + #'line-beginning-position "29.1") + +(define-obsolete-function-alias 'mh-line-end-position + #'line-end-position "29.1") + +(require 'mailabbrev nil t) +(define-obsolete-function-alias 'mh-mail-abbrev-make-syntax-table + #'mail-abbrev-make-syntax-table "29.1") + +(define-obsolete-function-alias 'mh-define-obsolete-variable-alias + #'define-obsolete-variable-alias "29.1") + +(define-obsolete-function-alias 'mh-make-obsolete-variable + #'make-obsolete-variable "29.1") + +(define-obsolete-function-alias 'mh-match-string-no-properties + #'match-string-no-properties "29.1") + +(define-obsolete-function-alias 'mh-replace-regexp-in-string + #'replace-regexp-in-string "29.1") + +(define-obsolete-function-alias 'mh-test-completion + #'test-completion "29.1") + (defconst mh-url-unreserved-chars '( ?a ?b ?c ?d ?e ?f ?g ?h ?i ?j ?k ?l ?m ?n ?o ?p ?q ?r ?s ?t ?u ?v ?w ?x ?y ?z @@ -321,51 +125,21 @@ on that system." nil) ?- ?_ ?. ?! ?~ ?* ?' ?\( ?\)) "A list of characters that are _NOT_ reserved in the URL spec. This is taken from RFC 2396.") +(make-obsolete-variable 'mh-url-unreserved-chars 'url-unreserved-chars "29.1") + +(define-obsolete-function-alias 'mh-url-hexify-string + #'url-hexify-string "29.1") + +(define-obsolete-function-alias 'mh-view-mode-enter + #'view-mode-enter "29.1") -(defun-mh mh-url-hexify-string url-hexify-string (str) - "Escape characters in a string. -This is a copy of `url-hexify-string' from url-util.el in Emacs -22; needed by Emacs 21." - (mapconcat - (lambda (char) - ;; Fixme: use a char table instead. - (if (not (memq char mh-url-unreserved-chars)) - (if (> char 255) - (error "Hexifying multibyte character %s" str) - (format "%%%02X" char)) - (char-to-string char))) - str "")) - -(defun-mh mh-view-mode-enter - view-mode-enter (&optional return-to exit-action) - "Enter View mode. -This function is used by XEmacs that lacks `view-mode-enter'. -The function `view-mode' is used instead. -The arguments RETURN-TO and EXIT-ACTION are ignored." - ;; Shush compiler. - (if return-to nil) - (if exit-action nil) - (view-mode 1)) - -(defun-mh mh-window-full-height-p - window-full-height-p (&optional _window) - "Return non-nil if WINDOW is not the result of a vertical split. -This function is defined in XEmacs as it lacks -`window-full-height-p'. The values of the functions -`window-height' and `frame-height' are compared instead. The -argument WINDOW is ignored." - (= (1+ (window-height)) - (frame-height))) +(define-obsolete-function-alias 'mh-window-full-height-p + #'window-full-height-p "29.1") (defmacro mh-write-file-functions () - "Return `write-file-functions' if it exists. -Otherwise return `local-write-file-hooks'. -This macro exists purely for compatibility. The former symbol is used -in Emacs 22 onward while the latter is used in previous versions and -XEmacs." - (if (boundp 'write-file-functions) - ''write-file-functions ;Emacs 22 on - ''local-write-file-hooks)) ;XEmacs + "Return `write-file-functions'." + (declare (obsolete nil "29.1")) + ''write-file-functions) (provide 'mh-compat) diff --git a/lisp/mh-e/mh-e.el b/lisp/mh-e/mh-e.el index 9cbc8cfb737..17faff0716c 100644 --- a/lisp/mh-e/mh-e.el +++ b/lisp/mh-e/mh-e.el @@ -88,29 +88,6 @@ (require 'mh-buffers) (require 'mh-compat) -(mh-do-in-xemacs - (require 'mh-xemacs)) - -(mh-font-lock-add-keywords - 'emacs-lisp-mode - (eval-when-compile - `((,(concat "(\\(" - ;; Function declarations (use font-lock-function-name-face). - "\\(def\\(un\\|macro\\)-mh\\)\\|" - ;; Variable declarations (use font-lock-variable-name-face). - "\\(def\\(custom\\|face\\)-mh\\)\\|" - ;; Group declarations (use font-lock-type-face). - "\\(defgroup-mh\\)" - "\\)\\>" - ;; Any whitespace and defined object. - "[ \t'(]*" - "\\(setf[ \t]+\\sw+)\\|\\sw+\\)?") - (1 font-lock-keyword-face) - (7 (cond ((match-beginning 2) font-lock-function-name-face) - ((match-beginning 4) font-lock-variable-name-face) - (t font-lock-type-face)) - nil t))))) - ;;; Global Variables @@ -368,15 +345,13 @@ when searching for a separator.") "This regular expression matches the signature separator. See `mh-signature-separator'.") -(defvar mh-thread-scan-line-map nil +(defvar-local mh-thread-scan-line-map nil "Map of message index to various parts of the scan line.") -(make-variable-buffer-local 'mh-thread-scan-line-map) -(defvar mh-thread-scan-line-map-stack nil +(defvar-local mh-thread-scan-line-map-stack nil "Old map of message index to various parts of the scan line. This is the original map that is stored when the folder is narrowed.") -(make-variable-buffer-local 'mh-thread-scan-line-map-stack) (defcustom mh-x-mailer-string nil "String containing the contents of the X-Mailer header field. @@ -486,7 +461,7 @@ all the strings have been used." (count 0)) (while (and (not (eobp)) (< count mh-index-max-cmdline-args)) (push (buffer-substring-no-properties (point) - (mh-line-end-position)) + (line-end-position)) arg-list) (cl-incf count) (forward-line)) @@ -619,23 +594,18 @@ Output is expected to be shown to user, not parsed by MH-E." ;; The bug wasn't seen in emacs21 but still occurred in XEmacs21.4. (mh-exchange-point-and-mark-preserving-active-mark)) -;; Shush compiler. -(mh-do-in-xemacs - (defvar mark-active)) - (defun mh-exchange-point-and-mark-preserving-active-mark () "Put the mark where point is now, and point where the mark is now. This command works even when the mark is not active, and preserves whether the mark is active or not." (interactive nil) - (let ((is-active (and (boundp 'mark-active) mark-active))) + (let ((is-active mark-active)) (let ((omark (mark t))) (if (null omark) (error "No mark set in this buffer")) (set-mark (point)) (goto-char omark) - (if (boundp 'mark-active) - (setq mark-active is-active)) + (setq mark-active is-active) nil))) (defun mh-exec-lib-cmd-output (command &rest args) @@ -663,56 +633,39 @@ Set mark after inserted text." ;;; MH-E Customization Support Routines -;; Shush compiler (Emacs 21 and XEmacs). -(defvar customize-package-emacs-version-alist) - ;; Temporary function and data structure used customization. ;; These will be unbound after the options are defined. (defmacro mh-strip-package-version (args) - "Strip :package-version keyword and its value from ARGS. -In Emacs versions that support the :package-version keyword, -ARGS is returned unchanged." - `(if (boundp 'customize-package-emacs-version-alist) - ,args - (let (seen) - (cl-loop for keyword in ,args - if (cond ((eq keyword ':package-version) (setq seen t) nil) - (seen (setq seen nil) nil) - (t t)) - collect keyword)))) + "ARGS is returned unchanged." + (declare (obsolete identity "29.1")) + args) (defmacro defgroup-mh (symbol members doc &rest args) "Declare SYMBOL as a customization group containing MEMBERS. See documentation for `defgroup' for a description of the arguments -SYMBOL, MEMBERS, DOC and ARGS. -This macro is used by Emacs versions that lack the :package-version -keyword, introduced in Emacs 22." - (declare (doc-string 3) (indent defun)) - `(defgroup ,symbol ,members ,doc ,@(mh-strip-package-version args))) +SYMBOL, MEMBERS, DOC and ARGS." + (declare (obsolete defgroup "29.1") (doc-string 3) (indent defun)) + `(defgroup ,symbol ,members ,doc ,args)) (defmacro defcustom-mh (symbol value doc &rest args) "Declare SYMBOL as a customizable variable that defaults to VALUE. See documentation for `defcustom' for a description of the arguments -SYMBOL, VALUE, DOC and ARGS. -This macro is used by Emacs versions that lack the :package-version -keyword, introduced in Emacs 22." - (declare (doc-string 3) (indent defun)) - `(defcustom ,symbol ,value ,doc ,@(mh-strip-package-version args))) +SYMBOL, VALUE, DOC and ARGS." + (declare (obsolete defcustom "29.1") (doc-string 3) (indent defun)) + `(defcustom ,symbol ,value ,doc ,args)) (defmacro defface-mh (face spec doc &rest args) "Declare FACE as a customizable face that defaults to SPEC. See documentation for `defface' for a description of the arguments -FACE, SPEC, DOC and ARGS. -This macro is used by Emacs versions that lack the :package-version -keyword, introduced in Emacs 22." - (declare (doc-string 3) (indent defun)) - `(defface ,face ,spec ,doc ,@(mh-strip-package-version args))) +FACE, SPEC, DOC and ARGS." + (declare (obsolete defface "29.1") (doc-string 3) (indent defun)) + `(defface ,face ,spec ,doc ,args)) ;;; Variant Support -(defcustom-mh mh-path nil +(defcustom mh-path nil "Additional list of directories to search for MH. See `mh-variant'." :group 'mh-e @@ -947,7 +900,7 @@ finally GNU mailutils MH." (mapconcat (lambda (x) (format "%s" (car x))) (mh-variants) " or ")))))) -(defcustom-mh mh-variant 'autodetect +(defcustom mh-variant 'autodetect "Specifies the variant used by MH-E. The default setting of this option is \"Auto-detect\" which means @@ -1023,19 +976,18 @@ windows in the frame are removed." (when delete-other-windows-flag (delete-other-windows))) -(if (boundp 'customize-package-emacs-version-alist) - (add-to-list 'customize-package-emacs-version-alist - '(MH-E ("6.0" . "22.1") ("6.1" . "22.1") ("7.0" . "22.1") - ("7.1" . "22.1") ("7.2" . "22.1") ("7.3" . "22.1") - ("7.4" . "22.1") ("8.0" . "22.1") ("8.1" . "23.1") - ("8.2" . "23.1") ("8.3" . "24.1") ("8.4" . "24.4") - ("8.5" . "24.4") ("8.6" . "24.4")))) +(add-to-list 'customize-package-emacs-version-alist + '(MH-E ("6.0" . "22.1") ("6.1" . "22.1") ("7.0" . "22.1") + ("7.1" . "22.1") ("7.2" . "22.1") ("7.3" . "22.1") + ("7.4" . "22.1") ("8.0" . "22.1") ("8.1" . "23.1") + ("8.2" . "23.1") ("8.3" . "24.1") ("8.4" . "24.4") + ("8.5" . "24.4") ("8.6" . "24.4"))) ;;; MH-E Customization Groups -(defgroup-mh mh-e nil +(defgroup mh-e nil "Emacs interface to the MH mail system. MH is the Rand Mail Handler. Other implementations include nmh and GNU mailutils." @@ -1043,126 +995,126 @@ and GNU mailutils." :group 'mail :package-version '(MH-E . "8.0")) -(defgroup-mh mh-alias nil +(defgroup mh-alias nil "Aliases." :link '(custom-manual "(mh-e)Aliases") :prefix "mh-alias-" :group 'mh-e :package-version '(MH-E . "7.1")) -(defgroup-mh mh-folder nil +(defgroup mh-folder nil "Organizing your mail with folders." :prefix "mh-" :link '(custom-manual "(mh-e)Folders") :group 'mh-e :package-version '(MH-E . "7.1")) -(defgroup-mh mh-folder-selection nil +(defgroup mh-folder-selection nil "Folder selection." :prefix "mh-" :link '(custom-manual "(mh-e)Folder Selection") :group 'mh-e :package-version '(MH-E . "8.0")) -(defgroup-mh mh-identity nil +(defgroup mh-identity nil "Identities." :link '(custom-manual "(mh-e)Identities") :prefix "mh-identity-" :group 'mh-e :package-version '(MH-E . "7.1")) -(defgroup-mh mh-inc nil +(defgroup mh-inc nil "Incorporating your mail." :prefix "mh-inc-" :link '(custom-manual "(mh-e)Incorporating Mail") :group 'mh-e :package-version '(MH-E . "8.0")) -(defgroup-mh mh-junk nil +(defgroup mh-junk nil "Dealing with junk mail." :link '(custom-manual "(mh-e)Junk") :prefix "mh-junk-" :group 'mh-e :package-version '(MH-E . "7.3")) -(defgroup-mh mh-letter nil +(defgroup mh-letter nil "Editing a draft." :prefix "mh-" :link '(custom-manual "(mh-e)Editing Drafts") :group 'mh-e :package-version '(MH-E . "7.1")) -(defgroup-mh mh-ranges nil +(defgroup mh-ranges nil "Ranges." :prefix "mh-" :link '(custom-manual "(mh-e)Ranges") :group 'mh-e :package-version '(MH-E . "8.0")) -(defgroup-mh mh-scan-line-formats nil +(defgroup mh-scan-line-formats nil "Scan line formats." :link '(custom-manual "(mh-e)Scan Line Formats") :prefix "mh-" :group 'mh-e :package-version '(MH-E . "8.0")) -(defgroup-mh mh-search nil +(defgroup mh-search nil "Searching." :link '(custom-manual "(mh-e)Searching") :prefix "mh-search-" :group 'mh-e :package-version '(MH-E . "8.0")) -(defgroup-mh mh-sending-mail nil +(defgroup mh-sending-mail nil "Sending mail." :prefix "mh-" :link '(custom-manual "(mh-e)Sending Mail") :group 'mh-e :package-version '(MH-E . "8.0")) -(defgroup-mh mh-sequences nil +(defgroup mh-sequences nil "Sequences." :prefix "mh-" :link '(custom-manual "(mh-e)Sequences") :group 'mh-e :package-version '(MH-E . "8.0")) -(defgroup-mh mh-show nil +(defgroup mh-show nil "Reading your mail." :prefix "mh-" :link '(custom-manual "(mh-e)Reading Mail") :group 'mh-e :package-version '(MH-E . "7.1")) -(defgroup-mh mh-speedbar nil +(defgroup mh-speedbar nil "The speedbar." :prefix "mh-speed-" :link '(custom-manual "(mh-e)Speedbar") :group 'mh-e :package-version '(MH-E . "8.0")) -(defgroup-mh mh-thread nil +(defgroup mh-thread nil "Threading." :prefix "mh-thread-" :link '(custom-manual "(mh-e)Threading") :group 'mh-e :package-version '(MH-E . "8.0")) -(defgroup-mh mh-tool-bar nil +(defgroup mh-tool-bar nil "The tool bar" :link '(custom-manual "(mh-e)Tool Bar") :prefix "mh-" :group 'mh-e :package-version '(MH-E . "8.0")) -(defgroup-mh mh-hooks nil +(defgroup mh-hooks nil "MH-E hooks." :link '(custom-manual "(mh-e)Top") :prefix "mh-" :group 'mh-e :package-version '(MH-E . "7.1")) -(defgroup-mh mh-faces nil +(defgroup mh-faces nil "Faces used in MH-E." :link '(custom-manual "(mh-e)Top") :prefix "mh-" @@ -1178,7 +1130,7 @@ and GNU mailutils." ;;; Aliases (:group 'mh-alias) -(defcustom-mh mh-alias-completion-ignore-case-flag t +(defcustom mh-alias-completion-ignore-case-flag t "Non-nil means don't consider case significant in MH alias completion. As MH ignores case in the aliases, so too does MH-E. However, you @@ -1189,7 +1141,7 @@ lowercase for mailing lists and uppercase for people." :group 'mh-alias :package-version '(MH-E . "7.1")) -(defcustom-mh mh-alias-expand-aliases-flag nil +(defcustom mh-alias-expand-aliases-flag nil "Non-nil means to expand aliases entered in the minibuffer. In other words, aliases entered in the minibuffer will be @@ -1199,7 +1151,7 @@ this expansion is not performed." :group 'mh-alias :package-version '(MH-E . "7.1")) -(defcustom-mh mh-alias-flash-on-comma t +(defcustom mh-alias-flash-on-comma t "Specify whether to flash address or warn on translation. This option controls the behavior when a [comma] is pressed while @@ -1212,7 +1164,7 @@ does not display a warning if the alias is not found." :group 'mh-alias :package-version '(MH-E . "7.1")) -(defcustom-mh mh-alias-insert-file nil +(defcustom mh-alias-insert-file nil "Filename used to store a new MH-E alias. The default setting of this option is \"Use Aliasfile Profile @@ -1226,7 +1178,7 @@ name, MH-E will prompt for one of them when MH-E adds an alias." :group 'mh-alias :package-version '(MH-E . "7.1")) -(defcustom-mh mh-alias-insertion-location 'sorted +(defcustom mh-alias-insertion-location 'sorted "Specifies where new aliases are entered in alias files. This option is set to \"Alphabetical\" by default. If you organize @@ -1238,7 +1190,7 @@ or \"Bottom\" of your alias file might be more appropriate." :group 'mh-alias :package-version '(MH-E . "7.1")) -(defcustom-mh mh-alias-local-users t +(defcustom mh-alias-local-users t "Non-nil means local users are added to alias completion. Aliases are created from \"/etc/passwd\" entries with a user ID @@ -1259,7 +1211,7 @@ NIS password file." :group 'mh-alias :package-version '(MH-E . "7.1")) -(defcustom-mh mh-alias-local-users-prefix "local." +(defcustom mh-alias-local-users-prefix "local." "String prefixed to the real names of users from the password file. This option can also be set to \"Use Login\". @@ -1281,7 +1233,7 @@ turned off." :group 'mh-alias :package-version '(MH-E . "7.4")) -(defcustom-mh mh-alias-passwd-gecos-comma-separator-flag t +(defcustom mh-alias-passwd-gecos-comma-separator-flag t "Non-nil means the gecos field in the password file uses a comma separator. In the example in `mh-alias-local-users-prefix', commas are used @@ -1295,7 +1247,7 @@ whose contents may contain commas, you can turn this option off." ;;; Organizing Your Mail with Folders (:group 'mh-folder) -(defcustom-mh mh-new-messages-folders t +(defcustom mh-new-messages-folders t "Folders searched for the \"unseen\" sequence. Set this option to \"Inbox\" to search the \"+inbox\" folder or @@ -1310,7 +1262,7 @@ See also `mh-recursive-folders-flag'." :group 'mh-folder :package-version '(MH-E . "8.0")) -(defcustom-mh mh-ticked-messages-folders t +(defcustom mh-ticked-messages-folders t "Folders searched for `mh-tick-seq'. Set this option to \"Inbox\" to search the \"+inbox\" folder or @@ -1325,7 +1277,7 @@ See also `mh-recursive-folders-flag'." :group 'mh-folder :package-version '(MH-E . "8.0")) -(defcustom-mh mh-large-folder 200 +(defcustom mh-large-folder 200 "The number of messages that indicates a large folder. If a folder is deemed to be large, that is the number of messages @@ -1337,7 +1289,7 @@ folders are treated as if they are small." :group 'mh-folder :package-version '(MH-E . "7.0")) -(defcustom-mh mh-recenter-summary-flag nil +(defcustom mh-recenter-summary-flag nil "Non-nil means to recenter the summary window. If this option is turned on, recenter the summary window when the @@ -1346,13 +1298,13 @@ show window is toggled off." :group 'mh-folder :package-version '(MH-E . "7.0")) -(defcustom-mh mh-recursive-folders-flag nil +(defcustom mh-recursive-folders-flag nil "Non-nil means that commands which operate on folders do so recursively." :type 'boolean :group 'mh-folder :package-version '(MH-E . "7.0")) -(defcustom-mh mh-sortm-args nil +(defcustom mh-sortm-args nil "Additional arguments for \"sortm\"\\<mh-folder-mode-map>. This option is consulted when a prefix argument is used with @@ -1366,7 +1318,7 @@ an alternate view. For example, (\"-nolimit\" \"-textfield\" ;;; Folder Selection (:group 'mh-folder-selection) -(defcustom-mh mh-default-folder-for-message-function nil +(defcustom mh-default-folder-for-message-function nil "Function to select a default folder for refiling or \"Fcc:\". When this function is called, the current buffer contains the message @@ -1378,7 +1330,7 @@ the default, or an empty string to suppress the default entirely." :group 'mh-folder-selection :package-version '(MH-E . "8.0")) -(defcustom-mh mh-default-folder-list nil +(defcustom mh-default-folder-list nil "List of addresses and folders. The folder name associated with the first address found in this @@ -1396,7 +1348,7 @@ for more information." :group 'mh-folder-selection :package-version '(MH-E . "7.2")) -(defcustom-mh mh-default-folder-must-exist-flag t +(defcustom mh-default-folder-must-exist-flag t "Non-nil means guessed folder name must exist to be used. If the derived folder does not exist, and this option is on, then @@ -1410,7 +1362,7 @@ for more information." :group 'mh-folder-selection :package-version '(MH-E . "7.2")) -(defcustom-mh mh-default-folder-prefix "" +(defcustom mh-default-folder-prefix "" "Prefix used for folder names generated from aliases. The prefix is used to prevent clutter in your mail directory. @@ -1429,7 +1381,7 @@ for more information." Real definition will take effect when mh-identity is loaded." nil))) -(defcustom-mh mh-identity-list nil +(defcustom mh-identity-list nil "List of identities. To customize this option, click on the \"INS\" button and enter a label @@ -1498,7 +1450,7 @@ fashion." :group 'mh-identity :package-version '(MH-E . "7.1")) -(defcustom-mh mh-auto-fields-list nil +(defcustom mh-auto-fields-list nil "List of recipients for which header lines are automatically inserted. This option can be used to set the identity depending on the @@ -1559,14 +1511,14 @@ as the result is undefined." :group 'mh-identity :package-version '(MH-E . "7.3")) -(defcustom-mh mh-auto-fields-prompt-flag t +(defcustom mh-auto-fields-prompt-flag t "Non-nil means to prompt before sending if fields inserted. See `mh-auto-fields-list'." :type 'boolean :group 'mh-identity :package-version '(MH-E . "8.0")) -(defcustom-mh mh-identity-default nil +(defcustom mh-identity-default nil "Default identity to use when `mh-letter-mode' is called. See `mh-identity-list'." :type (append @@ -1577,7 +1529,7 @@ See `mh-identity-list'." :group 'mh-identity :package-version '(MH-E . "7.1")) -(defcustom-mh mh-identity-handlers +(defcustom mh-identity-handlers '(("From" . mh-identity-handler-top) (":default" . mh-identity-handler-bottom) (":attribution-verb" . mh-identity-handler-attribution-verb) @@ -1613,7 +1565,7 @@ containing the VALUE for the field is given." ;;; Incorporating Your Mail (:group 'mh-inc) -(defcustom-mh mh-inc-prog "inc" +(defcustom mh-inc-prog "inc" "Program to incorporate new mail into a folder. This program generates a one-line summary for each of the new @@ -1632,7 +1584,7 @@ several scan line format variables appropriately." Real definition will take effect when mh-inc is loaded." nil))) -(defcustom-mh mh-inc-spool-list nil +(defcustom mh-inc-spool-list nil "Alternate spool files. You can use the `mh-inc-spool-list' variable to direct MH-E to @@ -1655,17 +1607,14 @@ on the \"INS\" button. Enter a \"Spool File\" of \"~/mail/mh-e\", a \"Folder\" of \"mh-e\", and a \"Key Binding\" of \"m\". You can use \"xbuffy\" to automate the incorporation of this mail -using the Emacs 22 command \"emacsclient\" as follows: +using \"emacsclient\" as follows: box ~/mail/mh-e title mh-e origMode polltime 10 headertime 0 - command emacsclient --eval \\='(mh-inc-spool-mh-e)\\=' - -In XEmacs, the command \"gnuclient\" is used in a similar -fashion." + command emacsclient --eval \\='(mh-inc-spool-mh-e)\\='" :type '(repeat (list (file :tag "Spool File") (string :tag "Folder") (character :tag "Key Binding"))) @@ -1705,7 +1654,7 @@ The function is always called with SYMBOL bound to until (executable-find (symbol-name (car element))) finally return (car element))))) -(defcustom-mh mh-junk-background nil +(defcustom mh-junk-background nil "If on, spam programs are run in background. By default, the programs are run in the foreground, but this can @@ -1723,14 +1672,14 @@ may be useful for debugging." :group 'mh-junk :package-version '(MH-E . "8.0")) -(defcustom-mh mh-junk-disposition nil +(defcustom mh-junk-disposition nil "Disposition of junk mail." :type '(choice (const :tag "Delete Spam" nil) (string :tag "Spam Folder")) :group 'mh-junk :package-version '(MH-E . "8.0")) -(defcustom-mh mh-junk-program nil +(defcustom mh-junk-program nil "Spam program that MH-E should use. The default setting of this option is \"Auto-detect\" which means @@ -1748,7 +1697,7 @@ bogofilter, then you can set this option to \"Bogofilter\"." ;;; Editing a Draft (:group 'mh-letter) -(defcustom-mh mh-compose-insertion (if (locate-library "mml") 'mml 'mh) +(defcustom mh-compose-insertion (if (locate-library "mml") 'mml 'mh) "Type of tags used when composing MIME messages. In addition to MH-style directives, MH-E also supports MML (MIME @@ -1762,7 +1711,7 @@ MH-style directives are preferred." :group 'mh-letter :package-version '(MH-E . "7.0")) -(defcustom-mh mh-compose-skipped-header-fields +(defcustom mh-compose-skipped-header-fields '("From" "Organization" "References" "In-Reply-To" "X-Face" "Face" "X-Image-URL" "X-Mailer") "List of header fields to skip over when navigating in draft." @@ -1770,13 +1719,13 @@ MH-style directives are preferred." :group 'mh-letter :package-version '(MH-E . "7.4")) -(defcustom-mh mh-compose-space-does-completion-flag nil +(defcustom mh-compose-space-does-completion-flag nil "Non-nil means \\<mh-letter-mode-map>\\[mh-letter-complete-or-space] does completion in message header." :type 'boolean :group 'mh-letter :package-version '(MH-E . "7.4")) -(defcustom-mh mh-delete-yanked-msg-window-flag nil +(defcustom mh-delete-yanked-msg-window-flag nil "Non-nil means delete any window displaying the message. This deletes the window containing the original message after @@ -1786,7 +1735,7 @@ more room on your screen for your reply." :group 'mh-letter :package-version '(MH-E . "7.0")) -(defcustom-mh mh-extract-from-attribution-verb "wrote:" +(defcustom mh-extract-from-attribution-verb "wrote:" "Verb to use for attribution when a message is yanked by \\<mh-letter-mode-map>\\[mh-yank-cur-msg]. The attribution consists of the sender's name and email address @@ -1800,7 +1749,7 @@ followed by the content of this option. This option can be set to :group 'mh-letter :package-version '(MH-E . "7.0")) -(defcustom-mh mh-ins-buf-prefix "> " +(defcustom mh-ins-buf-prefix "> " "String to put before each line of a yanked or inserted message. The prefix \"> \" is the default setting of this option. I @@ -1816,17 +1765,17 @@ flavors of `mh-yank-behavior' or you have added a :group 'mh-letter :package-version '(MH-E . "6.0")) -(defcustom-mh mh-letter-complete-function 'ispell-complete-word +(defcustom mh-letter-complete-function 'ispell-complete-word "Function to call when completing outside of address or folder fields. In the body of the message, -\\<mh-letter-mode-map>\\[mh-letter-complete] runs this function, +\\<mh-letter-mode-map>\\[completion-at-point] runs this function, which is set to \"ispell-complete-word\" by default." :type '(choice function (const nil)) :group 'mh-letter :package-version '(MH-E . "7.1")) -(defcustom-mh mh-letter-fill-column 72 +(defcustom mh-letter-fill-column 72 "Fill column to use in MH Letter mode. By default, this option is 72 to allow others to quote your @@ -1835,7 +1784,7 @@ message without line wrapping." :group 'mh-letter :package-version '(MH-E . "6.0")) -(defcustom-mh mh-mml-method-default (if mh-pgp-support-flag "pgpmime" "none") +(defcustom mh-mml-method-default (if mh-pgp-support-flag "pgpmime" "none") "Default method to use in security tags. This option is used to select between a variety of mail security @@ -1858,7 +1807,7 @@ you write!" :group 'mh-letter :package-version '(MH-E . "8.0")) -(defcustom-mh mh-signature-file-name "~/.signature" +(defcustom mh-signature-file-name "~/.signature" "Source of user's signature. By default, the text of your signature is taken from the file @@ -1881,7 +1830,7 @@ The signature is inserted into your message with the command :group 'mh-letter :package-version '(MH-E . "6.0")) -(defcustom-mh mh-signature-separator-flag t +(defcustom mh-signature-separator-flag t "Non-nil means a signature separator should be inserted. It is not recommended that you change this option since various @@ -1892,7 +1841,7 @@ replying or yanking a letter into a draft." :group 'mh-letter :package-version '(MH-E . "8.0")) -(defcustom-mh mh-x-face-file "~/.face" +(defcustom mh-x-face-file "~/.face" "File containing face header field to insert in outgoing mail. If the file starts with either of the strings \"X-Face:\", \"Face:\" @@ -1921,7 +1870,7 @@ this option doesn't exist." :group 'mh-letter :package-version '(MH-E . "7.0")) -(defcustom-mh mh-yank-behavior 'attribution +(defcustom mh-yank-behavior 'attribution "Controls which part of a message is yanked by \\<mh-letter-mode-map>\\[mh-yank-cur-msg]. To include the entire message, including the entire header, use @@ -1968,7 +1917,7 @@ inserted." ;;; Ranges (:group 'mh-ranges) -(defcustom-mh mh-interpret-number-as-range-flag t +(defcustom mh-interpret-number-as-range-flag t "Non-nil means interpret a number as a range. Since one of the most frequent ranges used is \"last:N\", MH-E @@ -1988,7 +1937,7 @@ message 200, then use the range \"200:200\"." Real definition, below, uses variables that aren't defined yet." (set-default symbol value)))) -(defcustom-mh mh-adaptive-cmd-note-flag t +(defcustom mh-adaptive-cmd-note-flag t "Non-nil means that the message number width is determined dynamically. If you've created your own format to handle long message numbers, @@ -2017,7 +1966,7 @@ set SYMBOL to VALUE." "unless you use \"Use MH-E scan Format\"") (set-default symbol value))) -(defcustom-mh mh-scan-format-file t +(defcustom mh-scan-format-file t "Specifies the format file to pass to the scan program. The default setting for this option is \"Use MH-E scan Format\". This @@ -2056,7 +2005,7 @@ Otherwise, set SYMBOL to VALUE." "is set to \"Use MH-E scan Format\"") (set-default symbol value))) -(defcustom-mh mh-scan-prog "scan" +(defcustom mh-scan-prog "scan" "Program used to scan messages. The name of the program that generates a listing of one line per @@ -2071,7 +2020,7 @@ directory. You may link another program to `scan' (see ;;; Searching (:group 'mh-search) -(defcustom-mh mh-search-program nil +(defcustom mh-search-program nil "Search program that MH-E shall use. The default setting of this option is \"Auto-detect\" which means @@ -2094,7 +2043,7 @@ MH-E can be found in the documentation of `mh-search'." ;;; Sending Mail (:group 'mh-sending-mail) -(defcustom-mh mh-compose-forward-as-mime-flag t +(defcustom mh-compose-forward-as-mime-flag t "Non-nil means that messages are forwarded as attachments. By default, this option is on which means that the forwarded @@ -2110,7 +2059,7 @@ regardless of the settings of this option." :group 'mh-sending-mail :package-version '(MH-E . "8.0")) -(defcustom-mh mh-compose-letter-function nil +(defcustom mh-compose-letter-function nil "Invoked when starting a new draft. However, it is the last function called before you edit your @@ -2122,13 +2071,13 @@ fields." :group 'mh-sending-mail :package-version '(MH-E . "6.0")) -(defcustom-mh mh-compose-prompt-flag nil +(defcustom mh-compose-prompt-flag nil "Non-nil means prompt for header fields when composing a new draft." :type 'boolean :group 'mh-sending-mail :package-version '(MH-E . "7.4")) -(defcustom-mh mh-forward-subject-format "%s: %s" +(defcustom mh-forward-subject-format "%s: %s" "Format string for forwarded message subject. This option is a string which includes two escapes (\"%s\"). The @@ -2138,7 +2087,7 @@ and the second one is replaced with the original \"Subject:\"." :group 'mh-sending-mail :package-version '(MH-E . "6.0")) -(defcustom-mh mh-insert-x-mailer-flag t +(defcustom mh-insert-x-mailer-flag t "Non-nil means append an \"X-Mailer:\" header field to the header. This header field includes the version of MH-E and Emacs that you @@ -2148,7 +2097,7 @@ can turn this option off." :group 'mh-sending-mail :package-version '(MH-E . "7.0")) -(defcustom-mh mh-redist-full-contents-flag nil +(defcustom mh-redist-full-contents-flag nil "Non-nil means the \"dist\" command needs entire letter for redistribution. This option must be turned on if \"dist\" requires the whole @@ -2160,7 +2109,7 @@ has been redistributed before, turn off this option." :group 'mh-sending-mail :package-version '(MH-E . "8.0")) -(defcustom-mh mh-reply-default-reply-to nil +(defcustom mh-reply-default-reply-to nil "Sets the person or persons to whom a reply will be sent. This option is set to \"Prompt\" by default so that you are @@ -2176,7 +2125,7 @@ this option to \"cc\". Other choices include \"from\", \"to\", or :group 'mh-sending-mail :package-version '(MH-E . "6.0")) -(defcustom-mh mh-reply-show-message-flag t +(defcustom mh-reply-show-message-flag t "Non-nil means the MH-Show buffer is displayed when replying. If you include the message automatically, you can hide the @@ -2193,7 +2142,7 @@ See also `mh-reply'." ;; the docstring: "Additional sequences that should not to be preserved can be ;; specified by setting `mh-unpropagated-sequences' appropriately." XXX -(defcustom-mh mh-refile-preserves-sequences-flag t +(defcustom mh-refile-preserves-sequences-flag t "Non-nil means that sequences are preserved when messages are refiled. If a message is in any sequence (except \"Previous-Sequence:\" @@ -2204,7 +2153,7 @@ desired, then turn off this option." :group 'mh-sequences :package-version '(MH-E . "7.4")) -(defcustom-mh mh-tick-seq 'tick +(defcustom mh-tick-seq 'tick "The name of the MH sequence for ticked messages. You can customize this option if you already use the \"tick\" @@ -2216,7 +2165,7 @@ there isn't much advantage to that." :group 'mh-sequences :package-version '(MH-E . "7.3")) -(defcustom-mh mh-update-sequences-after-mh-show-flag t +(defcustom mh-update-sequences-after-mh-show-flag t "Non-nil means flush MH sequences to disk after message is shown\\<mh-folder-mode-map>. Three sequences are maintained internally by MH-E and pushed out @@ -2231,7 +2180,7 @@ commands." :group 'mh-sequences :package-version '(MH-E . "7.0")) -(defcustom-mh mh-allowlist-preserves-sequences-flag t +(defcustom mh-allowlist-preserves-sequences-flag t "Non-nil means that sequences are preserved when messages are allowlisted. If a message is in any sequence (except \"Previous-Sequence:\" @@ -2244,7 +2193,7 @@ not desired, then turn off this option." ;;; Reading Your Mail (:group 'mh-show) -(defcustom-mh mh-bury-show-buffer-flag t +(defcustom mh-bury-show-buffer-flag t "Non-nil means show buffer is buried. One advantage of not burying the show buffer is that one can @@ -2255,7 +2204,7 @@ running \\[electric-buffer-list] to see what I mean." :group 'mh-show :package-version '(MH-E . "7.0")) -(defcustom-mh mh-clean-message-header-flag t +(defcustom mh-clean-message-header-flag t "Non-nil means remove extraneous header fields. See also `mh-invisible-header-fields-default' and @@ -2264,7 +2213,7 @@ See also `mh-invisible-header-fields-default' and :group 'mh-show :package-version '(MH-E . "7.0")) -(defcustom-mh mh-decode-mime-flag (not (not (locate-library "mm-decode"))) +(defcustom mh-decode-mime-flag (not (not (locate-library "mm-decode"))) "Non-nil means attachments are handled\\<mh-folder-mode-map>. MH-E can handle attachments as well if the Gnus `mm-decode' @@ -2282,7 +2231,7 @@ messages and other graphical widgets. See the options :group 'mh-show :package-version '(MH-E . "7.0")) -(defcustom-mh mh-display-buttons-for-alternatives-flag nil +(defcustom mh-display-buttons-for-alternatives-flag nil "Non-nil means display buttons for all alternative attachments. Sometimes, a mail program will produce multiple alternatives of @@ -2294,7 +2243,7 @@ inline and buttons are shown for each of the other alternatives." :group 'mh-show :package-version '(MH-E . "7.4")) -(defcustom-mh mh-display-buttons-for-inline-parts-flag nil +(defcustom mh-display-buttons-for-inline-parts-flag nil "Non-nil means display buttons for all inline attachments\\<mh-folder-mode-map>. The sender can request that attachments should be viewed inline so @@ -2317,7 +2266,7 @@ text (including HTML) and images." :group 'mh-show :package-version '(MH-E . "7.0")) -(defcustom-mh mh-do-not-confirm-flag nil +(defcustom mh-do-not-confirm-flag nil "Non-nil means non-reversible commands do not prompt for confirmation. Commands such as `mh-pack-folder' prompt to confirm whether to @@ -2329,7 +2278,7 @@ retracted--without question." :group 'mh-show :package-version '(MH-E . "7.0")) -(defcustom-mh mh-fetch-x-image-url nil +(defcustom mh-fetch-x-image-url nil "Control fetching of \"X-Image-URL:\" header field image. This option controls the fetching of the \"X-Image-URL:\" header @@ -2365,7 +2314,7 @@ turned on." :group 'mh-show :package-version '(MH-E . "7.3")) -(defcustom-mh mh-graphical-smileys-flag t +(defcustom mh-graphical-smileys-flag t "Non-nil means graphical smileys are displayed. It is a long standing custom to inject body language using a @@ -2380,7 +2329,7 @@ turned off." :group 'mh-show :package-version '(MH-E . "7.0")) -(defcustom-mh mh-graphical-emphasis-flag t +(defcustom mh-graphical-emphasis-flag t "Non-nil means graphical emphasis is displayed. A few typesetting features are indicated in ASCII text with @@ -2397,7 +2346,7 @@ turned off." :group 'mh-show :package-version '(MH-E . "7.0")) -(defcustom-mh mh-highlight-citation-style 'gnus +(defcustom mh-highlight-citation-style 'gnus "Style for highlighting citations. If the sender of the message has cited other messages in his @@ -2819,7 +2768,7 @@ Because the function `mh-invisible-headers' uses both `mh-invisible-header-fields' and `mh-invisible-header-fields', it cannot be run until both variables have been initialized.") -(defcustom-mh mh-invisible-header-fields nil +(defcustom mh-invisible-header-fields nil "Additional header fields to hide. Header fields that you would like to hide that aren't listed in @@ -2842,7 +2791,7 @@ See also `mh-clean-message-header-flag'." :group 'mh-show :package-version '(MH-E . "7.1")) -(defcustom-mh mh-invisible-header-fields-default nil +(defcustom mh-invisible-header-fields-default nil "List of hidden header fields. The header fields listed in this option are hidden, although you @@ -2899,7 +2848,7 @@ removed and entries from `mh-invisible-header-fields' are added." ;; Compile invisible header fields. (mh-invisible-headers) -(defcustom-mh mh-lpr-command-format "lpr -J '%s'" +(defcustom mh-lpr-command-format "lpr -J '%s'" "Command used to print\\<mh-folder-mode-map>. This option contains the Unix command line which performs the @@ -2916,7 +2865,7 @@ This option is not used by the commands \\[mh-ps-print-msg] or :group 'mh-show :package-version '(MH-E . "6.0")) -(defcustom-mh mh-max-inline-image-height nil +(defcustom mh-max-inline-image-height nil "Maximum inline image height if \"Content-Disposition:\" is not present. Some older mail programs do not insert this needed plumbing to @@ -2932,7 +2881,7 @@ these numbers." :group 'mh-show :package-version '(MH-E . "7.0")) -(defcustom-mh mh-max-inline-image-width nil +(defcustom mh-max-inline-image-width nil "Maximum inline image width if \"Content-Disposition:\" is not present. Some older mail programs do not insert this needed plumbing to @@ -2948,7 +2897,7 @@ these numbers." :group 'mh-show :package-version '(MH-E . "7.0")) -(defcustom-mh mh-mhl-format-file nil +(defcustom mh-mhl-format-file nil "Specifies the format file to pass to the \"mhl\" program. Normally MH-E takes care of displaying messages itself (rather than @@ -2972,7 +2921,7 @@ file." :group 'mh-show :package-version '(MH-E . "8.0")) -(defcustom-mh mh-mime-save-parts-default-directory t +(defcustom mh-mime-save-parts-default-directory t "Default directory to use for \\<mh-folder-mode-map>\\[mh-mime-save-parts]. The default value for this option is \"Prompt Always\" so that @@ -2988,7 +2937,7 @@ directory's name." :group 'mh-show :package-version '(MH-E . "7.0")) -(defcustom-mh mh-print-background-flag nil +(defcustom mh-print-background-flag nil "Non-nil means messages should be printed in the background\\<mh-folder-mode-map>. Normally messages are printed in the foreground. If this is slow on @@ -3004,7 +2953,7 @@ This option is not used by the commands \\[mh-ps-print-msg] or :group 'mh-show :package-version '(MH-E . "7.0")) -(defcustom-mh mh-show-maximum-size 0 +(defcustom mh-show-maximum-size 0 "Maximum size of message (in bytes) to display automatically. This option provides an opportunity to skip over large messages @@ -3014,7 +2963,7 @@ message are shown regardless of size." :group 'mh-show :package-version '(MH-E . "8.0")) -(defcustom-mh mh-show-use-xface-flag (>= emacs-major-version 21) +(defcustom mh-show-use-xface-flag (>= emacs-major-version 21) "Non-nil means display face images in MH-show buffers. MH-E can display the content of \"Face:\", \"X-Face:\", and @@ -3029,15 +2978,12 @@ and off. This feature will be turned on by default if your system supports it. The first header field used, if present, is the Gnus-specific -\"Face:\" field. The \"Face:\" field appeared in GNU Emacs 21 and -XEmacs. For more information, see URL +\"Face:\" field. The \"Face:\" field appeared in Emacs 21. +For more information, see URL `https://quimby.gnus.org/circus/face/'. Next is the traditional \"X-Face:\" header field. The display of this field requires the \"uncompface\" program (see URL -`ftp://ftp.cs.indiana.edu/pub/faces/compface/compface.tar.z'). Recent -versions of XEmacs have internal support for \"X-Face:\" images. If -your version of XEmacs does not, then you'll need both \"uncompface\" -and the x-face package (see URL `https://www.jpl.org/ftp/pub/elisp/'). +`ftp://ftp.cs.indiana.edu/pub/faces/compface/compface.tar.z'). Finally, MH-E will display images referenced by the \"X-Image-URL:\" header field if neither the \"Face:\" nor the \"X-Face:\" fields are @@ -3054,7 +3000,7 @@ The option `mh-fetch-x-image-url' controls the fetching of the :group 'mh-show :package-version '(MH-E . "7.0")) -(defcustom-mh mh-store-default-directory nil +(defcustom mh-store-default-directory nil "Default directory for \\<mh-folder-mode-map>\\[mh-store-msg]. If you would like to change the initial default directory, @@ -3066,7 +3012,7 @@ the content of these messages." :group 'mh-show :package-version '(MH-E . "6.0")) -(defcustom-mh mh-summary-height nil +(defcustom mh-summary-height nil "Number of lines in MH-Folder buffer (including the mode line). The default value of this option is \"Automatic\" which means @@ -3081,7 +3027,7 @@ lines you'd like to see." ;;; The Speedbar (:group 'mh-speedbar) -(defcustom-mh mh-speed-update-interval 60 +(defcustom mh-speed-update-interval 60 "Time between speedbar updates in seconds. Set to 0 to disable automatic update." :type 'integer @@ -3090,7 +3036,7 @@ Set to 0 to disable automatic update." ;;; Threading (:group 'mh-thread) -(defcustom-mh mh-show-threads-flag nil +(defcustom mh-show-threads-flag nil "Non-nil means new folders start in threaded mode. Threading large number of messages can be time consuming so this @@ -3106,7 +3052,7 @@ threaded is less than `mh-large-folder'." ;; mh-tool-bar-folder-buttons and mh-tool-bar-letter-buttons defined ;; dynamically in mh-tool-bar.el. -(defcustom-mh mh-tool-bar-search-function 'mh-search +(defcustom mh-tool-bar-search-function 'mh-search "Function called by the tool bar search button. By default, this is set to `mh-search'. You can also choose @@ -3117,47 +3063,11 @@ of your own choosing." :group 'mh-tool-bar :package-version '(MH-E . "7.0")) -;; XEmacs has a couple of extra customizations... -(mh-do-in-xemacs - (defcustom-mh mh-xemacs-use-tool-bar-flag mh-xemacs-has-tool-bar-flag - "If non-nil, use tool bar. - -This option controls whether to show the MH-E icons at all. By -default, this option is turned on if the window system supports -tool bars. If your system doesn't support tool bars, then you -won't be able to turn on this option." - :type 'boolean - :group 'mh-tool-bar - :set (lambda (symbol value) - (if (and (eq value t) - (not mh-xemacs-has-tool-bar-flag)) - (error "Tool bar not supported")) - (set-default symbol value)) - :package-version '(MH-E . "7.3")) - - (defcustom-mh mh-xemacs-tool-bar-position nil - "Tool bar location. - -This option controls the placement of the tool bar along the four -edges of the frame. You can choose from one of \"Same As Default -Tool Bar\", \"Top\", \"Bottom\", \"Left\", or \"Right\". If this -variable is set to anything other than \"Same As Default Tool -Bar\" and the default tool bar is in a different location, then -two tool bars will be displayed: the MH-E tool bar and the -default tool bar." - :type '(radio (const :tag "Same As Default Tool Bar" :value nil) - (const :tag "Top" :value top) - (const :tag "Bottom" :value bottom) - (const :tag "Left" :value left) - (const :tag "Right" :value right)) - :group 'mh-tool-bar - :package-version '(MH-E . "7.3"))) - ;;; Hooks (:group 'mh-hooks + group where hook described) -(defcustom-mh mh-after-commands-processed-hook nil +(defcustom mh-after-commands-processed-hook nil "Hook run by \\<mh-folder-mode-map>\\[mh-execute-commands] after performing outstanding refile and delete requests. Variables that are useful in this hook include @@ -3169,14 +3079,14 @@ folder, which is also available in `mh-current-folder'." :group 'mh-folder :package-version '(MH-E . "8.0")) -(defcustom-mh mh-alias-reloaded-hook nil +(defcustom mh-alias-reloaded-hook nil "Hook run by `mh-alias-reload' after loading aliases." :type 'hook :group 'mh-hooks :group 'mh-alias :package-version '(MH-E . "8.0")) -(defcustom-mh mh-annotate-msg-hook nil +(defcustom mh-annotate-msg-hook nil "Hook run when a message is sent and after annotating the scan lines and message. Hook functions can access the current folder name with `mh-current-folder' and obtain the message numbers of the @@ -3186,7 +3096,7 @@ annotated messages with `mh-annotate-list'." :group 'mh-sending-mail :package-version '(MH-E . "8.1")) -(defcustom-mh mh-before-commands-processed-hook nil +(defcustom mh-before-commands-processed-hook nil "Hook run by \\<mh-folder-mode-map>\\[mh-execute-commands] before performing outstanding refile and delete requests. Variables that are useful in this hook include `mh-delete-list', @@ -3198,7 +3108,7 @@ used to see which changes will be made to the current folder, :group 'mh-folder :package-version '(MH-E . "8.0")) -(defcustom-mh mh-before-quit-hook nil +(defcustom mh-before-quit-hook nil "Hook run by \\<mh-folder-mode-map>\\[mh-quit] before quitting MH-E. This hook is called before the quit occurs, so you might use it @@ -3211,7 +3121,7 @@ See also `mh-quit-hook'." :group 'mh-folder :package-version '(MH-E . "6.0")) -(defcustom-mh mh-before-send-letter-hook nil +(defcustom mh-before-send-letter-hook nil "Hook run at the beginning of the \\<mh-letter-mode-map>\\[mh-send-letter] command. For example, if you want to check your spelling in your message @@ -3222,14 +3132,14 @@ before sending, add the `ispell-message' function." :group 'mh-letter :package-version '(MH-E . "6.0")) -(defcustom-mh mh-blocklist-msg-hook nil +(defcustom mh-blocklist-msg-hook nil "Hook run by \\<mh-letter-mode-map>\\[mh-junk-blocklist] after marking each message for blocklisting." :type 'hook :group 'mh-hooks :group 'mh-show :package-version '(MH-E . "8.4")) -(defcustom-mh mh-delete-msg-hook nil +(defcustom mh-delete-msg-hook nil "Hook run by \\<mh-letter-mode-map>\\[mh-delete-msg] after marking each message for deletion. For example, a past maintainer of MH-E used this once when he @@ -3239,7 +3149,7 @@ kept statistics on his mail usage." :group 'mh-show :package-version '(MH-E . "6.0")) -(defcustom-mh mh-find-path-hook nil +(defcustom mh-find-path-hook nil "Hook run by `mh-find-path' after reading the user's MH profile. This hook can be used the change the value of the variables that @@ -3250,28 +3160,28 @@ between MH and MH-E." :group 'mh-e :package-version '(MH-E . "7.0")) -(defcustom-mh mh-folder-mode-hook nil +(defcustom mh-folder-mode-hook nil "Hook run by `mh-folder-mode' when visiting a new folder." :type 'hook :group 'mh-hooks :group 'mh-folder :package-version '(MH-E . "6.0")) -(defcustom-mh mh-forward-hook nil +(defcustom mh-forward-hook nil "Hook run by `mh-forward' on a forwarded letter." :type 'hook :group 'mh-hooks :group 'mh-sending-mail :package-version '(MH-E . "8.0")) -(defcustom-mh mh-inc-folder-hook nil +(defcustom mh-inc-folder-hook nil "Hook run by \\<mh-folder-mode-map>\\[mh-inc-folder] after incorporating mail into a folder." :type 'hook :group 'mh-hooks :group 'mh-inc :package-version '(MH-E . "6.0")) -(defcustom-mh mh-insert-signature-hook nil +(defcustom mh-insert-signature-hook nil "Hook run by \\<mh-letter-mode-map>\\[mh-insert-signature] after signature has been inserted. Hook functions may access the actual name of the file or the @@ -3282,9 +3192,9 @@ function used to insert the signature with :group 'mh-letter :package-version '(MH-E . "8.0")) -(mh-define-obsolete-variable-alias 'mh-kill-folder-suppress-prompt-hooks +(define-obsolete-variable-alias 'mh-kill-folder-suppress-prompt-hooks 'mh-kill-folder-suppress-prompt-functions "24.3") -(defcustom-mh mh-kill-folder-suppress-prompt-functions '(mh-search-p) +(defcustom mh-kill-folder-suppress-prompt-functions '(mh-search-p) "Abnormal hook run at the beginning of \\<mh-folder-mode-map>\\[mh-kill-folder]. The hook functions are called with no arguments and should return @@ -3302,7 +3212,7 @@ accident in the \"+inbox\" folder, you will not be happy." :group 'mh-folder :package-version '(MH-E . "7.4")) -(defcustom-mh mh-letter-mode-hook nil +(defcustom mh-letter-mode-hook nil "Hook run by `mh-letter-mode' on a new letter. This hook allows you to do some processing before editing a @@ -3315,14 +3225,14 @@ go." :group 'mh-sending-mail :package-version '(MH-E . "6.0")) -(defcustom-mh mh-mh-to-mime-hook nil +(defcustom mh-mh-to-mime-hook nil "Hook run on the formatted letter by \\<mh-letter-mode-map>\\[mh-mh-to-mime]." :type 'hook :group 'mh-hooks :group 'mh-letter :package-version '(MH-E . "8.0")) -(defcustom-mh mh-search-mode-hook nil +(defcustom mh-search-mode-hook nil "Hook run upon entry to `mh-search-mode'\\<mh-folder-mode-map>. If you find that you do the same thing over and over when editing @@ -3334,7 +3244,7 @@ This can be done with this hook which is called when :group 'mh-search :package-version '(MH-E . "8.0")) -(defcustom-mh mh-pack-folder-hook nil +(defcustom mh-pack-folder-hook nil "Hook run by \\<mh-folder-mode-map>\\[mh-pack-folder] after renumbering the messages. Hook functions can access the current folder name with `mh-current-folder'." :type 'hook @@ -3342,7 +3252,7 @@ Hook functions can access the current folder name with `mh-current-folder'." :group 'mh-folder :package-version '(MH-E . "8.2")) -(defcustom-mh mh-quit-hook nil +(defcustom mh-quit-hook nil "Hook run by \\<mh-folder-mode-map>\\[mh-quit] after quitting MH-E. This hook is not run in an MH-E context, so you might use it to @@ -3354,14 +3264,14 @@ See also `mh-before-quit-hook'." :group 'mh-folder :package-version '(MH-E . "6.0")) -(defcustom-mh mh-refile-msg-hook nil +(defcustom mh-refile-msg-hook nil "Hook run by \\<mh-folder-mode-map>\\[mh-refile-msg] after marking each message for refiling." :type 'hook :group 'mh-hooks :group 'mh-folder :package-version '(MH-E . "6.0")) -(defcustom-mh mh-show-hook nil +(defcustom mh-show-hook nil "Hook run after \\<mh-folder-mode-map>\\[mh-show] shows a message. It is the last thing called after messages are displayed. It's @@ -3372,7 +3282,7 @@ used to affect the behavior of MH-E in general or when :group 'mh-show :package-version '(MH-E . "6.0")) -(defcustom-mh mh-show-mode-hook nil +(defcustom mh-show-mode-hook nil "Hook run upon entry to `mh-show-mode'. This hook is called early on in the process of the message display, @@ -3384,7 +3294,7 @@ buffer itself. See also `mh-show-hook'." :group 'mh-show :package-version '(MH-E . "8.7")) -(defcustom-mh mh-unseen-updated-hook nil +(defcustom mh-unseen-updated-hook nil "Hook run after the unseen sequence has been updated. The variable `mh-seen-list' can be used by this hook to obtain @@ -3395,7 +3305,7 @@ sequence." :group 'mh-sequences :package-version '(MH-E . "6.0")) -(defcustom-mh mh-allowlist-msg-hook nil +(defcustom mh-allowlist-msg-hook nil "Hook run by \\<mh-letter-mode-map>\\[mh-junk-allowlist] after marking each message for allowlisting." :type 'hook :group 'mh-hooks @@ -3406,15 +3316,10 @@ sequence." ;;; Faces (:group 'mh-faces + group where faces described) -(if (boundp 'facemenu-unlisted-faces) - ;; This variable was removed in Emacs 22.1. - (add-to-list 'facemenu-unlisted-faces "^mh-")) - ;; To add a new face: ;; 1. Add entry to variable mh-face-data. -;; 2. Create face using defface-mh (which removes min-color spec and -;; :package-version keyword where these are not supported), -;; accessing face data with function mh-face-data. +;; 2. Create face using defface, accessing face data with function +;; mh-face-data. ;; 3. Add inherit argument to function mh-face-data if applicable. (defvar mh-face-data '((mh-folder-followup @@ -3561,18 +3466,17 @@ sequence." (:underline t))))) "MH-E face data. Used by function `mh-face-data' which returns spec that is -consumed by `defface-mh'.") +consumed by `defface'.") (require 'cus-face) -(defvar mh-inherit-face-flag (assq :inherit custom-face-attributes) - "Non-nil means that the `defface' :inherit keyword is available. -The :inherit keyword is available on all supported versions of -GNU Emacs and XEmacs from at least 21.5.23 on.") +(defvar mh-inherit-face-flag t + "Non-nil means that the `defface' :inherit keyword is available.") +(make-obsolete-variable 'mh-inherit-face-flag nil "29.1") -(defvar mh-min-colors-defined-flag (and (not (featurep 'xemacs)) - (>= emacs-major-version 22)) +(defvar mh-min-colors-defined-flag t "Non-nil means `defface' supports min-colors display requirement.") +(make-obsolete-variable 'mh-min-colors-defined-flag nil "29.1") (defun mh-face-data (face &optional inherit) "Return spec for FACE. @@ -3583,53 +3487,26 @@ keyword, return INHERIT literally; otherwise, return spec for FACE from the variable `mh-face-data'. This isn't a perfect implementation. In the case that the :inherit keyword is not supported, any additional attributes in the inherit parameter are -not added to the returned spec. - -Furthermore, when `mh-min-colors-defined-flag' is nil, this -function finds display entries with \"min-colors\" requirements -and either removes the \"min-colors\" requirement or strips the -display entirely if the display does not support the number of -specified colors." - (let ((spec - (if (and inherit mh-inherit-face-flag) - inherit - (or (cadr (assq face mh-face-data)) - (error "Could not find %s in mh-face-data" face))))) - - (if mh-min-colors-defined-flag - spec - (let ((cells (mh-display-color-cells)) - new-spec) - ;; Remove entries with min-colors, or delete them if we have - ;; fewer colors than they specify. - (cl-loop - for entry in (reverse spec) do - (let ((requirement (if (eq (car entry) t) - nil - (assq 'min-colors (car entry))))) - (if requirement - (when (>= cells (nth 1 requirement)) - (setq new-spec (cons (cons (delq requirement (car entry)) - (cdr entry)) - new-spec))) - (setq new-spec (cons entry new-spec))))) - new-spec)))) - -(defface-mh mh-folder-address +not added to the returned spec." + (or inherit + (cadr (assq face mh-face-data)) + (error "Could not find %s in mh-face-data" face))) + +(defface mh-folder-address (mh-face-data 'mh-folder-subject '((t (:inherit mh-folder-subject)))) "Recipient face." :group 'mh-faces :group 'mh-folder :package-version '(MH-E . "8.0")) -(defface-mh mh-folder-blocklisted +(defface mh-folder-blocklisted (mh-face-data 'mh-folder-msg-number '((t (:inherit mh-folder-msg-number)))) "Blocklisted message face." :group 'mh-faces :group 'mh-folder :package-version '(MH-E . "8.4")) -(defface-mh mh-folder-body +(defface mh-folder-body (mh-face-data 'mh-folder-msg-number '((((class color)) (:inherit mh-folder-msg-number)) @@ -3640,7 +3517,7 @@ specified colors." :group 'mh-folder :package-version '(MH-E . "8.0")) -(defface-mh mh-folder-cur-msg-number +(defface mh-folder-cur-msg-number (mh-face-data 'mh-folder-msg-number '((t (:inherit mh-folder-msg-number :bold t)))) "Current message number face." @@ -3648,39 +3525,39 @@ specified colors." :group 'mh-folder :package-version '(MH-E . "8.0")) -(defface-mh mh-folder-date +(defface mh-folder-date (mh-face-data 'mh-folder-msg-number '((t (:inherit mh-folder-msg-number)))) "Date face." :group 'mh-faces :group 'mh-folder :package-version '(MH-E . "8.0")) -(defface-mh mh-folder-deleted +(defface mh-folder-deleted (mh-face-data 'mh-folder-msg-number '((t (:inherit mh-folder-msg-number)))) "Deleted message face." :group 'mh-faces :group 'mh-folder :package-version '(MH-E . "8.0")) -(defface-mh mh-folder-followup (mh-face-data 'mh-folder-followup) +(defface mh-folder-followup (mh-face-data 'mh-folder-followup) "\"Re:\" face." :group 'mh-faces :group 'mh-folder :package-version '(MH-E . "8.0")) -(defface-mh mh-folder-msg-number (mh-face-data 'mh-folder-msg-number) +(defface mh-folder-msg-number (mh-face-data 'mh-folder-msg-number) "Message number face." :group 'mh-faces :group 'mh-folder :package-version '(MH-E . "8.0")) -(defface-mh mh-folder-refiled (mh-face-data 'mh-folder-refiled) +(defface mh-folder-refiled (mh-face-data 'mh-folder-refiled) "Refiled message face." :group 'mh-faces :group 'mh-folder :package-version '(MH-E . "8.0")) -(defface-mh mh-folder-sent-to-me-hint +(defface mh-folder-sent-to-me-hint (mh-face-data 'mh-folder-msg-number '((t (:inherit mh-folder-date)))) "Fontification hint face in messages sent directly to us. The detection of messages sent to us is governed by the scan @@ -3690,7 +3567,7 @@ format `mh-scan-format-nmh' and the regular expression :group 'mh-folder :package-version '(MH-E . "8.0")) -(defface-mh mh-folder-sent-to-me-sender +(defface mh-folder-sent-to-me-sender (mh-face-data 'mh-folder-followup '((t (:inherit mh-folder-followup)))) "Sender face in messages sent directly to us. The detection of messages sent to us is governed by the scan @@ -3700,105 +3577,105 @@ format `mh-scan-format-nmh' and the regular expression :group 'mh-folder :package-version '(MH-E . "8.0")) -(defface-mh mh-folder-subject (mh-face-data 'mh-folder-subject) +(defface mh-folder-subject (mh-face-data 'mh-folder-subject) "Subject face." :group 'mh-faces :group 'mh-folder :package-version '(MH-E . "8.0")) -(defface-mh mh-folder-tick (mh-face-data 'mh-folder-tick) +(defface mh-folder-tick (mh-face-data 'mh-folder-tick) "Ticked message face." :group 'mh-faces :group 'mh-folder :package-version '(MH-E . "8.0")) -(defface-mh mh-folder-to (mh-face-data 'mh-folder-to) +(defface mh-folder-to (mh-face-data 'mh-folder-to) "\"To:\" face." :group 'mh-faces :group 'mh-folder :package-version '(MH-E . "8.0")) -(defface-mh mh-folder-allowlisted +(defface mh-folder-allowlisted (mh-face-data 'mh-folder-refiled '((t (:inherit mh-folder-refiled)))) "Allowlisted message face." :group 'mh-faces :group 'mh-folder :package-version '(MH-E . "8.4")) -(defface-mh mh-letter-header-field (mh-face-data 'mh-letter-header-field) +(defface mh-letter-header-field (mh-face-data 'mh-letter-header-field) "Editable header field value face in draft buffers." :group 'mh-faces :group 'mh-letter :package-version '(MH-E . "8.0")) -(defface-mh mh-search-folder (mh-face-data 'mh-search-folder) +(defface mh-search-folder (mh-face-data 'mh-search-folder) "Folder heading face in MH-Folder buffers created by searches." :group 'mh-faces :group 'mh-search :package-version '(MH-E . "8.0")) -(defface-mh mh-show-cc (mh-face-data 'mh-show-cc) +(defface mh-show-cc (mh-face-data 'mh-show-cc) "Face used to highlight \"cc:\" header fields." :group 'mh-faces :group 'mh-show :package-version '(MH-E . "8.0")) -(defface-mh mh-show-date (mh-face-data 'mh-show-date) +(defface mh-show-date (mh-face-data 'mh-show-date) "Face used to highlight \"Date:\" header fields." :group 'mh-faces :group 'mh-show :package-version '(MH-E . "8.0")) -(defface-mh mh-show-from (mh-face-data 'mh-show-from) +(defface mh-show-from (mh-face-data 'mh-show-from) "Face used to highlight \"From:\" header fields." :group 'mh-faces :group 'mh-show :package-version '(MH-E . "8.0")) -(defface-mh mh-show-header (mh-face-data 'mh-show-header) +(defface mh-show-header (mh-face-data 'mh-show-header) "Face used to deemphasize less interesting header fields." :group 'mh-faces :group 'mh-show :package-version '(MH-E . "8.0")) -(defface-mh mh-show-pgg-bad (mh-face-data 'mh-show-pgg-bad) +(defface mh-show-pgg-bad (mh-face-data 'mh-show-pgg-bad) "Bad PGG signature face." :group 'mh-faces :group 'mh-show :package-version '(MH-E . "8.0")) -(defface-mh mh-show-pgg-good (mh-face-data 'mh-show-pgg-good) +(defface mh-show-pgg-good (mh-face-data 'mh-show-pgg-good) "Good PGG signature face." :group 'mh-faces :group 'mh-show :package-version '(MH-E . "8.0")) -(defface-mh mh-show-pgg-unknown (mh-face-data 'mh-show-pgg-unknown) +(defface mh-show-pgg-unknown (mh-face-data 'mh-show-pgg-unknown) "Unknown or untrusted PGG signature face." :group 'mh-faces :group 'mh-show :package-version '(MH-E . "8.0")) -(defface-mh mh-show-signature (mh-face-data 'mh-show-signature) +(defface mh-show-signature (mh-face-data 'mh-show-signature) "Signature face." :group 'mh-faces :group 'mh-show :package-version '(MH-E . "8.0")) -(defface-mh mh-show-subject +(defface mh-show-subject (mh-face-data 'mh-folder-subject '((t (:inherit mh-folder-subject)))) "Face used to highlight \"Subject:\" header fields." :group 'mh-faces :group 'mh-show :package-version '(MH-E . "8.0")) -(defface-mh mh-show-to (mh-face-data 'mh-show-to) +(defface mh-show-to (mh-face-data 'mh-show-to) "Face used to highlight \"To:\" header fields." :group 'mh-faces :group 'mh-show :package-version '(MH-E . "8.0")) -(defface-mh mh-show-xface +(defface mh-show-xface (mh-face-data 'mh-show-from '((t (:inherit (mh-show-from highlight))))) "X-Face image face. The background and foreground are used in the image." @@ -3806,13 +3683,13 @@ The background and foreground are used in the image." :group 'mh-show :package-version '(MH-E . "8.0")) -(defface-mh mh-speedbar-folder (mh-face-data 'mh-speedbar-folder) +(defface mh-speedbar-folder (mh-face-data 'mh-speedbar-folder) "Basic folder face." :group 'mh-faces :group 'mh-speedbar :package-version '(MH-E . "8.0")) -(defface-mh mh-speedbar-folder-with-unseen-messages +(defface mh-speedbar-folder-with-unseen-messages (mh-face-data 'mh-speedbar-folder '((t (:inherit mh-speedbar-folder :bold t)))) "Folder face when folder contains unread messages." @@ -3820,14 +3697,14 @@ The background and foreground are used in the image." :group 'mh-speedbar :package-version '(MH-E . "8.0")) -(defface-mh mh-speedbar-selected-folder +(defface mh-speedbar-selected-folder (mh-face-data 'mh-speedbar-selected-folder) "Selected folder face." :group 'mh-faces :group 'mh-speedbar :package-version '(MH-E . "8.0")) -(defface-mh mh-speedbar-selected-folder-with-unseen-messages +(defface mh-speedbar-selected-folder-with-unseen-messages (mh-face-data 'mh-speedbar-selected-folder '((t (:inherit mh-speedbar-selected-folder :bold t)))) "Selected folder face when folder contains unread messages." diff --git a/lisp/mh-e/mh-folder.el b/lisp/mh-e/mh-folder.el index 35277ae46a1..132ac33d269 100644 --- a/lisp/mh-e/mh-folder.el +++ b/lisp/mh-e/mh-folder.el @@ -72,10 +72,8 @@ the MH mail system." ;;; Desktop Integration -;; desktop-buffer-mode-handlers appeared in Emacs 22. -(if (boundp 'desktop-buffer-mode-handlers) - (add-to-list 'desktop-buffer-mode-handlers - '(mh-folder-mode . mh-restore-desktop-buffer))) +(add-to-list 'desktop-buffer-mode-handlers + '(mh-folder-mode . mh-restore-desktop-buffer)) (defun mh-restore-desktop-buffer (_file-name name _misc) "Restore an MH folder buffer specified in a desktop file. @@ -213,141 +211,137 @@ annotation.") (defalias 'mh-alt-visit-folder #'mh-visit-folder) ;; Save the "b" binding for a future `back'. Maybe? -(gnus-define-keys mh-folder-mode-map - " " mh-page-msg - "!" mh-refile-or-write-again - "'" mh-toggle-tick - "," mh-header-display - "." mh-alt-show - ":" mh-show-preferred-alternative - ";" mh-toggle-mh-decode-mime-flag - ">" mh-write-msg-to-file - "?" 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 - "^" mh-alt-refile-msg - "c" mh-copy-msg - "d" mh-delete-msg - "e" mh-edit-again - "f" mh-forward - "g" mh-goto-msg - "i" mh-inc-folder - "k" mh-delete-subject-or-thread - "m" mh-alt-send - "n" mh-next-undeleted-msg - "\M-n" mh-next-unread-msg - "o" mh-refile-msg - "p" mh-previous-undeleted-msg - "\M-p" mh-previous-unread-msg - "q" mh-quit - "r" mh-reply - "s" mh-send - "t" mh-toggle-showing - "u" mh-undo - "v" mh-index-visit-folder - "x" mh-execute-commands - "|" mh-pipe-msg) - -(gnus-define-keys (mh-folder-map "F" mh-folder-mode-map) - "?" mh-prefix-help - "'" mh-index-ticked-messages - "S" mh-sort-folder - "c" mh-catchup - "f" mh-alt-visit-folder - "k" mh-kill-folder - "l" mh-list-folders - "n" mh-index-new-messages - "o" mh-alt-visit-folder - "p" mh-pack-folder - "q" mh-index-sequenced-messages - "r" mh-rescan-folder - "s" mh-search - "u" mh-undo-folder - "v" mh-visit-folder) - -(define-key mh-folder-mode-map "I" mh-inc-spool-map) - -(gnus-define-keys (mh-junk-map "J" mh-folder-mode-map) - "?" mh-prefix-help - "a" mh-junk-allowlist - "b" mh-junk-blocklist - "w" mh-junk-whitelist) - -(gnus-define-keys (mh-ps-print-map "P" mh-folder-mode-map) - "?" mh-prefix-help - "C" mh-ps-print-toggle-color - "F" mh-ps-print-toggle-faces - "f" mh-ps-print-msg-file - "l" mh-print-msg - "p" mh-ps-print-msg) - -(gnus-define-keys (mh-sequence-map "S" mh-folder-mode-map) - "'" mh-narrow-to-tick - "?" mh-prefix-help - "d" mh-delete-msg-from-seq - "k" mh-delete-seq - "l" mh-list-sequences - "n" mh-narrow-to-seq - "p" mh-put-msg-in-seq - "s" mh-msg-is-in-seq - "w" mh-widen) - -(gnus-define-keys (mh-thread-map "T" mh-folder-mode-map) - "?" mh-prefix-help - "u" mh-thread-ancestor - "p" mh-thread-previous-sibling - "n" mh-thread-next-sibling - "t" mh-toggle-threads - "d" mh-thread-delete - "o" mh-thread-refile) - -(gnus-define-keys (mh-limit-map "/" mh-folder-mode-map) - "'" mh-narrow-to-tick - "?" mh-prefix-help - "c" mh-narrow-to-cc - "g" mh-narrow-to-range - "m" mh-narrow-to-from - "s" mh-narrow-to-subject - "t" mh-narrow-to-to - "w" mh-widen) - -(gnus-define-keys (mh-extract-map "X" mh-folder-mode-map) - "?" mh-prefix-help - "s" mh-store-msg ;shar - "u" mh-store-msg) ;uuencode - -(gnus-define-keys (mh-digest-map "D" mh-folder-mode-map) - " " mh-page-digest - "?" mh-prefix-help - "\177" mh-page-digest-backwards - "b" mh-burst-digest) - -(gnus-define-keys (mh-mime-map "K" mh-folder-mode-map) - "?" mh-prefix-help - "a" mh-mime-save-parts - "e" mh-display-with-external-viewer - "i" mh-folder-inline-mime-part - "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) - -(cond - ((featurep 'xemacs) - (define-key mh-folder-mode-map [button2] 'mh-show-mouse)) - (t - (define-key mh-folder-mode-map [mouse-2] 'mh-show-mouse))) +(define-keymap :keymap mh-folder-mode-map + "SPC" #'mh-page-msg + "!" #'mh-refile-or-write-again + "'" #'mh-toggle-tick + "," #'mh-header-display + "." #'mh-alt-show + ":" #'mh-show-preferred-alternative + ";" #'mh-toggle-mh-decode-mime-flag + ">" #'mh-write-msg-to-file + "?" #'mh-help + "E" #'mh-extract-rejected-mail + "M" #'mh-modify + "DEL" #'mh-previous-page + "C-d" #'mh-delete-msg-no-motion + "TAB" #'mh-index-next-folder + "<backtab>" #'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 + "e" #'mh-edit-again + "f" #'mh-forward + "g" #'mh-goto-msg + "i" #'mh-inc-folder + "k" #'mh-delete-subject-or-thread + "m" #'mh-alt-send + "n" #'mh-next-undeleted-msg + "M-n" #'mh-next-unread-msg + "o" #'mh-refile-msg + "p" #'mh-previous-undeleted-msg + "M-p" #'mh-previous-unread-msg + "q" #'mh-quit + "r" #'mh-reply + "s" #'mh-send + "t" #'mh-toggle-showing + "u" #'mh-undo + "v" #'mh-index-visit-folder + "x" #'mh-execute-commands + "|" #'mh-pipe-msg + + "F" (define-keymap :prefix 'mh-folder-map + "?" #'mh-prefix-help + "'" #'mh-index-ticked-messages + "S" #'mh-sort-folder + "c" #'mh-catchup + "f" #'mh-alt-visit-folder + "k" #'mh-kill-folder + "l" #'mh-list-folders + "n" #'mh-index-new-messages + "o" #'mh-alt-visit-folder + "p" #'mh-pack-folder + "q" #'mh-index-sequenced-messages + "r" #'mh-rescan-folder + "s" #'mh-search + "u" #'mh-undo-folder + "v" #'mh-visit-folder) + + "I" mh-inc-spool-map + + "J" (define-keymap :prefix 'mh-junk-map + "?" #'mh-prefix-help + "a" #'mh-junk-allowlist + "b" #'mh-junk-blocklist + "w" #'mh-junk-whitelist) + + "P" (define-keymap :prefix 'mh-ps-print-map + "?" #'mh-prefix-help + "C" #'mh-ps-print-toggle-color + "F" #'mh-ps-print-toggle-faces + "f" #'mh-ps-print-msg-file + "l" #'mh-print-msg + "p" #'mh-ps-print-msg) + + "S" (define-keymap :prefix 'mh-sequence-map + "'" #'mh-narrow-to-tick + "?" #'mh-prefix-help + "d" #'mh-delete-msg-from-seq + "k" #'mh-delete-seq + "l" #'mh-list-sequences + "n" #'mh-narrow-to-seq + "p" #'mh-put-msg-in-seq + "s" #'mh-msg-is-in-seq + "w" #'mh-widen) + + "T" (define-keymap :prefix 'mh-thread-map + "?" #'mh-prefix-help + "u" #'mh-thread-ancestor + "p" #'mh-thread-previous-sibling + "n" #'mh-thread-next-sibling + "t" #'mh-toggle-threads + "d" #'mh-thread-delete + "o" #'mh-thread-refile) + + "/" (define-keymap :prefix 'mh-limit-map + "'" #'mh-narrow-to-tick + "?" #'mh-prefix-help + "c" #'mh-narrow-to-cc + "g" #'mh-narrow-to-range + "m" #'mh-narrow-to-from + "s" #'mh-narrow-to-subject + "t" #'mh-narrow-to-to + "w" #'mh-widen) + + "X" (define-keymap :prefix 'mh-extract-map + "?" #'mh-prefix-help + "s" #'mh-store-msg ;shar + "u" #'mh-store-msg) ;uuencode + + "D" (define-keymap :prefix 'mh-digest-map + "SPC" #'mh-page-digest + "?" #'mh-prefix-help + "DEL" #'mh-page-digest-backwards + "b" #'mh-burst-digest) + + "K" (define-keymap :prefix 'mh-mime-map + "?" #'mh-prefix-help + "a" #'mh-mime-save-parts + "e" #'mh-display-with-external-viewer + "i" #'mh-folder-inline-mime-part + "o" #'mh-folder-save-mime-part + "t" #'mh-toggle-mime-buttons + "v" #'mh-folder-toggle-mime-part + "TAB" #'mh-next-button + "<backtab>" #'mh-prev-button + "C-M-i" #'mh-prev-button) + + "<mouse-2>" #'mh-show-mouse) ;; "C-c /" prefix is used in mh-folder-mode by pgp.el and mailcrypt @@ -512,24 +506,14 @@ font-lock is done highlighting.") ;;; MH-Folder Mode (defmacro mh-remove-xemacs-horizontal-scrollbar () - "Get rid of the horizontal scrollbar that XEmacs insists on putting in." - (when (featurep 'xemacs) - '(if (and (featurep 'scrollbar) - (fboundp 'set-specifier)) - (set-specifier horizontal-scrollbar-visible-p nil - (cons (current-buffer) nil))))) + (declare (obsolete nil "29.1")) + nil) ;; Register mh-folder-mode as supporting which-function-mode... -(eval-and-compile (mh-require 'which-func nil t)) +(eval-and-compile (require 'which-func nil t)) (when (and (boundp 'which-func-modes) (listp which-func-modes)) (add-to-list 'which-func-modes 'mh-folder-mode)) -;; Shush compiler. -(defvar desktop-save-buffer) -(defvar font-lock-auto-fontify) -(mh-do-in-xemacs - (defvar font-lock-defaults)) - ;; Ensure new buffers won't get this mode if default major-mode is nil. (put 'mh-folder-mode 'mode-class 'special) @@ -590,80 +574,68 @@ region in the MH-Folder buffer, then the MH-E command will perform the operation on all messages in that region. \\{mh-folder-mode-map}" - (mh-do-in-gnu-emacs - (unless mh-folder-tool-bar-map - (mh-tool-bar-folder-buttons-init)) - (if (boundp 'tool-bar-map) - (set (make-local-variable 'tool-bar-map) mh-folder-tool-bar-map))) - (mh-do-in-xemacs - (mh-tool-bar-init :folder)) + (unless mh-folder-tool-bar-map + (mh-tool-bar-folder-buttons-init)) + (if (boundp 'tool-bar-map) + (setq-local tool-bar-map mh-folder-tool-bar-map)) (make-local-variable 'font-lock-defaults) (setq font-lock-defaults '(mh-folder-font-lock-keywords t)) (make-local-variable 'desktop-save-buffer) (setq desktop-save-buffer t) - (mh-make-local-vars - 'mh-colors-available-flag (mh-colors-available-p) + (setq-local + mh-colors-available-flag (mh-colors-available-p) ; Do we have colors available - 'mh-current-folder (buffer-name) ; Name of folder, a string - 'mh-show-buffer (format "show-%s" (buffer-name)) ; Buffer that displays msgs - 'mh-folder-filename ; e.g. "/usr/foobar/Mail/inbox/" + mh-current-folder (buffer-name) ; Name of folder, a string + mh-show-buffer (format "show-%s" (buffer-name)) ; Buffer that displays msgs + mh-folder-filename ; e.g. "/usr/foobar/Mail/inbox/" (file-name-as-directory (mh-expand-file-name (buffer-name))) - 'mh-display-buttons-for-inline-parts-flag + mh-display-buttons-for-inline-parts-flag mh-display-buttons-for-inline-parts-flag ; Allow for display of buttons to ; be toggled. - 'mh-arrow-marker (make-marker) ; Marker where arrow is displayed - 'overlay-arrow-position nil ; Allow for simultaneous display in - 'overlay-arrow-string ">" ; different MH-E buffers. - 'mh-showing-mode nil ; Show message also? - 'mh-refile-list nil ; List of folder names in mh-seq-list - 'mh-delete-list nil ; List of msgs nums to delete - 'mh-blocklist nil ; List of messages to process as spam - 'mh-allowlist nil ; List of messages to process as ham - 'mh-seq-list nil ; Alist of (seq . msgs) nums - 'mh-seen-list nil ; List of displayed messages - 'mh-next-direction 'forward ; Direction to move to next message - 'mh-view-ops () ; Stack that keeps track of the order + mh-arrow-marker (make-marker) ; Marker where arrow is displayed + overlay-arrow-position nil ; Allow for simultaneous display in + overlay-arrow-string ">" ; different MH-E buffers. + mh-showing-mode nil ; Show message also? + mh-refile-list nil ; List of folder names in mh-seq-list + mh-delete-list nil ; List of msgs nums to delete + mh-blocklist nil ; List of messages to process as spam + mh-allowlist nil ; List of messages to process as ham + mh-seq-list nil ; Alist of (seq . msgs) nums + mh-seen-list nil ; List of displayed messages + mh-next-direction 'forward ; Direction to move to next message + mh-view-ops () ; Stack that keeps track of the order ; in which narrowing/threading has been ; carried out. - 'mh-folder-view-stack () ; Stack of previous views of the + mh-folder-view-stack () ; Stack of previous views of the ; folder. - 'mh-index-data nil ; If the folder was created by a call + mh-index-data nil ; If the folder was created by a call ; to mh-search, this contains info ; about the search results. - 'mh-index-previous-search nil ; folder, indexer, search-regexp - 'mh-index-msg-checksum-map nil ; msg -> checksum map - 'mh-index-checksum-origin-map nil ; checksum -> ( orig-folder, orig-msg ) - 'mh-index-sequence-search-flag nil ; folder resulted from sequence search - 'mh-first-msg-num nil ; Number of first msg in buffer - 'mh-last-msg-num nil ; Number of last msg in buffer - 'mh-msg-count nil ; Number of msgs in buffer - 'mh-mode-line-annotation nil ; Indicates message range - 'mh-sequence-notation-history (make-hash-table) + mh-index-previous-search nil ; folder, indexer, search-regexp + mh-index-msg-checksum-map nil ; msg -> checksum map + mh-index-checksum-origin-map nil ; checksum -> ( orig-folder, orig-msg ) + mh-index-sequence-search-flag nil ; folder resulted from sequence search + mh-first-msg-num nil ; Number of first msg in buffer + mh-last-msg-num nil ; Number of last msg in buffer + mh-msg-count nil ; Number of msgs in buffer + mh-mode-line-annotation nil ; Indicates message range + mh-sequence-notation-history (make-hash-table) ; Remember what is overwritten by ; mh-note-seq. - 'imenu-create-index-function 'mh-index-create-imenu-index + imenu-create-index-function 'mh-index-create-imenu-index ; Setup imenu support - 'mh-previous-window-config nil) ; Previous window configuration - (mh-remove-xemacs-horizontal-scrollbar) + mh-previous-window-config nil) ; Previous window configuration (setq truncate-lines t) (auto-save-mode -1) (setq buffer-offer-save t) - (mh-make-local-hook (mh-write-file-functions)) - (add-hook (mh-write-file-functions) #'mh-execute-commands nil t) + (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-do-in-xemacs - (easy-menu-add mh-folder-sequence-menu) - (easy-menu-add mh-folder-message-menu) - (easy-menu-add mh-folder-folder-menu)) (mh-inc-spool-make) - (mh-set-help mh-folder-mode-help-messages) - (if (and (featurep 'xemacs) - font-lock-auto-fontify) - (turn-on-font-lock))) ; Force font-lock in XEmacs. + (mh-set-help mh-folder-mode-help-messages)) @@ -1571,35 +1543,35 @@ after the commands are processed." (append folders-changed (mh-index-execute-commands)))) ;; Then refile messages - (mh-mapc #'(lambda (folder-msg-list) - (let* ((dest-folder (symbol-name (car folder-msg-list))) - (last (car (mh-translate-range dest-folder "last"))) - (msgs (cdr folder-msg-list))) - (push dest-folder folders-changed) - (setq redraw-needed-flag t) - (apply #'mh-exec-cmd - "refile" "-src" folder dest-folder - (mh-coalesce-msg-list msgs)) - (mh-delete-scan-msgs msgs) - ;; Preserve sequences in destination folder... - (when mh-refile-preserves-sequences-flag - (clrhash dest-map) - (cl-loop - for i from (1+ (or last 0)) - for msg in (sort (copy-sequence msgs) #'<) - do (cl-loop for seq-name in (gethash msg seq-map) - do (push i (gethash seq-name dest-map)))) - (maphash - #'(lambda (seq msgs) - ;; Can't be run in the background, since the - ;; current folder is changed by mark this could - ;; lead to a race condition with the next refile. - (apply #'mh-exec-cmd "mark" - "-sequence" (symbol-name seq) dest-folder - "-add" (mapcar #'(lambda (x) (format "%s" x)) - (mh-coalesce-msg-list msgs)))) - dest-map)))) - mh-refile-list) + (mapc (lambda (folder-msg-list) + (let* ((dest-folder (symbol-name (car folder-msg-list))) + (last (car (mh-translate-range dest-folder "last"))) + (msgs (cdr folder-msg-list))) + (push dest-folder folders-changed) + (setq redraw-needed-flag t) + (apply #'mh-exec-cmd + "refile" "-src" folder dest-folder + (mh-coalesce-msg-list msgs)) + (mh-delete-scan-msgs msgs) + ;; Preserve sequences in destination folder... + (when mh-refile-preserves-sequences-flag + (clrhash dest-map) + (cl-loop + for i from (1+ (or last 0)) + for msg in (sort (copy-sequence msgs) #'<) + do (cl-loop for seq-name in (gethash msg seq-map) + do (push i (gethash seq-name dest-map)))) + (maphash + #'(lambda (seq msgs) + ;; Can't be run in the background, since the + ;; current folder is changed by mark this could + ;; lead to a race condition with the next refile. + (apply #'mh-exec-cmd "mark" + "-sequence" (symbol-name seq) dest-folder + "-add" (mapcar #'(lambda (x) (format "%s" x)) + (mh-coalesce-msg-list msgs)))) + dest-map)))) + mh-refile-list) (setq mh-refile-list ()) ;; Now delete messages @@ -1642,14 +1614,14 @@ after the commands are processed." do (cl-loop for seq-name in (gethash msg seq-map) do (push i (gethash seq-name allow-map)))) (maphash - #'(lambda (seq msgs) - ;; Can't be run in background, since the current - ;; folder is changed by mark this could lead to a - ;; race condition with the next refile/allowlist. - (apply #'mh-exec-cmd "mark" - "-sequence" (symbol-name seq) mh-inbox - "-add" (mapcar #'(lambda(x) (format "%s" x)) - (mh-coalesce-msg-list msgs)))) + (lambda (seq msgs) + ;; Can't be run in background, since the current + ;; folder is changed by mark this could lead to a + ;; race condition with the next refile/allowlist. + (apply #'mh-exec-cmd "mark" + "-sequence" (symbol-name seq) mh-inbox + "-add" (mapcar #'(lambda(x) (format "%s" x)) + (mh-coalesce-msg-list msgs)))) allow-map)) (setq mh-allowlist nil))) diff --git a/lisp/mh-e/mh-funcs.el b/lisp/mh-e/mh-funcs.el index 4a5e670c1ef..0c73aae0d79 100644 --- a/lisp/mh-e/mh-funcs.el +++ b/lisp/mh-e/mh-funcs.el @@ -147,7 +147,7 @@ Display the results only if something went wrong." "-recurse" "-norecurse")) (goto-char (point-min)) - (mh-view-mode-enter) + (view-mode-enter) (setq view-exit-action 'kill-buffer) (message "Listing folders...done"))))) diff --git a/lisp/mh-e/mh-gnus.el b/lisp/mh-e/mh-gnus.el index cc60f7b6640..0e1bde71f20 100644 --- a/lisp/mh-e/mh-gnus.el +++ b/lisp/mh-e/mh-gnus.el @@ -29,110 +29,49 @@ (require 'mh-e) (eval-and-compile - (mh-require 'gnus-util nil t) - (mh-require 'mm-bodies nil t) - (mh-require 'mm-decode nil t) - (mh-require 'mm-view nil t) - (mh-require 'mml nil t)) - -;; Copy of function from gnus-util.el. -;; TODO This is not in Gnus 5.11. -(defun-mh mh-gnus-local-map-property gnus-local-map-property (map) + (require 'gnus-util nil t) + (require 'mm-bodies nil t) + (require 'mm-decode nil t) + (require 'mm-view nil t) + (require 'mml nil t)) + +(defun mh-gnus-local-map-property (map) "Return a list suitable for a text property list specifying keymap MAP." - (cond ((featurep 'xemacs) (list 'keymap map)) - ((>= emacs-major-version 21) (list 'keymap map)) - (t (list 'local-map map)))) - -;; Copy of function from mm-decode.el. -(defun-mh mh-mm-merge-handles mm-merge-handles (handles1 handles2) - (append - (if (listp (car handles1)) - handles1 - (list handles1)) - (if (listp (car handles2)) - handles2 - (list handles2)))) - -;; Copy of function from mm-decode.el. -(defun-mh mh-mm-set-handle-multipart-parameter - mm-set-handle-multipart-parameter (handle parameter value) - ;; HANDLE could be a CTL. - (when handle - (put-text-property 0 (length (car handle)) parameter value - (car handle)))) - -;; Copy of function from mm-view.el. -(defun-mh mh-mm-inline-text-vcard mm-inline-text-vcard (handle) - (let ((inhibit-read-only t)) - (mm-insert-inline - handle - (concat "\n-- \n" - (ignore-errors - (if (fboundp 'vcard-pretty-print) - (vcard-pretty-print (mm-get-part handle)) - (vcard-format-string - (vcard-parse-string (mm-get-part handle) - 'vcard-standard-filter)))))))) - -;; Function from mm-decode.el used in PGP messages. Just define it with older -;; Gnus to avoid compiler warning. -(defun-mh mh-mm-possibly-verify-or-decrypt - mm-possibly-verify-or-decrypt (_parts _ctl) - nil) - -;; Copy of macro in mm-decode.el. -(defmacro-mh mh-mm-handle-multipart-ctl-parameter - mm-handle-multipart-ctl-parameter (handle parameter) - `(get-text-property 0 ,parameter (car ,handle))) - -;; Copy of function in mm-decode.el. -(defun-mh mh-mm-readable-p mm-readable-p (handle) - "Say whether the content of HANDLE is readable." - (and (< (with-current-buffer (mm-handle-buffer handle) - (buffer-size)) 10000) - (mm-with-unibyte-buffer - (mm-insert-part handle) - (and (eq (mm-body-7-or-8) '7bit) - (not (mh-mm-long-lines-p 76)))))) - -;; Copy of function in mm-bodies.el. -(defun-mh mh-mm-long-lines-p mm-long-lines-p (length) - "Say whether any of the lines in the buffer is longer than LENGTH." - (save-excursion - (goto-char (point-min)) - (end-of-line) - (while (and (not (eobp)) - (not (> (current-column) length))) - (forward-line 1) - (end-of-line)) - (and (> (current-column) length) - (current-column)))) - -(defun-mh mh-mm-keep-viewer-alive-p mm-keep-viewer-alive-p (_handle) - ;; Released Gnus doesn't keep handles associated with externally displayed - ;; MIME parts. So this will always return nil. - nil) - -(defun-mh mh-mm-destroy-parts mm-destroy-parts (_list) - "Older versions of Emacs don't have this function." - nil) - -(defun-mh mh-mm-uu-dissect-text-parts mm-uu-dissect-text-parts (_handles) - "Emacs 21 and XEmacs don't have this function." - nil) - -;; Copy of function in mml.el. -(defun-mh mh-mml-minibuffer-read-disposition - mml-minibuffer-read-disposition (type &optional default filename) - (unless default - (setq default (mml-content-disposition type filename))) - (let ((disposition (completing-read - (format-prompt "Disposition" default) - '(("attachment") ("inline") ("")) - nil t nil nil default))) - (if (not (equal disposition "")) - disposition - default))) + (declare (obsolete nil "29.1")) + (list 'keymap map)) + +(define-obsolete-function-alias 'mh-mm-merge-handles + #'mm-merge-handles "29.1") + +(define-obsolete-function-alias 'mh-mm-set-handle-multipart-parameter + #'mm-set-handle-multipart-parameter "29.1") + +(define-obsolete-function-alias 'mh-mm-inline-text-vcard + #'mm-inline-text-vcard "29.1") + +(define-obsolete-function-alias 'mh-mm-possibly-verify-or-decrypt + #'mm-possibly-verify-or-decrypt "29.1") + +(define-obsolete-function-alias 'mh-mm-handle-multipart-ctl-parameter + #'mm-handle-multipart-ctl-parameter "29.1") + +(define-obsolete-function-alias 'mh-mm-readable-p + #'mm-readable-p "29.1") + +(define-obsolete-function-alias 'mh-mm-long-lines-p + #'mm-long-lines-p "29.1") + +(define-obsolete-function-alias 'mh-mm-keep-viewer-alive-p + #'mm-keep-viewer-alive-p "29.1") + +(define-obsolete-function-alias 'mh-mm-destroy-parts + #'mm-destroy-parts "29.1") + +(define-obsolete-function-alias 'mh-mm-uu-dissect-text-parts + #'mm-uu-dissect-text-parts "29.1") + +(define-obsolete-function-alias 'mh-mml-minibuffer-read-disposition + #'mml-minibuffer-read-disposition "29.1") ;; This is mm-save-part from Gnus 5.11 since that function in Emacs ;; 21.2 is buggy (the args to read-file-name are incorrect) and the @@ -163,8 +102,8 @@ PROMPT overrides the default one used to ask user for a file name." (defun mh-mm-text-html-renderer () "Find the renderer Gnus is using to display text/html MIME parts." - (or (and (boundp 'mm-inline-text-html-renderer) mm-inline-text-html-renderer) - (and (boundp 'mm-text-html-renderer) mm-text-html-renderer))) + (declare (obsolete mm-text-html-renderer "29.1")) + mm-text-html-renderer) (provide 'mh-gnus) diff --git a/lisp/mh-e/mh-identity.el b/lisp/mh-e/mh-identity.el index ceede0d07cb..994ab713915 100644 --- a/lisp/mh-e/mh-identity.el +++ b/lisp/mh-e/mh-identity.el @@ -39,11 +39,10 @@ (autoload 'mml-insert-tag "mml") -(defvar mh-identity-pgg-default-user-id nil +(defvar-local mh-identity-pgg-default-user-id nil "Holds the GPG key ID to be used by pgg.el. This is normally set as part of an Identity in `mh-identity-list'.") -(make-variable-buffer-local 'mh-identity-pgg-default-user-id) (defvar mh-identity-menu nil "The Identity menu.") @@ -54,8 +53,7 @@ This is normally set as part of an Identity in (defun mh-identity-make-menu () "Build the Identity menu. This should be called any time `mh-identity-list' or -`mh-auto-fields-list' change. -See `mh-identity-add-menu'." +`mh-auto-fields-list' change." (easy-menu-define mh-identity-menu mh-letter-mode-map "MH-E identity menu" (append @@ -88,12 +86,11 @@ See `mh-identity-add-menu'." (defun mh-identity-add-menu () "Add the current Identity menu. See `mh-identity-make-menu'." - (if mh-identity-menu - (mh-do-in-xemacs (easy-menu-add mh-identity-menu)))) + (declare (obsolete nil "29.1")) + nil) -(defvar mh-identity-local nil +(defvar-local mh-identity-local nil "Buffer-local variable that holds the identity currently in use.") -(make-variable-buffer-local 'mh-identity-local) (defun mh-header-field-delete (field value-only) "Delete header FIELD, or only its value if VALUE-ONLY is t. @@ -122,7 +119,7 @@ The field name is downcased. If the FIELD begins with the character \":\", then it must have a special handler defined in `mh-identity-handlers', else return an error since it is not a valid header field." - (or (cdr (mh-assoc-string field mh-identity-handlers t)) + (or (cdr (assoc-string field mh-identity-handlers t)) (and (eq (aref field 0) ?:) (error "Field %s not found in `mh-identity-handlers'" field)) (cdr (assoc ":default" mh-identity-handlers)) @@ -235,11 +232,9 @@ added." (if (null value) (mh-insert-signature) (mh-insert-signature value)) - (set (make-local-variable 'mh-identity-signature-start) - (point-min-marker)) + (setq-local mh-identity-signature-start (point-min-marker)) (set-marker-insertion-type mh-identity-signature-start t) - (set (make-local-variable 'mh-identity-signature-end) - (point-max-marker))))))) + (setq-local mh-identity-signature-end (point-max-marker))))))) (defvar mh-identity-attribution-verb-start nil "Marker for the beginning of the attribution verb.") @@ -271,11 +266,9 @@ If VALUE is nil, use `mh-extract-from-attribution-verb'." (if (null value) (insert mh-extract-from-attribution-verb) (insert value)) - (set (make-local-variable 'mh-identity-attribution-verb-start) - (point-min-marker)) + (setq-local mh-identity-attribution-verb-start (point-min-marker)) (set-marker-insertion-type mh-identity-attribution-verb-start t) - (set (make-local-variable 'mh-identity-attribution-verb-end) - (point-max-marker)))) + (setq-local mh-identity-attribution-verb-end (point-max-marker)))) (defun mh-identity-handler-default (field action top &optional value) "Process header FIELD. diff --git a/lisp/mh-e/mh-letter.el b/lisp/mh-e/mh-letter.el index ae5b80d5807..ebe94a7af83 100644 --- a/lisp/mh-e/mh-letter.el +++ b/lisp/mh-e/mh-letter.el @@ -114,68 +114,68 @@ ;;; MH-Letter Keys ;; If this changes, modify mh-letter-mode-help-messages accordingly, above. -(gnus-define-keys mh-letter-mode-map - " " 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" mh-letter-complete - "\t" mh-letter-next-header-field-or-indent - [backtab] mh-letter-previous-header-field) +(define-keymap :keymap mh-letter-mode-map + "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-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 + "<backtab>" #'mh-letter-previous-header-field) ;; "C-c /" prefix is used in mh-letter-mode by pgp.el and mailcrypt.el. @@ -253,17 +253,13 @@ searching for `mh-mail-header-separator' in the buffer." (goto-char (point-min)) (cond ((equal mh-mail-header-separator "") (point-min)) ((search-forward (format "\n%s\n" mh-mail-header-separator) nil t) - (mh-line-beginning-position 0)) + (line-beginning-position 0)) (t (point-min))))) ;;; MH-Letter Mode -;; Shush compiler. -(mh-do-in-xemacs - (defvar font-lock-defaults)) - ;; Ensure new buffers won't get this mode if default major-mode is nil. (put 'mh-letter-mode 'mode-class 'special) @@ -295,24 +291,21 @@ order). (make-local-variable 'mh-previous-window-config) (make-local-variable 'mh-sent-from-folder) (make-local-variable 'mh-sent-from-msg) - (mh-do-in-gnu-emacs - (unless mh-letter-tool-bar-map - (mh-tool-bar-letter-buttons-init)) - (if (boundp 'tool-bar-map) - (set (make-local-variable 'tool-bar-map) mh-letter-tool-bar-map))) - (mh-do-in-xemacs - (mh-tool-bar-init :letter)) + (unless mh-letter-tool-bar-map + (mh-tool-bar-letter-buttons-init)) + (if (boundp 'tool-bar-map) + (setq-local tool-bar-map mh-letter-tool-bar-map)) ;; Set the local value of mh-mail-header-separator according to what is ;; present in the buffer... - (set (make-local-variable 'mh-mail-header-separator) - (save-excursion - (goto-char (mh-mail-header-end)) - (buffer-substring-no-properties (point) (mh-line-end-position)))) + (setq-local mh-mail-header-separator + (save-excursion + (goto-char (mh-mail-header-end)) + (buffer-substring-no-properties (point) (line-end-position)))) (make-local-variable 'mail-header-separator) (setq mail-header-separator mh-mail-header-separator) ;override sendmail.el (mh-set-help mh-letter-mode-help-messages) (setq buffer-invisibility-spec '((vanish . t) t)) - (set (make-local-variable 'line-move-ignore-invisible) t) + (setq-local line-move-ignore-invisible t) ;; Enable undo since a show-mode buffer might have been reused. (buffer-enable-undo) @@ -328,12 +321,10 @@ order). (t ;; ...or the header only (setq font-lock-defaults '((mh-show-font-lock-keywords) t)))) - (mh-do-in-xemacs (easy-menu-add mh-letter-menu)) ;; Maybe we want to use the existing Mail menu from mail-mode in ;; 9.0; in the mean time, let's remove it since the redundancy will ;; only produce confusion. (define-key mh-letter-mode-map [menu-bar mail] #'undefined) - (mh-do-in-xemacs (easy-menu-remove mail-menubar-menu)) (setq fill-column mh-letter-fill-column) (add-hook 'completion-at-point-functions #'mh-letter-completion-at-point nil 'local) @@ -488,29 +479,8 @@ This provides alias and folder completion in header fields according to (or (funcall func) #'ignore) mh-letter-complete-function))) -;; TODO Now that completion-at-point performs the task of -;; mh-letter-complete, perhaps mh-letter-complete along with -;; mh-complete-word should be rewritten as a more general function for -;; XEmacs, renamed to mh-completion-at-point, and moved to -;; mh-compat.el. -(defun-mh mh-letter-complete completion-at-point () - "Perform completion on header field or word preceding point. - -If the field contains addresses (for example, \"To:\" or \"Cc:\") -or folders (for example, \"Fcc:\") then this command will provide -alias completion. In the body of the message, this command runs -`mh-letter-complete-function' instead, which is set to -`ispell-complete-word' by default." - (interactive) - (let ((data (mh-letter-completion-at-point))) - (cond - ((functionp data) (funcall data)) - ((consp data) - (let ((start (nth 0 data)) - (end (nth 1 data)) - (table (nth 2 data))) - (mh-complete-word (buffer-substring-no-properties start end) - table start end)))))) +(define-obsolete-function-alias 'mh-letter-complete + #'completion-at-point "29.1") (defun mh-letter-complete-or-space (arg) "Perform completion or insert space. @@ -530,7 +500,7 @@ one space." ((> (point) end-of-prev) (self-insert-command arg)) ((let ((mh-letter-complete-function nil)) (mh-letter-completion-at-point)) - (mh-letter-complete)) + (completion-at-point)) (t (self-insert-command arg))))) (defun mh-letter-confirm-address () @@ -722,7 +692,7 @@ and `mh-ins-buf-prefix' is not inserted." ;; Find displayed message (with-current-buffer show-buffer (let* ((from-attr (mh-extract-from-attribution)) - (yank-region (mh-mark-active-p nil)) + (yank-region mark-active) (mh-ins-str (cond ((and yank-region (or (eq 'supercite mh-yank-behavior) @@ -834,7 +804,7 @@ body." ((< (point) (progn (beginning-of-line) (re-search-forward mh-letter-header-field-regexp - (mh-line-end-position) t) + (line-end-position) t) (point))) (beginning-of-line)) (t (end-of-line))) diff --git a/lisp/mh-e/mh-limit.el b/lisp/mh-e/mh-limit.el index 39cf7c5d271..a00252284af 100644 --- a/lisp/mh-e/mh-limit.el +++ b/lisp/mh-e/mh-limit.el @@ -124,7 +124,7 @@ Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command." (setq pick-expr (let ((case-fold-search t)) (cl-loop for s in pick-expr - collect (mh-replace-regexp-in-string "re: *" "" s)))) + collect (replace-regexp-in-string "re: *" "" s)))) (mh-narrow-to-header-field 'subject pick-expr)) ;;;###mh-autoload @@ -214,7 +214,7 @@ Return number of messages put in the sequence: (string-equal "" (match-string 3))) (progn (message "No subject line") nil) - (let ((subject (mh-match-string-no-properties 3)) + (let ((subject (match-string-no-properties 3)) (list)) (if (> (length subject) mh-limit-max-subject-size) (setq subject (substring subject 0 mh-limit-max-subject-size))) @@ -222,7 +222,7 @@ Return number of messages put in the sequence: (if all (goto-char (point-min))) (while (re-search-forward mh-scan-subject-regexp nil t) - (let ((this-subject (mh-match-string-no-properties 3))) + (let ((this-subject (match-string-no-properties 3))) (if (> (length this-subject) mh-limit-max-subject-size) (setq this-subject (substring this-subject 0 mh-limit-max-subject-size))) @@ -313,7 +313,7 @@ The MH command pick is used to do the match." (while (not (eobp)) (let ((num (ignore-errors (string-to-number - (buffer-substring (point) (mh-line-end-position)))))) + (buffer-substring (point) (line-end-position)))))) (when num (push num msg-list)) (forward-line)))) (if (null msg-list) diff --git a/lisp/mh-e/mh-mime.el b/lisp/mh-e/mh-mime.el index ad594aef906..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) @@ -135,13 +136,11 @@ ("application/emacs-lisp" mm-display-elisp-inline identity) ("application/x-emacs-lisp" mm-display-elisp-inline identity) ("text/html" - ,(if (fboundp 'mm-inline-text-html) 'mm-inline-text-html 'mm-inline-text) + mm-inline-text-html (lambda (handle) - (or (and (boundp 'mm-inline-text-html-renderer) - mm-inline-text-html-renderer) - (and (boundp 'mm-text-html-renderer) mm-text-html-renderer)))) + mm-text-html-renderer)) ("text/x-vcard" - mh-mm-inline-text-vcard + mm-inline-text-vcard (lambda (handle) (or (featurep 'vcard) (locate-library "vcard")))) @@ -171,7 +170,7 @@ ("audio/.*" ignore ignore) ("image/.*" ignore ignore) ;; Default to displaying as text - (".*" mm-inline-text mh-mm-readable-p)) + (".*" mm-inline-text mm-readable-p)) "Alist of media types/tests saying whether types can be displayed inline.") (defvar mh-mime-save-parts-directory nil @@ -184,13 +183,7 @@ Set from last use.") '((mh-press-button "\r" "Toggle Display"))) (defvar mh-mime-button-map (let ((map (make-sparse-keymap))) - (unless (>= (string-to-number emacs-version) 21) - ;; XEmacs doesn't care. - (set-keymap-parent map mh-show-mode-map)) - (mh-do-in-gnu-emacs - (define-key map [mouse-2] #'mh-push-button)) - (mh-do-in-xemacs - (define-key map '(button2) #'mh-push-button)) + (define-key map [mouse-2] #'mh-push-button) (dolist (c mh-mime-button-commands) (define-key map (cadr c) (car c))) map)) @@ -210,13 +203,8 @@ Set from last use.") (?D pressed-details ?s))) (defvar mh-mime-security-button-map (let ((map (make-sparse-keymap))) - (unless (>= (string-to-number emacs-version) 21) - (set-keymap-parent map mh-show-mode-map)) (define-key map "\r" #'mh-press-button) - (mh-do-in-gnu-emacs - (define-key map [mouse-2] #'mh-push-button)) - (mh-do-in-xemacs - (define-key map '(button2) #'mh-push-button)) + (define-key map [mouse-2] #'mh-push-button) map)) @@ -251,24 +239,24 @@ usually reads the file \"/etc/mailcap\"." (when (consp part-index) (setq part-index (car part-index))) (mh-folder-mime-action part-index - #'(lambda () - (let* ((part (get-text-property (point) 'mh-data)) - (type (mm-handle-media-type part)) - (methods (mapcar (lambda (x) (list (cdr (assoc 'viewer x)))) - (mailcap-mime-info type 'all))) - (def (caar methods)) - (prompt (format-prompt "Viewer" def)) - (method (completing-read prompt methods nil nil nil nil def)) - (folder mh-show-folder-buffer) - (buffer-read-only nil)) - (when (string-match "^[^% \t]+$" method) - (setq method (concat method " %s"))) - (mh-flet - ((mm-handle-set-external-undisplayer - (handle function) - (mh-handle-set-external-undisplayer folder handle function))) - (unwind-protect (mm-display-external part method) - (set-buffer-modified-p nil))))) + (lambda () + (let* ((part (get-text-property (point) 'mh-data)) + (type (mm-handle-media-type part)) + (methods (mapcar (lambda (x) (list (cdr (assoc 'viewer x)))) + (mailcap-mime-info type 'all))) + (def (caar methods)) + (prompt (format-prompt "Viewer" def)) + (method (completing-read prompt methods nil nil nil nil def)) + (folder mh-show-folder-buffer) + (buffer-read-only nil)) + (when (string-match "^[^% \t]+$" method) + (setq method (concat method " %s"))) + (mh-flet + ((mm-handle-set-external-undisplayer + (handle function) + (mh-handle-set-external-undisplayer folder handle function))) + (unwind-protect (mm-display-external part method) + (set-buffer-modified-p nil))))) nil)) ;;;###mh-autoload @@ -299,14 +287,14 @@ the attachment labeled with that number." start end) (cond ((and data (not inserted-flag) (not displayed-flag)) (let ((contents (mm-get-part data))) - (add-text-properties (mh-line-beginning-position) - (mh-line-end-position) '(mh-mime-inserted t)) + (add-text-properties (line-beginning-position) + (line-end-position) '(mh-mime-inserted t)) (setq start (point-marker)) (forward-line 1) (mm-insert-inline data contents) (setq end (point-marker)) (add-text-properties - start (progn (goto-char start) (mh-line-end-position)) + start (progn (goto-char start) (line-end-position)) `(mh-region (,start . ,end))))) ((and data (or inserted-flag displayed-flag)) (mh-press-button) @@ -458,10 +446,10 @@ decoding the same message multiple times." (setf (gethash handle (mh-mime-handles-cache (mh-buffer-data))) (let ((handles (mm-dissect-buffer nil))) (if handles - (mh-mm-uu-dissect-text-parts handles) + (mm-uu-dissect-text-parts handles) (setq handles (mm-uu-dissect))) (setf (mh-mime-handles (mh-buffer-data)) - (mh-mm-merge-handles + (mm-merge-handles handles (mh-mime-handles (mh-buffer-data)))) handles)))) @@ -532,10 +520,10 @@ parsed and then displayed." (if pre-dissected-handles (setq handles pre-dissected-handles) (if (setq handles (mm-dissect-buffer nil)) - (mh-mm-uu-dissect-text-parts handles) + (mm-uu-dissect-text-parts handles) (setq handles (mm-uu-dissect))) (setf (mh-mime-handles (mh-buffer-data)) - (mh-mm-merge-handles handles + (mm-merge-handles handles (mh-mime-handles (mh-buffer-data)))) (unless handles (mh-decode-message-body))) @@ -641,7 +629,7 @@ buttons for alternative parts that are usually suppressed." (let ((mh-mime-security-button-line-format mh-mime-security-button-end-line-format)) (mh-insert-mime-security-button handle)) - (mh-mm-set-handle-multipart-parameter + (mm-set-handle-multipart-parameter handle 'mh-region (cons (point-min-marker) (point-max-marker))))) (defun mh-mime-display-single (handle) @@ -713,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)))) @@ -752,8 +739,8 @@ buttons for alternative parts that are usually suppressed." (mh-insert-mime-button handle id (mm-handle-displayed-p handle)) (goto-char point) (when region - (add-text-properties (mh-line-beginning-position) - (mh-line-end-position) + (add-text-properties (line-beginning-position) + (line-end-position) `(mh-region ,region))))))) (defun mh-mime-part-index (handle) @@ -777,20 +764,12 @@ This is only useful if a Content-Disposition header is not present." ; this only tells us if the image is ; something that emacs can display (let ((image (mm-get-image handle))) - (or (mh-do-in-xemacs - (and (mh-funcall-if-exists glyphp image) - (< (glyph-width image) - (or mh-max-inline-image-width (window-pixel-width))) - (< (glyph-height image) - (or mh-max-inline-image-height - (window-pixel-height))))) - (mh-do-in-gnu-emacs - (let ((size (and (fboundp 'image-size) (image-size image)))) - (and size - (< (cdr size) (or mh-max-inline-image-height - (1- (window-height)))) - (< (car size) (or mh-max-inline-image-width - (window-width))))))))))) + (let ((size (and (fboundp 'image-size) (image-size image)))) + (and size + (< (cdr size) (or mh-max-inline-image-height + (1- (window-height)))) + (< (car size) (or mh-max-inline-image-width + (window-width))))))))) (defun mh-inline-vcard-p (handle) "Decide if HANDLE is a vcard that must be displayed inline." @@ -813,27 +792,19 @@ being used to highlight the signature in a MIME part." ((not (and (equal (mm-handle-media-supertype handle) "text") (equal (mm-handle-media-subtype handle) "html"))) "^-- $") - ((eq (mh-mm-text-html-renderer) 'lynx) "^ --$") + ((eq mm-text-html-renderer 'lynx) "^ --$") (t "^--$")))) (save-excursion (goto-char (point-max)) (when (re-search-backward regexp nil t) - (mh-do-in-gnu-emacs - (let ((ov (make-overlay (point) (point-max)))) - (overlay-put ov 'face 'mh-show-signature) - (overlay-put ov 'evaporate t))) - (mh-do-in-xemacs - (set-extent-property (make-extent (point) (point-max)) - 'face 'mh-show-signature)))))) + (let ((ov (make-overlay (point) (point-max)))) + (overlay-put ov 'face 'mh-show-signature) + (overlay-put ov 'evaporate t)))))) ;;; Button Display -;; Shush compiler. -(mh-do-in-xemacs - (defvar ov)) - (defun mh-insert-mime-button (handle index displayed) "Insert MIME button for HANDLE. INDEX is the part number that will be DISPLAYED. It is also used @@ -865,10 +836,10 @@ by commands like \"K v\" which operate on individual MIME parts." (setq begin (point)) (gnus-eval-format mh-mime-button-line-format mh-mime-button-line-format-alist - `(,@(mh-gnus-local-map-property mh-mime-button-map) - mh-callback mh-mm-display-part - mh-part ,index - mh-data ,handle))) + `(keymap ,mh-mime-button-map + mh-callback mh-mm-display-part + mh-part ,index + mh-data ,handle))) (setq end (point)) (widget-convert-button 'link begin end @@ -877,16 +848,12 @@ by commands like \"K v\" which operate on individual MIME parts." :button-keymap mh-mime-button-map :help-echo "Mouse-2 click or press RET (in show buffer) to toggle display") - (dolist (ov (mh-funcall-if-exists overlays-in begin end)) - (mh-funcall-if-exists overlay-put ov 'evaporate t)))) - -;; Shush compiler. -(defvar mm-verify-function-alist) ; < Emacs 22 -(defvar mm-decrypt-function-alist) ; < Emacs 22 + (dolist (ov (overlays-in begin end)) + (overlay-put ov 'evaporate t)))) (defun mh-insert-mime-security-button (handle) "Display buttons for PGP message, HANDLE." - (let* ((protocol (mh-mm-handle-multipart-ctl-parameter handle 'protocol)) + (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol)) (crypto-type (or (nth 2 (assoc protocol mm-verify-function-alist)) (nth 2 (assoc protocol mm-decrypt-function-alist)) "Unknown")) @@ -897,10 +864,10 @@ by commands like \"K v\" which operate on individual MIME parts." (if (equal (car handle) "multipart/signed") " Signed" " Encrypted") " Part")) - (info (or (mh-mm-handle-multipart-ctl-parameter + (info (or (mm-handle-multipart-ctl-parameter handle 'gnus-info) "Undecided")) - (details (mh-mm-handle-multipart-ctl-parameter + (details (mm-handle-multipart-ctl-parameter handle 'gnus-details)) pressed-details) (setq details (if details (concat "\n" details) "")) @@ -911,11 +878,11 @@ by commands like \"K v\" which operate on individual MIME parts." (gnus-eval-format mh-mime-security-button-line-format mh-mime-security-button-line-format-alist - `(,@(mh-gnus-local-map-property mh-mime-security-button-map) - mh-button-pressed ,mh-mime-security-button-pressed - mh-callback mh-mime-security-press-button - mh-line-format ,mh-mime-security-button-line-format - mh-data ,handle)) + `(keymap ,mh-mime-security-button-map + mh-button-pressed ,mh-mime-security-button-pressed + mh-callback mh-mime-security-press-button + mh-line-format ,mh-mime-security-button-line-format + mh-data ,handle)) (setq end (point)) (widget-convert-button 'link begin end :mime-handle handle @@ -923,8 +890,8 @@ by commands like \"K v\" which operate on individual MIME parts." :button-keymap mh-mime-security-button-map :button-face face :help-echo "Mouse-2 click or press RET (in show buffer) to see security details.") - (dolist (ov (mh-funcall-if-exists overlays-in begin end)) - (mh-funcall-if-exists overlay-put ov 'evaporate t)) + (dolist (ov (overlays-in begin end)) + (overlay-put ov 'evaporate t)) (when (equal info "Failed") (let* ((type (if (equal (car handle) "multipart/signed") "verification" "decryption")) @@ -1081,7 +1048,7 @@ This is only called in recent versions of Gnus. The MIME handles are stored in data structures corresponding to MH-E folder buffer FOLDER instead of in Gnus (as in the original). The MIME part, HANDLE is associated with the undisplayer FUNCTION." - (if (mh-mm-keep-viewer-alive-p handle) + (if (mm-keep-viewer-alive-p handle) (let ((new-handle (copy-sequence handle))) (mm-handle-set-undisplayer new-handle function) (mm-handle-set-undisplayer handle nil) @@ -1091,19 +1058,19 @@ HANDLE is associated with the undisplayer FUNCTION." (defun mh-mime-security-press-button (handle) "Callback from security button for part HANDLE." - (if (mh-mm-handle-multipart-ctl-parameter handle 'gnus-info) + (if (mm-handle-multipart-ctl-parameter handle 'gnus-info) (mh-mime-security-show-details handle) - (let ((region (mh-mm-handle-multipart-ctl-parameter handle 'mh-region)) + (let ((region (mm-handle-multipart-ctl-parameter handle 'mh-region)) point) (setq point (point)) (goto-char (car region)) (delete-region (car region) (cdr region)) - (with-current-buffer (mh-mm-handle-multipart-ctl-parameter handle 'buffer) + (with-current-buffer (mm-handle-multipart-ctl-parameter handle 'buffer) (let* ((mm-verify-option 'known) (mm-decrypt-option 'known) - (new (mh-mm-possibly-verify-or-decrypt (cdr handle) handle))) + (new (mm-possibly-verify-or-decrypt (cdr handle) handle))) (unless (eq new (cdr handle)) - (mh-mm-destroy-parts (cdr handle)) + (mm-destroy-parts (cdr handle)) (setcdr handle new)))) (mh-mime-display-security handle) (goto-char point)))) @@ -1113,7 +1080,7 @@ HANDLE is associated with the undisplayer FUNCTION." ;; to be no way of getting rid of the inserted text. (defun mh-mime-security-show-details (handle) "Toggle display of detailed security info for HANDLE." - (let ((details (mh-mm-handle-multipart-ctl-parameter handle 'gnus-details))) + (let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details))) (when details (let ((mh-mime-security-button-pressed (not (get-text-property (point) 'mh-button-pressed))) @@ -1158,7 +1125,7 @@ this ;-)" (defun mh-display-smileys () "Display smileys." (when (and mh-graphical-smileys-flag (mh-small-show-buffer-p)) - (mh-funcall-if-exists smiley-region (point-min) (point-max)))) + (smiley-region (point-min) (point-max)))) ;;;###mh-autoload (defun mh-display-emphasis () @@ -1175,6 +1142,7 @@ this ;-)" This is used to decide if smileys and graphical emphasis should be displayed." (let ((max nil)) + ;; FIXME: font-lock-maximum-size is obsolete. (when (and (boundp 'font-lock-maximum-size) font-lock-maximum-size) (cond ((numberp font-lock-maximum-size) (setq max font-lock-maximum-size)) @@ -1303,7 +1271,7 @@ automatically." (type (mh-minibuffer-read-type file)) (description (mml-minibuffer-read-description)) (dispos (or disposition - (mh-mml-minibuffer-read-disposition type)))) + (mml-minibuffer-read-disposition type)))) (mml-insert-empty-tag 'part 'type type 'filename file 'disposition dispos 'description description))) @@ -1507,9 +1475,9 @@ This function will quote all such characters." (goto-char (point-min)) (while (re-search-forward "^#" nil t) (beginning-of-line) - (unless (mh-mh-directive-present-p (point) (mh-line-end-position)) + (unless (mh-mh-directive-present-p (point) (line-end-position)) (insert "#")) - (goto-char (mh-line-end-position))))) + (goto-char (line-end-position))))) ;;;###mh-autoload (defun mh-mh-to-mime-undo (noconfirm) @@ -1695,7 +1663,7 @@ buffer, while END defaults to the end of the buffer." (goto-char begin) (while (re-search-forward "^#" end t) (let ((s (buffer-substring-no-properties - (point) (mh-line-end-position)))) + (point) (line-end-position)))) (cond ((equal s "")) ((string-match "^forw[ \t\n]+" s) (cl-return-from search-for-mh-directive t)) @@ -1799,8 +1767,7 @@ initialized. Always use the command `mh-have-file-command'.") 'file -i' is used to get MIME type of composition insertion." (when (eq mh-have-file-command 'undefined) (setq mh-have-file-command - (and (fboundp 'executable-find) - (executable-find "file") ; file command exists + (and (executable-find "file") ; file command exists ; and accepts -i and -b args. (zerop (call-process "file" nil nil nil "-i" "-b" (expand-file-name "inc" mh-progs)))))) @@ -1814,10 +1781,9 @@ initialized. Always use the command `mh-have-file-command'.") (defun mh-mime-cleanup () "Free the decoded MIME parts." (let ((mime-data (gethash (current-buffer) mh-globals-hash))) - ;; This is for Emacs, what about XEmacs? - (mh-funcall-if-exists remove-images (point-min) (point-max)) + (remove-images (point-min) (point-max)) (when mime-data - (mh-mm-destroy-parts (mh-mime-handles mime-data)) + (mm-destroy-parts (mh-mime-handles mime-data)) (remhash (current-buffer) mh-globals-hash)))) ;;;###mh-autoload @@ -1825,7 +1791,7 @@ initialized. Always use the command `mh-have-file-command'.") "Free MIME data for externally displayed MIME parts." (let ((mime-data (mh-buffer-data))) (when mime-data - (mh-mm-destroy-parts (mh-mime-handles mime-data))) + (mm-destroy-parts (mh-mime-handles mime-data))) (remhash (current-buffer) mh-globals-hash))) (provide 'mh-mime) diff --git a/lisp/mh-e/mh-scan.el b/lisp/mh-e/mh-scan.el index 5aa599942e3..9ac251e8b71 100644 --- a/lisp/mh-e/mh-scan.el +++ b/lisp/mh-e/mh-scan.el @@ -315,7 +315,7 @@ produced by \"inc\".") ;;; Widths, Offsets and Columns -(defvar mh-cmd-note 4 +(defvar-local mh-cmd-note 4 "Column for notations. This variable should be set with the function `mh-set-cmd-note'. @@ -323,12 +323,15 @@ This variable may be updated dynamically if `mh-adaptive-cmd-note-flag' is on. Note that columns in Emacs start with 0.") -(make-variable-buffer-local 'mh-cmd-note) (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, @@ -510,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 e03c9dc83f7..8012e624f16 100644 --- a/lisp/mh-e/mh-search.el +++ b/lisp/mh-e/mh-search.el @@ -42,6 +42,7 @@ ;;; Code: (require 'mh-e) +(require 'mh-letter) (require 'gnus-util) (require 'imenu) @@ -318,10 +319,6 @@ folder containing the index search results." (cl-loop for msg-hash being the hash-values of mh-index-data count (> (hash-table-count msg-hash) 0))))))) -;; Shush compiler. -(mh-do-in-xemacs - (defvar pick-folder)) ;FIXME: Why? - (defun mh-search-folder (folder window-config) "Search FOLDER for messages matching a pattern. @@ -336,8 +333,8 @@ configuration and is used when the search folder is dismissed." (not (y-or-n-p "Reuse pattern? "))) (mh-make-pick-template) (message "")) - (mh-make-local-vars 'mh-current-folder folder - 'mh-previous-window-config window-config) + (setq-local mh-current-folder folder + mh-previous-window-config window-config) (message "%s" (substitute-command-keys (concat "Type \\[mh-index-do-search] to search messages, " "\\[mh-pick-do-search] to use pick, " @@ -356,13 +353,13 @@ configuration and is used when the search folder is dismissed." (goto-char (point-min)) (dotimes (_ 5) (add-text-properties (point) (1+ (point)) '(front-sticky t)) - (add-text-properties (- (mh-line-end-position) 2) - (1- (mh-line-end-position)) + (add-text-properties (- (line-end-position) 2) + (1- (line-end-position)) '(rear-nonsticky t)) - (add-text-properties (point) (1- (mh-line-end-position)) '(read-only t)) + (add-text-properties (point) (1- (line-end-position)) '(read-only t)) (forward-line)) (add-text-properties (point) (1+ (point)) '(front-sticky t)) - (add-text-properties (point) (1- (mh-line-end-position)) '(read-only t)) + (add-text-properties (point) (1- (line-end-position)) '(read-only t)) (goto-char (point-max))) ;; Sequence Searches @@ -522,10 +519,10 @@ group of results." (cond ((and (bolp) (eolp)) (ignore-errors (forward-line -1)) (setq msg (mh-get-msg-num t))) - ((equal (char-after (mh-line-beginning-position)) ?+) + ((equal (char-after (line-beginning-position)) ?+) (setq folder (buffer-substring-no-properties - (mh-line-beginning-position) - (mh-line-end-position)))) + (line-beginning-position) + (line-end-position)))) (t (setq msg (mh-get-msg-num t))))) (when (not folder) (setq folder (car (gethash (gethash msg mh-index-msg-checksum-map) @@ -552,20 +549,20 @@ group of results." ;;; MH-Search Keys ;; If this changes, modify mh-search-mode-help-messages accordingly, below. -(gnus-define-keys 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) +(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-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) @@ -616,7 +613,6 @@ The hook `mh-search-mode-hook' is called upon entry to this mode. \\{mh-search-mode-map}" - (mh-do-in-xemacs (easy-menu-add mh-pick-menu)) (mh-set-help mh-search-mode-help-messages)) @@ -653,13 +649,13 @@ The cdr of the element is the pattern to search." start begin) (goto-char (point-min)) (while (not (eobp)) - (if (search-forward "--------" (mh-line-end-position) t) + (if (search-forward "--------" (line-end-position) t) (setq in-body-flag t) (beginning-of-line) (setq begin (point)) (setq start (if in-body-flag (point) - (search-forward ":" (mh-line-end-position) t) + (search-forward ":" (line-end-position) t) (point))) (push (cons (and (not in-body-flag) (intern (downcase @@ -667,7 +663,7 @@ The cdr of the element is the pattern to search." begin (1- start))))) (mh-index-parse-search-regexp (buffer-substring-no-properties - start (mh-line-end-position)))) + start (line-end-position)))) pattern-list)) (forward-line)) pattern-list))) @@ -977,8 +973,8 @@ is used to search." (cl-return nil)) (when (equal (char-after (point)) ?#) (cl-return 'error)) - (let* ((start (search-forward " " (mh-line-end-position) t)) - (end (search-forward " " (mh-line-end-position) t))) + (let* ((start (search-forward " " (line-end-position) t)) + (end (search-forward " " (line-end-position) t))) (unless (and start end) (cl-return 'error)) (setq end (1- end)) @@ -1056,7 +1052,7 @@ SEARCH-REGEXP-LIST is used to search." (cl-return 'error)) (let ((start (point)) end msg-start) - (setq end (mh-line-end-position)) + (setq end (line-end-position)) (unless (search-forward mh-mairix-folder end t) (cl-return 'error)) (goto-char (match-beginning 0)) @@ -1197,7 +1193,7 @@ is used to search." (cl-block nil (when (eobp) (cl-return nil)) (let ((file-name (buffer-substring-no-properties - (point) (mh-line-end-position)))) + (point) (line-end-position)))) (unless (equal (string-match mh-namazu-folder file-name) 0) (cl-return 'error)) (unless (file-exists-p file-name) @@ -1245,17 +1241,17 @@ is used to search." (prog1 (cl-block nil (when (eobp) (cl-return nil)) - (when (search-forward-regexp "^\\+" (mh-line-end-position) t) + (when (search-forward-regexp "^\\+" (line-end-position) t) (setq mh-index-pick-folder - (buffer-substring-no-properties (mh-line-beginning-position) - (mh-line-end-position))) + (buffer-substring-no-properties (line-beginning-position) + (line-end-position))) (cl-return 'error)) - (unless (search-forward-regexp "^[1-9][0-9]*$" (mh-line-end-position) t) + (unless (search-forward-regexp "^[1-9][0-9]*$" (line-end-position) t) (cl-return 'error)) (list mh-index-pick-folder (string-to-number - (buffer-substring-no-properties (mh-line-beginning-position) - (mh-line-end-position))) + (buffer-substring-no-properties (line-beginning-position) + (line-end-position))) nil)) (forward-line))) @@ -1332,8 +1328,8 @@ record is invalid return `error'." (cl-block nil (when (eobp) (cl-return nil)) - (let ((eol-pos (mh-line-end-position)) - (bol-pos (mh-line-beginning-position)) + (let ((eol-pos (line-end-position)) + (bol-pos (line-beginning-position)) folder-start msg-end) (goto-char bol-pos) (unless (search-forward mh-user-path eol-pos t) @@ -1415,10 +1411,7 @@ being the list of messages originally from that folder." (when cur-msg (mh-goto-msg cur-msg t t)) (set-buffer-modified-p old-buffer-modified-flag))) -(eval-and-compile (mh-require 'which-func nil t)) - -;; Shush compiler. -(defvar which-func-mode) ; < Emacs 22, XEmacs +(eval-and-compile (require 'which-func nil t)) ;;;###mh-autoload (defun mh-index-create-imenu-index () @@ -1432,7 +1425,7 @@ being the list of messages originally from that folder." (save-excursion (beginning-of-line) (push (cons (buffer-substring-no-properties - (point) (mh-line-end-position)) + (point) (line-end-position)) (point-marker)) alist))) (setq imenu--index-alist (nreverse alist))))) @@ -1717,7 +1710,7 @@ folder, is removed from `mh-index-data'." "-format" "%{x-mhe-checksum}\n" folder msg) (goto-char (point-min)) (string-equal (buffer-substring-no-properties - (point) (mh-line-end-position)) + (point) (line-end-position)) checksum))) @@ -1826,8 +1819,8 @@ PROC is used to convert the value to actual data." (defun mh-md5sum-parser () "Parse md5sum output." - (let ((begin (mh-line-beginning-position)) - (end (mh-line-end-position)) + (let ((begin (line-beginning-position)) + (end (line-end-position)) first-space last-slash) (setq first-space (search-forward " " end t)) (goto-char end) @@ -1840,8 +1833,8 @@ PROC is used to convert the value to actual data." (defun mh-openssl-parser () "Parse openssl output." - (let ((begin (mh-line-beginning-position)) - (end (mh-line-end-position)) + (let ((begin (line-beginning-position)) + (end (line-end-position)) last-space last-slash) (goto-char end) (setq last-space (search-backward " " begin t)) @@ -1874,7 +1867,7 @@ origin-index) map is updated too." (let (msg checksum) (while (not (eobp)) (setq msg (buffer-substring-no-properties - (point) (mh-line-end-position))) + (point) (line-end-position))) (forward-line) (save-excursion (cond ((not (string-match "^[0-9]*$" msg))) @@ -1885,7 +1878,7 @@ origin-index) map is updated too." (t ;; update maps (setq checksum (buffer-substring-no-properties - (point) (mh-line-end-position))) + (point) (line-end-position))) (let ((msg (string-to-number msg))) (set-buffer folder) (mh-index-update-single-msg msg checksum origin-map))))) diff --git a/lisp/mh-e/mh-seq.el b/lisp/mh-e/mh-seq.el index a50319a455d..077e289c01d 100644 --- a/lisp/mh-e/mh-seq.el +++ b/lisp/mh-e/mh-seq.el @@ -38,9 +38,8 @@ (defvar mh-last-seq-used nil "Name of seq to which a msg was last added.") -(defvar mh-non-seq-mode-line-annotation nil +(defvar-local mh-non-seq-mode-line-annotation nil "Saved value of `mh-mode-line-annotation' when narrowed to a seq.") -(make-variable-buffer-local 'mh-non-seq-mode-line-annotation) (defvar mh-internal-seqs '(answered cur deleted forwarded printed)) @@ -167,7 +166,7 @@ The list appears in a buffer named \"*MH-E Sequences*\"." (insert "\n")) (setq seq-list (cdr seq-list))) (goto-char (point-min)) - (mh-view-mode-enter) + (view-mode-enter) (setq view-exit-action 'kill-buffer) (message "Listing sequences...done"))))) @@ -193,11 +192,6 @@ MESSAGE appears." (mh-list-to-string (mh-seq-containing-msg message t)) " ")))) -;; Shush compiler. -(mh-do-in-xemacs - (defvar tool-bar-mode)) -(defvar tool-bar-map) - ;;;###mh-autoload (defun mh-narrow-to-seq (sequence) "Restrict display to messages in SEQUENCE. @@ -229,12 +223,12 @@ When you want to widen the view to all your messages again, use (mh-make-folder-mode-line) (mh-recenter nil) (when (and (boundp 'tool-bar-mode) tool-bar-mode) - (set (make-local-variable 'tool-bar-map) - mh-folder-seq-tool-bar-map) + (setq-local tool-bar-map + mh-folder-seq-tool-bar-map) (when (buffer-live-p (get-buffer mh-show-buffer)) (with-current-buffer mh-show-buffer - (set (make-local-variable 'tool-bar-map) - mh-show-seq-tool-bar-map)))) + (setq-local tool-bar-map + mh-show-seq-tool-bar-map)))) (push 'widen mh-view-ops))) (t (error "No messages in sequence %s" (symbol-name sequence)))))) @@ -362,10 +356,10 @@ remove all limits and sequence restrictions." (mh-notate-cur) (mh-recenter nil))) (when (and (null mh-folder-view-stack) (boundp 'tool-bar-mode) tool-bar-mode) - (set (make-local-variable 'tool-bar-map) mh-folder-tool-bar-map) + (setq-local tool-bar-map mh-folder-tool-bar-map) (when (buffer-live-p (get-buffer mh-show-buffer)) (with-current-buffer mh-show-buffer - (set (make-local-variable 'tool-bar-map) mh-show-tool-bar-map))))) + (setq-local tool-bar-map mh-show-tool-bar-map))))) @@ -582,7 +576,7 @@ Otherwise, the message number at point is returned. This function is usually used with `mh-iterate-on-range' in order to provide a uniform interface to MH-E functions." - (cond ((mh-mark-active-p t) (cons (region-beginning) (region-end))) + (cond ((and transient-mark-mode mark-active) (cons (region-beginning) (region-end))) (current-prefix-arg (mh-read-range range-prompt nil nil t t)) (default default) (t (mh-get-msg-num t)))) @@ -736,7 +730,7 @@ completion is over." (cl-multiple-value-bind (folder unseen total) (cl-values-list (mh-parse-flist-output-line - (buffer-substring (point) (mh-line-end-position)))) + (buffer-substring (point) (line-end-position)))) (list total unseen folder)))) (defun mh-folder-size-folder (folder) @@ -764,7 +758,7 @@ folders whose names end with a `+' character." (when (search-backward " out of " (point-min) t) (setq total (string-to-number (buffer-substring-no-properties - (match-end 0) (mh-line-end-position)))) + (match-end 0) (line-end-position)))) (when (search-backward " in sequence " (point-min) t) (setq p (point)) (when (search-backward " has " (point-min) t) @@ -786,10 +780,10 @@ If SAVE-REFILES is non-nil, then keep the sequences that note messages to be refiled." (let ((seqs ())) (cond (save-refiles - (mh-mapc (lambda (seq) ; Save the refiling sequences - (if (mh-folder-name-p (mh-seq-name seq)) - (setq seqs (cons seq seqs)))) - mh-seq-list))) + (mapc (lambda (seq) ; Save the refiling sequences + (if (mh-folder-name-p (mh-seq-name seq)) + (setq seqs (cons seq seqs)))) + mh-seq-list))) (save-excursion (if (eq 0 (mh-exec-cmd-quiet nil "mark" folder "-list")) (progn @@ -942,7 +936,7 @@ font-lock is turned on." ;; the case of user sequences. (mh-notate nil nil mh-cmd-note) (when font-lock-mode - (font-lock-fontify-region (point) (mh-line-end-position)))) + (font-lock-fontify-region (point) (line-end-position)))) (forward-char (+ mh-cmd-note mh-scan-field-destination-offset)) (let ((stack (gethash msg mh-sequence-notation-history))) (setf (gethash msg mh-sequence-notation-history) diff --git a/lisp/mh-e/mh-show.el b/lisp/mh-e/mh-show.el index 803f07e02b2..16489bf0172 100644 --- a/lisp/mh-e/mh-show.el +++ b/lisp/mh-e/mh-show.el @@ -144,7 +144,7 @@ displayed." (if (not clean-message-header) (mh-start-of-uncleaned-message))) (mh-display-msg msg folder))) - (unless (mh-window-full-height-p) ; not vertically split + (unless (window-full-height-p) ; not vertically split (shrink-window (- (window-height) (or mh-summary-height (mh-summary-height))))) (mh-recenter nil) @@ -328,17 +328,15 @@ ignored if VISIBLE-HEADERS is non-nil." (defun mh-summary-height () "Return ideal value for the variable `mh-summary-height'. The current frame height is taken into consideration." - (or (and (fboundp 'frame-height) - (> (frame-height) 24) + (or (and (> (frame-height) 24) (min 10 (/ (frame-height) 6))) 4)) -;; Infrastructure to generate show-buffer functions from folder functions -;; XEmacs does not have deactivate-mark? What is the equivalent of -;; transient-mark-mode for XEmacs? Should we be restoring the mark in the -;; folder buffer after the operation has been carried out. +;; Infrastructure to generate show-buffer functions from folder functions. +;; Should we be restoring the mark in the folder buffer after the +;; operation has been carried out? (defmacro mh-defun-show-buffer (function original-function &optional dont-return) "Define FUNCTION to run ORIGINAL-FUNCTION in folder buffer. @@ -363,13 +361,14 @@ still visible.\n") folder-buffer) (delete-other-windows)) (mh-goto-cur-msg t) - (mh-funcall-if-exists deactivate-mark) + (deactivate-mark) (unwind-protect (prog1 (call-interactively (function ,original-function)) (setq normal-exit t)) - (mh-funcall-if-exists deactivate-mark) + (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 @@ -464,8 +463,7 @@ still visible.\n") (mh-defun-show-buffer mh-show-toggle-tick mh-toggle-tick) (mh-defun-show-buffer mh-show-narrow-to-tick mh-narrow-to-tick) (mh-defun-show-buffer mh-show-junk-allowlist mh-junk-allowlist) -(mh-defun-show-buffer mh-show-junk-whitelist mh-junk-allowlist) -(make-obsolete 'mh-show-junk-whitelist 'mh-show-junk-allowlist "28.1") +(mh-defun-show-buffer mh-show-junk-whitelist mh-junk-whitelist) (mh-defun-show-buffer mh-show-junk-blocklist mh-junk-blocklist) (mh-defun-show-buffer mh-show-index-new-messages mh-index-new-messages) (mh-defun-show-buffer mh-show-index-ticked-messages mh-index-ticked-messages) @@ -562,132 +560,132 @@ still visible.\n") ;;; MH-Show Keys -(gnus-define-keys mh-show-mode-map - " " mh-show-page-msg - "!" mh-show-refile-or-write-again - "'" mh-show-toggle-tick - "," mh-show-header-display - "." mh-show-show - ":" mh-show-show-preferred-alternative - ">" mh-show-write-message-to-file - "?" 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 - "^" mh-show-refile-msg - "c" mh-show-copy-msg - "d" mh-show-delete-msg - "e" mh-show-edit-again - "f" mh-show-forward - "g" mh-show-goto-msg - "i" mh-show-inc-folder - "k" mh-show-delete-subject-or-thread - "m" mh-show-send - "n" mh-show-next-undeleted-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 - "q" mh-show-quit - "r" mh-show-reply - "s" mh-show-send - "t" mh-show-toggle-showing - "u" mh-show-undo - "x" mh-show-execute-commands - "v" mh-show-index-visit-folder - "|" mh-show-pipe-msg) - -(gnus-define-keys (mh-show-folder-map "F" mh-show-mode-map) - "?" mh-prefix-help - "'" mh-index-ticked-messages - "S" mh-show-sort-folder - "c" mh-show-catchup - "f" mh-show-visit-folder - "k" mh-show-kill-folder - "l" mh-show-list-folders - "n" mh-index-new-messages - "o" mh-show-visit-folder - "p" mh-show-pack-folder - "q" mh-show-index-sequenced-messages - "r" mh-show-rescan-folder - "s" mh-search - "t" mh-show-toggle-threads - "u" mh-show-undo-folder - "v" mh-show-visit-folder) - -(gnus-define-keys (mh-show-sequence-map "S" mh-show-mode-map) - "'" mh-show-narrow-to-tick - "?" mh-prefix-help - "d" mh-show-delete-msg-from-seq - "k" mh-show-delete-seq - "l" mh-show-list-sequences - "n" mh-show-narrow-to-seq - "p" mh-show-put-msg-in-seq - "s" mh-show-msg-is-in-seq - "w" mh-show-widen) - -(define-key mh-show-mode-map "I" mh-inc-spool-map) - -(gnus-define-keys (mh-show-junk-map "J" mh-show-mode-map) - "?" mh-prefix-help - "a" mh-show-junk-allowlist - "b" mh-show-junk-blocklist - "w" mh-show-junk-whitelist) - -(gnus-define-keys (mh-show-ps-print-map "P" mh-show-mode-map) - "?" mh-prefix-help - "C" mh-show-ps-print-toggle-color - "F" mh-show-ps-print-toggle-faces - "f" mh-show-ps-print-msg-file - "l" mh-show-print-msg - "p" mh-show-ps-print-msg) - -(gnus-define-keys (mh-show-thread-map "T" mh-show-mode-map) - "?" mh-prefix-help - "u" mh-show-thread-ancestor - "p" mh-show-thread-previous-sibling - "n" mh-show-thread-next-sibling - "t" mh-show-toggle-threads - "d" mh-show-thread-delete - "o" mh-show-thread-refile) - -(gnus-define-keys (mh-show-limit-map "/" mh-show-mode-map) - "'" mh-show-narrow-to-tick - "?" mh-prefix-help - "c" mh-show-narrow-to-cc - "g" mh-show-narrow-to-range - "m" mh-show-narrow-to-from - "s" mh-show-narrow-to-subject - "t" mh-show-narrow-to-to - "w" mh-show-widen) - -(gnus-define-keys (mh-show-extract-map "X" mh-show-mode-map) - "?" mh-prefix-help - "s" mh-show-store-msg - "u" mh-show-store-msg) - -(gnus-define-keys (mh-show-digest-map "D" mh-show-mode-map) - "?" mh-prefix-help - " " mh-show-page-digest - "\177" mh-show-page-digest-backwards - "b" mh-show-burst-digest) - -(gnus-define-keys (mh-show-mime-map "K" mh-show-mode-map) - "?" mh-prefix-help - "a" mh-mime-save-parts - "e" mh-show-display-with-external-viewer - "v" mh-show-toggle-mime-part - "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) +(define-keymap :keymap mh-show-mode-map + "SPC" #'mh-show-page-msg + "!" #'mh-show-refile-or-write-again + "'" #'mh-show-toggle-tick + "," #'mh-show-header-display + "." #'mh-show-show + ":" #'mh-show-show-preferred-alternative + ">" #'mh-show-write-message-to-file + "?" #'mh-help + "E" #'mh-show-extract-rejected-mail + "M" #'mh-show-modify + "DEL" #'mh-show-previous-page + "C-d" #'mh-show-delete-msg-no-motion + "TAB" #'mh-show-next-button + "<backtab>" #'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 + "e" #'mh-show-edit-again + "f" #'mh-show-forward + "g" #'mh-show-goto-msg + "i" #'mh-show-inc-folder + "k" #'mh-show-delete-subject-or-thread + "m" #'mh-show-send + "n" #'mh-show-next-undeleted-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 + "q" #'mh-show-quit + "r" #'mh-show-reply + "s" #'mh-show-send + "t" #'mh-show-toggle-showing + "u" #'mh-show-undo + "x" #'mh-show-execute-commands + "v" #'mh-show-index-visit-folder + "|" #'mh-show-pipe-msg + + "F" (define-keymap :prefix 'mh-show-folder-map + "?" #'mh-prefix-help + "'" #'mh-index-ticked-messages + "S" #'mh-show-sort-folder + "c" #'mh-show-catchup + "f" #'mh-show-visit-folder + "k" #'mh-show-kill-folder + "l" #'mh-show-list-folders + "n" #'mh-index-new-messages + "o" #'mh-show-visit-folder + "p" #'mh-show-pack-folder + "q" #'mh-show-index-sequenced-messages + "r" #'mh-show-rescan-folder + "s" #'mh-search + "t" #'mh-show-toggle-threads + "u" #'mh-show-undo-folder + "v" #'mh-show-visit-folder) + + "S" (define-keymap :prefix 'mh-show-sequence-map + "'" #'mh-show-narrow-to-tick + "?" #'mh-prefix-help + "d" #'mh-show-delete-msg-from-seq + "k" #'mh-show-delete-seq + "l" #'mh-show-list-sequences + "n" #'mh-show-narrow-to-seq + "p" #'mh-show-put-msg-in-seq + "s" #'mh-show-msg-is-in-seq + "w" #'mh-show-widen) + + "I" mh-inc-spool-map + + "J" (define-keymap :prefix 'mh-show-junk-map + "?" #'mh-prefix-help + "a" #'mh-show-junk-allowlist + "b" #'mh-show-junk-blocklist + "w" #'mh-show-junk-whitelist) + + "P" (define-keymap :prefix 'mh-show-ps-print-map + "?" #'mh-prefix-help + "C" #'mh-show-ps-print-toggle-color + "F" #'mh-show-ps-print-toggle-faces + "f" #'mh-show-ps-print-msg-file + "l" #'mh-show-print-msg + "p" #'mh-show-ps-print-msg) + + "T" (define-keymap :prefix 'mh-show-thread-map + "?" #'mh-prefix-help + "u" #'mh-show-thread-ancestor + "p" #'mh-show-thread-previous-sibling + "n" #'mh-show-thread-next-sibling + "t" #'mh-show-toggle-threads + "d" #'mh-show-thread-delete + "o" #'mh-show-thread-refile) + + "/" (define-keymap :prefix 'mh-show-limit-map + "'" #'mh-show-narrow-to-tick + "?" #'mh-prefix-help + "c" #'mh-show-narrow-to-cc + "g" #'mh-show-narrow-to-range + "m" #'mh-show-narrow-to-from + "s" #'mh-show-narrow-to-subject + "t" #'mh-show-narrow-to-to + "w" #'mh-show-widen) + + "X" (define-keymap :prefix 'mh-show-extract-map + "?" #'mh-prefix-help + "s" #'mh-show-store-msg + "u" #'mh-show-store-msg) + + "D" (define-keymap :prefix 'mh-show-digest-map + "?" #'mh-prefix-help + "SPC" #'mh-show-page-digest + "DEL" #'mh-show-page-digest-backwards + "b" #'mh-show-burst-digest) + + "K" (define-keymap :prefix 'mh-show-mime-map + "?" #'mh-prefix-help + "a" #'mh-mime-save-parts + "e" #'mh-show-display-with-external-viewer + "v" #'mh-show-toggle-mime-part + "o" #'mh-show-save-mime-part + "i" #'mh-show-inline-mime-part + "t" #'mh-show-toggle-mime-buttons + "TAB" #'mh-show-next-button + "<backtab>" #'mh-show-prev-button + "C-M-i" #'mh-show-prev-button)) @@ -817,9 +815,6 @@ operation." ;; Ensure new buffers won't get this mode if default major-mode is nil. (put 'mh-show-mode 'mode-class 'special) -;; Shush compiler. -(defvar font-lock-auto-fontify) - ;;;###mh-autoload (define-derived-mode mh-show-mode text-mode "MH-Show" "Major mode for showing messages in MH-E.\\<mh-show-mode-map> @@ -836,17 +831,14 @@ The hook `mh-show-mode-hook' is called upon entry to this mode. See also `mh-folder-mode'. \\{mh-show-mode-map}" - (mh-do-in-gnu-emacs - (if (boundp 'tool-bar-map) - (set (make-local-variable 'tool-bar-map) mh-show-tool-bar-map))) - (mh-do-in-xemacs - (mh-tool-bar-init :show)) - (set (make-local-variable 'mail-header-separator) mh-mail-header-separator) + (if (boundp 'tool-bar-map) + (setq-local tool-bar-map mh-show-tool-bar-map)) + (setq-local mail-header-separator mh-mail-header-separator) (setq paragraph-start (default-value 'paragraph-start)) (setq buffer-invisibility-spec '((vanish . t) t)) - (set (make-local-variable 'line-move-ignore-invisible) t) + (setq-local line-move-ignore-invisible t) (make-local-variable 'font-lock-defaults) - ;;(set (make-local-variable 'font-lock-support-mode) nil) + ;;(setq-local font-lock-support-mode nil) (cond ((equal mh-highlight-citation-style 'font-lock) (setq font-lock-defaults '(mh-show-font-lock-keywords-with-cite t))) @@ -858,16 +850,8 @@ See also `mh-folder-mode'. (mh-gnus-article-highlight-citation)) (t (setq font-lock-defaults '(mh-show-font-lock-keywords t)))) - (if (and (featurep 'xemacs) - font-lock-auto-fontify) - (turn-on-font-lock)) (when mh-decode-mime-flag - (mh-make-local-hook 'kill-buffer-hook) (add-hook 'kill-buffer-hook #'mh-mime-cleanup nil t)) - (mh-do-in-xemacs - (easy-menu-add mh-show-sequence-menu) - (easy-menu-add mh-show-message-menu) - (easy-menu-add mh-show-folder-menu)) (make-local-variable 'mh-show-folder-buffer) (buffer-disable-undo) (use-local-map mh-show-mode-map)) diff --git a/lisp/mh-e/mh-speed.el b/lisp/mh-e/mh-speed.el index 76ef990d825..d9909a034d9 100644 --- a/lisp/mh-e/mh-speed.el +++ b/lisp/mh-e/mh-speed.el @@ -63,13 +63,13 @@ '("--" ["Visit Folder" mh-speed-view (with-current-buffer speedbar-buffer - (get-text-property (mh-line-beginning-position) 'mh-folder))] + (get-text-property (line-beginning-position) 'mh-folder))] ["Expand Nested Folders" mh-speed-expand-folder - (and (get-text-property (mh-line-beginning-position) 'mh-children-p) - (not (get-text-property (mh-line-beginning-position) 'mh-expanded)))] + (and (get-text-property (line-beginning-position) 'mh-children-p) + (not (get-text-property (line-beginning-position) 'mh-expanded)))] ["Contract Nested Folders" mh-speed-contract-folder - (and (get-text-property (mh-line-beginning-position) 'mh-children-p) - (get-text-property (mh-line-beginning-position) 'mh-expanded))] + (and (get-text-property (line-beginning-position) 'mh-children-p) + (get-text-property (line-beginning-position) 'mh-expanded))] ["Refresh Speedbar" mh-speed-refresh t]) "Extra menu items for speedbar.") @@ -83,11 +83,11 @@ (defvar mh-folder-speedbar-key-map (speedbar-make-specialized-keymap) "Specialized speedbar keymap for MH-E buffers.") -(gnus-define-keys mh-folder-speedbar-key-map - "+" mh-speed-expand-folder - "-" mh-speed-contract-folder - "\r" mh-speed-view - "r" mh-speed-refresh) +(define-keymap :keymap mh-folder-speedbar-key-map + "+" #'mh-speed-expand-folder + "-" #'mh-speed-contract-folder + "RET" #'mh-speed-view + "r" #'mh-speed-refresh) (defvar mh-show-speedbar-key-map mh-folder-speedbar-key-map) (defvar mh-letter-speedbar-key-map mh-folder-speedbar-key-map) @@ -150,7 +150,7 @@ The optional arguments from speedbar are IGNORED." (forward-line -1) (speedbar-change-expand-button-char ?+) (add-text-properties - (mh-line-beginning-position) (1+ (line-beginning-position)) + (line-beginning-position) (1+ (line-beginning-position)) '(mh-expanded nil))) (t (forward-line) @@ -158,14 +158,14 @@ The optional arguments from speedbar are IGNORED." (goto-char point) (speedbar-change-expand-button-char ?-) (add-text-properties - (mh-line-beginning-position) (1+ (line-beginning-position)) + (line-beginning-position) (1+ (line-beginning-position)) '(mh-expanded t))))))) (defun mh-speed-view (&rest _ignored) "Visits the selected folder just as if you had used \\<mh-folder-mode-map>\\[mh-visit-folder]. The optional arguments from speedbar are IGNORED." (interactive) - (let* ((folder (get-text-property (mh-line-beginning-position) 'mh-folder)) + (let* ((folder (get-text-property (line-beginning-position) 'mh-folder)) (range (and (stringp folder) (mh-read-range "Scan" folder t nil nil mh-interpret-number-as-range-flag)))) @@ -191,9 +191,9 @@ created." (forward-line -1) (setf (gethash nil mh-speed-folder-map) (set-marker (or (gethash nil mh-speed-folder-map) (make-marker)) - (1+ (mh-line-beginning-position)))) + (1+ (line-beginning-position)))) (add-text-properties - (mh-line-beginning-position) (1+ (line-beginning-position)) + (line-beginning-position) (1+ (line-beginning-position)) '(mh-folder nil mh-expanded nil mh-children-p t mh-level 0)) (mh-speed-stealth-update t) (when (> mh-speed-update-interval 0) @@ -260,12 +260,12 @@ The update is always carried out if FORCE is non-nil." (speedbar-with-writable (goto-char (gethash folder mh-speed-folder-map (point))) (beginning-of-line) - (if (re-search-forward "([1-9][0-9]*/[0-9]+)" (mh-line-end-position) t) + (if (re-search-forward "([1-9][0-9]*/[0-9]+)" (line-end-position) t) (setq face (mh-speed-bold-face face)) (setq face (mh-speed-normal-face face))) (beginning-of-line) - (when (re-search-forward "\\[.\\] " (mh-line-end-position) t) - (put-text-property (point) (mh-line-end-position) 'face face))))) + (when (re-search-forward "\\[.\\] " (line-end-position) t) + (put-text-property (point) (line-end-position) 'face face))))) (defun mh-speed-normal-face (face) "Return normal face for given FACE." @@ -305,7 +305,7 @@ The function will expand out parent folders of FOLDER if needed." (while suffix-list ;; We always need at least one toggle. We need two if the directory list ;; is stale since a folder was added. - (when (equal prefix (get-text-property (mh-line-beginning-position) + (when (equal prefix (get-text-property (line-beginning-position) 'mh-folder)) (mh-speed-toggle) (unless (get-text-property (point) 'mh-expanded) @@ -359,9 +359,9 @@ uses." (setf (gethash folder-name mh-speed-folder-map) (set-marker (or (gethash folder-name mh-speed-folder-map) (make-marker)) - (1+ (mh-line-beginning-position)))) + (1+ (line-beginning-position)))) (add-text-properties - (mh-line-beginning-position) (1+ (mh-line-beginning-position)) + (line-beginning-position) (1+ (line-beginning-position)) `(mh-folder ,folder-name mh-expanded nil mh-children-p ,(not (not (cdr f))) @@ -374,12 +374,9 @@ uses." (defvar mh-speed-flists-folder nil) (defmacro mh-process-kill-without-query (process) - "PROCESS can be killed without query on Emacs exit. -Avoid using `process-kill-without-query' if possible since it is -now obsolete." - (if (fboundp 'set-process-query-on-exit-flag) - `(set-process-query-on-exit-flag ,process nil) - `(process-kill-without-query ,process))) + "PROCESS can be killed without query on Emacs exit." + (declare (obsolete set-process-query-on-exit-flag "29.1")) + `(set-process-query-on-exit-flag ,process nil)) ;;;###mh-autoload (defun mh-speed-flists (force &rest folders) @@ -391,7 +388,7 @@ flists is run only for that one folder." (interactive (list t)) (when force (when mh-speed-flists-timer - (mh-cancel-timer mh-speed-flists-timer) + (cancel-timer mh-speed-flists-timer) (setq mh-speed-flists-timer nil)) (when (and (processp mh-speed-flists-process) (not (eq (process-status mh-speed-flists-process) 'exit))) @@ -427,7 +424,7 @@ flists is run only for that one folder." (or mh-speed-flists-folder '("-recurse")))) ;; Run flists on all folders the next time around... (setq mh-speed-flists-folder nil) - (mh-process-kill-without-query mh-speed-flists-process) + (set-process-query-on-exit-flag mh-speed-flists-process nil) (set-process-filter mh-speed-flists-process #'mh-speed-parse-flists-output))))))) @@ -462,25 +459,25 @@ be handled next." face) (when pos (goto-char pos) - (goto-char (mh-line-beginning-position)) + (goto-char (line-beginning-position)) (cond ((null (get-text-property (point) 'mh-count)) - (goto-char (mh-line-end-position)) + (goto-char (line-end-position)) (setq face (get-text-property (1- (point)) 'face)) (insert (format " (%s/%s)" unseen total)) (mh-speed-highlight 'unknown face) - (goto-char (mh-line-beginning-position)) + (goto-char (line-beginning-position)) (add-text-properties (point) (1+ (point)) `(mh-count (,unseen . ,total)))) ((not (equal (get-text-property (point) 'mh-count) (cons unseen total))) - (goto-char (mh-line-end-position)) + (goto-char (line-end-position)) (setq face (get-text-property (1- (point)) 'face)) - (re-search-backward " " (mh-line-beginning-position) t) - (delete-region (point) (mh-line-end-position)) + (re-search-backward " " (line-beginning-position) t) + (delete-region (point) (line-end-position)) (insert (format " (%s/%s)" unseen total)) (mh-speed-highlight 'unknown face) - (goto-char (mh-line-beginning-position)) + (goto-char (line-beginning-position)) (add-text-properties (point) (1+ (point)) `(mh-count (,unseen . ,total)))))))))))) @@ -509,15 +506,15 @@ be handled next." (caar parent-kids))) (setq parent-change ? )))) (goto-char parent-position) - (when (equal (get-text-property (mh-line-beginning-position) 'mh-folder) + (when (equal (get-text-property (line-beginning-position) 'mh-folder) parent) - (when (get-text-property (mh-line-beginning-position) 'mh-expanded) + (when (get-text-property (line-beginning-position) 'mh-expanded) (mh-speed-toggle)) (when parent-change (speedbar-with-writable (mh-speedbar-change-expand-button-char parent-change) (add-text-properties - (mh-line-beginning-position) (1+ (mh-line-beginning-position)) + (line-beginning-position) (1+ (line-beginning-position)) `(mh-children-p ,(equal parent-change ?+))))) (mh-speed-highlight mh-speed-last-selected-folder 'mh-speedbar-folder) (setq mh-speed-last-selected-folder nil) @@ -531,15 +528,15 @@ be handled next." "Change the expansion button character to CHAR for the current line." (save-excursion (beginning-of-line) - (if (re-search-forward "\\[.\\]" (mh-line-end-position) t) + (if (re-search-forward "\\[.\\]" (line-end-position) t) (speedbar-with-writable (backward-char 2) (delete-char 1) (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) @@ -562,9 +559,9 @@ The function invalidates the latest ancestor that is present." (speedbar-with-writable (mh-speedbar-change-expand-button-char ?+) (add-text-properties - (mh-line-beginning-position) (1+ (mh-line-beginning-position)) + (line-beginning-position) (1+ (line-beginning-position)) '(mh-children-p t))) - (when (get-text-property (mh-line-beginning-position) 'mh-expanded) + (when (get-text-property (line-beginning-position) 'mh-expanded) (mh-speed-toggle)) (setq mh-speed-refresh-flag t)))) diff --git a/lisp/mh-e/mh-thread.el b/lisp/mh-e/mh-thread.el index 89b0dbd9798..1be2185ecdf 100644 --- a/lisp/mh-e/mh-thread.el +++ b/lisp/mh-e/mh-thread.el @@ -86,41 +86,33 @@ message parent children (real-child-p t)) -(defvar mh-thread-id-hash nil +(defvar-local mh-thread-id-hash nil "Hash table used to canonicalize message identifiers.") -(make-variable-buffer-local 'mh-thread-id-hash) -(defvar mh-thread-subject-hash nil +(defvar-local mh-thread-subject-hash nil "Hash table used to canonicalize subject strings.") -(make-variable-buffer-local 'mh-thread-subject-hash) -(defvar mh-thread-id-table nil +(defvar-local mh-thread-id-table nil "Thread ID table maps from message identifiers to message containers.") -(make-variable-buffer-local 'mh-thread-id-table) -(defvar mh-thread-index-id-map nil +(defvar-local mh-thread-index-id-map nil "Table to look up message identifier from message index.") -(make-variable-buffer-local 'mh-thread-index-id-map) -(defvar mh-thread-id-index-map nil +(defvar-local mh-thread-id-index-map nil "Table to look up message index number from message identifier.") -(make-variable-buffer-local 'mh-thread-id-index-map) -(defvar mh-thread-subject-container-hash nil +(defvar-local mh-thread-subject-container-hash nil "Hash table used to group messages by subject.") -(make-variable-buffer-local 'mh-thread-subject-container-hash) -(defvar mh-thread-duplicates nil +(defvar-local mh-thread-duplicates nil "Hash table used to associate messages with the same message identifier.") -(make-variable-buffer-local 'mh-thread-duplicates) -(defvar mh-thread-history () +(defvar-local mh-thread-history () "Variable to remember the transformations to the thread tree. When new messages are added, these transformations are rewound, then the links are added from the newly seen messages. Finally the transformations are redone to get the new thread tree. This makes incremental threading easier.") -(make-variable-buffer-local 'mh-thread-history) (defvar mh-thread-body-width nil "Width of scan substring that contains subject and body of message.") @@ -147,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))))) @@ -250,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) @@ -283,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)) @@ -294,7 +286,7 @@ at the end." (while (not (eobp)) (forward-char address-start-offset) (unless (equal (string-match spaces (buffer-substring-no-properties - (point) (mh-line-end-position))) + (point) (line-end-position))) 0) (beginning-of-line) (backward-char) @@ -455,8 +447,8 @@ If optional argument STRING is given then that is assumed to be the scan line. Otherwise uses the line at point as the scan line to parse." (let* ((string (or string (buffer-substring-no-properties - (mh-line-beginning-position) - (mh-line-end-position)))) + (line-beginning-position) + (line-end-position)))) (address-start (+ mh-cmd-note mh-scan-field-from-start-offset)) (body-start (+ mh-cmd-note mh-scan-field-from-end-offset)) (first-string (substring string 0 address-start))) @@ -597,20 +589,20 @@ Only information about messages in MSG-LIST are added to the tree." (while (not (eobp)) (cl-block process-message (let* ((index-line - (prog1 (buffer-substring (point) (mh-line-end-position)) + (prog1 (buffer-substring (point) (line-end-position)) (forward-line))) (index (string-to-number index-line)) - (id (prog1 (buffer-substring (point) (mh-line-end-position)) + (id (prog1 (buffer-substring (point) (line-end-position)) (forward-line))) (refs (prog1 - (buffer-substring (point) (mh-line-end-position)) + (buffer-substring (point) (line-end-position)) (forward-line))) (in-reply-to (prog1 (buffer-substring (point) - (mh-line-end-position)) + (line-end-position)) (forward-line))) (subject (prog1 (buffer-substring - (point) (mh-line-end-position)) + (point) (line-end-position)) (forward-line))) (subject-re-p nil)) (unless (gethash index mh-thread-scan-line-map) diff --git a/lisp/mh-e/mh-tool-bar.el b/lisp/mh-e/mh-tool-bar.el index 94aa8dd4a92..d451ae34d29 100644 --- a/lisp/mh-e/mh-tool-bar.el +++ b/lisp/mh-e/mh-tool-bar.el @@ -27,10 +27,8 @@ ;;; Code: (require 'mh-e) -(mh-do-in-gnu-emacs - (require 'tool-bar)) -(mh-do-in-xemacs - (require 'toolbar)) +(require 'mh-acros) +(require 'tool-bar) ;;; Tool Bar Commands @@ -79,9 +77,6 @@ When INCLUDE-FLAG is non-nil, include message body being replied to." ;;; Tool Bar Creation -;; Shush compiler. -(defvar image-load-path) - (defmacro mh-tool-bar-define (defaults &rest buttons) "Define a tool bar for MH-E. DEFAULTS is the list of buttons that are present by default. It @@ -145,8 +140,6 @@ where, (let* ((name (nth 0 button)) (name-str (symbol-name name)) (icon (nth 2 button)) - (xemacs-icon (mh-do-in-xemacs - `(cdr (assoc (quote ,(intern icon)) mh-xemacs-icon-map)))) (full-doc (nth 3 button)) (doc (if (string-match "\\(.*\\)\n" full-doc) (match-string 1 full-doc) @@ -186,11 +179,10 @@ where, (t 'folder-buttons))) (docs (cond ((eq mbuttons 'letter-buttons) 'letter-docs) ((eq mbuttons 'folder-buttons) 'folder-docs)))) - (add-to-list vector-list `(vector ,xemacs-icon ',function t ,full-doc)) + (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)))))) @@ -209,145 +201,69 @@ where, (unless (memq x letter-buttons) (error "Letter defaults contains unknown button %s" x))) `(eval-and-compile - ;; GNU Emacs tool bar specific code - (mh-do-in-gnu-emacs - (defun mh-buffer-exists-p (mode) - "Test whether a buffer with major mode MODE is present." - (cl-loop for buf in (buffer-list) - when (with-current-buffer buf - (eq major-mode mode)) - return t)) - ;; Tool bar initialization functions - (defun mh-tool-bar-folder-buttons-init () - (when (mh-buffer-exists-p 'mh-folder-mode) - (let* ((load-path (mh-image-load-path-for-library "mh-e" - "mh-logo.xpm")) - (image-load-path (cons (car load-path) - (when (boundp 'image-load-path) - image-load-path)))) - (setq mh-folder-tool-bar-map - (let ((tool-bar-map (make-sparse-keymap))) - ,@(nreverse folder-button-setter) - tool-bar-map)) - (setq mh-folder-seq-tool-bar-map - (let ((tool-bar-map (copy-keymap mh-folder-tool-bar-map))) - ,@(nreverse sequence-button-setter) - tool-bar-map)) - (setq mh-show-tool-bar-map - (let ((tool-bar-map (make-sparse-keymap))) - ,@(nreverse show-button-setter) - tool-bar-map)) - (setq mh-show-seq-tool-bar-map - (let ((tool-bar-map (copy-keymap mh-show-tool-bar-map))) - ,@(nreverse show-seq-button-setter) - tool-bar-map))))) - (defun mh-tool-bar-letter-buttons-init () - (when (mh-buffer-exists-p 'mh-letter-mode) - (let* ((load-path (mh-image-load-path-for-library "mh-e" - "mh-logo.xpm")) - (image-load-path (cons (car load-path) - (when (boundp 'image-load-path) - image-load-path)))) - (setq mh-letter-tool-bar-map - (let ((tool-bar-map (make-sparse-keymap))) - ,@(nreverse letter-button-setter) - tool-bar-map))))) - ;; Custom setter functions - (defun mh-tool-bar-update (mode default-map sequence-map) - "Update `tool-bar-map' in all buffers of MODE. + (defun mh-buffer-exists-p (mode) + "Test whether a buffer with major mode MODE is present." + (cl-loop for buf in (buffer-list) + when (with-current-buffer buf + (eq major-mode mode)) + return t)) + ;; Tool bar initialization functions + (defun mh-tool-bar-folder-buttons-init () + (when (mh-buffer-exists-p 'mh-folder-mode) + (mh--with-image-load-path + (setq mh-folder-tool-bar-map + (let ((tool-bar-map (make-sparse-keymap))) + ,@(nreverse folder-button-setter) + tool-bar-map)) + (setq mh-folder-seq-tool-bar-map + (let ((tool-bar-map (copy-keymap mh-folder-tool-bar-map))) + ,@(nreverse sequence-button-setter) + tool-bar-map)) + (setq mh-show-tool-bar-map + (let ((tool-bar-map (make-sparse-keymap))) + ,@(nreverse show-button-setter) + tool-bar-map)) + (setq mh-show-seq-tool-bar-map + (let ((tool-bar-map (copy-keymap mh-show-tool-bar-map))) + ,@(nreverse show-seq-button-setter) + tool-bar-map))))) + (defun mh-tool-bar-letter-buttons-init () + (when (mh-buffer-exists-p 'mh-letter-mode) + (mh--with-image-load-path + (setq mh-letter-tool-bar-map + (let ((tool-bar-map (make-sparse-keymap))) + ,@(nreverse letter-button-setter) + tool-bar-map))))) + ;; Custom setter functions + (defun mh-tool-bar-update (mode default-map sequence-map) + "Update `tool-bar-map' in all buffers of MODE. Use SEQUENCE-MAP if display is limited; DEFAULT-MAP otherwise." - (cl-loop for buf in (buffer-list) - do (with-current-buffer buf - (when (eq mode major-mode) ;FIXME: derived-mode-p? - (let ((map (if mh-folder-view-stack - sequence-map - default-map))) - ;; Yes, make-local-variable is necessary since we - ;; get here during initialization when loading - ;; mh-e.el, after the +inbox buffer has been - ;; created, but before mh-folder-mode has run and - ;; created the local map. - (set (make-local-variable 'tool-bar-map) map)))))) - (defun mh-tool-bar-folder-buttons-set (symbol value) - "Construct tool bar for `mh-folder-mode' and `mh-show-mode'." - (set-default symbol value) - (mh-tool-bar-folder-buttons-init) - (mh-tool-bar-update 'mh-folder-mode mh-folder-tool-bar-map - mh-folder-seq-tool-bar-map) - (mh-tool-bar-update 'mh-show-mode mh-show-tool-bar-map - mh-show-seq-tool-bar-map)) - (defun mh-tool-bar-letter-buttons-set (symbol value) - "Construct tool bar for `mh-letter-mode'." - (set-default symbol value) - (mh-tool-bar-letter-buttons-init) - (mh-tool-bar-update 'mh-letter-mode mh-letter-tool-bar-map - mh-letter-tool-bar-map))) - ;; XEmacs specific code - (mh-do-in-xemacs - (defvar mh-tool-bar-folder-vector-map - (list ,@(cl-loop for button in folder-buttons - for vector in folder-vectors - collect `(cons ',button ,vector)))) - (defvar mh-tool-bar-show-vector-map - (list ,@(cl-loop for button in show-buttons - for vector in show-vectors - collect `(cons ',button ,vector)))) - (defvar mh-tool-bar-letter-vector-map - (list ,@(cl-loop for button in letter-buttons - for vector in letter-vectors - collect `(cons ',button ,vector)))) - (defvar mh-tool-bar-folder-buttons) - (defvar mh-tool-bar-show-buttons) - (defvar mh-tool-bar-letter-buttons) - ;; Custom setter functions - (defun mh-tool-bar-letter-buttons-set (symbol value) - (set-default symbol value) - (when mh-xemacs-has-tool-bar-flag - (setq mh-tool-bar-letter-buttons - (cl-loop - for b in value - collect (cdr (assoc b mh-tool-bar-letter-vector-map)))))) - (defun mh-tool-bar-folder-buttons-set (symbol value) - (set-default symbol value) - (when mh-xemacs-has-tool-bar-flag - (setq mh-tool-bar-folder-buttons - (cl-loop - for b in value - collect (cdr (assoc b mh-tool-bar-folder-vector-map)))) - (setq mh-tool-bar-show-buttons - (cl-loop - for b in value - collect (cdr (assoc b mh-tool-bar-show-vector-map)))))) - (defun mh-tool-bar-init (mode) - "Install tool bar in MODE." - (when mh-xemacs-use-tool-bar-flag - (let ((tool-bar (cond ((eq mode :folder) - mh-tool-bar-folder-buttons) - ((eq mode :letter) - mh-tool-bar-letter-buttons) - ((eq mode :show) - mh-tool-bar-show-buttons))) - (height 37) - (width 40) - (buffer (current-buffer))) - (cond - ((eq mh-xemacs-tool-bar-position 'top) - (set-specifier top-toolbar tool-bar buffer) - (set-specifier top-toolbar-visible-p t) - (set-specifier top-toolbar-height height)) - ((eq mh-xemacs-tool-bar-position 'bottom) - (set-specifier bottom-toolbar tool-bar buffer) - (set-specifier bottom-toolbar-visible-p t) - (set-specifier bottom-toolbar-height height)) - ((eq mh-xemacs-tool-bar-position 'left) - (set-specifier left-toolbar tool-bar buffer) - (set-specifier left-toolbar-visible-p t) - (set-specifier left-toolbar-width width)) - ((eq mh-xemacs-tool-bar-position 'right) - (set-specifier right-toolbar tool-bar buffer) - (set-specifier right-toolbar-visible-p t) - (set-specifier right-toolbar-width width)) - (t (set-specifier default-toolbar tool-bar buffer))))))) + (cl-loop for buf in (buffer-list) + do (with-current-buffer buf + (when (eq mode major-mode) ;FIXME: derived-mode-p? + (let ((map (if mh-folder-view-stack + sequence-map + default-map))) + ;; Yes, make-local-variable is necessary since we + ;; get here during initialization when loading + ;; mh-e.el, after the +inbox buffer has been + ;; created, but before mh-folder-mode has run and + ;; created the local map. + (setq-local tool-bar-map map)))))) + (defun mh-tool-bar-folder-buttons-set (symbol value) + "Construct tool bar for `mh-folder-mode' and `mh-show-mode'." + (set-default symbol value) + (mh-tool-bar-folder-buttons-init) + (mh-tool-bar-update 'mh-folder-mode mh-folder-tool-bar-map + mh-folder-seq-tool-bar-map) + (mh-tool-bar-update 'mh-show-mode mh-show-tool-bar-map + mh-show-seq-tool-bar-map)) + (defun mh-tool-bar-letter-buttons-set (symbol value) + "Construct tool bar for `mh-letter-mode'." + (set-default symbol value) + (mh-tool-bar-letter-buttons-init) + (mh-tool-bar-update 'mh-letter-mode mh-letter-tool-bar-map + mh-letter-tool-bar-map)) ;; Declare customizable tool bars (custom-declare-variable 'mh-tool-bar-folder-buttons @@ -372,7 +288,6 @@ Use SEQUENCE-MAP if display is limited; DEFAULT-MAP otherwise." ;;:package-version '(MH-E "7.1") )))) -;; The icon names are duplicated in the Makefile and mh-xemacs.el. (mh-tool-bar-define ((:folder mh-inc-folder mh-mime-save-parts mh-previous-undeleted-msg mh-page-msg diff --git a/lisp/mh-e/mh-utils.el b/lisp/mh-e/mh-utils.el index bbce17013b1..b75025d6a4d 100644 --- a/lisp/mh-e/mh-utils.el +++ b/lisp/mh-e/mh-utils.el @@ -52,7 +52,7 @@ used in lieu of `search' in the CL package." (let ((syntax-table (syntax-table))) (unwind-protect (save-excursion - (mh-mail-abbrev-make-syntax-table) + (mail-abbrev-make-syntax-table) (set-syntax-table mail-abbrev-syntax-table) (backward-word n) (point)) @@ -61,9 +61,9 @@ used in lieu of `search' in the CL package." ;;;###mh-autoload (defun mh-colors-available-p () "Check if colors are available in the Emacs being used." - (or (featurep 'xemacs) - (let ((color-cells (mh-display-color-cells))) - (and (numberp color-cells) (>= color-cells 8))))) + ;; FIXME: Can this be replaced with `display-color-p'? + (let ((color-cells (display-color-cells))) + (and (numberp color-cells) (>= color-cells 8)))) ;;;###mh-autoload (defun mh-colors-in-use-p () @@ -78,16 +78,13 @@ used in lieu of `search' in the CL package." ;;;###mh-autoload (defun mh-make-local-vars (&rest pairs) "Initialize local variables according to the variable-value PAIRS." + (declare (obsolete setq-local "29.1")) (while pairs (set (make-local-variable (car pairs)) (car (cdr pairs))) (setq pairs (cdr (cdr pairs))))) ;;;###mh-autoload -(defun mh-mapc (function list) - "Apply FUNCTION to each element of LIST for side effects only." - (while list - (funcall function (car list)) - (setq list (cdr list)))) +(define-obsolete-function-alias 'mh-mapc #'mapc "29.1") (defvar mh-pick-regexp-chars ".*$[" "List of special characters in pick regular expressions.") @@ -102,7 +99,7 @@ PICK-EXPR is a list of strings. Return nil if PICK-EXPR is nil." (not (string-equal string ""))) (cl-loop for i from 0 to (1- (length mh-pick-regexp-chars)) do (let ((s (string ?\\ (aref mh-pick-regexp-chars i)))) - (setq string (mh-replace-regexp-in-string s s string t t)))) + (setq string (replace-regexp-in-string s s string t t)))) (setq quoted-pick-expr (append quoted-pick-expr (list string))))) quoted-pick-expr)) @@ -119,34 +116,32 @@ Ignores case when searching for OLD." ;;; Logo Display -(defvar mh-logo-cache nil) +;;;###mh-autoload +(defmacro mh--with-image-load-path (&rest body) + "Load `image' and eval BODY with `image-load-path' set appropriately." + (declare (debug t) (indent 0)) + `(progn + ;; Not preloaded in without-x builds. + (require 'image) + (defvar image-load-path) + (declare-function image-load-path-for-library "image") + (let* ((load-path (image-load-path-for-library "mh-e" "mh-logo.xpm")) + (image-load-path (cons (car load-path) image-load-path))) + ,@body))) -;; Shush compiler. -(defvar image-load-path) +(defvar mh-logo-cache nil) ;;;###mh-autoload (defun mh-logo-display () "Modify mode line to display MH-E logo." - (mh-do-in-gnu-emacs - (let* ((load-path (mh-image-load-path-for-library "mh-e" "mh-logo.xpm")) - (image-load-path (cons (car load-path) - (when (boundp 'image-load-path) - image-load-path)))) - (add-text-properties - 0 2 - `(display ,(or mh-logo-cache - (setq mh-logo-cache - (mh-funcall-if-exists - find-image '((:type xpm :ascent center - :file "mh-logo.xpm")))))) - (car mode-line-buffer-identification)))) - (mh-do-in-xemacs - (setq modeline-buffer-identification - (list - (if mh-modeline-glyph - (cons modeline-buffer-id-left-extent mh-modeline-glyph) - (cons modeline-buffer-id-left-extent "XEmacs%N:")) - (cons modeline-buffer-id-right-extent " %17b"))))) + (mh--with-image-load-path + (add-text-properties + 0 2 + `(display ,(or mh-logo-cache + (setq mh-logo-cache + (find-image '(( :type xpm :ascent center + :file "mh-logo.xpm" )))))) + (car mode-line-buffer-identification)))) @@ -509,8 +504,8 @@ they will not be returned." ;; folder is specified, ensure it is nil to avoid adding the ;; folder to the folder-list and adding a slash to it. (when folder - (setq folder (mh-replace-regexp-in-string "^\\+" "" folder)) - (setq folder (mh-replace-regexp-in-string "/+$" "" folder)) + (setq folder (replace-regexp-in-string "^\\+" "" folder)) + (setq folder (replace-regexp-in-string "/+$" "" folder)) (if (equal folder "") (setq folder nil))) ;; Add provided folder to list, unless all folders are asked for. @@ -535,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) @@ -562,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) @@ -571,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 (mh-line-end-position)) - (let ((start-pos (mh-line-beginning-position)) - (has-pos (search-backward " has " - (mh-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)" (mh-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))) @@ -727,16 +741,12 @@ See Info node `(elisp) Programmed Completion' for details." ((equal path mh-user-path) nil) (t (file-directory-p path)))))))) -;; Shush compiler. -(defvar completion-root-regexp) ;; Apparently used in XEmacs - (defun mh-folder-completing-read (prompt default allow-root-folder-flag) "Read folder name with PROMPT and default result DEFAULT. If ALLOW-ROOT-FOLDER-FLAG is non-nil then \"+\" is allowed to be a folder name corresponding to `mh-user-path'." (mh-normalize-folder-name - (let ((completion-root-regexp "^[+/]") ;FIXME: Who/what uses that? - (minibuffer-local-completion-map mh-folder-completion-map) + (let ((minibuffer-local-completion-map mh-folder-completion-map) (mh-allow-root-folder-flag allow-root-folder-flag)) (completing-read prompt 'mh-folder-completion-function nil nil nil 'mh-folder-hist default)) @@ -920,11 +930,7 @@ Handle RFC 822 (or later) continuation lines." (defvar mh-hidden-header-keymap (let ((map (make-sparse-keymap))) - (mh-do-in-gnu-emacs - (define-key map [mouse-2] #'mh-letter-toggle-header-field-display-button)) - (mh-do-in-xemacs - (define-key map '(button2) - #'mh-letter-toggle-header-field-display-button)) + (define-key map [mouse-2] #'mh-letter-toggle-header-field-display-button) map)) ;;;###mh-autoload @@ -958,9 +964,9 @@ is hidden, if positive then the field is displayed." (and (numberp arg) (>= arg 0)) (and (eq arg 'long) - (> (mh-line-beginning-position 5) end))) + (> (line-beginning-position 5) end))) (remove-text-properties begin end '(invisible nil)) - (search-forward ":" (mh-line-end-position) t) + (search-forward ":" (line-end-position) t) (mh-letter-skip-leading-whitespace-in-header-field)) ;; XXX Redesign to make usable by user. Perhaps use a positive ;; numeric prefix to make that many lines visible. diff --git a/lisp/mh-e/mh-xface.el b/lisp/mh-e/mh-xface.el index 58177c1794e..8350f3d0fbb 100644 --- a/lisp/mh-e/mh-xface.el +++ b/lisp/mh-e/mh-xface.el @@ -30,17 +30,11 @@ (autoload 'mail-header-parse-address "mail-parse") (autoload 'message-fetch-field "message") -(defvar mh-show-xface-function - (cond ((and (featurep 'xemacs) (locate-library "x-face") (not (featurep 'xface))) - (load "x-face" t t) - #'mh-face-display-function) - ((>= emacs-major-version 21) - #'mh-face-display-function) - (t #'ignore)) +(defvar mh-show-xface-function #'mh-face-display-function "Determine at run time what function should be called to display X-Face.") +(make-obsolete-variable 'mh-show-xface-function nil "29.1") -(defvar mh-uncompface-executable - (and (fboundp 'executable-find) (executable-find "uncompface"))) +(defvar mh-uncompface-executable (executable-find "uncompface")) @@ -52,7 +46,7 @@ (when (and window-system mh-show-use-xface-flag (or mh-decode-mime-flag mh-mhl-format-file mh-clean-message-header-flag)) - (funcall mh-show-xface-function))) + (mh-face-display-function))) (defun mh-face-display-function () "Display a Face, X-Face, or X-Image-URL header field. @@ -77,53 +71,20 @@ in this order is used." (when type (goto-char (point-min)) (when (re-search-forward "^from:" (point-max) t) - ;; GNU Emacs - (mh-do-in-gnu-emacs - (if (eq type 'url) - (mh-x-image-url-display url) - (mh-funcall-if-exists - insert-image (create-image - raw type t - :foreground - (mh-face-foreground 'mh-show-xface nil t) - :background - (mh-face-background 'mh-show-xface nil t)) - " "))) - ;; XEmacs - (mh-do-in-xemacs - (cond - ((eq type 'url) - (mh-x-image-url-display url)) - ((eq type 'png) - (when (featurep 'png) - (set-extent-begin-glyph - (make-extent (point) (point)) - (make-glyph (vector 'png ':data (mh-face-to-png face)))))) - ;; Try internal xface support if available... - ((and (eq type 'pbm) (featurep 'xface)) - (set-glyph-face - (set-extent-begin-glyph - (make-extent (point) (point)) - (make-glyph (vector 'xface ':data (concat "X-Face: " x-face)))) - 'mh-show-xface)) - ;; Otherwise try external support with x-face... - ((and (eq type 'pbm) - (fboundp 'x-face-xmas-wl-display-x-face) - (fboundp 'executable-find) (executable-find "uncompface")) - (mh-funcall-if-exists x-face-xmas-wl-display-x-face)) - ;; Picon display - ((and raw (member type '(xpm xbm gif))) - (when (featurep type) - (set-extent-begin-glyph - (make-extent (point) (point)) - (make-glyph (vector type ':data raw)))))) - (when raw (insert " ")))))))) + (if (eq type 'url) + (mh-x-image-url-display url) + (insert-image (create-image + raw type t + :foreground + (face-foreground 'mh-show-xface nil t) + :background + (face-background 'mh-show-xface nil t)) + " "))))))) (defun mh-face-to-png (data) "Convert base64 encoded DATA to png image." (with-temp-buffer - (if (fboundp 'set-buffer-multibyte) - (set-buffer-multibyte nil)) + (set-buffer-multibyte nil) (insert data) (ignore-errors (base64-decode-region (point-min) (point-max))) (buffer-string))) @@ -131,8 +92,7 @@ in this order is used." (defun mh-uncompface (data) "Run DATA through `uncompface' to generate bitmap." (with-temp-buffer - (if (fboundp 'set-buffer-multibyte) - (set-buffer-multibyte nil)) + (set-buffer-multibyte nil) (insert data) (when (and mh-uncompface-executable (equal (call-process-region (point-min) (point-max) @@ -176,10 +136,8 @@ The directories are searched for in the order they appear in the list.") (defvar mh-picon-image-types (cl-loop for type in '(xpm xbm gif) - when (or (mh-do-in-gnu-emacs - (ignore-errors - (mh-funcall-if-exists image-type-available-p type))) - (mh-do-in-xemacs (featurep type))) + when (ignore-errors + (image-type-available-p type)) collect type)) (autoload 'message-tokenize-header "sendmail") @@ -270,8 +228,7 @@ file contents as a string is returned. If FILE is nil, then both elements of the list are nil." (if (stringp file) (with-temp-buffer - (if (fboundp 'set-buffer-multibyte) - (set-buffer-multibyte nil)) + (set-buffer-multibyte nil) (let ((type (and (string-match ".*\\.\\(...\\)$" file) (intern (match-string 1 file))))) (insert-file-contents-literally file) @@ -321,7 +278,7 @@ If the URL isn't present in the cache then it is fetched with wget." (let* ((cache-filename (mh-x-image-url-cache-canonicalize url)) (state (mh-x-image-get-download-state cache-filename)) (marker (point-marker))) - (set (make-local-variable 'mh-x-image-marker) marker) + (setq-local mh-x-image-marker marker) (cond ((not (mh-x-image-url-sane-p url))) ((eq state 'ok) (mh-x-image-display cache-filename marker)) @@ -357,14 +314,14 @@ This is only done if `mh-x-image-cache-directory' is nil." (defun mh-x-image-url-cache-canonicalize (url) "Canonicalize URL. Replace the ?/ character with a ?! character and append .png. -Also replaces special characters with `mh-url-hexify-string' +Also replaces special characters with `url-hexify-string' since not all characters, such as :, are valid within Windows filenames. In addition, replaces * with %2a. See URL `https://msdn.microsoft.com/library/default.asp?url=/library/en-us/shellcc/platform/shell/reference/ifaces/iitemnamelimits/GetValidCharacters.asp'." (format "%s/%s.png" mh-x-image-cache-directory - (mh-replace-regexp-in-string + (replace-regexp-in-string "\\*" "%2a" - (mh-url-hexify-string + (url-hexify-string (with-temp-buffer (insert url) (mh-replace-string "/" "!") @@ -404,16 +361,7 @@ filenames. In addition, replaces * with %2a. See URL (when (and (file-readable-p image) (not (file-symlink-p image)) (eq marker mh-x-image-marker)) (goto-char marker) - (mh-do-in-gnu-emacs - (mh-funcall-if-exists insert-image (create-image image 'png))) - (mh-do-in-xemacs - (when (featurep 'png) - (set-extent-begin-glyph - (make-extent (point) (point)) - (make-glyph - (vector 'png ':data (with-temp-buffer - (insert-file-contents-literally image) - (buffer-string)))))))) + (insert-image (create-image image 'png))) (set-buffer-modified-p buffer-modified-flag))))) (defun mh-x-image-url-fetch-image (url cache-file marker sentinel) @@ -423,12 +371,11 @@ be displayed in a buffer and position specified by MARKER. The actual display is carried out by the SENTINEL function." (if mh-wget-executable (let ((buffer (generate-new-buffer mh-temp-fetch-buffer)) - (filename (or (mh-funcall-if-exists make-temp-file "mhe-fetch") - (expand-file-name (make-temp-name "~/mhe-fetch"))))) + (filename (make-temp-file "mhe-fetch"))) (with-current-buffer buffer - (set (make-local-variable 'mh-x-image-url-cache-file) cache-file) - (set (make-local-variable 'mh-x-image-marker) marker) - (set (make-local-variable 'mh-x-image-temp-file) filename)) + (setq-local mh-x-image-url-cache-file cache-file) + (setq-local mh-x-image-marker marker) + (setq-local mh-x-image-temp-file filename)) (set-process-sentinel (start-process "*mh-x-image-url-fetch*" buffer mh-wget-executable mh-wget-option filename url) diff --git a/lisp/midnight.el b/lisp/midnight.el index b3adbf00172..51173e7429f 100644 --- a/lisp/midnight.el +++ b/lisp/midnight.el @@ -159,7 +159,7 @@ the current date/time, buffer name, how many seconds ago it was displayed (can be nil if the buffer was never displayed) and its lifetime, i.e., its \"age\" when it will be purged." (interactive) - (let ((tm (current-time)) bts (ts (format-time-string "%Y-%m-%d %T")) + (let* ((tm (current-time)) bts (ts (format-time-string "%Y-%m-%d %T" tm)) delay cbld bn) (dolist (buf (buffer-list)) (when (buffer-live-p buf) diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 21d610fdf44..b1e8e154261 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -1,4 +1,4 @@ -;;; minibuffer.el --- Minibuffer completion functions -*- lexical-binding: t -*- +;;; minibuffer.el --- Minibuffer and completion functions -*- lexical-binding: t -*- ;; Copyright (C) 2008-2021 Free Software Foundation, Inc. @@ -1379,14 +1379,18 @@ scroll the window of possible completions." ;; and this command is repeated, scroll that window. ((and (window-live-p minibuffer-scroll-window) (eq t (frame-visible-p (window-frame minibuffer-scroll-window)))) - (let ((window minibuffer-scroll-window)) + (let ((window minibuffer-scroll-window) + (reverse (equal (this-command-keys) [backtab]))) (with-current-buffer (window-buffer window) - (if (pos-visible-in-window-p (point-max) window) - ;; If end is in view, scroll up to the beginning. - (set-window-start window (point-min) nil) + (if (pos-visible-in-window-p (if reverse (point-min) (point-max)) window) + ;; If end or beginning is in view, scroll up to the + ;; beginning or end respectively. + (if reverse + (set-window-point window (point-max)) + (set-window-start window (point-min) nil)) ;; Else scroll down one screen. (with-selected-window window - (scroll-up))) + (if reverse (scroll-down) (scroll-up)))) nil))) ;; If we're cycling, keep on cycling. ((and completion-cycling completion-all-sorted-completions) @@ -2444,14 +2448,12 @@ Also respects the obsolete wrapper hook `completion-in-region-functions'. (completion-in-region-mode 1)) (completion--in-region-1 start end)))) -(defvar completion-in-region-mode-map - (let ((map (make-sparse-keymap))) - ;; FIXME: Only works if completion-in-region-mode was activated via - ;; completion-at-point called directly. - (define-key map "\M-?" 'completion-help-at-point) - (define-key map "\t" 'completion-at-point) - map) - "Keymap activated during `completion-in-region'.") +(defvar-keymap completion-in-region-mode-map + :doc "Keymap activated during `completion-in-region'." + ;; FIXME: Only works if completion-in-region-mode was activated via + ;; completion-at-point called directly. + "M-?" #'completion-help-at-point + "TAB" #'completion-at-point) ;; It is difficult to know when to exit completion-in-region-mode (i.e. hide ;; the *Completions*). Here's how previous packages did it: @@ -2647,48 +2649,41 @@ The completion method is determined by `completion-at-point-functions'." (define-key map "\n" 'exit-minibuffer) (define-key map "\r" 'exit-minibuffer)) -(defvar minibuffer-local-completion-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map minibuffer-local-map) - (define-key map "\t" 'minibuffer-complete) - ;; M-TAB is already abused for many other purposes, so we should find - ;; another binding for it. - ;; (define-key map "\e\t" 'minibuffer-force-complete) - (define-key map " " 'minibuffer-complete-word) - (define-key map "?" 'minibuffer-completion-help) - (define-key map [prior] 'switch-to-completions) - (define-key map "\M-v" 'switch-to-completions) - (define-key map "\M-g\M-c" 'switch-to-completions) - map) - "Local keymap for minibuffer input with completion.") - -(defvar minibuffer-local-must-match-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map minibuffer-local-completion-map) - (define-key map "\r" 'minibuffer-complete-and-exit) - (define-key map "\n" 'minibuffer-complete-and-exit) - map) - "Local keymap for minibuffer input with completion, for exact match.") - -(defvar minibuffer-local-filename-completion-map - (let ((map (make-sparse-keymap))) - (define-key map " " nil) - map) - "Local keymap for minibuffer input with completion for filenames. +(defvar-keymap minibuffer-local-completion-map + :doc "Local keymap for minibuffer input with completion." + :parent minibuffer-local-map + "TAB" #'minibuffer-complete + "<backtab>" #'minibuffer-complete + ;; M-TAB is already abused for many other purposes, so we should find + ;; another binding for it. + ;; "M-TAB" #'minibuffer-force-complete + "SPC" #'minibuffer-complete-word + "?" #'minibuffer-completion-help + "<prior>" #'switch-to-completions + "M-v" #'switch-to-completions + "M-g M-c" #'switch-to-completions) + +(defvar-keymap minibuffer-local-must-match-map + :doc "Local keymap for minibuffer input with completion, for exact match." + :parent minibuffer-local-completion-map + "RET" #'minibuffer-complete-and-exit + "C-j" #'minibuffer-complete-and-exit) + +(defvar-keymap minibuffer-local-filename-completion-map + :doc "Local keymap for minibuffer input with completion for filenames. Gets combined either with `minibuffer-local-completion-map' or -with `minibuffer-local-must-match-map'.") +with `minibuffer-local-must-match-map'." + "SPC" nil) (defvar minibuffer-local-filename-must-match-map (make-sparse-keymap)) (make-obsolete-variable 'minibuffer-local-filename-must-match-map nil "24.1") -(defvar minibuffer-local-ns-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map minibuffer-local-map) - (define-key map " " #'exit-minibuffer) - (define-key map "\t" #'exit-minibuffer) - (define-key map "?" #'self-insert-and-exit) - map) - "Local keymap for the minibuffer when spaces are not allowed.") +(defvar-keymap minibuffer-local-ns-map + :doc "Local keymap for the minibuffer when spaces are not allowed." + :parent minibuffer-local-map + "SPC" #'exit-minibuffer + "TAB" #'exit-minibuffer + "?" #'self-insert-and-exit) (defun read-no-blanks-input (prompt &optional initial inherit-input-method) "Read a string from the terminal, not allowing blanks. @@ -2709,24 +2704,23 @@ If `inhibit-interaction' is non-nil, this function will signal an ;;; Major modes for the minibuffer -(defvar minibuffer-inactive-mode-map - (let ((map (make-keymap))) - (suppress-keymap map) - (define-key map "e" 'find-file-other-frame) - (define-key map "f" 'find-file-other-frame) - (define-key map "b" 'switch-to-buffer-other-frame) - (define-key map "i" 'info) - (define-key map "m" 'mail) - (define-key map "n" 'make-frame) - (define-key map [mouse-1] 'view-echo-area-messages) - ;; So the global down-mouse-1 binding doesn't clutter the execution of the - ;; above mouse-1 binding. - (define-key map [down-mouse-1] #'ignore) - map) - "Keymap for use in the minibuffer when it is not active. +(defvar-keymap minibuffer-inactive-mode-map + :doc "Keymap for use in the minibuffer when it is not active. The non-mouse bindings in this keymap can only be used in minibuffer-only frames, since the minibuffer can normally not be selected when it is -not active.") +not active." + :full t + :suppress t + "e" #'find-file-other-frame + "f" #'find-file-other-frame + "b" #'switch-to-buffer-other-frame + "i" #'info + "m" #'mail + "n" #'make-frame + "<mouse-1>" #'view-echo-area-messages + ;; So the global down-mouse-1 binding doesn't clutter the execution of the + ;; above mouse-1 binding. + "<down-mouse-1>" #'ignore) (define-derived-mode minibuffer-inactive-mode nil "InactiveMinibuffer" :abbrev-table nil ;abbrev.el is not loaded yet during dump. @@ -2735,7 +2729,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.el b/lisp/mouse.el index 8474a821118..11fdd3f6391 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -184,8 +184,8 @@ items `Turn Off' and `Help'." "-" " " (format "%S" minor-mode)))) (turn-off menu-item "Turn off minor mode" ,mm-fun) (help menu-item "Help for minor mode" - (lambda () (interactive) - (describe-function ',mm-fun))))))) + ,(lambda () (interactive) + (describe-function mm-fun))))))) (if menu (popup-menu menu) (message "No menu available"))))) @@ -271,7 +271,7 @@ not it is actually displayed." ;; FIXME: We have a problem here: we have to use the global/local/minor ;; so they're displayed in the expected order, but later on in the command ;; loop, they're actually looked up in the opposite order. - (apply 'append + (apply #'append global-menu local-menu minor-mode-menus))) @@ -327,13 +327,23 @@ the function `context-menu-filter-function'." (setq menu (funcall fun menu click)) nil))) - ;; Remove duplicate separators - (let ((l menu)) - (while (consp l) - (when (and (equal (cdr-safe (car l)) menu-bar-separator) - (equal (cdr-safe (cadr l)) menu-bar-separator)) - (setcdr l (cddr l))) - (setq l (cdr l)))) + ;; Remove duplicate separators as well as ones at the beginning or + ;; end of the menu. + (let ((l menu) saw-first-item) + (while (and (consp l) + (consp (cdr l))) + ;; If the next item is a separator, remove it if 1) we haven't + ;; seen any other items yet, or 2) it's followed by either + ;; another separator or the end of the list. + (if (and (equal (cdr-safe (cadr l)) menu-bar-separator) + (or (not saw-first-item) + (null (caddr l)) + (equal (cdr-safe (caddr l)) menu-bar-separator))) + (setcdr l (cddr l)) + ;; The "first item" is any cons cell; this excludes the + ;; `keymap' symbol and the menu name. + (when (consp (cadr l)) (setq saw-first-item t)) + (setq l (cdr l))))) (when (functionp context-menu-filter-function) (setq menu (funcall context-menu-filter-function menu click))) @@ -514,8 +524,8 @@ Some context functions add menu items below the separator." menu) (defvar context-menu-entry - `(menu-item ,(purecopy "Context Menu") ignore - :filter (lambda (_) (context-menu-map))) + `(menu-item ,(purecopy "Context Menu") ,(make-sparse-keymap) + :filter ,(lambda (_) (context-menu-map))) "Menu item that creates the context menu and can be bound to a mouse key.") (defvar context-menu-mode-map @@ -536,7 +546,7 @@ Some context functions add menu items below the separator." When Context Menu mode is enabled, clicking the mouse button down-mouse-3 activates the menu whose contents depends on its surrounding context." - :global t :group 'mouse) + :global t) (defun context-menu-open () "Start key navigation of the context menu. @@ -548,7 +558,7 @@ This is the keyboard interface to \\[context-menu-map]." (call-interactively map) (popup-menu map (point))))) -(global-set-key [S-f10] 'context-menu-open) +(global-set-key [S-f10] #'context-menu-open) (defun mark-thing-at-mouse (click thing) "Activate the region around THING found near the mouse CLICK." @@ -603,7 +613,7 @@ This command must be bound to a mouse click." (or (eq frame oframe) (set-mouse-position (selected-frame) (1- (frame-width)) 0)))) -(define-obsolete-function-alias 'mouse-tear-off-window 'tear-off-window "24.4") +(define-obsolete-function-alias 'mouse-tear-off-window #'tear-off-window "24.4") (defun tear-off-window (click) "Delete the selected window, and create a new frame displaying its buffer." (interactive (list last-nonmenu-event)) @@ -679,7 +689,6 @@ must be one of the symbols `header', `mode', or `vertical'." ;; previously sampled position. The difference of `position' ;; and `last-position' determines the size change of WINDOW. (last-position position) - (draggable t) posn-window growth dragged) ;; Decide on whether we are allowed to track at all and whose ;; window's edge we drag. @@ -732,7 +741,7 @@ must be one of the symbols `header', `mode', or `vertical'." (setq dragged t) (adjust-window-trailing-edge window growth t t)) (setq last-position position)) - (draggable + (t ;; Drag bottom edge of `window'. (setq start (event-start event)) ;; Set `posn-window' to the window where `event' was recorded. @@ -1573,8 +1582,7 @@ The region will be defined with mark and point." (mouse-minibuffer-check start-event) (setq mouse-selection-click-count-buffer (current-buffer)) (deactivate-mark) - (let* ((scroll-margin 0) ; Avoid margin scrolling (Bug#9541). - (start-posn (event-start start-event)) + (let* ((start-posn (event-start start-event)) (start-point (posn-point start-posn)) (start-window (posn-window start-posn)) (_ (with-current-buffer (window-buffer start-window) @@ -1596,76 +1604,88 @@ The region will be defined with mark and point." ;; Don't count the mode line. (1- (nth 3 bounds)))) (click-count (1- (event-click-count start-event))) - ;; Suppress automatic hscrolling, because that is a nuisance - ;; when setting point near the right fringe (but see below). + ;; Save original automatic scrolling behavior (see below). (auto-hscroll-mode-saved auto-hscroll-mode) - (old-track-mouse track-mouse)) + (scroll-margin-saved scroll-margin) + (old-track-mouse track-mouse) + (cleanup (lambda () + (setq track-mouse old-track-mouse) + (setq auto-hscroll-mode auto-hscroll-mode-saved) + (setq scroll-margin scroll-margin-saved)))) + (condition-case err + (progn + (setq mouse-selection-click-count click-count) + + ;; Suppress automatic scrolling near the edges while tracking + ;; movement, as it interferes with the natural dragging behavior + ;; (point will unexpectedly be moved beneath the pointer, making + ;; selections in auto-scrolling margins impossible). + (setq auto-hscroll-mode nil) + (setq scroll-margin 0) + + ;; In case the down click is in the middle of some intangible text, + ;; use the end of that text, and put it in START-POINT. + (if (< (point) start-point) + (goto-char start-point)) + (setq start-point (point)) + + ;; Activate the region, using `mouse-start-end' to determine where + ;; to put point and mark (e.g., double-click will select a word). + (setq-local transient-mark-mode + (if (eq transient-mark-mode 'lambda) + '(only) + (cons 'only transient-mark-mode))) + (let ((range (mouse-start-end start-point start-point click-count))) + (push-mark (nth 0 range) t t) + (goto-char (nth 1 range))) - (setq mouse-selection-click-count click-count) - ;; In case the down click is in the middle of some intangible text, - ;; use the end of that text, and put it in START-POINT. - (if (< (point) start-point) - (goto-char start-point)) - (setq start-point (point)) + (setf (terminal-parameter nil 'mouse-drag-start) start-event) + ;; 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) - ;; Activate the region, using `mouse-start-end' to determine where - ;; to put point and mark (e.g., double-click will select a word). - (setq-local transient-mark-mode - (if (eq transient-mark-mode 'lambda) - '(only) - (cons 'only transient-mark-mode))) - (let ((range (mouse-start-end start-point start-point click-count))) - (push-mark (nth 0 range) t t) - (goto-char (nth 1 range))) - - (setf (terminal-parameter nil 'mouse-drag-start) start-event) - ;; 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) - (setq auto-hscroll-mode nil) - - (set-transient-map - (let ((map (make-sparse-keymap))) - (define-key map [switch-frame] #'ignore) - (define-key map [select-window] #'ignore) - (define-key map [mouse-movement] - (lambda (event) (interactive "e") - (let* ((end (event-end event)) - (end-point (posn-point end))) - (unless (eq end-point start-point) - ;; As soon as the user moves, we can re-enable auto-hscroll. - (setq auto-hscroll-mode auto-hscroll-mode-saved) - ;; And remember that we have moved, so mouse-set-region can know - ;; its event is really a drag event. - (setcar start-event 'mouse-movement)) - (if (and (eq (posn-window end) start-window) - (integer-or-marker-p end-point)) - (mouse--drag-set-mark-and-point start-point - end-point click-count) - (let ((mouse-row (cdr (cdr (mouse-position))))) - (cond - ((null mouse-row)) - ((< mouse-row top) - (mouse-scroll-subr start-window (- mouse-row top) - nil start-point)) - ((>= mouse-row bottom) - (mouse-scroll-subr start-window (1+ (- mouse-row bottom)) - nil start-point)))))))) - map) - t (lambda () - (setq track-mouse old-track-mouse) - (setq auto-hscroll-mode auto-hscroll-mode-saved) - ;; Don't deactivate the mark when the context menu was invoked - ;; by down-mouse-3 immediately after down-mouse-1 and without - ;; releasing the mouse button with mouse-1. This allows to use - ;; region-related context menu to operate on the selected region. - (unless (and context-menu-mode - (eq (car-safe (aref (this-command-keys-vector) 0)) - 'down-mouse-3)) - (deactivate-mark) - (pop-mark)))))) + (set-transient-map + (let ((map (make-sparse-keymap))) + (define-key map [switch-frame] #'ignore) + (define-key map [select-window] #'ignore) + (define-key map [mouse-movement] + (lambda (event) (interactive "e") + (let* ((end (event-end event)) + (end-point (posn-point end))) + (unless (eq end-point start-point) + ;; And remember that we have moved, so mouse-set-region can know + ;; its event is really a drag event. + (setcar start-event 'mouse-movement)) + (if (and (eq (posn-window end) start-window) + (integer-or-marker-p end-point)) + (mouse--drag-set-mark-and-point start-point + end-point click-count) + (let ((mouse-row (cdr (cdr (mouse-position))))) + (cond + ((null mouse-row)) + ((< mouse-row top) + (mouse-scroll-subr start-window (- mouse-row top) + nil start-point)) + ((>= mouse-row bottom) + (mouse-scroll-subr start-window (1+ (- mouse-row bottom)) + nil start-point)))))))) + map) + t (lambda () + (funcall cleanup) + ;; Don't deactivate the mark when the context menu was invoked + ;; by down-mouse-3 immediately after down-mouse-1 and without + ;; releasing the mouse button with mouse-1. This allows to use + ;; region-related context menu to operate on the selected region. + (unless (and context-menu-mode + (eq (car-safe (aref (this-command-keys-vector) 0)) + 'down-mouse-3)) + (deactivate-mark) + (pop-mark))))) + ;; Cleanup on errors + (error (funcall cleanup) + (signal (car err) (cdr err)))))) (defun mouse--drag-set-mark-and-point (start click click-count) (let* ((range (mouse-start-end start click click-count)) @@ -1821,7 +1841,7 @@ If MODE is 2 then do the same for lines." event))) (setcar last new) (if (and (not (equal modifiers old-modifiers)) - (key-binding (apply 'vector events))) + (key-binding (apply #'vector events))) t (setcar last event) nil))) @@ -1875,12 +1895,12 @@ regardless of where you click." (setq mouse-selection-click-count 0) (yank arg)) -(defun mouse-yank-primary (click) - "Insert the primary selection at the position clicked on. +(defun mouse-yank-primary (&optional event) + "Insert the primary selection, Move point to the end of the inserted text, and set mark at beginning. If `mouse-yank-at-point' is non-nil, insert at point -regardless of where you click." - (interactive "e") +otherwise insert it at the position of EVENT." + (interactive (list last-nonmenu-event)) ;; Give temporary modes such as isearch a chance to turn off. (run-hooks 'mouse-leave-buffer-hook) ;; Without this, confusing things happen upon e.g. inserting into @@ -1888,7 +1908,7 @@ regardless of where you click." (when select-active-regions (let (select-active-regions) (deactivate-mark))) - (or mouse-yank-at-point (mouse-set-point click)) + (or mouse-yank-at-point (mouse-set-point event)) (let ((primary (gui-get-primary-selection))) (push-mark) (insert-for-yank primary))) @@ -2028,11 +2048,11 @@ if `mouse-drag-copy-region' is non-nil)." (setq mouse-save-then-kill-posn click-pt))))) -(global-set-key [M-mouse-1] 'mouse-start-secondary) -(global-set-key [M-drag-mouse-1] 'mouse-set-secondary) -(global-set-key [M-down-mouse-1] 'mouse-drag-secondary) -(global-set-key [M-mouse-3] 'mouse-secondary-save-then-kill) -(global-set-key [M-mouse-2] 'mouse-yank-secondary) +(global-set-key [M-mouse-1] #'mouse-start-secondary) +(global-set-key [M-drag-mouse-1] #'mouse-set-secondary) +(global-set-key [M-down-mouse-1] #'mouse-drag-secondary) +(global-set-key [M-mouse-3] #'mouse-secondary-save-then-kill) +(global-set-key [M-mouse-2] #'mouse-yank-secondary) (defconst mouse-secondary-overlay (let ((ol (make-overlay (point-min) (point-min)))) @@ -3192,78 +3212,78 @@ is copied instead of being cut." ;;; Bindings for mouse commands. -(global-set-key [down-mouse-1] 'mouse-drag-region) -(global-set-key [mouse-1] 'mouse-set-point) -(global-set-key [drag-mouse-1] 'mouse-set-region) +(global-set-key [down-mouse-1] #'mouse-drag-region) +(global-set-key [mouse-1] #'mouse-set-point) +(global-set-key [drag-mouse-1] #'mouse-set-region) (defun mouse--strip-first-event (_prompt) (substring (this-single-command-raw-keys) 1)) -(define-key function-key-map [left-fringe mouse-1] 'mouse--strip-first-event) -(define-key function-key-map [right-fringe mouse-1] 'mouse--strip-first-event) +(define-key function-key-map [left-fringe mouse-1] #'mouse--strip-first-event) +(define-key function-key-map [right-fringe mouse-1] #'mouse--strip-first-event) -(global-set-key [mouse-2] 'mouse-yank-primary) +(global-set-key [mouse-2] #'mouse-yank-primary) ;; Allow yanking also when the corresponding cursor is "in the fringe". -(define-key function-key-map [right-fringe mouse-2] 'mouse--strip-first-event) -(define-key function-key-map [left-fringe mouse-2] 'mouse--strip-first-event) -(global-set-key [mouse-3] 'mouse-save-then-kill) -(define-key function-key-map [right-fringe mouse-3] 'mouse--strip-first-event) -(define-key function-key-map [left-fringe mouse-3] 'mouse--strip-first-event) +(define-key function-key-map [right-fringe mouse-2] #'mouse--strip-first-event) +(define-key function-key-map [left-fringe mouse-2] #'mouse--strip-first-event) +(global-set-key [mouse-3] #'mouse-save-then-kill) +(define-key function-key-map [right-fringe mouse-3] #'mouse--strip-first-event) +(define-key function-key-map [left-fringe mouse-3] #'mouse--strip-first-event) ;; By binding these to down-going events, we let the user use the up-going ;; event to make the selection, saving a click. -(global-set-key [C-down-mouse-1] 'mouse-buffer-menu) +(global-set-key [C-down-mouse-1] #'mouse-buffer-menu) (if (not (eq system-type 'ms-dos)) - (global-set-key [S-down-mouse-1] 'mouse-appearance-menu)) + (global-set-key [S-down-mouse-1] #'mouse-appearance-menu)) ;; C-down-mouse-2 is bound in facemenu.el. (global-set-key [C-down-mouse-3] `(menu-item ,(purecopy "Menu Bar") ignore - :filter (lambda (_) - (if (zerop (or (frame-parameter nil 'menu-bar-lines) 0)) - (mouse-menu-bar-map) - (mouse-menu-major-mode-map))))) + :filter ,(lambda (_) + (if (zerop (or (frame-parameter nil 'menu-bar-lines) 0)) + (mouse-menu-bar-map) + (mouse-menu-major-mode-map))))) ;; Binding mouse-1 to mouse-select-window when on mode-, header-, or ;; vertical-line prevents Emacs from signaling an error when the mouse ;; button is released after dragging these lines, on non-toolkit ;; versions. -(global-set-key [header-line down-mouse-1] 'mouse-drag-header-line) -(global-set-key [header-line mouse-1] 'mouse-select-window) -(global-set-key [tab-line down-mouse-1] 'mouse-drag-tab-line) -(global-set-key [tab-line mouse-1] 'mouse-select-window) +(global-set-key [header-line down-mouse-1] #'mouse-drag-header-line) +(global-set-key [header-line mouse-1] #'mouse-select-window) +(global-set-key [tab-line down-mouse-1] #'mouse-drag-tab-line) +(global-set-key [tab-line mouse-1] #'mouse-select-window) ;; (global-set-key [mode-line drag-mouse-1] 'mouse-select-window) -(global-set-key [mode-line down-mouse-1] 'mouse-drag-mode-line) -(global-set-key [mode-line mouse-1] 'mouse-select-window) -(global-set-key [mode-line mouse-2] 'mouse-delete-other-windows) -(global-set-key [mode-line mouse-3] 'mouse-delete-window) -(global-set-key [mode-line C-mouse-2] 'mouse-split-window-horizontally) -(global-set-key [vertical-scroll-bar C-mouse-2] 'mouse-split-window-vertically) -(global-set-key [horizontal-scroll-bar C-mouse-2] 'mouse-split-window-horizontally) -(global-set-key [vertical-line down-mouse-1] 'mouse-drag-vertical-line) -(global-set-key [vertical-line mouse-1] 'mouse-select-window) -(global-set-key [vertical-line C-mouse-2] 'mouse-split-window-vertically) -(global-set-key [right-divider down-mouse-1] 'mouse-drag-vertical-line) -(global-set-key [right-divider mouse-1] 'ignore) -(global-set-key [right-divider C-mouse-2] 'mouse-split-window-vertically) -(global-set-key [bottom-divider down-mouse-1] 'mouse-drag-mode-line) -(global-set-key [bottom-divider mouse-1] 'ignore) -(global-set-key [bottom-divider C-mouse-2] 'mouse-split-window-horizontally) -(global-set-key [left-edge down-mouse-1] 'mouse-drag-left-edge) -(global-set-key [left-edge mouse-1] 'ignore) -(global-set-key [top-left-corner down-mouse-1] 'mouse-drag-top-left-corner) -(global-set-key [top-left-corner mouse-1] 'ignore) -(global-set-key [top-edge down-mouse-1] 'mouse-drag-top-edge) -(global-set-key [top-edge mouse-1] 'ignore) -(global-set-key [top-right-corner down-mouse-1] 'mouse-drag-top-right-corner) -(global-set-key [top-right-corner mouse-1] 'ignore) -(global-set-key [right-edge down-mouse-1] 'mouse-drag-right-edge) -(global-set-key [right-edge mouse-1] 'ignore) -(global-set-key [bottom-right-corner down-mouse-1] 'mouse-drag-bottom-right-corner) -(global-set-key [bottom-right-corner mouse-1] 'ignore) -(global-set-key [bottom-edge down-mouse-1] 'mouse-drag-bottom-edge) -(global-set-key [bottom-edge mouse-1] 'ignore) -(global-set-key [bottom-left-corner down-mouse-1] 'mouse-drag-bottom-left-corner) -(global-set-key [bottom-left-corner mouse-1] 'ignore) +(global-set-key [mode-line down-mouse-1] #'mouse-drag-mode-line) +(global-set-key [mode-line mouse-1] #'mouse-select-window) +(global-set-key [mode-line mouse-2] #'mouse-delete-other-windows) +(global-set-key [mode-line mouse-3] #'mouse-delete-window) +(global-set-key [mode-line C-mouse-2] #'mouse-split-window-horizontally) +(global-set-key [vertical-scroll-bar C-mouse-2] #'mouse-split-window-vertically) +(global-set-key [horizontal-scroll-bar C-mouse-2] #'mouse-split-window-horizontally) +(global-set-key [vertical-line down-mouse-1] #'mouse-drag-vertical-line) +(global-set-key [vertical-line mouse-1] #'mouse-select-window) +(global-set-key [vertical-line C-mouse-2] #'mouse-split-window-vertically) +(global-set-key [right-divider down-mouse-1] #'mouse-drag-vertical-line) +(global-set-key [right-divider mouse-1] #'ignore) +(global-set-key [right-divider C-mouse-2] #'mouse-split-window-vertically) +(global-set-key [bottom-divider down-mouse-1] #'mouse-drag-mode-line) +(global-set-key [bottom-divider mouse-1] #'ignore) +(global-set-key [bottom-divider C-mouse-2] #'mouse-split-window-horizontally) +(global-set-key [left-edge down-mouse-1] #'mouse-drag-left-edge) +(global-set-key [left-edge mouse-1] #'ignore) +(global-set-key [top-left-corner down-mouse-1] #'mouse-drag-top-left-corner) +(global-set-key [top-left-corner mouse-1] #'ignore) +(global-set-key [top-edge down-mouse-1] #'mouse-drag-top-edge) +(global-set-key [top-edge mouse-1] #'ignore) +(global-set-key [top-right-corner down-mouse-1] #'mouse-drag-top-right-corner) +(global-set-key [top-right-corner mouse-1] #'ignore) +(global-set-key [right-edge down-mouse-1] #'mouse-drag-right-edge) +(global-set-key [right-edge mouse-1] #'ignore) +(global-set-key [bottom-right-corner down-mouse-1] #'mouse-drag-bottom-right-corner) +(global-set-key [bottom-right-corner mouse-1] #'ignore) +(global-set-key [bottom-edge down-mouse-1] #'mouse-drag-bottom-edge) +(global-set-key [bottom-edge mouse-1] #'ignore) +(global-set-key [bottom-left-corner down-mouse-1] #'mouse-drag-bottom-left-corner) +(global-set-key [bottom-left-corner mouse-1] #'ignore) (provide 'mouse) diff --git a/lisp/mwheel.el b/lisp/mwheel.el index 51410e3ef4c..fbe8daa77f8 100644 --- a/lisp/mwheel.el +++ b/lisp/mwheel.el @@ -55,7 +55,8 @@ (mouse-wheel-mode 1))) (defcustom mouse-wheel-down-event - (if (or (featurep 'w32-win) (featurep 'ns-win)) + (if (or (featurep 'w32-win) (featurep 'ns-win) + (featurep 'haiku-win) (featurep 'pgtk-win)) 'wheel-up 'mouse-4) "Event used for scrolling down." @@ -63,8 +64,20 @@ :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 - (if (or (featurep 'w32-win) (featurep 'ns-win)) + (if (or (featurep 'w32-win) (featurep 'ns-win) + (featurep 'haiku-win) (featurep 'pgtk-win)) 'wheel-down 'mouse-5) "Event used for scrolling up." @@ -72,6 +85,17 @@ :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 @@ -221,17 +245,33 @@ Also see `mouse-wheel-tilt-scroll'." "Function that does the job of scrolling right.") (defvar mouse-wheel-left-event - (if (or (featurep 'w32-win) (featurep 'ns-win)) + (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-6)) + "Alternative wheel left event to consider.") + (defvar mouse-wheel-right-event - (if (or (featurep 'w32-win) (featurep 'ns-win)) + (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 @@ -296,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) (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)) - ((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. @@ -318,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) (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)) - ((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 @@ -378,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 ((eq button mouse-wheel-down-event) + (cond ((memq button (list mouse-wheel-down-event + mouse-wheel-down-alternate-event)) (text-scale-increase 1)) - ((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)))) @@ -432,15 +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 (list 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 (list 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))))))) + 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/ange-ftp.el b/lisp/net/ange-ftp.el index 2585833e1d4..a6c256eeba8 100644 --- a/lisp/net/ange-ftp.el +++ b/lisp/net/ange-ftp.el @@ -1230,8 +1230,9 @@ only return the directory part of FILE." ;; found another machine with the same user. ;; Try that account. (read-passwd - (format "passwd for %s@%s (default same as %s@%s): " - user host user other) + (format-prompt "passwd for %s@%s" + (format "same as %s@%s" user other) + user host) nil (ange-ftp-lookup-passwd other user)) diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 4ae56864c55..9a41f018f28 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 GNOME Web (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 "GNOME Web (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" @@ -219,7 +221,7 @@ be used instead." (defcustom browse-url-button-regexp (concat - "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|" + "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|gemini\\|" "nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)" "\\(//[-a-z0-9_.]+:[0-9]*\\)?" (let ((chars "-a-z0-9_=#$@~%&*+\\/[:word:]") @@ -238,33 +240,6 @@ be used instead." :version "27.1" :type 'regexp) -(defcustom browse-url-netscape-program "netscape" - ;; Info about netscape-remote from Karl Berry. - "The name by which to invoke Netscape. - -The free program `netscape-remote' from -<URL:http://home.netscape.com/newsref/std/remote.c> is said to start -up very much quicker than `netscape'. Reported to compile on a GNU -system, given vroot.h from the same directory, with cc flags - -DSTANDALONE -L/usr/X11R6/lib -lXmu -lX11." - :type 'string) - -(make-obsolete-variable 'browse-url-netscape-program nil "25.1") - -(defcustom browse-url-netscape-arguments nil - "A list of strings to pass to Netscape as arguments." - :type '(repeat (string :tag "Argument"))) - -(make-obsolete-variable 'browse-url-netscape-arguments nil "25.1") - -(defcustom browse-url-netscape-startup-arguments browse-url-netscape-arguments - "A list of strings to pass to Netscape when it starts up. -Defaults to the value of `browse-url-netscape-arguments' at the time -`browse-url' is loaded." - :type '(repeat (string :tag "Argument"))) - -(make-obsolete-variable 'browse-url-netscape-startup-arguments nil "25.1") - (defcustom browse-url-browser-display nil "The X display for running the browser, if not same as Emacs's." :type '(choice string (const :tag "Default" nil))) @@ -283,11 +258,13 @@ Defaults to the value of `browse-url-mozilla-arguments' at the time `browse-url' is loaded." :type '(repeat (string :tag "Argument"))) +(defun browse-url--find-executable (candidates default) + (while (and candidates (not (executable-find (car candidates)))) + (setq candidates (cdr candidates))) + (or (car candidates) default)) + (defcustom browse-url-firefox-program - (let ((candidates '("icecat" "iceweasel" "firefox"))) - (while (and candidates (not (executable-find (car candidates)))) - (setq candidates (cdr candidates))) - (or (car candidates) "firefox")) + (browse-url--find-executable '("icecat" "iceweasel") "firefox") "The name by which to invoke Firefox or a variant of it." :type 'string) @@ -305,10 +282,8 @@ Defaults to the value of `browse-url-firefox-arguments' at the time "it no longer has any effect." "24.5") (defcustom browse-url-chrome-program - (let ((candidates '("google-chrome-stable" "google-chrome"))) - (while (and candidates (not (executable-find (car candidates)))) - (setq candidates (cdr candidates))) - (or (car candidates) "chromium")) + (browse-url--find-executable '("google-chrome-stable" "google-chrome") + "chromium") "The name by which to invoke the Chrome browser." :type 'string :version "25.1") @@ -319,10 +294,7 @@ Defaults to the value of `browse-url-firefox-arguments' at the time :version "25.1") (defcustom browse-url-chromium-program - (let ((candidates '("chromium" "chromium-browser"))) - (while (and candidates (not (executable-find (car candidates)))) - (setq candidates (cdr candidates))) - (or (car candidates) "chromium")) + (browse-url--find-executable '("chromium" "chromium-browser") "chromium") "The name by which to invoke Chromium." :type 'string :version "24.1") @@ -332,26 +304,6 @@ Defaults to the value of `browse-url-firefox-arguments' at the time :type '(repeat (string :tag "Argument")) :version "24.1") -(defcustom browse-url-galeon-program "galeon" - "The name by which to invoke Galeon." - :type 'string) - -(make-obsolete-variable 'browse-url-galeon-program nil "25.1") - -(defcustom browse-url-galeon-arguments nil - "A list of strings to pass to Galeon as arguments." - :type '(repeat (string :tag "Argument"))) - -(make-obsolete-variable 'browse-url-galeon-arguments nil "25.1") - -(defcustom browse-url-galeon-startup-arguments browse-url-galeon-arguments - "A list of strings to pass to Galeon when it starts up. -Defaults to the value of `browse-url-galeon-arguments' at the time -`browse-url' is loaded." - :type '(repeat (string :tag "Argument"))) - -(make-obsolete-variable 'browse-url-galeon-startup-arguments nil "25.1") - (defcustom browse-url-epiphany-program "epiphany" "The name by which to invoke GNOME Web (Epiphany)." :type 'string) @@ -366,7 +318,12 @@ Defaults to the value of `browse-url-epiphany-arguments' at the time `browse-url' is loaded." :type '(repeat (string :tag "Argument"))) -;; GNOME means of invoking either Mozilla or Netscape. +(defcustom browse-url-webpositive-program "WebPositive" + "The name by which to invoke WebPositive." + :type 'string + :version "29.1") + +;; GNOME means of invoking Mozilla. (defvar browse-url-gnome-moz-program "gnome-moz-remote") (make-obsolete-variable 'browse-url-gnome-moz-program nil "25.1") @@ -399,29 +356,12 @@ If non-nil, then open the URL in a new buffer rather than a new window if (make-obsolete-variable 'browse-url-conkeror-new-window-is-buffer nil "28.1") -(defcustom browse-url-galeon-new-window-is-tab nil - "Whether to open up new windows in a tab or a new window. -If non-nil, then open the URL in a new tab rather than a new window if -`browse-url-galeon' is asked to open it in a new window." - :type 'boolean) - -(make-obsolete-variable 'browse-url-galeon-new-window-is-tab nil "25.1") - (defcustom browse-url-epiphany-new-window-is-tab nil "Whether to open up new windows in a tab or a new window. If non-nil, then open the URL in a new tab rather than a new window if `browse-url-epiphany' is asked to open it in a new window." :type 'boolean) -(defcustom browse-url-netscape-new-window-is-tab nil - "Whether to open up new windows in a tab or a new window. -If non-nil, then open the URL in a new tab rather than a new -window if `browse-url-netscape' is asked to open it in a new -window." - :type 'boolean) - -(make-obsolete-variable 'browse-url-netscape-new-window-is-tab nil "25.1") - (defcustom browse-url-new-window-flag nil "Non-nil means always open a new browser window with appropriate browsers. Passing an interactive argument to \\[browse-url], or specific browser @@ -518,14 +458,6 @@ You might want to set this to somewhere with restricted read permissions for privacy's sake." :type 'string) -(defcustom browse-url-netscape-version 3 - "The version of Netscape you are using. -This affects how URL reloading is done; the mechanism changed -incompatibly at version 4." - :type 'number) - -(make-obsolete-variable 'browse-url-netscape-version nil "25.1") - (defcustom browse-url-text-browser "lynx" "The name of the text browser to invoke." :type 'string @@ -730,8 +662,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))) - (when (mouse-event-p 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 @@ -770,8 +701,10 @@ interactively. Turn the filename into a URL with function (cond ((not (buffer-modified-p))) (browse-url-save-file (save-buffer)) (t (message "%s modified since last save" file)))))) - (when (file-remote-p file) - (setq file (file-local-copy file))) + (when (and (file-remote-p file) + (not browse-url-temp-file-name)) + (setq browse-url-temp-file-name (file-local-copy file) + file browse-url-temp-file-name)) (browse-url (browse-url-file-url file)) (run-hooks 'browse-url-of-file-hook)) @@ -856,6 +789,8 @@ See `browse-url' for details." ;; A generic command to call the current browse-url-browser-function +(declare-function pgtk-backend-display-class "pgtkfns.c" (&optional terminal)) + ;;;###autoload (defun browse-url (url &rest args) "Open URL using a configurable method. @@ -893,8 +828,17 @@ If ARGS are omitted, the default is to pass ;; When connected to various displays, be careful to use the display of ;; the currently selected frame, rather than the original start display, ;; which may not even exist any more. - (if (stringp (frame-parameter nil 'display)) - (setenv "DISPLAY" (frame-parameter nil 'display))) + (let ((dpy (frame-parameter nil 'display)) + classname) + (if (stringp dpy) + (cond + ((featurep 'pgtk) + (setq classname (pgtk-backend-display-class)) + (if (equal classname "GdkWaylandDisplay") + (setenv "WAYLAND_DISPLAY" dpy) + (setenv "DISPLAY" dpy))) + (t + (setenv "DISPLAY" dpy))))) (if (functionp function) (apply function url args) (error "No suitable browser for URL %s" url)))) @@ -1003,8 +947,6 @@ The optional NEW-WINDOW argument is not used." (function-put 'browse-url-default-macosx-browser 'browse-url-browser-kind 'external) -;; --- Netscape --- - (defun browse-url-process-environment () "Set DISPLAY in the environment to the X display the browser will use. This is either the value of variable `browse-url-browser-display' if @@ -1047,10 +989,9 @@ instead of `browse-url-new-window-flag'." ((executable-find browse-url-mozilla-program) 'browse-url-mozilla) ((executable-find browse-url-firefox-program) 'browse-url-firefox) ((executable-find browse-url-chromium-program) 'browse-url-chromium) -;;; ((executable-find browse-url-galeon-program) 'browse-url-galeon) ((executable-find browse-url-kde-program) 'browse-url-kde) -;;; ((executable-find browse-url-netscape-program) 'browse-url-netscape) ((executable-find browse-url-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 @@ -1083,82 +1024,6 @@ The optional argument IGNORED is not used." (function-put 'browse-url-xdg-open 'browse-url-browser-kind 'external) ;;;###autoload -(defun browse-url-netscape (url &optional new-window) - "Ask the Netscape WWW browser to load URL. -Default to the URL around or before point. The strings in variable -`browse-url-netscape-arguments' are also passed to Netscape. - -When called interactively, if variable `browse-url-new-window-flag' is -non-nil, load the document in a new Netscape window, otherwise use a -random existing one. A non-nil interactive prefix argument reverses -the effect of `browse-url-new-window-flag'. - -If `browse-url-netscape-new-window-is-tab' is non-nil, then -whenever a document would otherwise be loaded in a new window, it -is loaded in a new tab in an existing window instead. - -When called non-interactively, optional second argument NEW-WINDOW is -used instead of `browse-url-new-window-flag'." - (declare (obsolete nil "25.1")) - (interactive (browse-url-interactive-arg "URL: ")) - (setq url (browse-url-encode-url url)) - (let* ((process-environment (browse-url-process-environment)) - (process - (apply #'start-process - (concat "netscape " url) nil - browse-url-netscape-program - (append - browse-url-netscape-arguments - (if (eq window-system 'w32) - (list url) - (append - (if new-window '("-noraise")) - (list "-remote" - (concat "openURL(" url - (if (browse-url-maybe-new-window - new-window) - (if browse-url-netscape-new-window-is-tab - ",new-tab" - ",new-window")) - ")")))))))) - (set-process-sentinel process - (lambda (process _change) - (browse-url-netscape-sentinel process url))))) - -(function-put 'browse-url-netscape 'browse-url-browser-kind 'external) - -(defun browse-url-netscape-sentinel (process url) - "Handle a change to the process communicating with Netscape." - (declare (obsolete nil "25.1")) - (or (eq (process-exit-status process) 0) - (let* ((process-environment (browse-url-process-environment))) - ;; Netscape not running - start it - (message "Starting %s..." browse-url-netscape-program) - (apply #'start-process (concat "netscape" url) nil - browse-url-netscape-program - (append browse-url-netscape-startup-arguments (list url)))))) - -(defun browse-url-netscape-reload () - "Ask Netscape to reload its current document. -How depends on `browse-url-netscape-version'." - (declare (obsolete nil "25.1")) - (interactive) - ;; Backwards incompatibility reported by - ;; <peter.kruse@psychologie.uni-regensburg.de>. - (browse-url-netscape-send (if (>= browse-url-netscape-version 4) - "xfeDoCommand(reload)" - "reload"))) - -(defun browse-url-netscape-send (command) - "Send a remote control command to Netscape." - (declare (obsolete nil "25.1")) - (let* ((process-environment (browse-url-process-environment))) - (apply #'start-process "netscape" nil - browse-url-netscape-program - (append browse-url-netscape-arguments - (list "-remote" command))))) - -;;;###autoload (defun browse-url-mozilla (url &optional new-window) "Ask the Mozilla WWW browser to load URL. Default to the URL around or before point. The strings in variable @@ -1278,56 +1143,6 @@ The optional argument NEW-WINDOW is not used." (function-put 'browse-url-chrome 'browse-url-browser-kind 'external) -;;;###autoload -(defun browse-url-galeon (url &optional new-window) - "Ask the Galeon WWW browser to load URL. -Default to the URL around or before point. The strings in variable -`browse-url-galeon-arguments' are also passed to Galeon. - -When called interactively, if variable `browse-url-new-window-flag' is -non-nil, load the document in a new Galeon window, otherwise use a -random existing one. A non-nil interactive prefix argument reverses -the effect of `browse-url-new-window-flag'. - -If `browse-url-galeon-new-window-is-tab' is non-nil, then whenever a -document would otherwise be loaded in a new window, it is loaded in a -new tab in an existing window instead. - -When called non-interactively, optional second argument NEW-WINDOW is -used instead of `browse-url-new-window-flag'." - (declare (obsolete nil "25.1")) - (interactive (browse-url-interactive-arg "URL: ")) - (setq url (browse-url-encode-url url)) - (let* ((process-environment (browse-url-process-environment)) - (process (apply #'start-process - (concat "galeon " url) - nil - browse-url-galeon-program - (append - browse-url-galeon-arguments - (if (browse-url-maybe-new-window new-window) - (if browse-url-galeon-new-window-is-tab - '("--new-tab") - '("--new-window" "--noraise")) - '("--existing")) - (list url))))) - (set-process-sentinel process - (lambda (process _change) - (browse-url-galeon-sentinel process url))))) - -(function-put 'browse-url-galeon 'browse-url-browser-kind 'external) - -(defun browse-url-galeon-sentinel (process url) - "Handle a change to the process communicating with Galeon." - (declare (obsolete nil "25.1")) - (or (eq (process-exit-status process) 0) - (let* ((process-environment (browse-url-process-environment))) - ;; Galeon is not running - start it - (message "Starting %s..." browse-url-galeon-program) - (apply #'start-process (concat "galeon " url) nil - browse-url-galeon-program - (append browse-url-galeon-startup-arguments (list url)))))) - (defun browse-url-epiphany (url &optional new-window) "Ask the GNOME Web (Epiphany) WWW browser to load URL. Default to the URL around or before point. The strings in variable @@ -1378,6 +1193,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. Optional argument SAME-WINDOW non-nil means show the URL in the @@ -1399,7 +1226,7 @@ currently selected window instead." ;;;###autoload (defun browse-url-gnome-moz (url &optional new-window) - "Ask Mozilla/Netscape to load URL via the GNOME program `gnome-moz-remote'. + "Ask Mozilla to load URL via the GNOME program `gnome-moz-remote'. Default to the URL around or before point. The strings in variable `browse-url-gnome-moz-arguments' are also passed. diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 560ece67517..9e5d652cf0f 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -36,6 +36,7 @@ ;; Declare used subroutines and variables. (declare-function dbus-message-internal "dbusbind.c") (declare-function dbus--init-bus "dbusbind.c") +(declare-function libxml-parse-xml-region "xml.c") (defvar dbus-message-type-invalid) (defvar dbus-message-type-method-call) (defvar dbus-message-type-method-return) @@ -2102,7 +2103,7 @@ has been handled by this function." (interface (dbus-event-interface-name event)) (member (dbus-event-member-name event)) (arguments (dbus-event-arguments event)) - (time (time-to-seconds (current-time)))) + (time (float-time))) (save-excursion ;; Check for matching method-call. (goto-char (point-max)) @@ -2252,15 +2253,19 @@ keywords `:system-private' or `:session-private', respectively." bus nil dbus-path-local dbus-interface-local "Disconnected" #'dbus-handle-bus-disconnect))) - -;; Initialize `:system' and `:session' buses. This adds their file -;; descriptors to input_wait_mask, in order to detect incoming -;; messages immediately. -(when (featurep 'dbusbind) - (dbus-ignore-errors - (dbus-init-bus :system)) - (dbus-ignore-errors - (dbus-init-bus :session))) + +(defun dbus--init () + ;; Initialize `:system' and `:session' buses. This adds their file + ;; descriptors to input_wait_mask, in order to detect incoming + ;; messages immediately. + (when (featurep 'dbusbind) + (dbus-ignore-errors + (dbus-init-bus :system)) + (dbus-ignore-errors + (dbus-init-bus :session)))) + +(add-hook 'after-pdump-load-hook #'dbus--init) +(dbus--init) (provide 'dbus) diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el index 14e5c28b2dc..62c2913b50a 100644 --- a/lisp/net/eudc.el +++ b/lisp/net/eudc.el @@ -46,16 +46,9 @@ ;;; Code: (require 'wid-edit) - (require 'cl-lib) - -(unless (fboundp 'custom-menu-create) - (autoload 'custom-menu-create "cus-edit")) - (require 'eudc-vars) - - ;;{{{ Internal cooking ;;{{{ Internal variables and compatibility tricks diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 238900db0c3..8930eb427d2 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -178,6 +178,40 @@ the tab bar is enabled." :group 'eww :type 'hook) +(defcustom eww-auto-rename-buffer nil + "Automatically rename EWW buffers once the page is rendered. + +When nil, do not rename the buffer. With a non-nil value +determine the renaming scheme, as follows: + +- `title': Use the web page's title. +- `url': Use the web page's URL. +- a function's symbol: Run a user-defined function that returns a + string with which to rename the buffer. Sample of a + user-defined function: + + (defun my-eww-rename-buffer () + (when (eq major-mode 'eww-mode) + (when-let ((string (or (plist-get eww-data :title) + (plist-get eww-data :url)))) + (format \"*%s*\" string)))) + +The string of `title' and `url' is always truncated to the value +of `eww-buffer-name-length'." + :version "29.1" + :type '(choice + (const :tag "Do not rename buffers (default)" nil) + (const :tag "Rename buffer to web page title" title) + (const :tag "Rename buffer to web page URL" url) + (function :tag "A user-defined function to rename the buffer")) + :group 'eww) + +(defcustom eww-buffer-name-length 40 + "Length of renamed buffer name, per `eww-auto-rename-buffer'." + :type 'natnum + :version "29.1" + :group 'eww) + (defcustom eww-form-checkbox-selected-symbol "[X]" "Symbol used to represent a selected checkbox. See also `eww-form-checkbox-symbol'." @@ -197,8 +231,15 @@ See also `eww-form-checkbox-selected-symbol'." (const "☐") ; Unicode BALLOT BOX string)) +(defcustom eww-url-transformers '(eww-remove-tracking) + "This is a list of transforming functions applied to an URL before usage. +The functions will be called with the URL as the single +parameter, and should return the (possibly) transformed URL." + :type '(repeat function) + :version "29.1") + (defface eww-form-submit - '((((type x w32 ns) (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." @@ -206,7 +247,7 @@ See also `eww-form-checkbox-selected-symbol'." :group 'eww) (defface eww-form-file - '((((type x w32 ns) (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." @@ -214,7 +255,7 @@ See also `eww-form-checkbox-selected-symbol'." :group 'eww) (defface eww-form-checkbox - '((((type x w32 ns) (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." @@ -222,7 +263,7 @@ See also `eww-form-checkbox-selected-symbol'." :group 'eww) (defface eww-form-select - '((((type x w32 ns) (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." @@ -271,15 +312,13 @@ See also `eww-form-checkbox-selected-symbol'." "text/html, text/plain, text/sgml, text/css, application/xhtml+xml, */*;q=0.01" "Value used for the HTTP 'Accept' header.") -(defvar eww-link-keymap - (let ((map (copy-keymap shr-map))) - (define-key map "\r" 'eww-follow-link) - map)) +(defvar-keymap eww-link-keymap + :parent shr-map + "RET" #'eww-follow-link) -(defvar eww-image-link-keymap - (let ((map (copy-keymap shr-image-map))) - (define-key map "\r" 'eww-follow-link) - map)) +(defvar-keymap eww-image-link-keymap + :parent shr-map + "RET" #'eww-follow-link) (defun eww-suggested-uris nil "Return the list of URIs to suggest at the `eww' prompt. @@ -313,13 +352,13 @@ will start Emacs and browse the GNU web site." ;;;###autoload -(defun eww (url &optional arg buffer) +(defun eww (url &optional new-buffer buffer) "Fetch URL and render the page. If the input doesn't look like an URL or a domain name, the word(s) will be searched for via `eww-search-prefix'. -If called with a prefix ARG, use a new buffer instead of reusing -the default EWW buffer. +If NEW-BUFFER is non-nil (interactively, the prefix arg), use a +new buffer instead of reusing the default EWW buffer. If BUFFER, the data to be rendered is in that buffer. In that case, this function doesn't actually fetch URL. BUFFER will be @@ -329,11 +368,11 @@ killed after rendering." (list (read-string (format-prompt "Enter URL or keywords" (and uris (car uris))) nil 'eww-prompt-history uris) - (prefix-numeric-value current-prefix-arg)))) + current-prefix-arg))) (setq url (eww--dwim-expand-url url)) (pop-to-buffer-same-window (cond - ((eq arg 4) + (new-buffer (generate-new-buffer "*eww*")) ((eq major-mode 'eww-mode) (current-buffer)) @@ -353,9 +392,10 @@ killed after rendering." (while (string-match "\\`/[.][.]/" (url-filename parsed)) (setf (url-filename parsed) (substring (url-filename parsed) 3)))) (setq url (url-recreate-url parsed))) + (setq url (eww--transform-url url)) (plist-put eww-data :url url) (plist-put eww-data :title "") - (eww-update-header-line-format) + (eww--after-page-change) (let ((inhibit-read-only t)) (insert (format "Loading %s..." url)) (goto-char (point-min))) @@ -504,6 +544,30 @@ Currently this means either text/html or application/xhtml+xml." (member content-type '("text/html" "application/xhtml+xml"))) +(defun eww--rename-buffer () + "Rename the current EWW buffer. +The renaming scheme is performed in accordance with +`eww-auto-rename-buffer'." + (let ((rename-string) + (formatter + (lambda (string) + (format "*%s # eww*" (truncate-string-to-width + string eww-buffer-name-length)))) + (site-title (plist-get eww-data :title)) + (site-url (plist-get eww-data :url))) + (cond ((null eww-auto-rename-buffer)) + ((eq eww-auto-rename-buffer 'url) + (setq rename-string (funcall formatter site-url))) + ((functionp eww-auto-rename-buffer) + (setq rename-string (funcall eww-auto-rename-buffer))) + (t (setq rename-string + (funcall formatter (if (or (equal site-title "") + (null site-title)) + "Untitled" + site-title))))) + (when rename-string + (rename-buffer rename-string t)))) + (defun eww-render (status url &optional point buffer encode) (let* ((headers (eww-parse-headers)) (content-type @@ -554,7 +618,7 @@ Currently this means either text/html or application/xhtml+xml." (eww-display-raw buffer (or encode charset 'utf-8)))) (with-current-buffer buffer (plist-put eww-data :url url) - (eww-update-header-line-format) + (eww--after-page-change) (setq eww-history-position 0) (and last-coding-system-used (set-buffer-file-coding-system last-coding-system-used)) @@ -638,14 +702,15 @@ Currently this means either text/html or application/xhtml+xml." (meta . eww-tag-meta) (a . eww-tag-a))))) (erase-buffer) - (shr-insert-document document) + (with-delayed-message (2 "Rendering HTML...") + (shr-insert-document document)) (cond (point (goto-char point)) (shr-target-id (goto-char (point-min)) (let ((match (text-property-search-forward - 'shr-target-id shr-target-id t))) + 'shr-target-id shr-target-id #'member))) (when match (goto-char (prop-match-beginning match))))) (t @@ -798,12 +863,16 @@ Currently this means either text/html or application/xhtml+xml." `((?u . ,(or url "")) (?t . ,title)))))))) +(defun eww--after-page-change () + (eww-update-header-line-format) + (eww--rename-buffer)) + (defun eww-tag-title (dom) (plist-put eww-data :title (replace-regexp-in-string "^ \\| $" "" (replace-regexp-in-string "[ \t\r\n]+" " " (dom-text dom)))) - (eww-update-header-line-format)) + (eww--after-page-change)) (defun eww-display-raw (buffer &optional encode) (let ((data (buffer-substring (point) (point-max)))) @@ -931,7 +1000,7 @@ the like." nil (current-buffer)) (dolist (elem '(:source :url :title :next :previous :up)) (plist-put eww-data elem (plist-get old-data elem))) - (eww-update-header-line-format))) + (eww--after-page-change))) (defun eww-score-readability (node) (let ((score -1)) @@ -973,67 +1042,67 @@ the like." (setq result highest)))) result)) -(defvar eww-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "g" 'eww-reload) ;FIXME: revert-buffer-function instead! - (define-key map "G" 'eww) - (define-key map [?\M-\r] 'eww-open-in-new-buffer) - (define-key map [?\t] 'shr-next-link) - (define-key map [?\M-\t] 'shr-previous-link) - (define-key map [backtab] 'shr-previous-link) - (define-key map [delete] 'scroll-down-command) - (define-key map "l" 'eww-back-url) - (define-key map "r" 'eww-forward-url) - (define-key map "n" 'eww-next-url) - (define-key map "p" 'eww-previous-url) - (define-key map "u" 'eww-up-url) - (define-key map "t" 'eww-top-url) - (define-key map "&" 'eww-browse-with-external-browser) - (define-key map "d" 'eww-download) - (define-key map "w" 'eww-copy-page-url) - (define-key map "C" 'url-cookie-list) - (define-key map "v" 'eww-view-source) - (define-key map "R" 'eww-readable) - (define-key map "H" 'eww-list-histories) - (define-key map "E" 'eww-set-character-encoding) - (define-key map "s" 'eww-switch-to-buffer) - (define-key map "S" 'eww-list-buffers) - (define-key map "F" 'eww-toggle-fonts) - (define-key map "D" 'eww-toggle-paragraph-direction) - (define-key map [(meta C)] 'eww-toggle-colors) - (define-key map [(meta I)] 'eww-toggle-images) - - (define-key map "b" 'eww-add-bookmark) - (define-key map "B" 'eww-list-bookmarks) - (define-key map [(meta n)] 'eww-next-bookmark) - (define-key map [(meta p)] 'eww-previous-bookmark) - - (easy-menu-define nil map "" - '("Eww" - ["Exit" quit-window t] - ["Close browser" quit-window t] - ["Reload" eww-reload t] - ["Follow URL in new buffer" eww-open-in-new-buffer] - ["Back to previous page" eww-back-url - :active (not (zerop (length eww-history)))] - ["Forward to next page" eww-forward-url - :active (not (zerop eww-history-position))] - ["Browse with external browser" eww-browse-with-external-browser t] - ["Download" eww-download t] - ["View page source" eww-view-source] - ["Copy page URL" eww-copy-page-url t] - ["List histories" eww-list-histories t] - ["Switch to buffer" eww-switch-to-buffer t] - ["List buffers" eww-list-buffers t] - ["Add bookmark" eww-add-bookmark t] - ["List bookmarks" eww-list-bookmarks t] - ["List cookies" url-cookie-list t] - ["Toggle fonts" eww-toggle-fonts t] - ["Toggle colors" eww-toggle-colors t] - ["Toggle images" eww-toggle-images t] - ["Character Encoding" eww-set-character-encoding] - ["Toggle Paragraph Direction" eww-toggle-paragraph-direction])) - map)) +(defvar-keymap eww-mode-map + "g" #'eww-reload ;FIXME: revert-buffer-function instead! + "G" #'eww + "M-RET" #'eww-open-in-new-buffer + "TAB" #'shr-next-link + "C-M-i" #'shr-previous-link + "<backtab>" #'shr-previous-link + "<delete>" #'scroll-down-command + "l" #'eww-back-url + "r" #'eww-forward-url + "n" #'eww-next-url + "p" #'eww-previous-url + "u" #'eww-up-url + "t" #'eww-top-url + "&" #'eww-browse-with-external-browser + "d" #'eww-download + "w" #'eww-copy-page-url + "C" #'url-cookie-list + "v" #'eww-view-source + "R" #'eww-readable + "H" #'eww-list-histories + "E" #'eww-set-character-encoding + "s" #'eww-switch-to-buffer + "S" #'eww-list-buffers + "F" #'eww-toggle-fonts + "D" #'eww-toggle-paragraph-direction + "M-C" #'eww-toggle-colors + "M-I" #'eww-toggle-images + + "b" #'eww-add-bookmark + "B" #'eww-list-bookmarks + "M-n" #'eww-next-bookmark + "M-p" #'eww-previous-bookmark + + "<mouse-8>" #'eww-back-url + "<mouse-9>" #'eww-forward-url + + :menu '("Eww" + ["Exit" quit-window t] + ["Close browser" quit-window t] + ["Reload" eww-reload t] + ["Follow URL in new buffer" eww-open-in-new-buffer] + ["Back to previous page" eww-back-url + :active (not (zerop (length eww-history)))] + ["Forward to next page" eww-forward-url + :active (not (zerop eww-history-position))] + ["Browse with external browser" eww-browse-with-external-browser t] + ["Download" eww-download t] + ["View page source" eww-view-source] + ["Copy page URL" eww-copy-page-url t] + ["List histories" eww-list-histories t] + ["Switch to buffer" eww-switch-to-buffer t] + ["List buffers" eww-list-buffers t] + ["Add bookmark" eww-add-bookmark t] + ["List bookmarks" eww-list-bookmarks t] + ["List cookies" url-cookie-list t] + ["Toggle fonts" eww-toggle-fonts t] + ["Toggle colors" eww-toggle-colors t] + ["Toggle images" eww-toggle-images t] + ["Character Encoding" eww-set-character-encoding] + ["Toggle Paragraph Direction" eww-toggle-paragraph-direction])) (defun eww-context-menu (menu click) "Populate MENU with eww commands at CLICK." @@ -1166,7 +1235,7 @@ instead of `browse-url-new-window-flag'." (goto-char (plist-get elem :point)) ;; Make buffer listings more informative. (setq list-buffers-directory (plist-get elem :url)) - (eww-update-header-line-format)))) + (eww--after-page-change)))) (defun eww-next-url () "Go to the page marked `next'. @@ -1230,54 +1299,43 @@ just re-display the HTML already fetched." (defvar eww-form nil) -(defvar eww-submit-map - (let ((map (make-sparse-keymap))) - (define-key map "\r" 'eww-submit) - (define-key map [(control c) (control c)] 'eww-submit) - map)) - -(defvar eww-submit-file - (let ((map (make-sparse-keymap))) - (define-key map "\r" 'eww-select-file) - (define-key map [(control c) (control c)] 'eww-submit) - map)) - -(defvar eww-checkbox-map - (let ((map (make-sparse-keymap))) - (define-key map " " 'eww-toggle-checkbox) - (define-key map "\r" 'eww-toggle-checkbox) - (define-key map [(control c) (control c)] 'eww-submit) - map)) - -(defvar eww-text-map - (let ((map (make-keymap))) - (set-keymap-parent map text-mode-map) - (define-key map "\r" 'eww-submit) - (define-key map [(control a)] 'eww-beginning-of-text) - (define-key map [(control c) (control c)] 'eww-submit) - (define-key map [(control e)] 'eww-end-of-text) - (define-key map [?\t] 'shr-next-link) - (define-key map [?\M-\t] 'shr-previous-link) - (define-key map [backtab] 'shr-previous-link) - map)) - -(defvar eww-textarea-map - (let ((map (make-keymap))) - (set-keymap-parent map text-mode-map) - (define-key map "\r" 'forward-line) - (define-key map [(control c) (control c)] 'eww-submit) - (define-key map [?\t] 'shr-next-link) - (define-key map [?\M-\t] 'shr-previous-link) - (define-key map [backtab] 'shr-previous-link) - map)) - -(defvar eww-select-map - (let ((map (make-sparse-keymap))) - (define-key map "\r" 'eww-change-select) - (define-key map [follow-link] 'mouse-face) - (define-key map [mouse-2] 'eww-change-select) - (define-key map [(control c) (control c)] 'eww-submit) - map)) +(defvar-keymap eww-submit-map + "RET" #'eww-submit + "C-c C-c" #'eww-submit) + +(defvar-keymap eww-submit-file + "RET" #'eww-select-file + "C-c C-c" #'eww-submit) + +(defvar-keymap eww-checkbox-map + "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 + "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 + "<backtab>" #'shr-previous-link) + +(defvar-keymap eww-textarea-map + :full t :parent text-mode-map + "RET" #'forward-line + "C-c C-c" #'eww-submit + "TAB" #'shr-next-link + "M-TAB" #'shr-previous-link + "<backtab>" #'shr-previous-link) + +(defvar-keymap eww-select-map + :doc "Map for select buttons" + "RET" #'eww-change-select + "<follow-link>" 'mouse-face + "<mouse-2>" #'eww-change-select + "C-c C-c" #'eww-submit) (defun eww-beginning-of-text () "Move to the start of the input field." @@ -1784,6 +1842,17 @@ The browser to used is specified by the (funcall browse-url-secondary-browser-function (or url (plist-get eww-data :url)))) +(defun eww-remove-tracking (url) + "Remove the commong utm_ tracking cookies from URLs." + (replace-regexp-in-string ".utm_.*" "" url)) + +(defun eww--transform-url (url) + "Appy `eww-url-transformers'." + (when url + (dolist (func eww-url-transformers) + (setq url (funcall func url))) + url)) + (defun eww-follow-link (&optional external mouse-event) "Browse the URL under point. If EXTERNAL is single prefix, browse the URL using @@ -1794,7 +1863,8 @@ If EXTERNAL is double prefix, browse in new buffer." (list current-prefix-arg last-nonmenu-event) eww-mode) (mouse-set-point mouse-event) - (let ((url (get-text-property (point) 'shr-url))) + (let* ((orig-url (get-text-property (point) 'shr-url)) + (url (eww--transform-url orig-url))) (cond ((not url) (message "No link under point")) @@ -1813,7 +1883,7 @@ If EXTERNAL is double prefix, browse in new buffer." (plist-put eww-data :url url) (eww-display-html 'utf-8 url dom nil (current-buffer)))) (t - (eww-browse-url url external))))) + (eww-browse-url orig-url external))))) (defun eww-same-page-p (url1 url2) "Return non-nil if URL1 and URL2 represent the same page. @@ -2100,23 +2170,18 @@ If ERROR-OUT, signal user-error if there are no bookmarks." 'eww-bookmark))) (eww-browse-url (plist-get bookmark :url)))) -(defvar eww-bookmark-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [(control k)] 'eww-bookmark-kill) - (define-key map [(control y)] 'eww-bookmark-yank) - (define-key map "\r" 'eww-bookmark-browse) - - (easy-menu-define nil map - "Menu for `eww-bookmark-mode-map'." - '("Eww Bookmark" - ["Exit" quit-window t] - ["Browse" eww-bookmark-browse - :active (get-text-property (line-beginning-position) 'eww-bookmark)] - ["Kill" eww-bookmark-kill - :active (get-text-property (line-beginning-position) 'eww-bookmark)] - ["Yank" eww-bookmark-yank - :active eww-bookmark-kill-ring])) - map)) +(defvar-keymap eww-bookmark-mode-map + "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 + :active (get-text-property (line-beginning-position) 'eww-bookmark)] + ["Kill" eww-bookmark-kill + :active (get-text-property (line-beginning-position) 'eww-bookmark)] + ["Yank" eww-bookmark-yank + :active eww-bookmark-kill-ring])) (define-derived-mode eww-bookmark-mode special-mode "eww bookmarks" "Mode for listing bookmarks. @@ -2181,19 +2246,15 @@ If ERROR-OUT, signal user-error if there are no bookmarks." (pop-to-buffer-same-window buffer))) (eww-restore-history history))) -(defvar eww-history-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\r" 'eww-history-browse) - (define-key map "n" 'next-line) - (define-key map "p" 'previous-line) - - (easy-menu-define nil map - "Menu for `eww-history-mode-map'." - '("Eww History" - ["Exit" quit-window t] - ["Browse" eww-history-browse - :active (get-text-property (line-beginning-position) 'eww-history)])) - map)) +(defvar-keymap eww-history-mode-map + "RET" #'eww-history-browse + "n" #'next-line + "p" #'previous-line + :menu '("Eww History" + ["Exit" quit-window t] + ["Browse" eww-history-browse + :active (get-text-property (line-beginning-position) + 'eww-history)])) (define-derived-mode eww-history-mode special-mode "eww history" "Mode for listing eww-histories. @@ -2304,22 +2365,18 @@ If ERROR-OUT, signal user-error if there are no bookmarks." (forward-line -1)) (eww-buffer-show)) -(defvar eww-buffers-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [(control k)] 'eww-buffer-kill) - (define-key map "\r" 'eww-buffer-select) - (define-key map "n" 'eww-buffer-show-next) - (define-key map "p" 'eww-buffer-show-previous) - - (easy-menu-define nil map - "Menu for `eww-buffers-mode-map'." - '("Eww Buffers" - ["Exit" quit-window t] - ["Select" eww-buffer-select - :active (get-text-property (line-beginning-position) 'eww-buffer)] - ["Kill" eww-buffer-kill - :active (get-text-property (line-beginning-position) 'eww-buffer)])) - map)) +(defvar-keymap eww-buffers-mode-map + "C-k" #'eww-buffer-kill + "RET" #'eww-buffer-select + "n" #'eww-buffer-show-next + "p" #'eww-buffer-show-previous + :menu '("Eww Buffers" + ["Exit" quit-window t] + ["Select" eww-buffer-select + :active (get-text-property (line-beginning-position) 'eww-buffer)] + ["Kill" eww-buffer-kill + :active (get-text-property (line-beginning-position) + 'eww-buffer)])) (define-derived-mode eww-buffers-mode special-mode "eww buffers" "Mode for listing buffers. diff --git a/lisp/net/hmac-def.el b/lisp/net/hmac-def.el index 5af6d4324ae..5778857ff80 100644 --- a/lisp/net/hmac-def.el +++ b/lisp/net/hmac-def.el @@ -37,6 +37,7 @@ a string and return a digest of it (in binary form). B is a byte length of a block size of H. (B=64 for both SHA1 and MD5.) L is a byte length of hash outputs. (L=16 for MD5, L=20 for SHA1.) If BIT is non-nil, truncate output to specified bits." + (declare (indent defun)) `(defun ,name (text key) ,(concat "Compute " (upcase (symbol-name name)) diff --git a/lisp/net/mailcap.el b/lisp/net/mailcap.el index 83d0eeef9f1..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) @@ -423,14 +421,6 @@ MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus (interactive (list nil t)) (when (or (not mailcap-parsed-p) force) - ;; Clear out all old data. - (setq mailcap--computed-mime-data nil) - ;; Add the Emacs-distributed defaults (which will be used as - ;; fallbacks). Do it this way instead of just copying the list, - ;; since entries are destructively modified. - (cl-loop for (major . minors) in mailcap-mime-data - do (cl-loop for (minor . entry) in minors - do (mailcap-add-mailcap-entry major minor entry))) (cond (path nil) ((getenv "MAILCAPS") @@ -447,18 +437,26 @@ 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))))) - ;; 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)))) - (when (and (file-readable-p file-name) - (file-regular-p file-name)) - (mailcap-parse-mailcap file-name source)))) + (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) + ;; Clear out all old data. + (setq mailcap--computed-mime-data nil) + ;; Add the Emacs-distributed defaults (which will be used as + ;; fallbacks). Do it this way instead of just copying the list, + ;; since entries are destructively modified. + (cl-loop for (major . minors) in mailcap-mime-data + 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 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))))) (setq mailcap-parsed-p t))) (defun mailcap-parse-mailcap (fname &optional source) @@ -636,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)) @@ -707,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)))) @@ -837,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. @@ -1065,12 +1063,21 @@ For instance, \"foo.png\" will result in \"image/png\"." (match-string 1 file-name) ""))) +;;;###autoload +(defun mailcap-mime-type-to-extension (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) + mime-type) + "/")))) + (defun mailcap-mime-types () "Return a list of MIME media types." (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/newst-backend.el b/lisp/net/newst-backend.el index 03a297ca41f..d51f8c0189f 100644 --- a/lisp/net/newst-backend.el +++ b/lisp/net/newst-backend.el @@ -402,13 +402,6 @@ headline after it has been retrieved for the first time." "Miscellaneous newsticker settings." :group 'newsticker) -(defcustom newsticker-cache-filename - "~/.newsticker-cache" - "Name of the newsticker cache file." - :type 'string - :group 'newsticker-miscellaneous) -(make-obsolete-variable 'newsticker-cache-filename 'newsticker-dir "23.1") - (defcustom newsticker-dir (locate-user-emacs-file "newsticker/" ".newsticker/") "Directory where newsticker saves data." @@ -2114,28 +2107,6 @@ well." (throw 'result t))))) (< (or (newsticker--pos item1) 0) (or (newsticker--pos item2) 0)))) -(defun newsticker--cache-save-version1 () - "Update and save newsticker cache file." - (interactive) - (newsticker--cache-update t)) - -(defun newsticker--cache-update (&optional save) - "Update newsticker cache file. -If optional argument SAVE is not nil the cache file is saved to disk." - (save-excursion - (unless (file-directory-p newsticker-dir) - (make-directory newsticker-dir t)) - (let ((coding-system-for-write 'utf-8) - (buf (find-file-noselect newsticker-cache-filename))) - (when buf - (set-buffer buf) - (setq buffer-undo-list t) - (erase-buffer) - (insert ";; -*- coding: utf-8 -*-\n") - (insert (prin1-to-string newsticker--cache)) - (when save - (save-buffer)))))) - (defun newsticker--cache-get-feed (feed) "Return the cached data for the feed FEED. FEED is a symbol!" @@ -2162,30 +2133,11 @@ FEED is a symbol!" (insert ";; -*- coding: utf-8 -*-\n") (insert (prin1-to-string (cdr feed))))))) -(defun newsticker--cache-read-version1 () - "Read version1 cache data." - (let ((coding-system-for-read 'utf-8)) - (when (file-exists-p newsticker-cache-filename) - (with-temp-buffer - (insert-file-contents newsticker-cache-filename) - (goto-char (point-min)) - (condition-case nil - (setq newsticker--cache (read (current-buffer))) - (error - (message "Error while reading newsticker cache file!") - (setq newsticker--cache nil))))))) - (defun newsticker--cache-read () "Read cache data." (setq newsticker--cache nil) - (if (file-exists-p newsticker-cache-filename) - (progn - (when (y-or-n-p "Old newsticker cache file exists. Read it? ") - (newsticker--cache-read-version1)) - (when (y-or-n-p "Delete old newsticker cache file? ") - (delete-file newsticker-cache-filename))) - (dolist (f (append newsticker-url-list-defaults newsticker-url-list)) - (newsticker--cache-read-feed (car f))))) + (dolist (f (append newsticker-url-list-defaults newsticker-url-list)) + (newsticker--cache-read-feed (car f)))) (defun newsticker--cache-read-feed (feed-name) "Read cache data for feed named FEED-NAME." diff --git a/lisp/net/newst-plainview.el b/lisp/net/newst-plainview.el index 420cf82e4d8..82977b000b6 100644 --- a/lisp/net/newst-plainview.el +++ b/lisp/net/newst-plainview.el @@ -589,7 +589,7 @@ calls `w3m-toggle-inline-image'. It works only if (defun newsticker-close-buffer () "Close the newsticker buffer." (interactive) - (newsticker--cache-update t) + (newsticker--cache-save) (bury-buffer)) (defun newsticker-next-new-item (&optional do-not-wrap-at-eob) @@ -748,7 +748,7 @@ Return new buffer position." (newsticker--cache-replace-age newsticker--cache feed 'new 'old) (newsticker--cache-replace-age newsticker--cache feed 'obsolete 'old) - (newsticker--cache-update) + (newsticker--cache-save) (newsticker--buffer-set-uptodate nil) (newsticker--ticker-text-setup) (newsticker-buffer-update) @@ -879,7 +879,7 @@ not get changed." (newsticker--cache-replace-age newsticker--cache 'any 'new 'old) (newsticker--buffer-set-uptodate nil) (newsticker--ticker-text-setup) - (newsticker--cache-update) + (newsticker--cache-save) (newsticker-buffer-update))) (defun newsticker-hide-extra () diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el index 2ac1df1d58a..b067b23f8ff 100644 --- a/lisp/net/nsm.el +++ b/lisp/net/nsm.el @@ -79,8 +79,7 @@ option." (const :tag "Off" nil) (function :tag "Custom function"))) -(defcustom nsm-settings-file (expand-file-name "network-security.data" - user-emacs-directory) +(defcustom nsm-settings-file (locate-user-emacs-file "network-security.data") "The file the security manager settings will be stored in." :version "25.1" :type 'file) diff --git a/lisp/net/ntlm.el b/lisp/net/ntlm.el index 0e0146df969..fed93ddf704 100644 --- a/lisp/net/ntlm.el +++ b/lisp/net/ntlm.el @@ -102,9 +102,7 @@ is not given." (let ((request-ident (concat "NTLMSSP" (make-string 1 0))) (request-msgType (concat (make-string 1 1) (make-string 3 0))) ;0x01 0x00 0x00 0x00 - (request-flags (concat (make-string 1 7) (make-string 1 130) - (make-string 1 8) (make-string 1 0))) - ;0x07 0x82 0x08 0x00 + (request-flags (unibyte-string #x07 #x82 #x08 #x00)) ) (when (and user (string-match "@" user)) (unless domain @@ -245,9 +243,7 @@ by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of ;;(msgType (substring rchallenge 8 12)) ;msgType, 4 bytes (uDomain (substring rchallenge 12 20)) ;uDomain, 8 bytes ;; match default setting in `ntlm-build-auth-request' - (request-flags (concat (make-string 1 7) (make-string 1 130) - (make-string 1 8) (make-string 1 0))) - ;0x07 0x82 0x08 0x00 + (request-flags (unibyte-string #x07 #x82 #x08 #x00)) (flags (substring rchallenge 20 24)) ;flags, 4 bytes (challengeData (substring rchallenge 24 32)) ;challengeData, 8 bytes ;; Extract domain string from challenge string. 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 5c92c60eda2..2375b14cca2 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)) @@ -713,8 +716,8 @@ that are joined after authentication." (setq rcirc-nick-table (make-hash-table :test 'equal)) (setq rcirc-nick nick) (setq rcirc-startup-channels startup-channels) - (setq rcirc-last-server-message-time (current-time)) (setq rcirc-last-connect-time (current-time)) + (setq rcirc-last-server-message-time rcirc-last-connect-time) ;; Check if the immediate process state (sit-for .1) diff --git a/lisp/net/sasl-scram-rfc.el b/lisp/net/sasl-scram-rfc.el index 91d76663ef2..c0793691993 100644 --- a/lisp/net/sasl-scram-rfc.el +++ b/lisp/net/sasl-scram-rfc.el @@ -90,6 +90,8 @@ (sasl-mechanism-name (sasl-client-mechanism client)) (sasl-client-name client)))) (salt (base64-decode-string salt-base64)) + (string-xor (lambda (a b) + (apply #'unibyte-string (cl-mapcar #'logxor a b)))) (salted-password ;; Hi(str, salt, i): (let ((digest (concat salt (string 0 0 0 1))) @@ -98,7 +100,7 @@ (setq digest (funcall hmac-fun digest password)) (setq xored (if (null xored) digest - (cl-map 'string 'logxor xored digest)))))) + (funcall string-xor xored digest)))))) (client-key (funcall hmac-fun "Client Key" salted-password)) (stored-key (decode-hex-string (funcall hash-fun client-key))) @@ -108,7 +110,7 @@ step-data "," client-final-message-without-proof)) (client-signature (funcall hmac-fun (encode-coding-string auth-message 'utf-8) stored-key)) - (client-proof (cl-map 'string 'logxor client-key client-signature)) + (client-proof (funcall string-xor client-key client-signature)) (client-final-message (concat client-final-message-without-proof "," "p=" (base64-encode-string client-proof)))) diff --git a/lisp/net/sasl.el b/lisp/net/sasl.el index b7f814f7237..0a3ecf9f534 100644 --- a/lisp/net/sasl.el +++ b/lisp/net/sasl.el @@ -174,21 +174,24 @@ It contain at least 64 bits of entropy." ;; stolen (and renamed) from message.el (defun sasl-unique-id-function () - ;; Don't use microseconds from (current-time), they may be unsupported. + ;; Don't use fractional seconds from timestamp; they may be unsupported. ;; Instead we use this randomly inited counter. (setq sasl-unique-id-char - (% (1+ (or sasl-unique-id-char (logand (random) (1- (ash 1 20))))) - ;; (current-time) returns 16-bit ints, - ;; and 2^16*25 just fits into 4 digits i base 36. - (* 25 25))) - (let ((tm (current-time))) + ;; 2^16 * 25 just fits into 4 digits i base 36. + (let ((base (* 25 25))) + (if sasl-unique-id-char + (% (1+ sasl-unique-id-char) base) + (random base)))) + (let ((tm (time-convert nil 'integer))) (concat (sasl-unique-id-number-base36 - (+ (car tm) - (ash (% sasl-unique-id-char 25) 16)) 4) + (+ (ash tm -16) + (ash (% sasl-unique-id-char 25) 16)) + 4) (sasl-unique-id-number-base36 - (+ (nth 1 tm) - (ash (/ sasl-unique-id-char 25) 16)) 4)))) + (+ (logand tm #xffff) + (ash (/ sasl-unique-id-char 25) 16)) + 4)))) (defun sasl-unique-id-number-base36 (num len) (if (if (< len 0) diff --git a/lisp/net/secrets.el b/lisp/net/secrets.el index 4217c219ad9..552638348c5 100644 --- a/lisp/net/secrets.el +++ b/lisp/net/secrets.el @@ -77,15 +77,17 @@ ;; (secrets-delete-collection "my collection") ;; (secrets-create-collection "my collection") -;; There exists a special collection called "session", which has the -;; lifetime of the corresponding client session (aka Emacs's -;; lifetime). It is created automatically when Emacs uses the Secret -;; Service interface, and it is deleted when Emacs is killed. +;; With GNOME Keyring, there exists a special collection called +;; "session", which has the lifetime of the user being logged in. Its +;; data are not stored on disk and go away when the user logs out. ;; Therefore, it can be used to store and retrieve secret items -;; temporarily. This shall be preferred over creation of a persistent -;; collection, when the information shall not live longer than Emacs. -;; The session collection can be addressed either by the string -;; "session", or by nil, whenever a collection parameter is needed. +;; temporarily. The "session" collection can be addressed either by +;; the string "session", or by nil, whenever a collection parameter is +;; needed. + +;; However, other Secret Service provider don't create this temporary +;; "session" collection. You shall check first that this collection +;; exists, before you use it. ;; As already said, a collection is a group of secret items. A secret ;; item has a label, the "secret" (which is a string), and a set of @@ -98,8 +100,7 @@ ;; => ("this item" "another item") ;; Secret items can be added or deleted to a collection. In the -;; following examples, we use the special collection "session", which -;; is bound to Emacs's lifetime. +;; following examples, we use the special collection "session". ;; ;; (secrets-delete-item "session" "my item") ;; (secrets-create-item "session" "my item" "geheim" @@ -137,7 +138,7 @@ ;; It has been tested with GNOME Keyring 2.29.92. An implementation ;; for KWallet will be available at ;; svn://anonsvn.kde.org/home/kde/trunk/playground/base/ksecretservice; -;; not tested yet. +;; not tested yet. This package has also been tested with KeePassXC 2.6.6. ;; Pacify byte-compiler. D-Bus support in the Emacs core can be ;; disabled with configuration option "--without-dbus". Declare used @@ -263,6 +264,7 @@ It returns t if not." ;; </signal> ;; </interface> +;; This exist only for GNOME Keyring. (defconst secrets-session-collection-path "/org/freedesktop/secrets/collection/session" "The D-Bus temporary session collection object path.") @@ -311,43 +313,8 @@ It returns t if not." (defconst secrets-interface-item-type-generic "org.freedesktop.Secret.Generic" "The default item type we are using.") -;; We cannot use introspection, because some servers, like -;; mate-keyring-daemon, don't provide relevant data. Once the dust -;; has settled, we shall assume the new interface, and get rid of the test. -(defconst secrets-struct-secret-content-type - (ignore-errors - (let ((content-type "text/plain") - (path (cadr - (dbus-call-method - :session secrets-service secrets-path - secrets-interface-service - "OpenSession" "plain" '(:variant "")))) - result) - ;; Create a dummy item. - (setq result - (dbus-call-method - :session secrets-service secrets-session-collection-path - secrets-interface-collection "CreateItem" - ;; Properties. - `(:array - (:dict-entry ,(concat secrets-interface-item ".Label") - (:variant " "))) - ;; Secret. - `(:struct :object-path ,path - (:array :signature "y") - ,(dbus-string-to-byte-array " ") - :string ,content-type) - ;; Don't replace. - nil)) - ;; Remove it. - (dbus-call-method - :session secrets-service (car result) - secrets-interface-item "Delete") - ;; Result. - `(,content-type))) - "The content_type of a secret struct. -It must be wrapped as list, because we add it via `append'. This -is an interface introduced in 2011.") +(defconst secrets-struct-secret-content-type "text/plain" + "The content_type of a secret struct.") (defconst secrets-interface-session "org.freedesktop.Secret.Session" "A session tracks state between the service and a client application.") @@ -696,13 +663,10 @@ The object path of the created item is returned." `((:dict-entry ,(concat secrets-interface-item ".Attributes") (:variant ,(append '(:array) props)))))) ;; Secret. - (append - `(:struct :object-path ,secrets-session-path - (:array :signature "y") ;; No parameters. - ,(dbus-string-to-byte-array password)) - ;; We add the content_type. In backward compatibility - ;; mode, nil is appended, which means nothing. - secrets-struct-secret-content-type) + `(:struct :object-path ,secrets-session-path + (:array :signature "y") ;; No parameters. + ,(dbus-string-to-byte-array password) + ,secrets-struct-secret-content-type) ;; Do not replace. Replace does not seem to work. nil)) (secrets-prompt (cadr result)) @@ -943,7 +907,7 @@ to their attributes." secrets-interface-service "CollectionDeleted" 'secrets-collection-handler) - ;; We shall inform, whether the secret service is enabled on this + ;; We shall inform, that the secret service is enabled on this ;; machine. (setq secrets-enabled t)) @@ -954,6 +918,7 @@ to their attributes." ;; * secrets-debug should be structured like auth-source-debug to ;; prevent leaking sensitive information. Right now I don't see ;; anything sensitive though. + ;; * Check, whether the dh-ietf1024-aes128-cbc-pkcs7 algorithm can be ;; used for the transfer of the secrets. Currently, we use the ;; plain algorithm. diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 4a22091d59b..676f609c24b 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -40,6 +40,7 @@ (require 'image) (require 'puny) (require 'url-cookie) +(require 'pixel-fill) (require 'text-property-search) (defgroup shr nil @@ -56,8 +57,15 @@ fit these criteria." :version "24.1" :type 'float) +(defcustom shr-allowed-images nil + "If non-nil, only images that match this regexp are displayed. +If nil, all URLs are allowed. Also see `shr-blocked-images'." + :version "29.1" + :type '(choice (const nil) regexp)) + (defcustom shr-blocked-images nil - "Images that have URLs matching this regexp will be blocked." + "Images that have URLs matching this regexp will be blocked. +If nil, no images are blocked. Also see `shr-allowed-images'." :version "24.1" :type '(choice (const nil) regexp)) @@ -162,6 +170,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-text)) + "Face used for rendering text." + :version "29.1") + (defface shr-strike-through '((t :strike-through t)) "Face for <s> elements." :version "24.1") @@ -183,6 +195,11 @@ temporarily blinks with this face." "Face for <abbr> elements." :version "27.1") +(defface shr-sup + '((t :height 0.8)) + "Face for <sup> and <sub> elements." + :version "29.1") + (defface shr-h1 '((t :height 1.3 :weight bold)) "Face for <h1> elements." @@ -231,7 +248,6 @@ and other things: (defvar shr-internal-width nil) (defvar shr-list-mode nil) (defvar shr-content-cache nil) -(defvar shr-kinsoku-shorten nil) (defvar shr-table-depth 0) (defvar shr-stylesheet nil) (defvar shr-base nil) @@ -246,24 +262,23 @@ and other things: (defvar shr-target-id nil "Target fragment identifier anchor.") - -(defvar shr-map - (let ((map (make-sparse-keymap))) - (define-key map "a" #'shr-show-alt-text) - (define-key map "i" #'shr-browse-image) - (define-key map "z" #'shr-zoom-image) - (define-key map [?\t] #'shr-next-link) - (define-key map [?\M-\t] #'shr-previous-link) - (define-key map [follow-link] 'mouse-face) - (define-key map [mouse-2] #'shr-browse-url) - (define-key map [C-down-mouse-1] #'shr-mouse-browse-url-new-window) - (define-key map "I" #'shr-insert-image) - (define-key map "w" #'shr-maybe-probe-and-copy-url) - (define-key map "u" #'shr-maybe-probe-and-copy-url) - (define-key map "v" #'shr-browse-url) - (define-key map "O" #'shr-save-contents) - (define-key map "\r" #'shr-browse-url) - map)) +(defvar shr--link-targets nil) + +(defvar-keymap shr-map + "a" #'shr-show-alt-text + "i" #'shr-browse-image + "z" #'shr-zoom-image + "TAB" #'shr-next-link + "C-M-i" #'shr-previous-link + "<follow-link>" 'mouse-face + "<mouse-2>" #'shr-browse-url + "C-<down-mouse-1>" #'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 + "RET" #'shr-browse-url) (defvar shr-image-map (let ((map (copy-keymap shr-map))) @@ -305,6 +320,18 @@ and other things: (or (not (zerop (fringe-columns 'right))) (not (zerop (fringe-columns 'left)))))) +(defun shr--window-width () + ;; Compute the width based on the window width. We need to + ;; adjust the available width for when the user disables + ;; the fringes, which will cause the display engine usurp + ;; one column for the continuation glyph. + (if (not shr-use-fonts) + (- (window-body-width) 1 + (if (shr--have-one-fringe-p) + 1 + 0)) + (pixel-fill-width))) + ;;;###autoload (defun shr-insert-document (dom) "Render the parsed document DOM into the current buffer. @@ -326,22 +353,9 @@ DOM should be a parse tree as generated by (if (not shr-use-fonts) shr-width (* shr-width (frame-char-width))) - ;; Compute the width based on the window width. We need to - ;; adjust the available width for when the user disables - ;; the fringes, which will cause the display engine usurp - ;; one column for the continuation glyph. - (if (not shr-use-fonts) - (- (window-body-width) 1 - (if (shr--have-one-fringe-p) - 1 - 0)) - (- (window-body-width nil t) - (* 2 (frame-char-width)) - (if (shr--have-one-fringe-p) - 0 - (* (frame-char-width) 2)) - 1)))) + (shr--window-width))) (max-specpdl-size max-specpdl-size) + (shr--link-targets nil) ;; `bidi-display-reordering' is supposed to be only used for ;; debugging purposes, but Shr's naïve filling algorithm ;; cannot cope with the complexity of RTL text in an LTR @@ -365,9 +379,22 @@ DOM should be a parse tree as generated by (shr-descend dom) (shr-fill-lines start (point)) (shr--remove-blank-lines-at-the-end start (point)) + (shr--set-target-ids shr--link-targets) (when shr-warning (message "%s" shr-warning)))) +(defun shr--set-target-ids (ids) + ;; If the buffer is empty, there's no point in setting targets. + (unless (zerop (buffer-size)) + ;; We may have several targets in the same place (if you have + ;; several <span id='foo'> things after one another). So group + ;; them by position. + (dolist (group (seq-group-by #'cdr ids)) + (let ((point (min (1- (point-max)) (car group)))) + (put-text-property point (1+ point) + 'shr-target-id + (mapcar #'car (cdr group))))))) + (defun shr--remove-blank-lines-at-the-end (start end) (save-restriction (save-excursion @@ -547,6 +574,12 @@ size, and full-buffer size." (shr-insert sub) (shr-descend sub)))) +(defun shr-image-blocked-p (url) + (or (and shr-blocked-images + (string-match shr-blocked-images url)) + (and shr-allowed-images + (not (string-match shr-allowed-images url))))) + (defun shr-indirect-call (tag-name dom &rest args) (let ((function (intern (concat "shr-tag-" (symbol-name tag-name)) obarray)) ;; Allow other packages to override (or provide) rendering @@ -577,7 +610,7 @@ size, and full-buffer size." (setq shr-warning "Not rendering the complete page because of too-deep nesting") (when style - (if (string-match "color\\|display\\|border-collapse" style) + (if (string-match-p "color\\|display\\|border-collapse" style) (setq shr-stylesheet (nconc (shr-parse-style style) shr-stylesheet)) (setq style nil))) @@ -596,16 +629,8 @@ size, and full-buffer size." (funcall function dom)) (t (shr-generic dom))) - (when-let* ((id (dom-attr dom 'id))) - ;; If the element was empty, we don't have anything to put the - ;; anchor on. So just insert a dummy character. - (when (= start (point)) - (if (not (bolp)) - (insert ? ) - (insert ? ) - (shr-mark-fill start)) - (put-text-property (1- (point)) (point) 'display "")) - (put-text-property (1- (point)) (point) 'shr-target-id id)) + (when-let ((id (dom-attr dom 'id))) + (push (cons id (point)) shr--link-targets)) ;; If style is set, then this node has set the color. (when style (shr-colorize-region @@ -619,43 +644,11 @@ size, and full-buffer size." (with-temp-buffer (let ((shr-indentation 0) (shr-start nil) - (shr-internal-width (- (window-body-width nil t) - (* 2 (frame-char-width)) - ;; Adjust the window width for when - ;; the user disables the fringes, - ;; which causes the display engine - ;; to usurp one column for the - ;; continuation glyph. - (if (and (null shr-width) - (not (shr--have-one-fringe-p))) - (* (frame-char-width) 2) - 0)))) + (shr-internal-width (shr--window-width))) (shr-insert text) (shr-fill-lines (point-min) (point-max)) (buffer-string))))) -(define-inline shr-char-breakable-p (char) - "Return non-nil if a line can be broken before and after CHAR." - (inline-quote (aref fill-find-break-point-function-table ,char))) -(define-inline shr-char-nospace-p (char) - "Return non-nil if no space is required before and after CHAR." - (inline-quote (aref fill-nospace-between-words-table ,char))) - -;; KINSOKU is a Japanese word meaning a rule that should not be violated. -;; In Emacs, it is a term used for characters, e.g. punctuation marks, -;; parentheses, and so on, that should not be placed in the beginning -;; of a line or the end of a line. -(define-inline shr-char-kinsoku-bol-p (char) - "Return non-nil if a line ought not to begin with CHAR." - (inline-letevals (char) - (inline-quote (and (not (eq ,char ?')) - (aref (char-category-set ,char) ?>))))) -(define-inline shr-char-kinsoku-eol-p (char) - "Return non-nil if a line ought not to end with CHAR." - (inline-quote (aref (char-category-set ,char) ?<))) -(unless (shr-char-kinsoku-bol-p (make-char 'japanese-jisx0208 33 35)) - (load "kinsoku" nil t)) - (defun shr-pixel-column () (if (not shr-use-fonts) (current-column) @@ -669,6 +662,7 @@ size, and full-buffer size." (car (window-text-pixel-size nil (line-beginning-position) (point)))))) (defun shr-pixel-region () + (declare (obsolete nil "29.1")) (- (shr-pixel-column) (save-excursion (goto-char (mark)) @@ -711,7 +705,7 @@ size, and full-buffer size." (goto-char (point-max))))) (t (let ((font-start (point))) - (when (and (string-match "\\`[ \t\n\r]" text) + (when (and (string-match-p "\\`[ \t\n\r]" text) (not (bolp)) (not (eq (char-after (1- (point))) ? ))) (insert " ")) @@ -739,7 +733,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) @@ -788,7 +782,7 @@ size, and full-buffer size." (while (not (eolp)) ;; We have to do some folding. First find the first ;; previous point suitable for folding. - (if (or (not (shr-find-fill-point (line-beginning-position))) + (if (or (not (pixel-fill-find-fill-point (line-beginning-position))) (= (point) start)) ;; We had unbreakable text (for this width), so just go to ;; the first space and carry on. @@ -829,84 +823,6 @@ size, and full-buffer size." (when (looking-at " $") (delete-region (point) (line-end-position))))))) -(defun shr-find-fill-point (start) - (let ((bp (point)) - (end (point)) - failed) - (while (not (or (setq failed (<= (point) start)) - (eq (preceding-char) ? ) - (eq (following-char) ? ) - (shr-char-breakable-p (preceding-char)) - (shr-char-breakable-p (following-char)) - (and (shr-char-kinsoku-bol-p (preceding-char)) - (shr-char-breakable-p (following-char)) - (not (shr-char-kinsoku-bol-p (following-char)))) - (shr-char-kinsoku-eol-p (following-char)) - (bolp))) - (backward-char 1)) - (if failed - ;; There's no breakable point, so we give it up. - (let (found) - (goto-char bp) - ;; Don't overflow the window edge, even if - ;; shr-kinsoku-shorten is nil. - (unless (or shr-kinsoku-shorten (null shr-width)) - (while (setq found (re-search-forward - "\\(\\c>\\)\\| \\|\\c<\\|\\c|" - (line-end-position) 'move))) - (if (and found - (not (match-beginning 1))) - (goto-char (match-beginning 0))))) - (or - (eolp) - ;; Don't put kinsoku-bol characters at the beginning of a line, - ;; or kinsoku-eol characters at the end of a line. - (cond - ;; Don't overflow the window edge, even if shr-kinsoku-shorten - ;; is nil. - ((or shr-kinsoku-shorten (null shr-width)) - (while (and (not (memq (preceding-char) (list ?\C-@ ?\n ? ))) - (or (shr-char-kinsoku-eol-p (preceding-char)) - (shr-char-kinsoku-bol-p (following-char)))) - (backward-char 1)) - (when (setq failed (<= (point) start)) - ;; There's no breakable point that doesn't violate kinsoku, - ;; so we look for the second best position. - (while (and (progn - (forward-char 1) - (<= (point) end)) - (progn - (setq bp (point)) - (shr-char-kinsoku-eol-p (following-char))))) - (goto-char bp))) - ((shr-char-kinsoku-eol-p (preceding-char)) - ;; Find backward the point where kinsoku-eol characters begin. - (let ((count 4)) - (while - (progn - (backward-char 1) - (and (> (setq count (1- count)) 0) - (not (memq (preceding-char) (list ?\C-@ ?\n ? ))) - (or (shr-char-kinsoku-eol-p (preceding-char)) - (shr-char-kinsoku-bol-p (following-char))))))) - (when (setq failed (<= (point) start)) - ;; There's no breakable point that doesn't violate kinsoku, - ;; so we go to the second best position. - (if (looking-at "\\(\\c<+\\)\\c<") - (goto-char (match-end 1)) - (forward-char 1)))) - ((shr-char-kinsoku-bol-p (following-char)) - ;; Find forward the point where kinsoku-bol characters end. - (let ((count 4)) - (while (progn - (forward-char 1) - (and (>= (setq count (1- count)) 0) - (shr-char-kinsoku-bol-p (following-char)) - (shr-char-breakable-p (following-char)))))))) - (when (eq (following-char) ? ) - (forward-char 1)))) - (not failed))) - (defun shr-parse-base (url) ;; Always chop off anchors. (when (string-match "#.*" url) @@ -941,15 +857,13 @@ size, and full-buffer size." shr-base)) (when (zerop (length url)) (setq url nil)) - ;; Strip leading/trailing whitespace - (and url (string-match "\\`\\s-+" url) - (setq url (substring url (match-end 0)))) - (and url (string-match "\\s-+\\'" url) - (setq url (substring url 0 (match-beginning 0)))) + ;; Strip leading/trailing whitespace. + (when url + (setq url (string-trim url))) (cond ((zerop (length url)) (nth 3 base)) ((or (not base) - (string-match "\\`[a-z]*:" url)) + (string-match-p "\\`[a-z]*:" url)) ;; Absolute or empty URI url) ((eq (aref url 0) ?/) @@ -986,22 +900,6 @@ size, and full-buffer size." (looking-at " *$"))) ;; We're already at a new paragraph; do nothing. ) - ((and (not (bolp)) - (save-excursion - (beginning-of-line) - (looking-at " *$")) - (save-excursion - (forward-line -1) - (looking-at " *$")) - ;; Check all chars on the current line and see whether - ;; they're all placeholders. - (cl-loop for pos from (line-beginning-position) upto (1- (point)) - unless (get-text-property pos 'shr-target-id) - return nil - finally return t)) - ;; We have some invisible markers from <div id="foo"></div>; - ;; do nothing. - ) ((and prefix (= prefix (- (point) (line-beginning-position)))) ;; Do nothing; we're at the start of a <li>. @@ -1134,14 +1032,14 @@ the mouse click event." (let ((param (match-string 4 data)) (payload (url-unhex-string (match-string 5 data)))) (when (and param - (string-match "^.*\\(;[ \t]*base64\\)$" param)) + (string-match-p "^.*\\(;[ \t]*base64\\)$" param)) (setq payload (ignore-errors (base64-decode-string payload)))) payload))) ;; Behind display-graphic-p test. (declare-function image-size "image.c" (spec &optional pixels frame)) -(declare-function image-animate "image" (image &optional index limit)) +(declare-function image-animate "image" (image &optional index limit position)) (defun shr-put-image (spec alt &optional flags) "Insert image SPEC with a string ALT. Return image. @@ -1178,13 +1076,14 @@ element is the data blob and the second element is the content-type." (when (and (> (current-column) 0) (> (car (image-size image t)) 400)) (insert "\n")) - (if (eq size 'original) - (insert-sliced-image image (or alt "*") nil 20 1) - (insert-image image (or alt "*"))) - (put-text-property start (point) 'image-size size) - (when (and shr-image-animate - (cdr (image-multi-frame-p image))) - (image-animate image nil 60))) + (let ((image-pos (point))) + (if (eq size 'original) + (insert-sliced-image image (or alt "*") nil 20 1) + (insert-image image (or alt "*"))) + (put-text-property start (point) 'image-size size) + (when (and shr-image-animate + (cdr (image-multi-frame-p image))) + (image-animate image nil 60 image-pos)))) image) (insert (or alt "")))) @@ -1270,7 +1169,7 @@ Return a string with image data." ;; SVG images may contain references to further images that we may ;; want to block. So special-case these by parsing the XML data ;; and remove anything that looks like a blocked bit. - (when (and shr-blocked-images + (when (and (or shr-allowed-images shr-blocked-images) (eq content-type 'image/svg+xml)) (setq data ;; Note that libxml2 doesn't parse everything perfectly, @@ -1449,8 +1348,7 @@ ones, in case fg and bg are nil." ((or (not (eq (dom-tag elem) 'image)) ;; Filter out blocked elements inside the SVG image. (not (setq url (dom-attr elem ':xlink:href))) - (not shr-blocked-images) - (not (string-match shr-blocked-images url))) + (not (shr-image-blocked-p url))) (insert " ") (shr-dom-print elem))))) (insert (format "</%s>" (dom-tag dom)))) @@ -1467,12 +1365,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) @@ -1534,9 +1434,7 @@ ones, in case fg and bg are nil." (defun shr-parse-style (style) (when style - (save-match-data - (when (string-match "\n" style) - (setq style (replace-match " " t t style)))) + (setq style (replace-regexp-in-string "\n" " " style)) (let ((plist nil)) (dolist (elem (split-string style ";")) (when elem @@ -1565,13 +1463,9 @@ ones, in case fg and bg are nil." (start (point)) shr-start) (shr-generic dom) - (when-let* ((id (unless (dom-attr dom 'id) ; Handled by `shr-descend'. - (dom-attr dom 'name)))) ; Obsolete since HTML5. - ;; We have an empty element, so just insert... something. - (when (= start (point)) - (insert ?\s) - (put-text-property (1- (point)) (point) 'display "")) - (put-text-property start (1+ start) 'shr-target-id id)) + (when-let* ((id (and (not (dom-attr dom 'id)) ; Handled by `shr-descend'. + (dom-attr dom 'name)))) ; Obsolete since HTML5. + (push (cons id (point)) shr--link-targets)) (when url (shr-urlify (or shr-start start) (shr-expand-url url) title)))) @@ -1594,7 +1488,7 @@ ones, in case fg and bg are nil." (let ((start (point)) url multimedia image) (when-let* ((type (dom-attr dom 'type))) - (when (string-match "\\`image/svg" type) + (when (string-match-p "\\`image/svg" type) (setq url (dom-attr dom 'data) image t))) (dolist (child (dom-non-text-children dom)) @@ -1630,6 +1524,14 @@ url if no type is specified. The value should be a float in the range 0.0 to :version "24.4" :type '(alist :key-type regexp :value-type float)) +(defcustom shr-use-xwidgets-for-media nil + "If non-nil, use xwidgets to display video and audio elements. +This also depends on Emacs being built with xwidgets capability. +Note that this is experimental, and may lead to instability on +some platforms." + :type 'boolean + :version "29.1") + (defun shr--get-media-pref (elem) "Determine the preference for ELEM. The preference is a float determined from `shr-prefer-media-type'." @@ -1666,16 +1568,39 @@ The preference is a float determined from `shr-prefer-media-type'." pref (cdr ret))))))))) (cons url pref)) +(declare-function xwidget-webkit-execute-script "xwidget.c" + (xwidget script &optional callback)) + (defun shr-tag-video (dom) (let ((image (dom-attr dom 'poster)) (url (dom-attr dom 'src)) (start (point))) (unless url (setq url (car (shr--extract-best-source dom)))) - (if (> (length image) 0) - (shr-indirect-call 'img nil image) - (shr-insert " [video] ")) - (shr-urlify start (shr-expand-url url)))) + (if (and shr-use-xwidgets-for-media + (fboundp 'make-xwidget)) + ;; Play the video. + (progn + (require 'xwidget) + (let ((widget (make-xwidget + 'webkit + "Video" + (truncate (* (window-pixel-width) 0.8)) + (truncate (* (window-pixel-width) 0.8 0.75))))) + (insert + (propertize + " [video] " + 'display (list 'xwidget :xwidget widget))) + (xwidget-webkit-execute-script + widget (format "document.body.innerHTML = %S;" + (format + "<style>body { margin: 0px; }</style><div style='background: black; height: 100%%; display: flex; align-items: center; justify-content: center;'><video autoplay loop muted controls style='max-width: 100%%; max-height: 100%%;'><source src=%S type='video/mp4'></source></video></div>" + url))))) + ;; No xwidgets. + (if (> (length image) 0) + (shr-indirect-call 'img nil image) + (shr-insert " [video] ")) + (shr-urlify start (shr-expand-url url))))) (defun shr-tag-audio (dom) (let ((url (dom-attr dom 'src)) @@ -1725,8 +1650,7 @@ The preference is a float determined from `shr-prefer-media-type'." (funcall shr-put-image-function image alt (list :width width :height height))))) ((or shr-inhibit-images - (and shr-blocked-images - (string-match shr-blocked-images url))) + (shr-image-blocked-p url)) (setq shr-start (point)) (shr-insert alt)) ((and (not shr-ignore-cache) @@ -2038,7 +1962,8 @@ BASE is the URL of the HTML being rendered." (setq dom (or (dom-child-by-tag dom 'tbody) dom)) (let* ((shr-inhibit-images t) (shr-table-depth (1+ shr-table-depth)) - (shr-kinsoku-shorten t) + ;; Fill hard in CJK languages. + (pixel-fill-respect-kinsoku nil) ;; Find all suggested widths. (columns (shr-column-specs dom)) ;; Compute how many pixels wide each TD should be. @@ -2532,9 +2457,10 @@ flags that control whether to collect or render objects." (style (dom-attr dom 'style)) (shr-stylesheet shr-stylesheet) (max-width 0) + (shr--link-targets nil) natural-width) (when style - (setq style (and (string-match "color" style) + (setq style (and (string-search "color" style) (shr-parse-style style)))) (when bgcolor (setq style (nconc (list (cons 'background-color bgcolor)) @@ -2573,6 +2499,7 @@ flags that control whether to collect or render objects." (end-of-line) (point))) (goto-char (point-min)) + (shr--set-target-ids shr--link-targets) (list max-width natural-width (count-lines (point-min) (point-max)) diff --git a/lisp/net/soap-client.el b/lisp/net/soap-client.el index b4aed279819..6f915e97452 100644 --- a/lisp/net/soap-client.el +++ b/lisp/net/soap-client.el @@ -718,10 +718,9 @@ representing leap seconds." second) minute hour day month year second-fraction datatype time-zone) (let ((time - (apply - #'encode-time (list - (if new-decode-time new-decode-time-second second) - minute hour day month year nil nil time-zone)))) + (encode-time (list + (if new-decode-time new-decode-time-second second) + minute hour day month year nil nil time-zone)))) (if new-decode-time (with-no-warnings (decode-time time nil t)) (decode-time time)))))) diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 362a258f43d..b662e0bf6cf 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) @@ -191,11 +192,10 @@ It is used for TCP/IP devices." ;; It must be a `defsubst' in order to push the whole code into ;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading. ;;;###tramp-autoload -(defsubst tramp-adb-file-name-p (filename) - "Check if it's a FILENAME for ADB." - (and (tramp-tramp-file-p filename) - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-adb-method))) +(defsubst tramp-adb-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME for ADB." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (string= (tramp-file-name-method vec) tramp-adb-method))) ;;;###tramp-autoload (defun tramp-adb-file-name-handler (operation &rest args) @@ -306,7 +306,7 @@ arguments to pass to the OPERATION." (directory &optional full match nosort id-format count) "Like `directory-files-and-attributes' for Tramp files." (unless (file-exists-p directory) - (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) (when (file-directory-p directory) (with-parsed-tramp-file-name (expand-file-name directory) nil (copy-tree @@ -415,6 +415,8 @@ Emacs dired can't find files." (defun tramp-adb-ls-output-time-less-p (a b) "Sort \"ls\" output by time, descending." (let (time-a time-b) + ;; Once we can assume Emacs 27 or later, the two calls + ;; (apply #'encode-time X) can be replaced by (encode-time X). (string-match tramp-adb-ls-date-regexp a) (setq time-a (apply #'encode-time (parse-time-string (match-string 0 a)))) (string-match tramp-adb-ls-date-regexp b) @@ -499,7 +501,7 @@ Emacs dired can't find files." "Like `file-local-copy' for Tramp files." (with-parsed-tramp-file-name filename nil (unless (file-exists-p (file-truename filename)) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (let ((tmpfile (tramp-compat-make-temp-file filename))) (with-tramp-progress-reporter v 3 (format "Fetching %s to tmp file %s" filename tmpfile) @@ -591,8 +593,7 @@ Emacs dired can't find files." ;; Set file modification time. (when (or (eq visit t) (stringp visit)) (set-visited-file-modtime - (or (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (or (file-attribute-modification-time (file-attributes filename)) (current-time)))) ;; Unlock file. @@ -660,7 +661,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (jka-compr-inhibit t)) (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) @@ -720,8 +721,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when keep-date (tramp-compat-set-file-times newname - (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (file-attribute-modification-time (file-attributes filename)) (unless ok-if-already-exists 'nofollow))))) (defun tramp-adb-handle-rename-file @@ -742,7 +742,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (jka-compr-inhibit t)) (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) @@ -1349,22 +1349,18 @@ connection if a previous connection has died for some reason." ;; Mark it as connected. (tramp-set-connection-property p "connected" t))))))) -;;; Default connection-local variables for Tramp: -;; `connection-local-set-profile-variables' and -;; `connection-local-set-profiles' exists since Emacs 26.1. +;;; Default connection-local variables for Tramp. (defconst tramp-adb-connection-local-default-shell-variables '((shell-file-name . "/system/bin/sh") (shell-command-switch . "-c")) "Default connection-local shell variables for remote adb connections.") -(tramp-compat-funcall - 'connection-local-set-profile-variables +(connection-local-set-profile-variables 'tramp-adb-connection-local-default-shell-profile tramp-adb-connection-local-default-shell-variables) (with-eval-after-load 'shell - (tramp-compat-funcall - 'connection-local-set-profiles + (connection-local-set-profiles `(:application tramp :protocol ,tramp-adb-method) 'tramp-adb-connection-local-default-shell-profile)) diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index bd0f82cbad6..bba94f2743c 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -54,6 +54,7 @@ ;; * ".ar" - UNIX archiver formats ;; * ".cab", ".CAB" - Microsoft Windows cabinets ;; * ".cpio" - CPIO archives +;; * ".crate" - Cargo (Rust) packages ;; * ".deb" - Debian packages ;; * ".depot" - HP-UX SD depots ;; * ".exe" - Self extracting Microsoft Windows EXE files @@ -141,6 +142,7 @@ "ar" ;; UNIX archiver formats. "cab" "CAB" ;; Microsoft Windows cabinets. "cpio" ;; CPIO archives. + "crate" ;; Cargo (Rust) packages. Not in libarchive testsuite. "deb" ;; Debian packages. Not in libarchive testsuite. "depot" ;; HP-UX SD depot. Not in libarchive testsuite. "exe" ;; Self extracting Microsoft Windows EXE files. @@ -211,7 +213,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. @@ -572,9 +575,8 @@ offered." preserve-uid-gid preserve-extended-attributes) "Like `copy-file' for file archives." (when (tramp-archive-file-name-p newname) - (tramp-error - (tramp-archive-dissect-file-name newname) 'file-error - "Permission denied: %s" newname)) + (tramp-compat-permission-denied + (tramp-archive-dissect-file-name newname) newname)) (copy-file (tramp-archive-gvfs-file-name filename) newname ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes)) @@ -618,7 +620,7 @@ offered." (defun tramp-archive-handle-file-system-info (filename) "Like `file-system-info' for file archives." (with-parsed-tramp-archive-file-name filename nil - (list (tramp-compat-file-attribute-size (file-attributes archive)) 0 0))) + (list (file-attribute-size (file-attributes archive)) 0 0))) (defun tramp-archive-handle-file-truename (filename) "Like `file-truename' for file archives." @@ -658,7 +660,7 @@ offered." ;; mounted directory, it is returned as it. Not what we want. (with-parsed-tramp-archive-file-name default-directory nil (let ((default-directory (file-name-directory archive))) - (tramp-compat-temporary-file-directory-function)))) + (temporary-file-directory)))) (defun tramp-archive-handle-not-implemented (operation &rest args) "Generic handler for operations not implemented for file archives." diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index f1c656ec209..b909c5706d6 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -49,8 +49,6 @@ ;; an open connection. Examples: "scripts" keeps shell script ;; definitions already sent to the remote shell, "last-cmd-time" is ;; the time stamp a command has been sent to the remote process. -;; "lock-pid" is the timestamp a (network) process is created, it is -;; used instead of the pid in file locks. ;; ;; - The key is nil. These are temporary properties related to the ;; local machine. Examples: "parse-passwd" and "parse-group" keep @@ -101,8 +99,7 @@ details see the info pages." (choice :tag " Value" sexp)))) ;;;###tramp-autoload -(defcustom tramp-persistency-file-name - (expand-file-name (locate-user-emacs-file "tramp")) +(defcustom tramp-persistency-file-name (locate-user-emacs-file "tramp") "File which keeps connection history for Tramp connections." :group 'tramp :type 'file) @@ -225,7 +222,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-cmds.el b/lisp/net/tramp-cmds.el index 63eab1b31a1..2eaebebed9f 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -67,7 +67,7 @@ SYNTAX can be one of the symbols `default' (default), nil (mapcar (lambda (x) - (with-current-buffer x (when (tramp-tramp-file-p default-directory) x))) + (when (tramp-tramp-file-p (tramp-get-default-directory x)) x)) (buffer-list)))) ;;;###tramp-autoload @@ -593,9 +593,8 @@ buffer in your bug report. (defun tramp-reporter-dump-variable (varsym mailbuf) "Pretty-print the value of the variable in symbol VARSYM." - (let* ((reporter-eval-buffer (symbol-value 'reporter-eval-buffer)) - (val (with-current-buffer reporter-eval-buffer - (symbol-value varsym)))) + (when-let ((reporter-eval-buffer reporter-eval-buffer) + (val (buffer-local-value varsym reporter-eval-buffer))) (if (hash-table-p val) ;; Pretty print the cache. diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index fbc3d684ce8..1936d2af1a6 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -23,17 +23,12 @@ ;;; Commentary: -;; Tramp's main Emacs version for development is Emacs 28. This -;; package provides compatibility functions for Emacs 25, Emacs 26 and -;; Emacs 27. +;; Tramp's main Emacs version for development is Emacs 29. This +;; package provides compatibility functions for Emacs 26, Emacs 27 and +;; Emacs 28. ;;; Code: -;; In Emacs 25, `tramp-unload-file-name-handlers' is not autoloaded. -;; So we declare it here in order to avoid recursive load. This will -;; be overwritten in tramp.el. -(defun tramp-unload-file-name-handlers () ".") - (require 'auth-source) (require 'format-spec) (require 'ls-lisp) ;; Due to `tramp-handle-insert-directory'. @@ -42,8 +37,6 @@ (require 'subr-x) (declare-function tramp-error "tramp") -;; `temporary-file-directory' as function is introduced with Emacs 26.1. -(declare-function tramp-handle-temporary-file-directory "tramp") (declare-function tramp-tramp-file-p "tramp") (defvar tramp-temp-name-prefix) @@ -83,133 +76,19 @@ Add the extension of F, if existing." tramp-temp-name-prefix tramp-compat-temporary-file-directory) dir-flag (file-name-extension f t))) -;; `temporary-file-directory' as function is introduced with Emacs 26.1. -(defalias 'tramp-compat-temporary-file-directory-function - (if (fboundp 'temporary-file-directory) - #'temporary-file-directory - #'tramp-handle-temporary-file-directory)) - -;; `file-attribute-*' are introduced in Emacs 26.1. - -(defalias 'tramp-compat-file-attribute-type - (if (fboundp 'file-attribute-type) - #'file-attribute-type - (lambda (attributes) - "The type field in ATTRIBUTES returned by `file-attributes'. -The value is either t for directory, string (name linked to) for -symbolic link, or nil." - (nth 0 attributes)))) - -(defalias 'tramp-compat-file-attribute-link-number - (if (fboundp 'file-attribute-link-number) - #'file-attribute-link-number - (lambda (attributes) - "Return the number of links in ATTRIBUTES returned by `file-attributes'." - (nth 1 attributes)))) - -(defalias 'tramp-compat-file-attribute-user-id - (if (fboundp 'file-attribute-user-id) - #'file-attribute-user-id - (lambda (attributes) - "The UID field in ATTRIBUTES returned by `file-attributes'. -This is either a string or a number. If a string value cannot be -looked up, a numeric value, either an integer or a float, is -returned." - (nth 2 attributes)))) - -(defalias 'tramp-compat-file-attribute-group-id - (if (fboundp 'file-attribute-group-id) - #'file-attribute-group-id - (lambda (attributes) - "The GID field in ATTRIBUTES returned by `file-attributes'. -This is either a string or a number. If a string value cannot be -looked up, a numeric value, either an integer or a float, is -returned." - (nth 3 attributes)))) - -(defalias 'tramp-compat-file-attribute-access-time - (if (fboundp 'file-attribute-access-time) - #'file-attribute-access-time - (lambda (attributes) - "The last access time in ATTRIBUTES returned by `file-attributes'. -This a Lisp timestamp in the style of `current-time'." - (nth 4 attributes)))) - -(defalias 'tramp-compat-file-attribute-modification-time - (if (fboundp 'file-attribute-modification-time) - #'file-attribute-modification-time - (lambda (attributes) - "The modification time in ATTRIBUTES returned by `file-attributes'. -This is the time of the last change to the file's contents, and -is a Lisp timestamp in the style of `current-time'." - (nth 5 attributes)))) - -(defalias 'tramp-compat-file-attribute-status-change-time - (if (fboundp 'file-attribute-status-change-time) - #'file-attribute-status-change-time - (lambda (attributes) - "The status modification time in ATTRIBUTES returned by `file-attributes'. -This is the time of last change to the file's attributes: owner -and group, access mode bits, etc., and is a Lisp timestamp in the -style of `current-time'." - (nth 6 attributes)))) - -(defalias 'tramp-compat-file-attribute-size - (if (fboundp 'file-attribute-size) - #'file-attribute-size - (lambda (attributes) - "The size (in bytes) in ATTRIBUTES returned by `file-attributes'. -If the size is too large for a fixnum, this is a bignum in Emacs 27 -and later, and is a float in Emacs 26 and earlier." - (nth 7 attributes)))) - -(defalias 'tramp-compat-file-attribute-modes - (if (fboundp 'file-attribute-modes) - #'file-attribute-modes - (lambda (attributes) - "The file modes in ATTRIBUTES returned by `file-attributes'. -This is a string of ten letters or dashes as in ls -l." - (nth 8 attributes)))) - -;; `file-missing' is introduced in Emacs 26.1. -(defconst tramp-file-missing - (if (get 'file-missing 'error-conditions) 'file-missing 'file-error) - "The error symbol for the `file-missing' error.") - -(defsubst tramp-compat-file-missing (vec file) - "Emit the `file-missing' error." - (if (get 'file-missing 'error-conditions) - (tramp-error vec tramp-file-missing file) - (tramp-error vec tramp-file-missing "No such file or directory: %s" file))) - -;; `file-local-name', `file-name-quoted-p', `file-name-quote' and -;; `file-name-unquote' are introduced in Emacs 26.1. -(defalias 'tramp-compat-file-local-name - (if (fboundp 'file-local-name) - #'file-local-name - (lambda (name) - "Return the local name component of NAME. -It returns a file name which can be used directly as argument of -`process-file', `start-file-process', or `shell-command'." - (or (file-remote-p name 'localname) name)))) - ;; `file-name-quoted-p', `file-name-quote' and `file-name-unquote' got ;; a second argument in Emacs 27.1. (defalias 'tramp-compat-file-name-quoted-p - (if (and - (fboundp 'file-name-quoted-p) - (equal (tramp-compat-funcall 'func-arity #'file-name-quoted-p) '(1 . 2))) + (if (equal (func-arity #'file-name-quoted-p) '(1 . 2)) #'file-name-quoted-p (lambda (name &optional top) "Whether NAME is quoted with prefix \"/:\". If NAME is a remote file name and TOP is nil, check the local part of NAME." (let ((file-name-handler-alist (unless top file-name-handler-alist))) - (string-prefix-p "/:" (tramp-compat-file-local-name name)))))) + (string-prefix-p "/:" (file-local-name name)))))) (defalias 'tramp-compat-file-name-quote - (if (and - (fboundp 'file-name-quote) - (equal (tramp-compat-funcall 'func-arity #'file-name-quote) '(1 . 2))) + (if (equal (func-arity #'file-name-quote) '(1 . 2)) #'file-name-quote (lambda (name &optional top) "Add the quotation prefix \"/:\" to file NAME. @@ -217,20 +96,17 @@ If NAME is a remote file name and TOP is nil, the local part of NAME is quoted." (let ((file-name-handler-alist (unless top file-name-handler-alist))) (if (tramp-compat-file-name-quoted-p name top) name - (concat - (file-remote-p name) "/:" (tramp-compat-file-local-name name))))))) + (concat (file-remote-p name) "/:" (file-local-name name))))))) (defalias 'tramp-compat-file-name-unquote - (if (and - (fboundp 'file-name-unquote) - (equal (tramp-compat-funcall 'func-arity #'file-name-unquote) '(1 . 2))) + (if (equal (func-arity #'file-name-unquote) '(1 . 2)) #'file-name-unquote (lambda (name &optional top) "Remove quotation prefix \"/:\" from file NAME. If NAME is a remote file name and TOP is nil, the local part of NAME is unquoted." (let* ((file-name-handler-alist (unless top file-name-handler-alist)) - (localname (tramp-compat-file-local-name name))) + (localname (file-local-name name))) (when (tramp-compat-file-name-quoted-p localname top) (setq localname (if (= (length localname) 2) "/" (substring localname 2)))) @@ -288,8 +164,7 @@ A nil value for either argument stands for the current time." ;; `progress-reporter-update' got argument SUFFIX in Emacs 27.1. (defalias 'tramp-compat-progress-reporter-update - (if (equal (tramp-compat-funcall 'func-arity #'progress-reporter-update) - '(1 . 3)) + (if (equal (func-arity #'progress-reporter-update) '(1 . 3)) #'progress-reporter-update (lambda (reporter &optional value _suffix) (progress-reporter-update reporter value)))) @@ -306,19 +181,19 @@ CONDITION can also be a list of error conditions." ;; `file-modes', `set-file-modes' and `set-file-times' got argument ;; FLAG in Emacs 28.1. (defalias 'tramp-compat-file-modes - (if (equal (tramp-compat-funcall 'func-arity #'file-modes) '(1 . 2)) + (if (equal (func-arity #'file-modes) '(1 . 2)) #'file-modes (lambda (filename &optional _flag) (file-modes filename)))) (defalias 'tramp-compat-set-file-modes - (if (equal (tramp-compat-funcall 'func-arity #'set-file-modes) '(2 . 3)) + (if (equal (func-arity #'set-file-modes) '(2 . 3)) #'set-file-modes (lambda (filename mode &optional _flag) (set-file-modes filename mode)))) (defalias 'tramp-compat-set-file-times - (if (equal (tramp-compat-funcall 'func-arity #'set-file-times) '(1 . 3)) + (if (equal (func-arity #'set-file-times) '(1 . 3)) #'set-file-times (lambda (filename &optional timestamp _flag) (set-file-times filename timestamp)))) @@ -326,14 +201,13 @@ CONDITION can also be a list of error conditions." ;; `directory-files' and `directory-files-and-attributes' got argument ;; COUNT in Emacs 28.1. (defalias 'tramp-compat-directory-files - (if (equal (tramp-compat-funcall 'func-arity #'directory-files) '(1 . 5)) + (if (equal (func-arity #'directory-files) '(1 . 5)) #'directory-files (lambda (directory &optional full match nosort _count) (directory-files directory full match nosort)))) (defalias 'tramp-compat-directory-files-and-attributes - (if (equal (tramp-compat-funcall 'func-arity #'directory-files-and-attributes) - '(1 . 6)) + (if (equal (func-arity #'directory-files-and-attributes) '(1 . 6)) #'directory-files-and-attributes (lambda (directory &optional full match nosort id-format _count) (directory-files-and-attributes directory full match nosort id-format)))) @@ -398,6 +272,17 @@ CONDITION can also be a list of error conditions." (car components)) (cdr components))))))) +;; `permission-denied' is introduced in Emacs 29.1. +(defconst tramp-permission-denied + (if (get 'permission-denied 'error-conditions) 'permission-denied 'file-error) + "The error symbol for the `permission-denied' error.") + +(defsubst tramp-compat-permission-denied (vec file) + "Emit the `permission-denied' error." + (if (get 'permission-denied 'error-conditions) + (tramp-error vec tramp-permission-denied file) + (tramp-error vec tramp-permission-denied "Permission denied: %s" file))) + (dolist (elt (all-completions "tramp-compat-" obarray 'functionp)) (put (intern elt) 'tramp-suppress-trace t)) @@ -410,8 +295,6 @@ CONDITION can also be a list of error conditions." ;;; TODO: ;; -;; * `func-arity' exists since Emacs 26.1. -;; ;; * Starting with Emacs 27.1, there's no need to escape open ;; parentheses with a backslash in docstrings anymore. ;; diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index 5def3a4137c..dd2ba23f0f0 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) @@ -294,8 +295,8 @@ arguments to pass to the OPERATION." (defun tramp-crypt-config-file-name (vec) "Return the encfs config file name for VEC." (expand-file-name - (concat "tramp-" (tramp-file-name-host vec) tramp-crypt-encfs-config) - user-emacs-directory)) + (locate-user-emacs-file + (concat "tramp-" (tramp-file-name-host vec) tramp-crypt-encfs-config)))) (defun tramp-crypt-maybe-open-connection (vec) "Maybe open a connection VEC. @@ -322,7 +323,7 @@ connection if a previous connection has died for some reason." tramp-crypt-encfs-config (tramp-crypt-get-remote-dir vec))) (local-config (tramp-crypt-config-file-name vec))) ;; There is no local encfs6 config file. - (when (not (file-exists-p local-config)) + (unless (file-exists-p local-config) (if (and tramp-crypt-save-encfs-config-remote (file-exists-p remote-config)) ;; Copy remote encfs6 config file if possible. @@ -485,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.")) @@ -596,7 +598,7 @@ absolute file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) @@ -698,7 +700,7 @@ absolute file names." (directory &optional full match nosort count) "Like `directory-files' for Tramp files." (unless (file-exists-p directory) - (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) (when (file-directory-p directory) (setq directory (file-name-as-directory (expand-file-name directory))) (let* (tramp-crypt-enabled diff --git a/lisp/net/tramp-ftp.el b/lisp/net/tramp-ftp.el index 11ccdc8a4c9..f78c08ec415 100644 --- a/lisp/net/tramp-ftp.el +++ b/lisp/net/tramp-ftp.el @@ -175,11 +175,10 @@ pass to the OPERATION." ;; It must be a `defsubst' in order to push the whole code into ;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading. ;;;###tramp-autoload -(defsubst tramp-ftp-file-name-p (filename) - "Check if it's a FILENAME that should be forwarded to Ange-FTP." - (and (tramp-tramp-file-p filename) - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-ftp-method))) +(defsubst tramp-ftp-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME that should be forwarded to Ange-FTP." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (string= (tramp-file-name-method vec) tramp-ftp-method))) ;;;###tramp-autoload (tramp--with-startup diff --git a/lisp/net/tramp-fuse.el b/lisp/net/tramp-fuse.el index c359082dc1e..cb270be68fb 100644 --- a/lisp/net/tramp-fuse.el +++ b/lisp/net/tramp-fuse.el @@ -48,7 +48,7 @@ (directory &optional full match nosort count) "Like `directory-files' for Tramp files." (unless (file-exists-p directory) - (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) (when (file-directory-p directory) (setq directory (file-name-as-directory (expand-file-name directory))) (with-parsed-tramp-file-name directory nil @@ -107,12 +107,6 @@ (unless (string-match-p elt item) (throw 'match nil))) (setq result (cons (concat item "/") result)))))))))) -(defun tramp-fuse-handle-file-readable-p (filename) - "Like `file-readable-p' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-tramp-file-property v localname "file-readable-p" - (file-readable-p (tramp-fuse-local-file-name filename))))) - ;; This function isn't used. (defun tramp-fuse-handle-insert-directory (filename switches &optional wildcard full-directory-p) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index cab912bd93a..292da5a1669 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -122,10 +122,7 @@ (autoload 'zeroconf-init "zeroconf") (tramp-compat-funcall 'dbus-get-unique-name :system) (tramp-compat-funcall 'dbus-get-unique-name :session) - (or ;; Until Emacs 25, `process-attributes' could crash Emacs - ;; for some processes. Better we don't check. - (<= emacs-major-version 25) - (tramp-process-running-p "gvfs-fuse-daemon") + (or (tramp-process-running-p "gvfs-fuse-daemon") (tramp-process-running-p "gvfsd-fuse")))) "Non-nil when GVFS is available.") @@ -471,8 +468,7 @@ It has been changed in GVFS 1.14.") ;; </method> ;; </interface> -;; The basic structure for GNOME Online Accounts. We use a list :type, -;; in order to be compatible with Emacs 25. +;; The basic structure for GNOME Online Accounts. (cl-defstruct (tramp-goa-account (:type list) :named) method user host port) ;;;###tramp-autoload @@ -672,8 +668,7 @@ It has been changed in GVFS 1.14.") ;; STRING key (always-call-mount, is-removable, ...) ;; VARIANT value (boolean?) -;; The basic structure for media devices. We use a list :type, in -;; order to be compatible with Emacs 25. +;; The basic structure for media devices. (cl-defstruct (tramp-media-device (:type list) :named) method host port) ;; "gvfs-<command>" utilities have been deprecated in GVFS 1.31.1. We @@ -749,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) @@ -834,12 +830,11 @@ Operations not mentioned here will be handled by the default Emacs primitives.") ;; It must be a `defsubst' in order to push the whole code into ;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading. ;;;###tramp-autoload -(defsubst tramp-gvfs-file-name-p (filename) - "Check if it's a FILENAME handled by the GVFS daemon." - (and (tramp-tramp-file-p filename) - (let ((method - (tramp-file-name-method (tramp-dissect-file-name filename)))) - (and (stringp method) (member method tramp-gvfs-methods))))) +(defsubst tramp-gvfs-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME handled by the GVFS daemon." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (let ((method (tramp-file-name-method vec))) + (and (stringp method) (member method tramp-gvfs-methods))))) ;;;###tramp-autoload (defun tramp-gvfs-file-name-handler (operation &rest args) @@ -1002,7 +997,7 @@ file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) @@ -1102,8 +1097,7 @@ file names." (tramp-skeleton-delete-directory directory recursive trash (if (and recursive (not (file-symlink-p directory))) (mapc (lambda (file) - (if (eq t (tramp-compat-file-attribute-type - (file-attributes file))) + (if (eq t (file-attribute-type (file-attributes file))) (delete-directory file recursive) (delete-file file))) (directory-files @@ -1155,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 "/..". @@ -1178,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." @@ -1463,7 +1456,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." `file-notify' events." (let* ((events (process-get proc 'events)) (rest-string (process-get proc 'rest-string)) - (dd (with-current-buffer (process-buffer proc) default-directory)) + (dd (tramp-get-default-directory (process-buffer proc))) (ddu (regexp-quote (tramp-gvfs-url-file-name dd)))) (when rest-string (tramp-message proc 10 "Previous string:\n%s" rest-string)) @@ -1528,11 +1521,13 @@ If FILE-SYSTEM is non-nil, return file system attributes." (size (cdr (assoc "filesystem::size" attr))) (used (cdr (assoc "filesystem::used" attr))) (free (cdr (assoc "filesystem::free" attr)))) - (when (or size used free) - (list (string-to-number (or size "0")) - (string-to-number (or free "0")) - (- (string-to-number (or size "0")) - (string-to-number (or used "0")))))))) + (when (or size free) + (list (and size (string-to-number size)) + (and free (string-to-number free)) + ;; "mtp" connections do not return "filesystem::used". + (or (and size used + (- (string-to-number size) (string-to-number used))) + (and free (string-to-number free)))))))) (defun tramp-gvfs-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." @@ -1602,7 +1597,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." "%s" (if (or (null time) (tramp-compat-time-equal-p time tramp-time-doesnt-exist) (tramp-compat-time-equal-p time tramp-time-dont-know)) - (current-time) + nil time))))) (defun tramp-gvfs-handle-get-remote-uid (vec id-format) @@ -1614,9 +1609,8 @@ ID-FORMAT valid values are `string' and `integer'." (tramp-get-connection-property (tramp-get-process vec) "share" (tramp-get-connection-property vec "default-location" nil)))) - (tramp-compat-file-attribute-user-id - (file-attributes - (tramp-make-tramp-file-name vec localname) id-format))))) + (file-attribute-user-id + (file-attributes (tramp-make-tramp-file-name vec localname) id-format))))) (defun tramp-gvfs-handle-get-remote-gid (vec id-format) "The gid of the remote connection VEC, in ID-FORMAT. @@ -1625,9 +1619,8 @@ ID-FORMAT valid values are `string' and `integer'." (tramp-get-connection-property (tramp-get-process vec) "share" (tramp-get-connection-property vec "default-location" nil)))) - (tramp-compat-file-attribute-group-id - (file-attributes - (tramp-make-tramp-file-name vec localname) id-format)))) + (file-attribute-group-id + (file-attributes (tramp-make-tramp-file-name vec localname) id-format)))) (defun tramp-gvfs-handle-set-file-uid-gid (filename &optional uid gid) "Like `tramp-set-file-uid-gid' for Tramp files." @@ -1865,9 +1858,9 @@ Their full names are \"org.gtk.vfs.MountTracker.mounted\" and host (tramp-file-name-host v) port (tramp-file-name-port v))))) (when (member method tramp-gvfs-methods) - (let ((v (make-tramp-file-name - :method method :user user :domain domain - :host host :port port))) + (let ((v (make-tramp-file-name + :method method :user user :domain domain + :host host :port port))) (tramp-message v 6 "%s %s" signal-name (tramp-gvfs-stringify-dbus-message mount-info)) @@ -2134,9 +2127,6 @@ connection if a previous connection has died for some reason." (process-put p 'vector vec) (set-process-query-on-exit-flag p nil) - ;; Mark process for filelock. - (tramp-set-connection-property p "lock-pid" (truncate (time-to-seconds))) - ;; Set connection-local variables. (tramp-set-connection-local-variables vec))) diff --git a/lisp/net/tramp-integration.el b/lisp/net/tramp-integration.el index 17264193fd6..238abd34230 100644 --- a/lisp/net/tramp-integration.el +++ b/lisp/net/tramp-integration.el @@ -85,13 +85,6 @@ special handling of `substitute-in-file-name'." "An overlay covering the shadowed part of the filename." (format "[^%s/~]*\\(/\\|~\\)" tramp-postfix-host-format)) -;; Package rfn-eshadow is preloaded in Emacs, but for some reason, -;; it only did (defvar rfn-eshadow-overlay) without giving it a global -;; value, so it was only declared as dynamically-scoped within the -;; rfn-eshadow.el file. This is now fixed in Emacs>26.1 but we still need -;; this defvar here for older releases. -(defvar rfn-eshadow-overlay) - (defun tramp-rfn-eshadow-update-overlay () "Update `rfn-eshadow-overlay' to cover shadowed part of minibuffer input. This is intended to be used as a minibuffer `post-command-hook' for @@ -281,22 +274,18 @@ NAME must be equal to `tramp-current-connection'." (remove-hook 'compilation-start-hook #'tramp-compile-disable-ssh-controlmaster-options)))) -;;; Default connection-local variables for Tramp: -;; `connection-local-set-profile-variables' and -;; `connection-local-set-profiles' exists since Emacs 26.1. +;;; Default connection-local variables for Tramp. (defconst tramp-connection-local-default-system-variables '((path-separator . ":") (null-device . "/dev/null")) "Default connection-local system variables for remote connections.") -(tramp-compat-funcall - 'connection-local-set-profile-variables +(connection-local-set-profile-variables 'tramp-connection-local-default-system-profile tramp-connection-local-default-system-variables) -(tramp-compat-funcall - 'connection-local-set-profiles +(connection-local-set-profiles '(:application tramp) 'tramp-connection-local-default-system-profile) @@ -305,14 +294,12 @@ NAME must be equal to `tramp-current-connection'." (shell-command-switch . "-c")) "Default connection-local shell variables for remote connections.") -(tramp-compat-funcall - 'connection-local-set-profile-variables +(connection-local-set-profile-variables 'tramp-connection-local-default-shell-profile tramp-connection-local-default-shell-variables) (with-eval-after-load 'shell - (tramp-compat-funcall - 'connection-local-set-profiles + (connection-local-set-profiles '(:application tramp) 'tramp-connection-local-default-shell-profile)) diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index 812e06f3f11..71ec2607a30 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) @@ -110,7 +111,7 @@ (file-notify-rm-watch . ignore) (file-notify-valid-p . ignore) (file-ownership-preserved-p . ignore) - (file-readable-p . tramp-fuse-handle-file-readable-p) + (file-readable-p . tramp-rclone-handle-file-readable-p) (file-regular-p . tramp-handle-file-regular-p) (file-remote-p . tramp-handle-file-remote-p) (file-selinux-context . tramp-handle-file-selinux-context) @@ -156,11 +157,10 @@ Operations not mentioned here will be handled by the default Emacs primitives.") ;; It must be a `defsubst' in order to push the whole code into ;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading. ;;;###tramp-autoload -(defsubst tramp-rclone-file-name-p (filename) - "Check if it's a FILENAME for rclone." - (and (tramp-tramp-file-p filename) - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-rclone-method))) +(defsubst tramp-rclone-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME for rclone." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (string= (tramp-file-name-method vec) tramp-rclone-method))) ;;;###tramp-autoload (defun tramp-rclone-file-name-handler (operation &rest args) @@ -223,7 +223,7 @@ file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) @@ -280,6 +280,12 @@ file names." (list filename newname ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes)))) +(defun tramp-rclone-handle-file-readable-p (filename) + "Like `file-readable-p' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name filename) nil + (with-tramp-file-property v localname "file-readable-p" + (file-readable-p (tramp-fuse-local-file-name filename))))) + (defun tramp-rclone-handle-file-system-info (filename) "Like `file-system-info' for Tramp files." (ignore-errors @@ -362,10 +368,6 @@ connection if a previous connection has died for some reason." (process-put p 'vector vec) (set-process-query-on-exit-flag p nil) - ;; Mark process for filelock. - (tramp-set-connection-property - p "lock-pid" (truncate (time-to-seconds))) - ;; Set connection-local variables. (tramp-set-connection-local-variables vec))) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 21217381f14..72eb63d3929 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,6 +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' 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) @@ -1334,7 +1339,7 @@ component is used as the target of the symlink." (with-parsed-tramp-file-name f nil (let* ((remote-file-name-inhibit-cache t) (attr (file-attributes f)) - (modtime (or (tramp-compat-file-attribute-modification-time attr) + (modtime (or (file-attribute-modification-time attr) tramp-time-doesnt-exist))) (setq coding-system-used last-coding-system-used) (if (not (tramp-compat-time-equal-p modtime tramp-time-dont-know)) @@ -1372,7 +1377,7 @@ of." (with-parsed-tramp-file-name f nil (let* ((remote-file-name-inhibit-cache t) (attr (file-attributes f)) - (modtime (tramp-compat-file-attribute-modification-time attr)) + (modtime (file-attribute-modification-time attr)) (mt (visited-file-modtime))) (cond @@ -1424,7 +1429,7 @@ of." (if (or (null time) (tramp-compat-time-equal-p time tramp-time-doesnt-exist) (tramp-compat-time-equal-p time tramp-time-dont-know)) - (current-time) + nil time))) (tramp-send-command-and-check v (format @@ -1620,14 +1625,14 @@ ID-FORMAT valid values are `string' and `integer'." ;; information would be lost by an (attempted) delete and create. (or (null attributes) (and - (= (tramp-compat-file-attribute-user-id attributes) + (= (file-attribute-user-id attributes) (tramp-get-remote-uid v 'integer)) (or (not group) ;; On BSD-derived systems files always inherit the ;; parent directory's group, so skip the group-gid ;; test. (tramp-check-remote-uname v "BSD\\|DragonFly\\|Darwin") - (= (tramp-compat-file-attribute-group-id attributes) + (= (file-attribute-group-id attributes) (tramp-get-remote-gid v 'integer))))))))) ;; Directory listings. @@ -1637,8 +1642,7 @@ ID-FORMAT valid values are `string' and `integer'." "Like `directory-files-and-attributes' for Tramp files." (unless id-format (setq id-format 'integer)) (unless (file-exists-p directory) - (tramp-compat-file-missing - (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) (when (file-directory-p directory) (setq directory (expand-file-name directory)) (let* ((temp @@ -1858,7 +1862,7 @@ ID-FORMAT valid values are `string' and `integer'." target) (with-parsed-tramp-file-name (if t1 dirname newname) nil (unless (file-exists-p dirname) - (tramp-compat-file-missing v dirname)) + (tramp-error v 'file-missing dirname)) ;; `copy-directory-create-symlink' exists since Emacs 28.1. (if (and (bound-and-true-p copy-directory-create-symlink) @@ -1952,7 +1956,7 @@ file names." (let ((t1 (tramp-tramp-file-p filename)) (t2 (tramp-tramp-file-p newname)) - (length (tramp-compat-file-attribute-size + (length (file-attribute-size (file-attributes (file-truename filename)))) (attributes (and preserve-extended-attributes (file-extended-attributes filename))) @@ -1960,7 +1964,7 @@ file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) @@ -2052,7 +2056,7 @@ KEEP-DATE is non-nil if NEWNAME should have the same timestamp as FILENAME." ;; Check, whether file is too large. Emacs checks in `insert-file-1' ;; and `find-file-noselect', but that's not called here. (abort-if-file-too-large - (tramp-compat-file-attribute-size (file-attributes (file-truename filename))) + (file-attribute-size (file-attributes (file-truename filename))) (symbol-name op) filename) ;; We must disable multibyte, because binary data shall not be ;; converted. We don't want the target file to be compressed, so we @@ -2074,8 +2078,7 @@ KEEP-DATE is non-nil if NEWNAME should have the same timestamp as FILENAME." (when keep-date (tramp-compat-set-file-times newname - (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (file-attribute-modification-time (file-attributes filename)) (unless ok-if-already-exists 'nofollow))) ;; Set the mode. (set-file-modes newname (tramp-default-file-modes filename)) @@ -2094,7 +2097,7 @@ as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep the uid and gid from FILENAME." (let ((t1 (tramp-tramp-file-p filename)) (t2 (tramp-tramp-file-p newname)) - (file-times (tramp-compat-file-attribute-modification-time + (file-times (file-attribute-modification-time (file-attributes filename))) (file-modes (tramp-default-file-modes filename))) (with-parsed-tramp-file-name (if t1 filename newname) nil @@ -2419,8 +2422,7 @@ The method used must be an out-of-band method." (when (and keep-date (not copy-keep-date)) (tramp-compat-set-file-times newname - (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (file-attribute-modification-time (file-attributes filename)) (unless ok-if-already-exists 'nofollow))) ;; Set the mode. @@ -2476,42 +2478,58 @@ The method used must be an out-of-band method." (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)))) - - (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 (concat (nth 2 suffix) " " - (tramp-shell-quote-argument localname))) - (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 (concat "gzip -f " - (tramp-shell-quote-argument localname))) - (dired-remove-file file) - (cond ((file-exists-p (concat file ".gz")) - (concat file ".gz")) - ((file-exists-p (concat file ".z")) - (concat file ".z")) - (t nil))))))))) + ;; 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)))))))))))) (defun tramp-sh-handle-insert-directory (filename switches &optional wildcard full-directory-p) @@ -2583,7 +2601,7 @@ The method used must be an out-of-band method." ;; We cannot use `insert-buffer-substring' because the Tramp ;; buffer changes its contents before insertion due to calling ;; `expand-file-name' and alike. - (insert (with-current-buffer (tramp-get-buffer v) (buffer-string))) + (insert (tramp-get-buffer-string (tramp-get-buffer v))) ;; We must enable unibyte strings, because the "--dired" ;; output counts in bytes. @@ -2693,11 +2711,11 @@ the result will be a local, non-Tramp, file name." ;; Unless NAME is absolute, concat DIR and NAME. (unless (file-name-absolute-p name) (setq name (tramp-compat-file-name-concat dir name))) - ;; If connection is not established yet, run the real handler. - (if (not (tramp-connectable-p name)) - (tramp-run-real-handler #'expand-file-name (list name nil)) - ;; Dissect NAME. - (with-parsed-tramp-file-name name nil + ;; Dissect NAME. + (with-parsed-tramp-file-name name nil + ;; If connection is not established yet, run the real handler. + (if (not (tramp-connectable-p v)) + (tramp-run-real-handler #'expand-file-name (list name nil)) (unless (tramp-run-real-handler #'file-name-absolute-p (list localname)) (setq localname (concat "~/" localname))) ;; Tilde expansion if necessary. This needs a shell which @@ -3142,8 +3160,7 @@ implementation will be used." (when outbuf (with-current-buffer outbuf (insert - (with-current-buffer (tramp-get-connection-buffer v) - (buffer-string)))) + (tramp-get-buffer-string (tramp-get-connection-buffer v)))) (when (and display (get-buffer-window outbuf t)) (redisplay)))) ;; When the user did interrupt, we should do it also. We use ;; return code -1 as marker. @@ -3187,9 +3204,9 @@ implementation will be used." "Like `file-local-copy' for Tramp files." (with-parsed-tramp-file-name filename nil (unless (file-exists-p (file-truename filename)) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) - (let* ((size (tramp-compat-file-attribute-size + (let* ((size (file-attribute-size (file-attributes (file-truename filename)))) (rem-enc (tramp-get-inline-coding v "remote-encoding" size)) (loc-dec (tramp-get-inline-coding v "local-decoding" size)) @@ -3276,11 +3293,9 @@ implementation will be used." (tramp-error v 'file-already-exists filename)) (let ((file-locked (eq (file-locked-p lockname) t)) - (uid (or (tramp-compat-file-attribute-user-id - (file-attributes filename 'integer)) + (uid (or (file-attribute-user-id (file-attributes filename 'integer)) (tramp-get-remote-uid v 'integer))) - (gid (or (tramp-compat-file-attribute-group-id - (file-attributes filename 'integer)) + (gid (or (file-attribute-group-id (file-attributes filename 'integer)) (tramp-get-remote-gid v 'integer)))) ;; Lock file. @@ -3359,8 +3374,7 @@ implementation will be used." ;; specified. However, if the method _also_ specifies an ;; encoding function, then that is used for encoding the ;; contents of the tmp file. - (let* ((size (tramp-compat-file-attribute-size - (file-attributes tmpfile))) + (let* ((size (file-attribute-size (file-attributes tmpfile))) (rem-dec (tramp-get-inline-coding v "remote-decoding" size)) (loc-enc (tramp-get-inline-coding v "local-encoding" size))) (cond @@ -3460,8 +3474,7 @@ implementation will be used." (not (string-equal (buffer-string) - (with-current-buffer (tramp-get-buffer v) - (buffer-string)))) + (tramp-get-buffer-string (tramp-get-buffer v)))) (tramp-error v 'file-error (concat "Couldn't write region to `%s'," @@ -3495,10 +3508,10 @@ implementation will be used." ;; We must pass modtime explicitly, because FILENAME can ;; be different from (buffer-file-name), f.e. if ;; `file-precious-flag' is set. - (or (tramp-compat-file-attribute-modification-time file-attr) + (or (file-attribute-modification-time file-attr) (current-time))) - (when (and (= (tramp-compat-file-attribute-user-id file-attr) uid) - (= (tramp-compat-file-attribute-group-id file-attr) gid)) + (when (and (= (file-attribute-user-id file-attr) uid) + (= (file-attribute-group-id file-attr) gid)) (setq need-chown nil)))) ;; Set the ownership. @@ -3755,8 +3768,7 @@ Fall back to normal file name handler if no Tramp handler exists." "Read output from \"gio monitor\" and add corresponding `file-notify' events." (let ((events (process-get proc 'events)) (remote-prefix - (with-current-buffer (process-buffer proc) - (file-remote-p default-directory))) + (file-remote-p (tramp-get-default-directory (process-buffer proc)))) (rest-string (process-get proc 'rest-string)) pos) (when rest-string @@ -6011,5 +6023,8 @@ function cell is returned to be applied on a buffer." ;; be to stipulate, as a directory or connection-local variable, an ;; additional rc file on the remote machine that is sourced every ;; time Tramp connects. <https://emacs.stackexchange.com/questions/62306> +;; +;; * Support hostname canonicalization in ~/.ssh/config. +;; <https://stackoverflow.com/questions/70205232/> ;;; tramp-sh.el ends here diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 49f049d3f34..34203076b24 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) @@ -330,11 +331,10 @@ This can be used to disable echo etc." ;; It must be a `defsubst' in order to push the whole code into ;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading. ;;;###tramp-autoload -(defsubst tramp-smb-file-name-p (filename) - "Check if it's a FILENAME for SMB servers." - (and (tramp-tramp-file-p filename) - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-smb-method))) +(defsubst tramp-smb-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME for SMB servers." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (string= (tramp-file-name-method vec) tramp-smb-method))) ;;;###tramp-autoload (defun tramp-smb-file-name-handler (operation &rest args) @@ -419,7 +419,7 @@ arguments to pass to the OPERATION." target) (with-parsed-tramp-file-name (if t1 dirname newname) nil (unless (file-exists-p dirname) - (tramp-compat-file-missing v dirname)) + (tramp-error v 'file-missing dirname)) ;; `copy-directory-create-symlink' exists since Emacs 28.1. (if (and (bound-and-true-p copy-directory-create-symlink) @@ -442,7 +442,7 @@ arguments to pass to the OPERATION." (with-tramp-progress-reporter v 0 (format "Copying %s to %s" dirname newname) (unless (file-exists-p dirname) - (tramp-compat-file-missing v dirname)) + (tramp-error v 'file-missing dirname)) (when (and (file-directory-p newname) (not (directory-name-p newname))) (tramp-error v 'file-already-exists newname)) @@ -567,8 +567,7 @@ arguments to pass to the OPERATION." (when keep-date (tramp-compat-set-file-times newname - (tramp-compat-file-attribute-modification-time - (file-attributes dirname)) + (file-attribute-modification-time (file-attributes dirname)) (unless ok-if-already-exists 'nofollow))) ;; Set the mode. @@ -602,10 +601,10 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (copy-directory filename newname keep-date 'parents 'copy-contents) (unless (file-exists-p filename) - (tramp-compat-file-missing + (tramp-error (tramp-dissect-file-name (if (tramp-tramp-file-p filename) filename newname)) - filename)) + 'file-missing filename)) (if-let ((tmpfile (file-local-copy filename))) ;; Remote filename. @@ -645,8 +644,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when keep-date (tramp-compat-set-file-times newname - (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (file-attribute-modification-time (file-attributes filename)) (unless ok-if-already-exists 'nofollow))))) (defun tramp-smb-handle-delete-directory (directory &optional recursive trash) @@ -706,7 +704,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (directory &optional full match nosort count) "Like `directory-files' for Tramp files." (unless (file-exists-p directory) - (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) (let ((result (mapcar #'directory-file-name (file-name-all-completions "" directory)))) ;; Discriminate with regexp. @@ -976,7 +974,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." "Like `file-local-copy' for Tramp files." (with-parsed-tramp-file-name (file-truename filename) nil (unless (file-exists-p (file-truename filename)) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (let ((tmpfile (tramp-compat-make-temp-file filename))) (with-tramp-progress-reporter v 3 (format "Fetching %s to tmp file %s" filename tmpfile) @@ -1041,8 +1039,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." "Like `file-writable-p' for Tramp files." (if (file-exists-p filename) (tramp-compat-string-search - "w" - (or (tramp-compat-file-attribute-modes (file-attributes filename)) "")) + "w" (or (file-attribute-modes (file-attributes filename)) "")) (let ((dir (file-name-directory filename))) (and (file-exists-p dir) (file-writable-p dir))))) @@ -1145,11 +1142,11 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (insert (format "%10s %3d %-8s %-8s %8s %s " - (or (tramp-compat-file-attribute-modes attr) (nth 1 x)) - (or (tramp-compat-file-attribute-link-number attr) 1) - (or (tramp-compat-file-attribute-user-id attr) "nobody") - (or (tramp-compat-file-attribute-group-id attr) "nogroup") - (or (tramp-compat-file-attribute-size attr) (nth 2 x)) + (or (file-attribute-modes attr) (nth 1 x)) + (or (file-attribute-link-number attr) 1) + (or (file-attribute-user-id attr) "nobody") + (or (file-attribute-group-id attr) "nogroup") + (or (file-attribute-size attr) (nth 2 x)) (format-time-string (if (time-less-p ;; Half a year. @@ -1171,8 +1168,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Insert symlink. (when (and (tramp-compat-string-search "l" switches) - (stringp (tramp-compat-file-attribute-type attr))) - (insert " -> " (tramp-compat-file-attribute-type attr)))) + (stringp (file-attribute-type attr))) + (insert " -> " (file-attribute-type attr)))) (insert "\n") (beginning-of-line))) @@ -1394,7 +1391,7 @@ component is used as the target of the symlink." (with-parsed-tramp-file-name (if (tramp-tramp-file-p filename) filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) @@ -1439,9 +1436,9 @@ component is used as the target of the symlink." (unless (process-live-p proc) ;; Accept pending output. (while (tramp-accept-process-output proc)) - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 10 "\n%s" (buffer-string)) - (throw 'tramp-action 'ok)))) + (tramp-message + vec 10 "\n%s" (tramp-get-buffer-string (tramp-get-connection-buffer vec))) + (throw 'tramp-action 'ok))) (defun tramp-smb-handle-set-file-acl (filename acl-string) "Like `set-file-acl' for Tramp files." @@ -1647,8 +1644,7 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." ;; Set file modification time. (when (or (eq visit t) (stringp visit)) (set-visited-file-modtime - (or (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (or (file-attribute-modification-time (file-attributes filename)) (current-time)))) ;; Unlock file. diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index 1886031dec7..ef1f302546a 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) @@ -156,11 +157,10 @@ Operations not mentioned here will be handled by the default Emacs primitives.") ;; It must be a `defsubst' in order to push the whole code into ;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading. ;;;###tramp-autoload -(defsubst tramp-sshfs-file-name-p (filename) - "Check if it's a FILENAME for sshfs." - (and (tramp-tramp-file-p filename) - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-sshfs-method))) +(defsubst tramp-sshfs-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME for sshfs." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (string= (tramp-file-name-method vec) tramp-sshfs-method))) ;;;###tramp-autoload (defun tramp-sshfs-file-name-handler (operation &rest args) @@ -345,9 +345,6 @@ connection if a previous connection has died for some reason." (process-put p 'vector vec) (set-process-query-on-exit-flag p nil) - ;; Mark process for filelock. - (tramp-set-connection-property p "lock-pid" (truncate (time-to-seconds))) - ;; Set connection-local variables. (tramp-set-connection-local-variables vec))) diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 845f31d09b1..88e8c43534b 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) @@ -148,11 +149,10 @@ See `tramp-actions-before-shell' for more info.") ;; It must be a `defsubst' in order to push the whole code into ;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading. ;;;###tramp-autoload -(defsubst tramp-sudoedit-file-name-p (filename) - "Check if it's a FILENAME for SUDOEDIT." - (and (tramp-tramp-file-p filename) - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-sudoedit-method))) +(defsubst tramp-sudoedit-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME for SUDOEDIT." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (string= (tramp-file-name-method vec) tramp-sudoedit-method))) ;;;###tramp-autoload (defun tramp-sudoedit-file-name-handler (operation &rest args) @@ -233,7 +233,7 @@ absolute file names." (let ((t1 (tramp-sudoedit-file-name-p filename)) (t2 (tramp-sudoedit-file-name-p newname)) - (file-times (tramp-compat-file-attribute-modification-time + (file-times (file-attribute-modification-time (file-attributes filename))) (file-modes (tramp-default-file-modes filename)) (attributes (and preserve-extended-attributes @@ -247,7 +247,7 @@ absolute file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) @@ -336,7 +336,7 @@ absolute file names." (if (and delete-by-moving-to-trash trash) (move-file-to-trash filename) (unless (tramp-sudoedit-send-command - v "rm" (tramp-compat-file-name-unquote localname)) + v "rm" "-f" (tramp-compat-file-name-unquote localname)) ;; Propagate the error. (with-current-buffer (tramp-get-connection-buffer v) (goto-char (point-min)) @@ -453,12 +453,13 @@ the result will be a local, non-Tramp, file name." (if (file-directory-p (expand-file-name f directory)) (file-name-as-directory f) f)) - (with-current-buffer (tramp-get-connection-buffer v) - (delq - nil - (mapcar - (lambda (l) (and (not (string-match-p "^[[:space:]]*$" l)) l)) - (split-string (buffer-string) "\n" 'omit))))))))) + (delq + nil + (mapcar + (lambda (l) (and (not (string-match-p "^[[:space:]]*$" l)) l)) + (split-string + (tramp-get-buffer-string (tramp-get-connection-buffer v)) + "\n" 'omit)))))))) (defun tramp-sudoedit-handle-file-readable-p (filename) "Like `file-readable-p' for Tramp files." @@ -534,7 +535,7 @@ the result will be a local, non-Tramp, file name." (if (or (null time) (tramp-compat-time-equal-p time tramp-time-doesnt-exist) (tramp-compat-time-equal-p time tramp-time-dont-know)) - (current-time) + nil time))) (tramp-sudoedit-send-command v "env" "TZ=UTC" "touch" "-t" @@ -721,11 +722,9 @@ ID-FORMAT valid values are `string' and `integer'." "Like `write-region' for Tramp files." (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil - (let* ((uid (or (tramp-compat-file-attribute-user-id - (file-attributes filename 'integer)) + (let* ((uid (or (file-attribute-user-id (file-attributes filename 'integer)) (tramp-get-remote-uid v 'integer))) - (gid (or (tramp-compat-file-attribute-group-id - (file-attributes filename 'integer)) + (gid (or (file-attribute-group-id (file-attributes filename 'integer)) (tramp-get-remote-gid v 'integer))) (flag (and (eq mustbenew 'excl) 'nofollow)) (modes (tramp-default-file-modes filename flag)) @@ -736,10 +735,10 @@ ID-FORMAT valid values are `string' and `integer'." ;; Set the ownership, modes and extended attributes. This is ;; not performed in `tramp-handle-write-region'. - (unless (and (= (tramp-compat-file-attribute-user-id + (unless (and (= (file-attribute-user-id (file-attributes filename 'integer)) uid) - (= (tramp-compat-file-attribute-group-id + (= (file-attribute-group-id (file-attributes filename 'integer)) gid)) (tramp-set-file-uid-gid filename uid gid)) @@ -789,9 +788,6 @@ connection if a previous connection has died for some reason." (process-put p 'vector vec) (set-process-query-on-exit-flag p nil) - ;; Mark process for filelock. - (tramp-set-connection-property p "lock-pid" (truncate (time-to-seconds))) - ;; Set connection-local variables. (tramp-set-connection-local-variables vec) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 740cb23ebee..7dc3dd79ba1 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -751,11 +751,11 @@ The answer will be provided by `tramp-action-process-alive', (defconst tramp-temp-name-prefix "tramp." "Prefix to use for temporary files. -If this is a relative file name (such as \"tramp.\"), it is considered -relative to the directory name returned by the function -`tramp-compat-temporary-file-directory' (which see). It may also be an -absolute file name; don't forget to include a prefix for the filename -part, though.") +If this is a relative file name (such as \"tramp.\"), it is +considered relative to the directory name returned by the +function `temporary-file-directory' (which see). It may also be +an absolute file name; don't forget to include a prefix for the +filename part, though.") (defconst tramp-temp-buffer-name " *tramp temp*" "Buffer name for a temporary buffer. @@ -822,11 +822,10 @@ to be set, depending on VALUE." (tramp-register-file-name-handlers)) ;; Initialize the Tramp syntax variables. We want to override initial -;; value of `tramp-file-name-regexp'. Other Tramp syntax variables -;; must be initialized as well to proper values. We do not call +;; value of `tramp-file-name-regexp'. We do not call ;; `custom-set-variable', this would load Tramp via custom.el. (tramp--with-startup - (tramp-set-syntax 'tramp-syntax (tramp-compat-tramp-syntax))) + (tramp-set-syntax 'tramp-syntax tramp-syntax)) (defun tramp-syntax-values () "Return possible values of `tramp-syntax', a list." @@ -836,9 +835,9 @@ to be set, depending on VALUE." values)) (defun tramp-lookup-syntax (alist) - "Look up a syntax string in ALIST according to `tramp-compat-tramp-syntax'. -Raise an error if `tramp-syntax' is invalid." - (or (cdr (assq (tramp-compat-tramp-syntax) alist)) + "Look up a syntax string in ALIST according to `tramp-syntax'. +Raise an error if it is invalid." + (or (cdr (assq tramp-syntax alist)) (error "Wrong `tramp-syntax' %s" tramp-syntax))) (defconst tramp-prefix-format-alist @@ -1409,8 +1408,7 @@ calling HANDLER.") ;; internal data structure. Convenience functions for internal ;; data structure. -;; The basic structure for remote file names. We use a list :type, -;; in order to be compatible with Emacs 25. +;; The basic structure for remote file names. (cl-defstruct (tramp-file-name (:type list) :named) method user domain host port localname hop) @@ -1522,7 +1520,7 @@ of `process-file', `start-file-process', or `shell-command'." (or (and (tramp-tramp-file-p name) (string-match (nth 0 tramp-file-name-structure) name) (match-string (nth 4 tramp-file-name-structure) name)) - (tramp-compat-file-local-name name))) + (file-local-name name))) ;; The localname can be quoted with "/:". Extract this. (defun tramp-unquote-file-local-name (name) @@ -1669,6 +1667,18 @@ default values are used." (put #'tramp-dissect-file-name 'tramp-suppress-trace t) +(defun tramp-ensure-dissected-file-name (vec-or-filename) + "Return a `tramp-file-name' structure for VEC-OR-FILENAME. + +VEC-OR-FILENAME may be either a string or a `tramp-file-name'. +If it's not a Tramp filename, return nil." + (cond + ((tramp-file-name-p vec-or-filename) vec-or-filename) + ((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." @@ -1839,9 +1849,7 @@ from the default one." If connection-local variables are not supported by this Emacs version, the function does nothing." (with-current-buffer (tramp-get-connection-buffer vec) - ;; `hack-connection-local-variables-apply' exists since Emacs 26.1. - (tramp-compat-funcall - 'hack-connection-local-variables-apply + (hack-connection-local-variables-apply `(:application tramp :protocol ,(tramp-file-name-method vec) :user ,(tramp-file-name-user-domain vec) @@ -1852,14 +1860,27 @@ version, the function does nothing." If connection-local variables are not supported by this Emacs version, the function does nothing." (when (tramp-tramp-file-p default-directory) - ;; `hack-connection-local-variables-apply' exists since Emacs 26.1. - (tramp-compat-funcall - 'hack-connection-local-variables-apply + (hack-connection-local-variables-apply `(:application tramp :protocol ,(file-remote-p default-directory 'method) :user ,(file-remote-p default-directory 'user) :machine ,(file-remote-p default-directory 'host))))) +(defsubst tramp-get-default-directory (buffer) + "Return `default-directory' of BUFFER." + (buffer-local-value 'default-directory buffer)) + +(put #'tramp-get-default-directory 'tramp-suppress-trace t) + +(defsubst tramp-get-buffer-string (&optional buffer) + "Return contents of BUFFER. +If BUFFER is not a buffer or a buffer name, return the contents +of `current-buffer'." + (with-current-buffer (or buffer (current-buffer)) + (substring-no-properties (buffer-string)))) + +(put #'tramp-get-buffer-string 'tramp-suppress-trace t) + (defun tramp-debug-buffer-name (vec) "A name for the debug buffer for VEC." (let ((method (tramp-file-name-method vec)) @@ -1898,29 +1919,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) @@ -1982,9 +2029,7 @@ ARGUMENTS to actually emit the message (if applicable)." (unless (bolp) (insert "\n")) ;; Timestamp. - (let ((now (current-time))) - (insert (format-time-string "%T." now)) - (insert (format "%06d " (nth 2 now)))) + (insert (format-time-string "%T.%6N ")) ;; Calling Tramp function. We suppress compat and trace ;; functions from being displayed. (let ((btn 1) btf fn) @@ -2054,12 +2099,15 @@ applicable)." ;; Append connection buffer for error messages, if exists. (when (= level 1) (ignore-errors - (with-current-buffer - (if (processp vec-or-proc) - (process-buffer vec-or-proc) - (tramp-get-connection-buffer vec-or-proc 'dont-create)) - (setq fmt-string (concat fmt-string "\n%s") - arguments (append arguments (list (buffer-string))))))) + (setq fmt-string (concat fmt-string "\n%s") + arguments + (append + arguments + `(,(tramp-get-buffer-string + (if (processp vec-or-proc) + (process-buffer vec-or-proc) + (tramp-get-connection-buffer + vec-or-proc 'dont-create)))))))) ;; Translate proc to vec. (when (processp vec-or-proc) (setq vec-or-proc (process-get vec-or-proc 'vector)))) @@ -2121,8 +2169,8 @@ an input event arrives. The other arguments are passed to `tramp-error'." (and (tramp-file-name-p vec-or-proc) (tramp-get-connection-buffer vec-or-proc)))) (vec (or (and (tramp-file-name-p vec-or-proc) vec-or-proc) - (and buf (with-current-buffer buf - (tramp-dissect-file-name default-directory)))))) + (and buf (tramp-dissect-file-name + (tramp-get-default-directory buf)))))) (unwind-protect (apply #'tramp-error vec-or-proc signal fmt-string arguments) ;; Save exit. @@ -2186,10 +2234,14 @@ the resulting error message." (defun tramp-test-message (fmt-string &rest arguments) "Emit a Tramp message according `default-directory'." - (if (tramp-tramp-file-p default-directory) - (apply #'tramp-message - (tramp-dissect-file-name default-directory) 0 fmt-string arguments) - (apply #'message fmt-string arguments))) + (cond + ((tramp-tramp-file-p default-directory) + (apply #'tramp-message + (tramp-dissect-file-name default-directory) 0 fmt-string arguments)) + ((tramp-file-name-p (car tramp-current-connection)) + (apply #'tramp-message + (car tramp-current-connection) 0 fmt-string arguments)) + (t (apply #'message fmt-string arguments)))) (put #'tramp-test-message 'tramp-suppress-trace t) @@ -2476,19 +2528,17 @@ Must be handled by the callers." 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-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 + 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 26+ only. - file-name-case-insensitive-p ;; Emacs 27+ only. file-system-info ;; Emacs 28+ only. @@ -2501,8 +2551,6 @@ Must be handled by the callers." (nth 0 args) default-directory)) ;; STRING FILE. - ;; Starting with Emacs 26.1, just the 2nd argument of - ;; `make-symbolic-link' matters. ((eq operation 'make-symbolic-link) (nth 1 args)) ;; FILE DIRECTORY resp FILE1 FILE2. ((member operation @@ -2533,17 +2581,15 @@ Must be handled by the callers." (if (bufferp (nth 0 args)) (nth 0 args) (current-buffer)))) ;; COMMAND. ((member operation - '(process-file shell-command start-file-process - ;; Emacs 26+ only. - make-nearby-temp-file temporary-file-directory + '(make-nearby-temp-file process-file shell-command + start-file-process temporary-file-directory ;; Emacs 27+ only. exec-path make-process)) default-directory) ;; PROC. ((member operation '(file-notify-rm-watch file-notify-valid-p)) (when (processp (nth 0 args)) - (with-current-buffer (process-buffer (nth 0 args)) - default-directory))) + (tramp-get-default-directory (process-buffer (nth 0 args))))) ;; VEC. ((member operation '(tramp-get-remote-gid tramp-get-remote-uid)) (tramp-make-tramp-file-name (nth 0 args))) @@ -2554,11 +2600,21 @@ Must be handled by the callers." "Return foreign file name handler if exists." (when (tramp-tramp-file-p filename) (let ((handler tramp-foreign-file-name-handler-alist) - elt res) + (vec (tramp-dissect-file-name filename)) + elt func res) (while handler (setq elt (car handler) handler (cdr handler)) - (when (funcall (car elt) filename) + ;; Previously, this function was called with FILENAME, but now + ;; it's called with the 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))) @@ -2757,8 +2813,9 @@ remote file names." (defun tramp-register-foreign-file-name-handler (func handler &optional append) "Register (FUNC . HANDLER) in `tramp-foreign-file-name-handler-alist'. -FUNC is the function, which determines whether HANDLER is to be called. -Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'." +FUNC is the function, which takes a dissected filename and determines +whether HANDLER is to be called. Add operations defined in +`HANDLER-alist' to `tramp-file-name-handler'." (add-to-list 'tramp-foreign-file-name-handler-alist `(,func . ,handler) append) ;; Mark `operations' the handler is responsible for. @@ -2809,18 +2866,14 @@ Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'." (defun tramp-command-completion-p (_symbol buffer) "A predicate for Tramp interactive commands. They are completed by \"M-x TAB\" only if the current buffer is remote." - (with-current-buffer buffer (tramp-tramp-file-p default-directory))) + (tramp-tramp-file-p (tramp-get-default-directory buffer))) (defun tramp-connectable-p (vec-or-filename) "Check, whether it is possible to connect the remote host w/o side-effects. This is true, if either the remote host is already connected, or if we are not in completion mode." (let ((tramp-verbose 0) - (vec - (cond - ((tramp-file-name-p vec-or-filename) vec-or-filename) - ((tramp-tramp-file-p vec-or-filename) - (tramp-dissect-file-name vec-or-filename))))) + (vec (tramp-ensure-dissected-file-name vec-or-filename))) (or ;; We check this for the process related to ;; `tramp-buffer-name'; otherwise `start-file-process' ;; wouldn't run ever when `non-essential' is non-nil. @@ -3278,6 +3331,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)) @@ -3288,10 +3363,11 @@ User is always nil." (if (file-directory-p filename) #'file-accessible-directory-p #'file-readable-p) filename) - (tramp-error - v 'file-error (format "%s: Permission denied, %s" string filename))) - (tramp-compat-file-missing - v (format "%s: No such file or directory, %s" string filename))))) + (tramp-compat-permission-denied + v (format "%s: Permission denied, %s" string filename))) + (tramp-error + v 'file-missing + (format "%s: No such file or directory, %s" string filename))))) (defun tramp-handle-add-name-to-file (filename newname &optional ok-if-already-exists) @@ -3325,7 +3401,7 @@ User is always nil." ;; `copy-directory' creates NEWNAME before running this check. So ;; we do it ourselves. (unless (file-exists-p directory) - (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) ;; We must do it file-wise. (tramp-run-real-handler #'copy-directory @@ -3346,7 +3422,7 @@ User is always nil." (defun tramp-handle-directory-files (directory &optional full match nosort count) "Like `directory-files' for Tramp files." (unless (file-exists-p directory) - (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) (when (file-directory-p directory) (setq directory (file-name-as-directory (expand-file-name directory))) (let ((temp (nreverse (file-name-all-completions "" directory))) @@ -3397,13 +3473,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." @@ -3412,9 +3491,7 @@ User is always nil." (defun tramp-handle-file-directory-p (filename) "Like `file-directory-p' for Tramp files." - (eq (tramp-compat-file-attribute-type - (file-attributes (file-truename filename))) - t)) + (eq (file-attribute-type (file-attributes (file-truename filename))) t)) (defun tramp-handle-file-equal-p (filename1 filename2) "Like `file-equalp-p' for Tramp files." @@ -3446,7 +3523,7 @@ User is always nil." "Like `file-local-copy' for Tramp files." (with-parsed-tramp-file-name filename nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (let ((tmpfile (tramp-compat-make-temp-file filename))) (copy-file filename tmpfile 'ok-if-already-exists 'keep-time) tmpfile))) @@ -3454,7 +3531,7 @@ User is always nil." (defun tramp-handle-file-modes (filename &optional flag) "Like `file-modes' for Tramp files." (when-let ((attrs (file-attributes filename)) - (mode-string (tramp-compat-file-attribute-modes attrs))) + (mode-string (file-attribute-modes attrs))) (if (and (not (eq flag 'nofollow)) (eq ?l (aref mode-string 0))) (file-modes (file-truename filename)) (tramp-mode-string-to-int mode-string)))) @@ -3486,7 +3563,7 @@ User is always nil." (tramp-get-method-parameter v 'tramp-case-insensitive) ;; There isn't. So we must check, in case there's a connection already. - (and (file-remote-p filename nil 'connected) + (and (let ((non-essential t)) (tramp-connectable-p v)) (with-tramp-connection-property v "case-insensitive" (ignore-errors (with-tramp-progress-reporter v 5 "Checking case-insensitive" @@ -3507,16 +3584,13 @@ User is always nil." (directory-file-name (file-name-directory candidate)))) ;; Nothing found, so we must use a temporary file - ;; for comparison. `make-nearby-temp-file' is added - ;; to Emacs 26+ like `file-name-case-insensitive-p', - ;; so there is no compatibility problem calling it. + ;; for comparison. (unless (string-match-p "[[:lower:]]" (tramp-file-local-name candidate)) (setq tmpfile (let ((default-directory - (file-name-directory filename))) - (tramp-compat-funcall - 'make-nearby-temp-file "tramp.")) + (file-name-directory filename))) + (make-nearby-temp-file "tramp.")) candidate tmpfile)) ;; Check for the existence of the same file with ;; upper case letters. @@ -3577,9 +3651,8 @@ User is always nil." ((not (file-exists-p file1)) nil) ((not (file-exists-p file2)) t) (t (time-less-p - (tramp-compat-file-attribute-modification-time (file-attributes file2)) - (tramp-compat-file-attribute-modification-time - (file-attributes file1)))))) + (file-attribute-modification-time (file-attributes file2)) + (file-attribute-modification-time (file-attributes file1)))))) (defun tramp-handle-file-readable-p (filename) "Like `file-readable-p' for Tramp files." @@ -3598,7 +3671,7 @@ User is always nil." ;; Sometimes, `file-attributes' does not return a proper value ;; even if `file-exists-p' does. (when-let ((attr (file-attributes filename))) - (eq ?- (aref (tramp-compat-file-attribute-modes attr) 0))))) + (eq ?- (aref (file-attribute-modes attr) 0))))) (defun tramp-handle-file-remote-p (filename &optional identification connected) "Like `file-remote-p' for Tramp files." @@ -3630,7 +3703,7 @@ User is always nil." (defun tramp-handle-file-symlink-p (filename) "Like `file-symlink-p' for Tramp files." - (let ((x (tramp-compat-file-attribute-type (file-attributes filename)))) + (let ((x (file-attribute-type (file-attributes filename)))) (and (stringp x) x))) (defun tramp-handle-file-truename (filename) @@ -3719,7 +3792,7 @@ User is always nil." (when (and (not tramp-allow-unsafe-temporary-files) (not backup-inhibited) (file-in-directory-p (car result) temporary-file-directory) - (zerop (or (tramp-compat-file-attribute-user-id + (zerop (or (file-attribute-user-id (file-attributes filename 'integer)) tramp-unknown-id-integer)) (not (with-tramp-connection-property @@ -3776,7 +3849,7 @@ User is always nil." (unwind-protect (if (not (file-exists-p filename)) (let ((tramp-verbose (if visit 0 tramp-verbose))) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (with-tramp-progress-reporter v 3 (format-message "Inserting `%s'" filename) @@ -3890,16 +3963,19 @@ Return nil when there is no lockfile." (insert-file-contents-literally lockname) (buffer-string)))))) +(defvar tramp-lock-pid nil + "A random nunber local for every connection. +Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") + (defun tramp-get-lock-pid (file) "Determine pid for lockfile of FILE." - ;; Some Tramp methods do not offer a connection process, but just a - ;; network process as a place holder. Those processes use the - ;; "lock-pid" connection property as fake pid, in fact it is the - ;; time stamp the process is created. - (let ((p (tramp-get-process (tramp-dissect-file-name file)))) - (number-to-string - (or (process-id p) - (tramp-get-connection-property p "lock-pid" (emacs-pid)))))) + ;; Not all Tramp methods use an own process. So we use a random + ;; number, which is as good as a process id. + (with-current-buffer + (tramp-get-connection-buffer (tramp-dissect-file-name file)) + (or tramp-lock-pid + (setq-local + tramp-lock-pid (number-to-string (random most-positive-fixnum)))))) (defconst tramp-lock-file-info-regexp ;; USER@HOST.PID[:BOOT_TIME] @@ -3910,9 +3986,11 @@ Return nil when there is no lockfile." "Like `file-locked-p' for Tramp files." (when-let ((info (tramp-get-lock-file file)) (match (string-match tramp-lock-file-info-regexp info))) - (or (and (string-equal (match-string 1 info) (user-login-name)) + (or ; Locked by me. + (and (string-equal (match-string 1 info) (user-login-name)) (string-equal (match-string 2 info) (system-name)) (string-equal (match-string 3 info) (tramp-get-lock-pid file))) + ; User name. (match-string 1 info)))) (defun tramp-handle-lock-file (file) @@ -3941,7 +4019,7 @@ Return nil when there is no lockfile." (when (and (not tramp-allow-unsafe-temporary-files) create-lockfiles (file-in-directory-p lockname temporary-file-directory) - (zerop (or (tramp-compat-file-attribute-user-id + (zerop (or (file-attribute-user-id (file-attributes file 'integer)) tramp-unknown-id-integer)) (not (with-tramp-connection-property @@ -3993,7 +4071,7 @@ Return nil when there is no lockfile." v 'file-error "File `%s' does not include a `.el' or `.elc' suffix" file))) (unless (or noerror (file-exists-p file)) - (tramp-compat-file-missing v file)) + (tramp-error v 'file-missing file)) (if (not (file-exists-p file)) nil (let ((signal-hook-function (unless noerror signal-hook-function)) @@ -4255,18 +4333,13 @@ substitution. SPEC-LIST is a list of char/value pairs used for p)))))) (defun tramp-handle-make-symbolic-link - (target linkname &optional ok-if-already-exists) + (_target linkname &optional _ok-if-already-exists) "Like `make-symbolic-link' for Tramp files. This is the fallback implementation for backends which do not support symbolic links." - (if (tramp-tramp-file-p (expand-file-name linkname)) - (tramp-error - (tramp-dissect-file-name (expand-file-name linkname)) 'file-error - "make-symbolic-link not supported") - ;; This is needed prior Emacs 26.1, where TARGET has also be - ;; checked for a file name handler. - (tramp-run-real-handler - #'make-symbolic-link (list target linkname ok-if-already-exists)))) + (tramp-error + (tramp-dissect-file-name (expand-file-name linkname)) 'file-error + "make-symbolic-link not supported")) (defun tramp-handle-shell-command (command &optional output-buffer error-buffer) "Like `shell-command' for Tramp files." @@ -4484,7 +4557,7 @@ BUFFER might be a list, in this case STDERR is separated." (unless time-list (let ((remote-file-name-inhibit-cache t)) (setq time-list - (or (tramp-compat-file-attribute-modification-time + (or (file-attribute-modification-time (file-attributes (buffer-file-name))) tramp-time-doesnt-exist)))) (unless (tramp-compat-time-equal-p time-list tramp-time-dont-know) @@ -4508,7 +4581,7 @@ of." t (let* ((remote-file-name-inhibit-cache t) (attr (file-attributes f)) - (modtime (tramp-compat-file-attribute-modification-time attr)) + (modtime (file-attribute-modification-time attr)) (mt (visited-file-modtime))) (cond @@ -4539,11 +4612,9 @@ of." (tmpfile (tramp-compat-make-temp-file filename)) (modes (tramp-default-file-modes filename (and (eq mustbenew 'excl) 'nofollow))) - (uid (or (tramp-compat-file-attribute-user-id - (file-attributes filename 'integer)) + (uid (or (file-attribute-user-id (file-attributes filename 'integer)) (tramp-get-remote-uid v 'integer))) - (gid (or (tramp-compat-file-attribute-group-id - (file-attributes filename 'integer)) + (gid (or (file-attribute-group-id (file-attributes filename 'integer)) (tramp-get-remote-gid v 'integer)))) ;; Lock file. @@ -4579,8 +4650,7 @@ of." ;; Set file modification time. (when (or (eq visit t) (stringp visit)) (set-visited-file-modtime - (or (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (or (file-attribute-modification-time (file-attributes filename)) (current-time)))) ;; Set the ownership. @@ -4661,8 +4731,8 @@ of." (save-window-excursion (pop-to-buffer (tramp-get-connection-buffer vec)) (read-string (match-string 0))))))) - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 6 "\n%s" (buffer-string))) + (tramp-message + vec 6 "\n%s" (tramp-get-buffer-string (tramp-get-connection-buffer vec))) (tramp-message vec 3 "Sending login name `%s'" user) (tramp-send-string vec (concat user tramp-local-end-of-line))) t) @@ -4705,8 +4775,8 @@ See also `tramp-action-yn'." (unless (yes-or-no-p (match-string 0)) (kill-process proc) (throw 'tramp-action 'permission-denied)) - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 6 "\n%s" (buffer-string))) + (tramp-message + vec 6 "\n%s" (tramp-get-buffer-string (tramp-get-connection-buffer vec))) (tramp-send-string vec (concat "yes" tramp-local-end-of-line))) t) @@ -4719,8 +4789,8 @@ See also `tramp-action-yesno'." (unless (y-or-n-p (match-string 0)) (kill-process proc) (throw 'tramp-action 'permission-denied)) - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 6 "\n%s" (buffer-string))) + (tramp-message + vec 6 "\n%s" (tramp-get-buffer-string (tramp-get-connection-buffer vec))) (tramp-send-string vec (concat "y" tramp-local-end-of-line))) t) @@ -4728,15 +4798,15 @@ See also `tramp-action-yesno'." "Tell the remote host which terminal type to use. The terminal type can be configured with `tramp-terminal-type'." (tramp-message vec 5 "Setting `%s' as terminal type." tramp-terminal-type) - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 6 "\n%s" (buffer-string))) + (tramp-message + vec 6 "\n%s" (tramp-get-buffer-string (tramp-get-connection-buffer vec))) (tramp-send-string vec (concat tramp-terminal-type tramp-local-end-of-line)) t) (defun tramp-action-confirm-message (_proc vec) "Return RET in order to confirm the message." - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 6 "\n%s" (buffer-string))) + (tramp-message + vec 6 "\n%s" (tramp-get-buffer-string (tramp-get-connection-buffer vec))) (tramp-send-string vec tramp-local-end-of-line) t) @@ -5024,8 +5094,8 @@ nil." ;; The process could have timed out, for example due to session ;; timeout of sudo. The process buffer does not exist any longer then. (ignore-errors - (with-current-buffer (process-buffer proc) - (tramp-message proc 6 "\n%s" (buffer-string)))) + (tramp-message + proc 6 "\n%s" (tramp-get-buffer-string (process-buffer proc)))) (unless found (if timeout (tramp-error @@ -5247,7 +5317,7 @@ If FILENAME is remote, a file name handler is called." (let* ((dir (file-name-directory filename)) (modes (file-modes dir))) (when (and modes (not (zerop (logand modes #o2000)))) - (setq gid (tramp-compat-file-attribute-group-id (file-attributes dir))))) + (setq gid (file-attribute-group-id (file-attributes dir))))) (if-let ((handler (find-file-name-handler filename 'tramp-set-file-uid-gid))) (funcall handler #'tramp-set-file-uid-gid filename uid gid) @@ -5276,8 +5346,7 @@ ID-FORMAT valid values are `string' and `integer'." ;; `group-name' has been introduced with Emacs 27.1. ((and (fboundp 'group-name) (equal id-format 'string)) (tramp-compat-funcall 'group-name (group-gid))) - ((tramp-compat-file-attribute-group-id - (file-attributes "~/" id-format)))))) + ((file-attribute-group-id (file-attributes "~/" id-format)))))) (defun tramp-get-local-locale (&optional vec) "Determine locale, supporting UTF8 if possible. @@ -5332,31 +5401,22 @@ be granted." file-attr (or ;; Not a symlink. - (eq t (tramp-compat-file-attribute-type file-attr)) - (null (tramp-compat-file-attribute-type file-attr))) + (eq t (file-attribute-type file-attr)) + (null (file-attribute-type file-attr))) (or ;; World accessible. - (eq access - (aref (tramp-compat-file-attribute-modes file-attr) - (+ offset 6))) + (eq access (aref (file-attribute-modes file-attr) (+ offset 6))) ;; User accessible and owned by user. (and - (eq access - (aref (tramp-compat-file-attribute-modes file-attr) offset)) - (or (equal remote-uid - (tramp-compat-file-attribute-user-id file-attr)) - (equal unknown-id - (tramp-compat-file-attribute-user-id file-attr)))) + (eq access (aref (file-attribute-modes file-attr) offset)) + (or (equal remote-uid (file-attribute-user-id file-attr)) + (equal unknown-id (file-attribute-user-id file-attr)))) ;; Group accessible and owned by user's principal group. (and (eq access - (aref (tramp-compat-file-attribute-modes file-attr) - (+ offset 3))) - (or (equal remote-gid - (tramp-compat-file-attribute-group-id file-attr)) - (equal unknown-id - (tramp-compat-file-attribute-group-id - file-attr)))))))))))) + (aref (file-attribute-modes file-attr) (+ offset 3))) + (or (equal remote-gid (file-attribute-group-id file-attr)) + (equal unknown-id (file-attribute-group-id file-attr)))))))))))) (defun tramp-get-remote-uid (vec id-format) "The uid of the remote connection VEC, in ID-FORMAT. @@ -5497,7 +5557,7 @@ this file, if that variable is non-nil." (when (and (not tramp-allow-unsafe-temporary-files) auto-save-default (file-in-directory-p result temporary-file-directory) - (zerop (or (tramp-compat-file-attribute-user-id + (zerop (or (file-attribute-user-id (file-attributes filename 'integer)) tramp-unknown-id-integer)) (not (with-tramp-connection-property @@ -5533,8 +5593,7 @@ ALIST is of the form ((FROM . TO) ...)." (defun tramp-handle-make-nearby-temp-file (prefix &optional dir-flag suffix) "Like `make-nearby-temp-file' for Tramp files." - (let ((temporary-file-directory - (tramp-compat-temporary-file-directory-function))) + (let ((temporary-file-directory (temporary-file-directory))) (make-temp-file prefix dir-flag suffix))) ;;; Compatibility functions section: @@ -5557,14 +5616,12 @@ are written with verbosity of 6." (with-temp-buffer (setq result (apply - #'call-process program infile (or destination t) display args)) + #'call-process program infile (or destination t) display args) + output (tramp-get-buffer-string destination)) ;; `result' could also be an error string. (when (stringp result) (setq error result - result 1)) - (with-current-buffer - (if (bufferp destination) destination (current-buffer)) - (setq output (buffer-string)))) + result 1))) (error (setq error (error-message-string err) result 1))) @@ -5595,10 +5652,10 @@ are written with verbosity of 6." ;; `result' could also be an error string. (when (stringp result) (signal 'file-error (list result))) - (with-current-buffer (if (bufferp buffer) buffer (current-buffer)) - (if (zerop result) - (tramp-message vec 6 "%d" result) - (tramp-message vec 6 "%d\n%s" result (buffer-string))))) + (if (zerop result) + (tramp-message vec 6 "%d" result) + (tramp-message + vec 6 "%d\n%s" result (tramp-get-buffer-string buffer)))) (error (setq result 1) (tramp-message vec 6 "%d\n%s" result (error-message-string err)))) @@ -5663,7 +5720,7 @@ Invokes `password-read' if available, `read-passwd' else." (format "%s for %s " (capitalize (match-string 1)) key)))) (auth-source-creation-prompts `((secret . ,pw-prompt))) ;; Use connection-local value. - (auth-sources (with-current-buffer (process-buffer proc) auth-sources)) + (auth-sources (buffer-local-value 'auth-sources (process-buffer proc))) ;; We suspend the timers while reading the password. (stimers (with-timeout-suspend)) auth-info auth-passwd) @@ -5704,15 +5761,12 @@ Invokes `password-read' if available, `read-passwd' else." (setq auth-passwd (funcall auth-passwd))) auth-passwd) - ;; Try the password cache. Exists since Emacs 26.1. + ;; Try the password cache. (progn (setq auth-passwd (password-read pw-prompt key) tramp-password-save-function (lambda () (password-cache-add key auth-passwd))) - auth-passwd) - - ;; Else, get the password interactively w/o cache. - (read-passwd pw-prompt)) + auth-passwd)) ;; Workaround. Prior Emacs 28.1, auth-source has saved ;; empty passwords. See discussion in Bug#50399. @@ -5824,13 +5878,11 @@ name of a process or buffer, or nil to default to the current buffer." (while (tramp-accept-process-output proc 0)) (not (process-live-p proc)))))) -;; `interrupt-process-functions' exists since Emacs 26.1. -(when (boundp 'interrupt-process-functions) - (add-hook 'interrupt-process-functions #'tramp-interrupt-process) - (add-hook - 'tramp-unload-hook - (lambda () - (remove-hook 'interrupt-process-functions #'tramp-interrupt-process)))) +(add-hook 'interrupt-process-functions #'tramp-interrupt-process) +(add-hook + 'tramp-unload-hook + (lambda () + (remove-hook 'interrupt-process-functions #'tramp-interrupt-process))) (defun tramp-get-remote-null-device (vec) "Return null device on the remote host identified by VEC. @@ -5894,5 +5946,11 @@ BODY is the backend specific code." ;; and friends, for most of the handlers this is the major ;; difference between the different backends. Other handlers but ;; *-process-file would profit from this as well. +;; +;; * Implement file name abbreviation for a different user. That is, +;; (abbreviate-file-name "/ssh:user1@host:/home/user2") => +;; "/ssh:user1@host:~user2". +;; +;; * Implement file name abbreviation for user and host names. ;;; tramp.el ends here diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index 680bcf09318..6dc5da229c1 100644 --- a/lisp/net/trampver.el +++ b/lisp/net/trampver.el @@ -7,8 +7,8 @@ ;; Maintainer: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes ;; Package: tramp -;; Version: 2.5.2.28.1 -;; Package-Requires: ((emacs "25.1")) +;; Version: 2.6.0-pre +;; Package-Requires: ((emacs "26.1")) ;; Package-Type: multi ;; URL: https://www.gnu.org/software/tramp/ @@ -40,7 +40,7 @@ ;; ./configure" to change them. ;;;###tramp-autoload -(defconst tramp-version "2.5.2.28.1" +(defconst tramp-version "2.6.0-pre" "This version of Tramp.") ;;;###tramp-autoload @@ -74,9 +74,9 @@ "The repository revision of the Tramp sources.") ;; Check for Emacs version. -(let ((x (if (not (string-lessp emacs-version "25.1")) +(let ((x (if (not (string-version-lessp emacs-version "26.1")) "ok" - (format "Tramp 2.5.2.28.1 is not fit for %s" + (format "Tramp 2.6.0-pre is not fit for %s" (replace-regexp-in-string "\n" "" (emacs-version)))))) (unless (string-equal "ok" x) (error "%s" x))) diff --git a/lisp/net/webjump.el b/lisp/net/webjump.el index d14d382aac3..7547f92d7d3 100644 --- a/lisp/net/webjump.el +++ b/lisp/net/webjump.el @@ -61,6 +61,13 @@ ;;; Code: +;; TODO: +;; - Add a menu bar and tool bar for this library. +;; - Add commands to create/delete link from the hotlist. +;; - Add something like a bookmark folder in modern browsers. +;; - Add a command that can open/follow all links in a folder. +;; - Add tags for Web sites in the hotlist. + ;;-------------------------------------------------------- Package Dependencies (require 'browse-url) diff --git a/lisp/novice.el b/lisp/novice.el index 16766c253c5..65e48a21493 100644 --- a/lisp/novice.el +++ b/lisp/novice.el @@ -43,71 +43,65 @@ If nil, the feature is disabled, i.e., all commands work normally.") ;; because we won't get called otherwise. ;;;###autoload (defun disabled-command-function (&optional cmd keys) - (unless cmd (setq cmd this-command)) - (unless keys (setq keys (this-command-keys))) - (let (char) - (save-window-excursion - (with-output-to-temp-buffer "*Disabled Command*" ;; (help-buffer) - (if (or (eq (aref keys 0) - (if (stringp keys) - (aref "\M-x" 0) - ?\M-x)) - (and (>= (length keys) 2) - (eq (aref keys 0) meta-prefix-char) - (eq (aref keys 1) ?x))) - (princ (format "You have invoked the disabled command %s.\n" cmd)) - (princ (format "You have typed %s, invoking disabled command %s.\n" - (key-description keys) cmd))) - ;; Print any special message saying why the command is disabled. - (if (stringp (get cmd 'disabled)) - (princ (get cmd 'disabled)) - (princ "It is disabled because new users often find it confusing.\n") - (princ (substitute-command-keys - "Here's the first part of its description:\n\n")) - ;; Keep only the first paragraph of the documentation. - (with-current-buffer "*Disabled Command*" ;; standard-output - (goto-char (point-max)) - (let ((start (point))) - (save-excursion - (princ (or (condition-case () - (documentation cmd) - (error nil)) - "<< not documented >>"))) - (if (search-forward "\n\n" nil t) - (delete-region (match-beginning 0) (point-max))) - (goto-char (point-max)) - (indent-rigidly start (point) 3)))) - (princ "\n\nDo you want to use this command anyway?\n\n") - (princ (substitute-command-keys "You can now type -y to try it and enable it (no questions if you use it again). -n to cancel--don't try the command, and it remains disabled. -SPC to try the command just this once, but leave it disabled. -! to try it, and enable all disabled commands for this session only.")) - ;; Redundant since with-output-to-temp-buffer will do it anyway. - ;; (with-current-buffer standard-output - ;; (help-mode)) - ) - (fit-window-to-buffer (get-buffer-window "*Disabled Command*")) - (message "Type y, n, ! or SPC (the space bar): ") - (let ((cursor-in-echo-area t)) - (while (progn (setq char (read-event)) - (or (not (numberp char)) - (not (memq (downcase char) - '(?! ?y ?n ?\s ?\C-g))))) - (ding) - (message "Please type y, n, ! or SPC (the space bar): ")))) - (setq char (downcase char)) + (let* ((cmd (or cmd this-command)) + (keys (or keys (this-command-keys))) + (help-string + (concat + (if (or (eq (aref keys 0) + (if (stringp keys) + (aref "\M-x" 0) + ?\M-x)) + (and (>= (length keys) 2) + (eq (aref keys 0) meta-prefix-char) + (eq (aref keys 1) ?x))) + (format "You have invoked the disabled command %s.\n" cmd) + (substitute-command-keys + (format "You have typed \\`%s', invoking disabled command %s.\n" + (key-description keys) cmd))) + ;; Any special message saying why the command is disabled. + (if (stringp (get cmd 'disabled)) + (get cmd 'disabled) + (concat + "It is disabled because new users often find it confusing.\n" + (substitute-command-keys + "Here's the first part of its description:\n\n") + ;; Keep only the first paragraph of the documentation. + (with-temp-buffer + (insert (condition-case () + (documentation cmd) + (error "<< not documented >>"))) + (goto-char (point-min)) + (when (search-forward "\n\n" nil t) + (delete-region (match-beginning 0) (point-max))) + (indent-rigidly (point-min) (point-max) 3) + (buffer-string)))) + (substitute-command-keys "\n +Do you want to use this command anyway? + +You can now type: + \\`y' to try it and enable it (no questions if you use it again). + \\`n' to cancel--don't try the command, and it remains disabled. + \\`SPC' to try the command just this once, but leave it disabled. + \\`!' to try it, and enable all disabled commands for this session only."))) + (char + (car (read-multiple-choice "Use this command?" + '((?y "yes") + (?n "no") + (?! "yes; enable for session") + (?\s "(space bar) yes; once")) + help-string + "*Disabled Command*")))) (pcase char - (?\C-g (setq quit-flag t)) - (?! (setq disabled-command-function nil)) - (?y - (if (and user-init-file - (not (string= "" user-init-file)) - (y-or-n-p "Enable command for future editing sessions also? ")) - (enable-command cmd) - (put cmd 'disabled nil)))) - (or (char-equal char ?n) - (call-interactively cmd)))) + (?\C-g (setq quit-flag t)) + (?! (setq disabled-command-function nil)) + (?y + (if (and user-init-file + (not (string= "" user-init-file)) + (y-or-n-p "Enable command for future editing sessions also? ")) + (enable-command cmd) + (put cmd 'disabled nil)))) + (unless (char-equal char ?n) + (call-interactively cmd)))) (defun en/disable-command (command disable) (unless (commandp command) diff --git a/lisp/nxml/rng-cmpct.el b/lisp/nxml/rng-cmpct.el index dd3000773fd..1476aa0e5a3 100644 --- a/lisp/nxml/rng-cmpct.el +++ b/lisp/nxml/rng-cmpct.el @@ -369,7 +369,7 @@ OVERRIDE is either nil, require or t." (while (re-search-forward "\\\\x+{\\([[:xdigit:]]+\\)}" (point-max) t) - (let* ((ch (decode-char 'ucs (string-to-number (match-string 1) 16)))) + (let* ((ch (string-to-number (match-string 1) 16))) (if (and ch (> ch 0)) (let ((begin (match-beginning 0)) (end (match-end 0))) diff --git a/lisp/nxml/xmltok.el b/lisp/nxml/xmltok.el index 6159e00c511..ecad501a644 100644 --- a/lisp/nxml/xmltok.el +++ b/lisp/nxml/xmltok.el @@ -943,7 +943,6 @@ and VALUE-END, otherwise a STRING giving the value." (let ((n (string-to-number (buffer-substring-no-properties start end) base))) (cond ((and (integerp n) (xmltok-valid-char-p n)) - (setq n (xmltok-unicode-to-char n)) (and n (string n))) (t (xmltok-add-error "Invalid character code" start end) @@ -971,11 +970,6 @@ and VALUE-END, otherwise a STRING giving the value." (t (and (> n #xFFFF) (< n #x110000))))) -(defun xmltok-unicode-to-char (n) - "Return the character corresponding to Unicode scalar value N. -Return nil if unsupported in Emacs." - (decode-char 'ucs n)) - ;;; Prolog parsing (defvar xmltok-contains-doctype nil) @@ -1766,6 +1760,10 @@ and `xmltok-namespace-attributes'." xmltok-type)) (message "Scanned end of file"))) +;;; Obsolete + +(define-obsolete-function-alias 'xmltok-unicode-to-char #'identity "29.1") + (provide 'xmltok) ;;; xmltok.el ends here diff --git a/lisp/nxml/xsd-regexp.el b/lisp/nxml/xsd-regexp.el index f07ca6657ed..d6eaf7cc4bc 100644 --- a/lisp/nxml/xsd-regexp.el +++ b/lisp/nxml/xsd-regexp.el @@ -52,9 +52,6 @@ ;; or a character translatable to such a character (i.e a character ;; for which `encode-char' will return non-nil). ;; -;; Using unify-8859-on-decoding-mode is probably a good idea here -;; (and generally with XML and other Unicode-oriented formats). -;; ;; Unfortunately, this means that this package is currently useless ;; for CJK characters, since there's no mule-unicode charset for the ;; CJK ranges of Unicode. We should devise a workaround for this @@ -290,7 +287,7 @@ and whose tail is ACCUM." (defun xsdre-compile-single-char (ch) (if (memq ch '(?. ?* ?+ ?? ?\[ ?\] ?^ ?$ ?\\)) (string ?\\ ch) - (string (decode-char 'ucs ch)))) + (string ch))) (defun xsdre-char-class-to-range-list (cc) "Return a range-list for a symbolic char-class CC." @@ -407,10 +404,6 @@ consisting of a single char alternative delimited with []." (cons last chars) (cons last (cons ?- chars)))))) (setq range-list (cdr range-list))) - (setq chars - (mapcar (lambda (c) - (decode-char 'ucs c)) - chars)) (when caret (setq chars (cons ?^ chars))) (when hyphen diff --git a/lisp/obsolete/cl-compat.el b/lisp/obsolete/cl-compat.el index 619bc06122b..0dba366192e 100644 --- a/lisp/obsolete/cl-compat.el +++ b/lisp/obsolete/cl-compat.el @@ -52,6 +52,7 @@ ;;; Keyword routines not supported by new package. (defmacro defkeyword (x &optional doc) + (declare (indent defun)) (cl-list* 'defconst x (list 'quote x) (and doc (list doc)))) (defun keyword-of (sym) diff --git a/lisp/obsolete/cl.el b/lisp/obsolete/cl.el index 9df62318572..a892ed7c76b 100644 --- a/lisp/obsolete/cl.el +++ b/lisp/obsolete/cl.el @@ -513,7 +513,8 @@ a temporary-variables list, a value-forms list, a store-variables list See `gv-define-expander', and `gv-define-setter' for better and simpler ways to define setf-methods." (declare (debug - (&define name cl-lambda-list cl-declarations-or-string def-body))) + (&define name cl-lambda-list cl-declarations-or-string def-body)) + (indent defun)) `(progn ,@(if (stringp (car body)) (list `(put ',name 'setf-documentation ,(pop body)))) @@ -554,7 +555,8 @@ You can replace this form with `gv-define-setter'. (&define name [&or [symbolp &optional stringp] [cl-lambda-list (symbolp)]] - cl-declarations-or-string def-body))) + cl-declarations-or-string def-body)) + (indent defun)) (if (and (listp arg1) (consp args)) ;; Like `gv-define-setter' but with `cl-function'. `(gv-define-expander ,name @@ -615,7 +617,8 @@ arguments from ARGLIST using FUNC. For example: You can replace this macro with `gv-letplace'." (declare (debug (&define name cl-lambda-list ;; should exclude &key - symbolp &optional stringp))) + symbolp &optional stringp)) + (indent defun)) (if (memq '&key arglist) (error "&key not allowed in define-modify-macro")) (require 'cl-macs) ;For cl--arglist-args. diff --git a/lisp/obsolete/crisp.el b/lisp/obsolete/crisp.el index 69bf3ed12bc..ccf9aaa2b6a 100644 --- a/lisp/obsolete/crisp.el +++ b/lisp/obsolete/crisp.el @@ -231,27 +231,13 @@ does not load the scroll-all package." ;; The cut and paste routines are different between XEmacs and Emacs ;; so we need to set up aliases for the functions. - -(defalias 'crisp-set-clipboard - (if (fboundp 'clipboard-kill-ring-save) - 'clipboard-kill-ring-save - 'copy-primary-selection)) - -(defalias 'crisp-kill-region - (if (fboundp 'clipboard-kill-region) - 'clipboard-kill-region - 'kill-primary-selection)) - -(defalias 'crisp-yank-clipboard - (if (fboundp 'clipboard-yank) - 'clipboard-yank - 'yank-clipboard-selection)) +(defalias 'crisp-set-clipboard 'clipboard-kill-ring-save) +(defalias 'crisp-kill-region 'clipboard-kill-region) +(defalias 'crisp-yank-clipboard 'clipboard-yank) (defun crisp-region-active () "Compatibility function to test for an active region." - (if (featurep 'xemacs) - zmacs-region-active-p - mark-active)) + mark-active) (defun crisp-version (&optional arg) "Version number of the CRiSP emulator package. diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/obsolete/eieio-compat.el index 6d84839c341..60b0638c63f 100644 --- a/lisp/emacs-lisp/eieio-compat.el +++ b/lisp/obsolete/eieio-compat.el @@ -70,7 +70,8 @@ is appropriate to use. Uses `defmethod' to create methods, and calls `defgeneric' for you. With this implementation the ARGS are currently ignored. You can use `defgeneric' to apply specialized top level documentation to a method." - (declare (doc-string 3) (obsolete cl-defgeneric "25.1")) + (declare (doc-string 3) (obsolete cl-defgeneric "25.1") + (indent defun)) `(eieio--defalias ',method (eieio--defgeneric-init-form ',method @@ -103,6 +104,7 @@ Summary: \"doc-string\" body)" (declare (doc-string 3) (obsolete cl-defmethod "25.1") + (indent defun) (debug (&define ; this means we are defining something [&name sexp] ;Allow (setf ...) additionally to symbols. diff --git a/lisp/obsolete/eudcb-ph.el b/lisp/obsolete/eudcb-ph.el index 187879ce2f7..51a6780d903 100644 --- a/lisp/obsolete/eudcb-ph.el +++ b/lisp/obsolete/eudcb-ph.el @@ -176,9 +176,7 @@ SERVER is either a string naming the server or a list (NAME PORT)." (setq eudc-ph-process-buffer (get-buffer-create (format " *PH-%s*" host))) (with-current-buffer eudc-ph-process-buffer (erase-buffer) - (setq eudc-ph-read-point (point)) - (and (featurep 'xemacs) (featurep 'mule) - (set-buffer-file-coding-system 'binary t))) + (setq eudc-ph-read-point (point))) (setq process (open-network-stream "ph" eudc-ph-process-buffer host port)) (if (null process) (throw 'done nil)) diff --git a/lisp/obsolete/fast-lock.el b/lisp/obsolete/fast-lock.el index 960233d5627..1dee7120c0e 100644 --- a/lisp/obsolete/fast-lock.el +++ b/lisp/obsolete/fast-lock.el @@ -283,10 +283,7 @@ If a number, only buffers greater than this size have processing messages." (other :tag "always" t) (integer :tag "size"))) -(defvar fast-lock-save-faces - (when (featurep 'xemacs) - ;; XEmacs uses extents for everything, so we have to pick the right ones. - font-lock-face-list) +(defvar fast-lock-save-faces nil "Faces that will be saved in a Font Lock cache file. If nil, means information for all faces will be saved.") @@ -707,35 +704,7 @@ See `fast-lock-get-face-properties'." (while regions (add-text-properties (nth 0 regions) (nth 1 regions) plist) (setq regions (nthcdr 2 regions)))))))) - -;; Functions for XEmacs: - -(unless (boundp 'font-lock-syntactic-keywords) - (defvar font-lock-syntactic-keywords nil)) - -(unless (boundp 'font-lock-inhibit-thing-lock) - (defvar font-lock-inhibit-thing-lock nil)) - -(unless (fboundp 'font-lock-compile-keywords) - (defalias 'font-lock-compile-keywords #'identity)) - -(unless (fboundp 'font-lock-eval-keywords) - (defun font-lock-eval-keywords (keywords) - (if (symbolp keywords) - (font-lock-eval-keywords (if (fboundp keywords) - (funcall keywords) - (eval keywords t))) - keywords))) - -(unless (fboundp 'font-lock-value-in-major-mode) - (defun font-lock-value-in-major-mode (alist) - (if (consp alist) - (cdr (or (assq major-mode alist) (assq t alist))) - alist))) - -(unless (fboundp 'current-message) - (defun current-message () - "")) + ;; Install ourselves: diff --git a/lisp/obsolete/iswitchb.el b/lisp/obsolete/iswitchb.el index a630baf3543..f1e4414e93f 100644 --- a/lisp/obsolete/iswitchb.el +++ b/lisp/obsolete/iswitchb.el @@ -467,9 +467,7 @@ interfere with other minibuffer usage.") (switch-to-buffer-other-window . iswitchb-buffer-other-window) (switch-to-buffer-other-frame . iswitchb-buffer-other-frame) (display-buffer . iswitchb-display-buffer))) - (if (fboundp 'command-remapping) - (define-key map (vector 'remap (car b)) (cdr b)) - (substitute-key-definition (car b) (cdr b) map global-map))) + (define-key map (vector 'remap (car b)) (cdr b))) map) "Global keymap for `iswitchb-mode'.") @@ -977,17 +975,7 @@ Return the modified list with the last element prepended to it." (set-buffer buf)) (with-output-to-temp-buffer temp-buf - (if (featurep 'xemacs) - - ;; XEmacs extents are put on by default, doesn't seem to be - ;; any way of switching them off. - (display-completion-list (or iswitchb-matches iswitchb-buflist) - :help-string "iswitchb " - :activate-callback - (lambda (_x _y _z) - (message "doesn't work yet, sorry!"))) - ;; else running Emacs - (display-completion-list (or iswitchb-matches iswitchb-buflist)))) + (display-completion-list (or iswitchb-matches iswitchb-buflist))) (setq iswitchb-common-match-inserted nil)))) ;;; KILL CURRENT BUFFER @@ -1326,9 +1314,7 @@ This is an example function which can be hooked on to "Return non-nil if we should ignore case when matching. See the variable `iswitchb-case' for details." (if iswitchb-case - (if (featurep 'xemacs) - (isearch-no-upper-case-p iswitchb-text) - (isearch-no-upper-case-p iswitchb-text t)))) + (isearch-no-upper-case-p iswitchb-text t))) ;;;###autoload (define-minor-mode iswitchb-mode diff --git a/lisp/obsolete/otodo-mode.el b/lisp/obsolete/otodo-mode.el index 47f5089452f..a71d2b82e4c 100644 --- a/lisp/obsolete/otodo-mode.el +++ b/lisp/obsolete/otodo-mode.el @@ -908,8 +908,7 @@ If INCLUDE-SEP is non-nil, return point after the separator." ;;;###autoload (define-derived-mode todo-mode nil "TODO" "Major mode for editing TODO lists." - (when (featurep 'xemacs) - (easy-menu-add todo-menu))) + nil) (with-suppressed-warnings ((lexical date entry)) (defvar date) diff --git a/lisp/obsolete/pgg-parse.el b/lisp/obsolete/pgg-parse.el index 2c76365a415..3e4c216abef 100644 --- a/lisp/obsolete/pgg-parse.el +++ b/lisp/obsolete/pgg-parse.el @@ -496,8 +496,7 @@ (defun pgg-parse-armor (string) (with-temp-buffer (buffer-disable-undo) - (unless (featurep 'xemacs) - (set-buffer-multibyte nil)) + (set-buffer-multibyte nil) (insert string) (pgg-decode-armor-region (point-min)(point)))) diff --git a/lisp/obsolete/pgg.el b/lisp/obsolete/pgg.el index 5ed59933f23..127e1dc15c0 100644 --- a/lisp/obsolete/pgg.el +++ b/lisp/obsolete/pgg.el @@ -376,8 +376,7 @@ signer's public key from `pgg-default-keyserver-address'." (if (null signature) nil (with-temp-buffer (buffer-disable-undo) - (unless (featurep 'xemacs) - (set-buffer-multibyte nil)) + (set-buffer-multibyte nil) (insert-file-contents signature) (cdr (assq 2 (pgg-decode-armor-region (point-min)(point-max))))))) diff --git a/lisp/obsolete/tpu-edt.el b/lisp/obsolete/tpu-edt.el index e0e89c390ea..b59fb8c868c 100644 --- a/lisp/obsolete/tpu-edt.el +++ b/lisp/obsolete/tpu-edt.el @@ -650,12 +650,8 @@ GOLD is the ASCII 7-bit escape sequence <ESC>OP.") (setq tpu-mark-flag (if transient-mark-mode "" (if (tpu-mark) " @" " "))) (force-mode-line-update)) -(cond ((featurep 'xemacs) - (add-hook 'zmacs-deactivate-region-hook 'tpu-update-mode-line) - (add-hook 'zmacs-activate-region-hook 'tpu-update-mode-line)) - (t - (add-hook 'activate-mark-hook 'tpu-update-mode-line) - (add-hook 'deactivate-mark-hook 'tpu-update-mode-line))) +(add-hook 'activate-mark-hook 'tpu-update-mode-line) +(add-hook 'deactivate-mark-hook 'tpu-update-mode-line) ;;; @@ -727,15 +723,13 @@ Otherwise sets the tpu-match markers to nil and returns nil." "TPU-edt version of the mark function. Return the appropriate value of the mark for the current version of Emacs." - (cond ((featurep 'xemacs) (mark (not zmacs-regions))) - (t (and mark-active (mark (not transient-mark-mode)))))) + (and mark-active (mark (not transient-mark-mode)))) (defun tpu-set-mark (pos) "TPU-edt version of the `set-mark' function. Sets the mark at POS and activates the region according to the current version of Emacs." - (set-mark pos) - (when (featurep 'xemacs) (when pos (zmacs-activate-region)))) + (set-mark pos)) (defun tpu-string-prompt (prompt history-symbol) "Read a string with PROMPT." @@ -2306,17 +2300,14 @@ Accepts a prefix argument for the number of tpu-pan-columns to scroll." ;;; (defun tpu-load-xkeys (file) "Load the TPU-edt X-windows key definitions FILE. -If FILE is nil, try to load a default file. The default file names are -`~/.tpu-lucid-keys' for XEmacs, and `~/.tpu-keys' for Emacs." +If FILE is nil, try to load a default file. The default file name is +`~/.tpu-keys'." (interactive "fX key definition file: ") (cond (file (setq file (expand-file-name file))) (tpu-xkeys-file (setq file (expand-file-name tpu-xkeys-file))) - ((featurep 'xemacs) - (setq file (convert-standard-filename - (expand-file-name "~/.tpu-lucid-keys")))) - (t + (t (setq file (convert-standard-filename (expand-file-name "~/.tpu-keys"))) (and (not (file-exists-p file)) diff --git a/lisp/obsolete/tpu-mapper.el b/lisp/obsolete/tpu-mapper.el index 5ae0a6558d5..02ba3632504 100644 --- a/lisp/obsolete/tpu-mapper.el +++ b/lisp/obsolete/tpu-mapper.el @@ -46,24 +46,14 @@ ;;; (defun tpu-map-key (ident descrip func gold-func) (interactive) - (if (featurep 'xemacs) - (progn - (setq tpu-key-seq (read-key-sequence - (format "Press %s%s: " ident descrip)) - tpu-key (format "[%s]" (event-key (aref tpu-key-seq 0)))) - (unless (equal tpu-key tpu-return) - (set-buffer "Keys") - (insert (format"(global-set-key %s %s)\n" tpu-key func)) - (set-buffer "Gold-Keys") - (insert (format "(define-key tpu-gold-map %s %s)\n" tpu-key gold-func)))) - (message "Press %s%s: " ident descrip) - (setq tpu-key-seq (read-event) - tpu-key (format "[%s]" tpu-key-seq)) - (unless (equal tpu-key tpu-return) - (set-buffer "Keys") - (insert (format"(define-key tpu-global-map %s %s)\n" tpu-key func)) - (set-buffer "Gold-Keys") - (insert (format "(define-key tpu-gold-map %s %s)\n" tpu-key gold-func)))) + (message "Press %s%s: " ident descrip) + (setq tpu-key-seq (read-event) + tpu-key (format "[%s]" tpu-key-seq)) + (unless (equal tpu-key tpu-return) + (set-buffer "Keys") + (insert (format"(define-key tpu-global-map %s %s)\n" tpu-key func)) + (set-buffer "Gold-Keys") + (insert (format "(define-key tpu-gold-map %s %s)\n" tpu-key gold-func))) (set-buffer "Directions") tpu-key) @@ -103,8 +93,7 @@ your local X guru can try to figure out why the key is being ignored." ;; Make sure the window is big enough to display the instructions - (if (featurep 'xemacs) (set-screen-size (selected-screen) 80 36) - (set-frame-size (selected-frame) 80 36)) + (set-frame-size (selected-frame) 80 36) ;; Create buffers - Directions, Keys, Gold-Keys @@ -162,14 +151,9 @@ your local X guru can try to figure out why the key is being ignored." ;; Save <CR> for future reference - (cond - ((featurep 'xemacs) - (setq tpu-return-seq (read-key-sequence "Hit carriage-return <CR> to continue ")) - (setq tpu-return (concat "[" (format "%s" (event-key (aref tpu-return-seq 0))) "]"))) - (t - (message "Hit carriage-return <CR> to continue ") - (setq tpu-return-seq (read-event)) - (setq tpu-return (concat "[" (format "%s" tpu-return-seq) "]")))) + (message "Hit carriage-return <CR> to continue ") + (setq tpu-return-seq (read-event)) + (setq tpu-return (concat "[" (format "%s" tpu-return-seq) "]")) ;; Build the keymap file @@ -308,24 +292,14 @@ your local X guru can try to figure out why the key is being ignored." ;; ") - (cond ((featurep 'xemacs) - (insert (format "(setq tpu-help-enter \"%s\")\n" tpu-enter-seq)) - (insert (format "(setq tpu-help-return \"%s\")\n" tpu-return-seq)) - (insert "(setq tpu-help-N \"[#<keypress-event N>]\")\n") - (insert "(setq tpu-help-n \"[#<keypress-event n>]\")\n") - (insert "(setq tpu-help-P \"[#<keypress-event P>]\")\n") - (insert "(setq tpu-help-p \"[#<keypress-event p>]\")\n")) - (t - (insert (format "(setq tpu-help-enter \"%s\")\n" tpu-enter)))) + (insert (format "(setq tpu-help-enter \"%s\")\n" tpu-enter)) (append-to-buffer "Keys" 1 (point)) (set-buffer "Keys") ;; Save the key mapping program - (let ((file - (convert-standard-filename - (if (featurep 'xemacs) "~/.tpu-lucid-keys" "~/.tpu-keys")))) + (let ((file (convert-standard-filename "~/.tpu-keys"))) (set-visited-file-name (read-file-name (format "Save key mapping to file (default %s): " file) "" file))) (save-buffer) diff --git a/lisp/obsolete/vc-arch.el b/lisp/obsolete/vc-arch.el index fbbd2d4ecfe..1dffd36f0ea 100644 --- a/lisp/obsolete/vc-arch.el +++ b/lisp/obsolete/vc-arch.el @@ -83,8 +83,6 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches." (repeat :tag "Argument List" :value ("") string)) :version "23.1") -(define-obsolete-variable-alias 'vc-arch-command 'vc-arch-program "23.1") - (defcustom vc-arch-program (let ((candidates '("tla" "baz"))) (while (and candidates (not (executable-find (car candidates)))) diff --git a/lisp/org/ol-eshell.el b/lisp/org/ol-eshell.el index a7550e3769b..b13f659b22d 100644 --- a/lisp/org/ol-eshell.el +++ b/lisp/org/ol-eshell.el @@ -46,7 +46,7 @@ followed by a colon." (eshell-buffer-name (car buffer-and-command)) (command (cadr buffer-and-command))) (if (get-buffer eshell-buffer-name) - (pop-to-buffer-same-window eshell-buffer-name) + (pop-to-buffer eshell-buffer-name display-comint-buffer-action) (eshell)) (goto-char (point-max)) (eshell-kill-input) diff --git a/lisp/org/ol-man.el b/lisp/org/ol-man.el index 0d9ac7c8c71..e6b0105fdc2 100644 --- a/lisp/org/ol-man.el +++ b/lisp/org/ol-man.el @@ -8,12 +8,12 @@ ;; ;; This file is part of GNU Emacs. ;; -;; This program is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. -;; This program is distributed in the hope that it will be useful, +;; 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. diff --git a/lisp/org/ol.el b/lisp/org/ol.el index aa1849715c3..b70f1996d54 100644 --- a/lisp/org/ol.el +++ b/lisp/org/ol.el @@ -1575,7 +1575,7 @@ non-nil." (setq link (format-time-string (car org-time-stamp-formats) - (apply 'encode-time + (encode-time (list 0 0 0 (nth 1 cd) (nth 0 cd) (nth 2 cd) nil nil nil)))) (org-link-store-props :type "calendar" :date cd))) diff --git a/lisp/org/org-capture.el b/lisp/org/org-capture.el index a9350c58d52..1756b34fc5b 100644 --- a/lisp/org/org-capture.el +++ b/lisp/org/org-capture.el @@ -1815,10 +1815,13 @@ by their respective `org-store-link-plist' properties if present." ;; Load history list for current prompt. (setq org-capture--prompt-history (gethash prompt org-capture--prompt-history-table)) - (push (org-completing-read - (concat (or prompt "Enter string") - (and default (format " [%s]" default)) - ": ") + (push (org-completing-read + ;; `format-prompt' is new in Emacs 28.1. + (if (fboundp 'format-prompt) + (format-prompt (or prompt "Enter string") default) + (concat (or prompt "Enter string") + (and default (format " [%s]" default)) + ": ")) completions nil nil nil 'org-capture--prompt-history default) strings) diff --git a/lisp/org/org-clock.el b/lisp/org/org-clock.el index 6f83fe2bcbf..2cd9fc56d36 100644 --- a/lisp/org/org-clock.el +++ b/lisp/org/org-clock.el @@ -219,8 +219,7 @@ Emacs initialization file." (const :tag "Clock and history" t) (const :tag "No persistence" nil))) -(defcustom org-clock-persist-file (convert-standard-filename - (concat user-emacs-directory "org-clock-save.el")) +(defcustom org-clock-persist-file (locate-user-emacs-file "org-clock-save.el") "File to save clock data to." :group 'org-clock :type 'string) @@ -1905,11 +1904,11 @@ PROPNAME lets you set a custom text property instead of :org-clock-minutes." ((match-end 2) ;; Two time stamps. (let* ((ts (float-time - (apply #'encode-time + (encode-time (save-match-data (org-parse-time-string (match-string 2)))))) (te (float-time - (apply #'encode-time + (encode-time (org-parse-time-string (match-string 3))))) (dt (- (if tend (min te tend) te) (if tstart (max ts tstart) ts)))) @@ -2838,7 +2837,7 @@ a number of clock tables." (pcase (if range (car range) (plist-get params :tstart)) ((and (pred numberp) n) (pcase-let ((`(,m ,d ,y) (calendar-gregorian-from-absolute n))) - (apply #'encode-time (list 0 0 org-extend-today-until d m y)))) + (encode-time 0 0 org-extend-today-until d m y))) (timestamp (seconds-to-time (org-matcher-time (or timestamp @@ -2848,7 +2847,7 @@ a number of clock tables." (pcase (if range (nth 1 range) (plist-get params :tend)) ((and (pred numberp) n) (pcase-let ((`(,m ,d ,y) (calendar-gregorian-from-absolute n))) - (apply #'encode-time (list 0 0 org-extend-today-until d m y)))) + (encode-time 0 0 org-extend-today-until d m y))) (timestamp (seconds-to-time (org-matcher-time timestamp)))))) (while (time-less-p start end) (unless (bolp) (insert "\n")) @@ -3043,9 +3042,9 @@ Otherwise, return nil." (setq ts (match-string 1) te (match-string 3)) (setq s (- (float-time - (apply #'encode-time (org-parse-time-string te))) + (encode-time (org-parse-time-string te))) (float-time - (apply #'encode-time (org-parse-time-string ts)))) + (encode-time (org-parse-time-string ts)))) neg (< s 0) s (abs s) h (floor (/ s 3600)) diff --git a/lisp/org/org-colview.el b/lisp/org/org-colview.el index 9794382d8a4..f93e948bdcd 100644 --- a/lisp/org/org-colview.el +++ b/lisp/org/org-colview.el @@ -782,7 +782,7 @@ around it." (setq time-after (copy-sequence time)) (setf (nth 3 time-before) (1- (nth 3 time))) (setf (nth 3 time-after) (1+ (nth 3 time))) - (mapcar (lambda (x) (format-time-string fmt (apply #'encode-time x))) + (mapcar (lambda (x) (format-time-string fmt (encode-time x))) (list time-before time time-after))))) (defun org-columns-open-link (&optional arg) diff --git a/lisp/org/org-compat.el b/lisp/org/org-compat.el index d230ee2b11f..b140df76223 100644 --- a/lisp/org/org-compat.el +++ b/lisp/org/org-compat.el @@ -170,8 +170,7 @@ extension beyond end of line was not controllable." (defsubst file-attribute-modification-time (attributes) "The modification time in ATTRIBUTES returned by `file-attributes'. This is the time of the last change to the file's contents, and -is a list of integers (HIGH LOW USEC PSEC) in the same style -as (current-time)." +is a Lisp timestamp in the same style as `current-time'." (nth 5 attributes))) (unless (fboundp 'file-attribute-size) diff --git a/lisp/org/org-id.el b/lisp/org/org-id.el index 56783d10833..bd7e73905f3 100644 --- a/lisp/org/org-id.el +++ b/lisp/org/org-id.el @@ -196,8 +196,7 @@ the link." :group 'org-id :type 'boolean) -(defcustom org-id-locations-file (convert-standard-filename - (concat user-emacs-directory ".org-id-locations")) +(defcustom org-id-locations-file (locate-user-emacs-file ".org-id-locations") "The file for remembering in which file an ID was defined. This variable is only relevant when `org-id-track-globally' is set." :group 'org-id diff --git a/lisp/org/org-macro.el b/lisp/org/org-macro.el index c0287a25a55..83c35faea41 100644 --- a/lisp/org/org-macro.el +++ b/lisp/org/org-macro.el @@ -378,7 +378,7 @@ Return value as a string." (buffer-substring (point) (line-end-position))))) (when (cl-some #'identity time) - (setq date (apply #'encode-time time)))))))) + (setq date (encode-time time)))))))) (let ((proc (get-buffer-process buf))) (while (and proc (accept-process-output proc .5 nil t))))) (kill-buffer buf)) diff --git a/lisp/org/org-macs.el b/lisp/org/org-macs.el index 0779c3a82c8..044056b7a04 100644 --- a/lisp/org/org-macs.el +++ b/lisp/org/org-macs.el @@ -1185,7 +1185,7 @@ nil, just return 0." ((numberp s) s) ((stringp s) (condition-case nil - (float-time (apply #'encode-time (org-parse-time-string s))) + (float-time (encode-time (org-parse-time-string s))) (error 0))) (t 0))) @@ -1252,7 +1252,7 @@ following special strings: \"<now>\", \"<today>\", \"<tomorrow>\", and \"<yesterday>\". Return 0. if S is not recognized as a valid value." - (let ((today (float-time (apply #'encode-time + (let ((today (float-time (encode-time (append '(0 0 0) (nthcdr 3 (decode-time))))))) (save-match-data (cond diff --git a/lisp/org/org-refile.el b/lisp/org/org-refile.el index 678759e10db..73eaad6bf52 100644 --- a/lisp/org/org-refile.el +++ b/lisp/org/org-refile.el @@ -640,11 +640,13 @@ this function appends the default value from org-refile-target-table)) (completion-ignore-case t) cdef - (prompt (concat prompt - (or (and (car org-refile-history) - (concat " (default " (car org-refile-history) ")")) - (and (assoc cbnex tbl) (setq cdef cbnex) - (concat " (default " cbnex ")"))) ": ")) + (prompt (let ((default (or (car org-refile-history) + (and (assoc cbnex tbl) (setq cdef cbnex) + cbnex)))) + ;; `format-prompt' is new in Emacs 28.1. + (if (fboundp 'format-prompt) + (format-prompt prompt default) + (concat prompt " (default " default ": ")))) pa answ parent-target child parent old-hist) (setq old-hist org-refile-history) (setq answ (funcall cfunc prompt tbl nil (not new-nodes) diff --git a/lisp/org/org-table.el b/lisp/org/org-table.el index e34872fb491..a6dd8bff20f 100644 --- a/lisp/org/org-table.el +++ b/lisp/org/org-table.el @@ -2606,7 +2606,7 @@ location of point." (format-time-string (org-time-stamp-format (string-match-p "[0-9]\\{1,2\\}:[0-9]\\{2\\}" ts)) - (apply #'encode-time + (encode-time (save-match-data (org-parse-time-string ts)))))) form t t)) diff --git a/lisp/org/org.el b/lisp/org/org.el index d58f6af5505..e54bccdf2ec 100644 --- a/lisp/org/org.el +++ b/lisp/org/org.el @@ -13986,7 +13986,7 @@ user." (when (< (nth 2 org-defdecode) org-extend-today-until) (setf (nth 2 org-defdecode) -1) (setf (nth 1 org-defdecode) 59) - (setq org-def (apply #'encode-time org-defdecode)) + (setq org-def (encode-time org-defdecode)) (setq org-defdecode (decode-time org-def))) (let* ((timestr (format-time-string (if org-with-time "%Y-%m-%d %H:%M" "%Y-%m-%d") @@ -14470,7 +14470,7 @@ The command returns the inserted time stamp." time (org-fix-decoded-time t1) str (org-add-props (format-time-string - (substring tf 1 -1) (apply 'encode-time time)) + (substring tf 1 -1) (encode-time time)) nil 'mouse-face 'highlight)) (put-text-property beg end 'display str))) @@ -14725,7 +14725,7 @@ days in order to avoid rounding problems." (defun org-time-string-to-time (s) "Convert timestamp string S into internal time." - (apply #'encode-time (org-parse-time-string s))) + (encode-time (org-parse-time-string s))) (defun org-time-string-to-seconds (s) "Convert a timestamp string S into a number of seconds." @@ -15155,7 +15155,7 @@ When SUPPRESS-TMP-DELAY is non-nil, suppress delays like (setcar time0 (or (car time0) 0)) (setcar (nthcdr 1 time0) (or (nth 1 time0) 0)) (setcar (nthcdr 2 time0) (or (nth 2 time0) 0)) - (setq time (apply 'encode-time time0)))) + (setq time (encode-time time0)))) ;; Insert the new time-stamp, and ensure point stays in the same ;; category as before (i.e. not after the last position in that ;; category). diff --git a/lisp/org/ox-icalendar.el b/lisp/org/ox-icalendar.el index 16c3dc9a029..211d0f716b8 100644 --- a/lisp/org/ox-icalendar.el +++ b/lisp/org/ox-icalendar.el @@ -824,8 +824,7 @@ as a communication channel." (if (not (plist-get info :with-author)) "" (org-export-data (plist-get info :author) info)) ;; Timezone. - (if (org-string-nw-p org-icalendar-timezone) org-icalendar-timezone - (cadr (current-time-zone))) + (or (org-string-nw-p org-icalendar-timezone) (format-time-string "%Z")) ;; Description. (org-export-data (plist-get info :title) info) contents)) @@ -972,7 +971,7 @@ This function assumes major mode for current buffer is (org-icalendar--vcalendar org-icalendar-combined-name user-full-name - (or (org-string-nw-p org-icalendar-timezone) (cadr (current-time-zone))) + (or (org-string-nw-p org-icalendar-timezone) (format-time-string "%Z")) org-icalendar-combined-description contents))) (run-hook-with-args 'org-icalendar-after-save-hook file))) @@ -995,7 +994,7 @@ FILES is a list of files to build the calendar from." user-full-name ;; Timezone. (or (org-string-nw-p org-icalendar-timezone) - (cadr (current-time-zone))) + (format-time-string "Z")) ;; Description. org-icalendar-combined-description ;; Contents. diff --git a/lisp/outline.el b/lisp/outline.el index 52a94b4d9f4..5e3d4e0e002 100644 --- a/lisp/outline.el +++ b/lisp/outline.el @@ -35,6 +35,8 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) + (defgroup outlines nil "Support for hierarchical outlining." :prefix "outline-" @@ -219,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 @@ -272,6 +274,25 @@ in the file it applies to.") (defvar outline-font-lock-faces [outline-1 outline-2 outline-3 outline-4 outline-5 outline-6 outline-7 outline-8]) + +(defcustom outline-minor-mode-use-buttons nil + "If non-nil, use clickable buttons on the headings. +Note that this feature is not meant to be used in editing +buffers (yet) -- that will be amended in a future version. + +The `outline-minor-mode-buttons' variable specifies how the +buttons should look." + :type 'boolean + :safe #'booleanp + :version "29.1") + +(defcustom outline-minor-mode-buttons + '(("▶️" "🔽" outline--valid-emoji-p) + ("▶" "▼" outline--valid-char-p)) + "List of close/open pairs to use if using buttons." + :type 'sexp + :version "29.1") + (defvar outline-level #'outline-level "Function of no args to compute a header's nesting level in an outline. @@ -356,8 +377,8 @@ When point is on a heading line, then typing `TAB' cycles between `hide all', a heading line cycles the whole buffer (`outline-cycle-buffer'). Typing these keys anywhere outside heading lines uses their default bindings." :type 'boolean + :safe #'booleanp :version "28.1") -;;;###autoload(put 'outline-minor-mode-cycle 'safe-local-variable 'booleanp) (defcustom outline-minor-mode-highlight nil "Highlight headings in `outline-minor-mode' using font-lock keywords. @@ -371,8 +392,8 @@ faces to major mode's faces." (const :tag "Overwrite major mode faces" override) (const :tag "Append outline faces to major mode faces" append) (const :tag "Highlight separately from major mode faces" t)) + :safe #'symbolp :version "28.1") -;;;###autoload(put 'outline-minor-mode-highlight 'safe-local-variable 'symbolp) (defun outline-minor-mode-highlight-buffer () ;; Fallback to overlays when font-lock is unsupported. @@ -388,6 +409,8 @@ faces to major mode's faces." (goto-char (match-beginning 0)) (not (get-text-property (point) 'face)))) (overlay-put overlay 'face (outline-font-lock-face))) + (when outline-minor-mode-use-buttons + (outline--insert-open-button)) (when outline-minor-mode-cycle (overlay-put overlay 'keymap outline-minor-mode-cycle-map))) (goto-char (match-end 0)))))) @@ -807,6 +830,7 @@ If FLAG is nil then text is shown, while if FLAG is t the text is hidden." (overlay-put o 'isearch-open-invisible (or outline-isearch-open-invisible-function #'outline-isearch-open-invisible)))) + (outline--fix-up-all-buttons from to) ;; Seems only used by lazy-lock. I.e. obsolete. (run-hooks 'outline-view-change-hook)) @@ -923,11 +947,82 @@ Note that this does not hide the lines preceding the first heading line." (define-obsolete-function-alias 'show-all #'outline-show-all "25.1") -(defun outline-hide-subtree () - "Hide everything after this heading at deeper levels." - (interactive) +(defun outline-hide-subtree (&optional event) + "Hide everything after this heading at deeper levels. +If non-nil, EVENT should be a mouse event." + (interactive (list last-nonmenu-event)) + (when (mouse-event-p event) + (mouse-set-point event)) + (when (and outline-minor-mode-use-buttons outline-minor-mode) + (outline--insert-close-button)) (outline-flag-subtree t)) +(defun outline--make-button (type) + (cl-loop for (close open test) in outline-minor-mode-buttons + when (and (funcall test close) (funcall test open)) + return (concat (if (eq type 'close) + close + open) + " " (buffer-substring (point) (1+ (point)))))) + +(defun outline--valid-emoji-p (string) + (when-let ((font (and (display-multi-font-p) + (car (internal-char-font nil ?😀))))) + (font-has-char-p font (aref string 0)))) + +(defun outline--valid-char-p (string) + (char-displayable-p (aref string 0))) + +(defun outline--make-button-overlay (type) + (let ((o (seq-find (lambda (o) + (overlay-get o 'outline-button)) + (overlays-at (point))))) + (unless o + (setq o (make-overlay (point) (1+ (point)))) + (overlay-put o 'follow-link 'mouse-face) + (overlay-put o 'mouse-face 'highlight) + (overlay-put o 'outline-button t)) + (overlay-put o 'display (outline--make-button type)) + o)) + +(defun outline--insert-open-button () + (save-excursion + (beginning-of-line) + (let ((o (outline--make-button-overlay 'open))) + (overlay-put o 'help-echo "Click to hide") + (overlay-put o 'keymap + (define-keymap + :parent outline-minor-mode-cycle-map + "RET" #'outline-hide-subtree + "<mouse-2>" #'outline-hide-subtree))))) + +(defun outline--insert-close-button () + (save-excursion + (beginning-of-line) + (let ((o (outline--make-button-overlay 'close))) + (overlay-put o 'help-echo "Click to show") + (overlay-put o 'keymap + (define-keymap + :parent outline-minor-mode-cycle-map + "RET" #'outline-show-subtree + "<mouse-2>" #'outline-show-subtree))))) + +(defun outline--fix-up-all-buttons (&optional from to) + (when from + (save-excursion + (goto-char from) + (setq from (line-beginning-position)))) + (when outline-minor-mode-use-buttons + (outline-map-region + (lambda () + ;; `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))))) + (define-obsolete-function-alias 'hide-subtree #'outline-hide-subtree "25.1") (defun outline-hide-leaves () @@ -943,9 +1038,13 @@ Note that this does not hide the lines preceding the first heading line." (define-obsolete-function-alias 'hide-leaves #'outline-hide-leaves "25.1") -(defun outline-show-subtree () +(defun outline-show-subtree (&optional event) "Show everything after this heading at deeper levels." - (interactive) + (interactive (list last-nonmenu-event)) + (when (mouse-event-p event) + (mouse-set-point event)) + (when (and outline-minor-mode-use-buttons outline-minor-mode) + (outline--insert-open-button)) (outline-flag-subtree nil)) (define-obsolete-function-alias 'show-subtree #'outline-show-subtree "25.1") @@ -1295,7 +1394,8 @@ Return either 'hide-all, 'headings-only, or 'show-all." (t (outline-show-all) (setq outline--cycle-buffer-state 'show-all) - (message "Show all"))))) + (message "Show all"))) + (outline--fix-up-all-buttons))) (defvar outline-navigation-repeat-map (let ((map (make-sparse-keymap))) diff --git a/lisp/paren.el b/lisp/paren.el index ce6aa9ae13b..7e7cf6c262a 100644 --- a/lisp/paren.el +++ b/lisp/paren.el @@ -88,6 +88,14 @@ is not highlighted, the cursor being regarded as adequate to mark its position." :type 'boolean) +(defcustom show-paren-context-when-offscreen nil + "If non-nil, show context in the echo area when the openparen is offscreen. +The context is usually the line that contains the openparen, +except if the openparen is on its own line, in which case the +context includes the previous nonblank line." + :type 'boolean + :version "29.1") + (defvar show-paren--idle-timer nil) (defvar show-paren--overlay (let ((ol (make-overlay (point) (point) nil t))) (delete-overlay ol) ol) @@ -312,6 +320,19 @@ It is the default value of `show-paren-data-function'." (current-buffer)) (move-overlay show-paren--overlay there-beg there-end (current-buffer))) + ;; If `show-paren-open-line-when-offscreen' is t and point + ;; is at a close paren, show the line that contains the + ;; openparen in the echo area. + (let ((openparen (min here-beg there-beg))) + (if (and show-paren-context-when-offscreen + (< there-beg here-beg) + (not (pos-visible-in-window-p openparen))) + (let ((open-paren-line-string + (blink-paren-open-paren-line-string openparen)) + (message-log-max nil)) + (minibuffer-message + "Matches %s" + (substring-no-properties open-paren-line-string))))) ;; Always set the overlay face, since it varies. (overlay-put show-paren--overlay 'priority show-paren-priority) (overlay-put show-paren--overlay 'face face)))))) diff --git a/lisp/pcomplete.el b/lisp/pcomplete.el index 64acc416c23..1636e218821 100644 --- a/lisp/pcomplete.el +++ b/lisp/pcomplete.el @@ -680,8 +680,8 @@ user actually typed in." (match-string which arg) (throw 'pcompleted nil)))) -(defalias 'pcomplete-match-beginning 'match-beginning) -(defalias 'pcomplete-match-end 'match-end) +(define-obsolete-function-alias 'pcomplete-match-beginning #'match-beginning "29.1") +(define-obsolete-function-alias 'pcomplete-match-end #'match-end "29.1") (defsubst pcomplete--test (pred arg) "Perform a programmable completion predicate match." @@ -1006,7 +1006,7 @@ Arguments NO-GANGING and ARGS-FOLLOW are currently ignored." ((eq arg-char ?*) (pcomplete-executables)) ((eq arg-char ??) nil) ((eq arg-char ?.) (pcomplete-entries)) - ((eq arg-char ?\() (eval result)))))) + ((eq arg-char ?\() (eval result t)))))) (setq index (1+ index)))))))) (defun pcomplete--here (&optional form stub paring form-only) @@ -1040,7 +1040,7 @@ See the documentation for `pcomplete-here'." (funcall form) ;; Old calling convention, might still be used by files ;; byte-compiled with the older code. - (eval form))))) + (eval form t))))) (defmacro pcomplete-here* (&optional form stub form-only) @@ -1062,9 +1062,9 @@ See the documentation for `pcomplete-here'." pcomplete-window-restore-timer nil)) (define-obsolete-function-alias 'pcomplete-event-matches-key-specifier-p - 'eq "27.1") + #'eq "27.1") -(define-obsolete-function-alias 'pcomplete-read-event 'read-event "27.1") +(define-obsolete-function-alias 'pcomplete-read-event #'read-event "27.1") (defun pcomplete-show-completions (completions) "List in help buffer sorted COMPLETIONS. @@ -1244,7 +1244,7 @@ If specific documentation can't be given, be generic." (fboundp 'Info-goto-node)) (listp pcomplete-help))) (if (listp pcomplete-help) - (message "%s" (eval pcomplete-help)) + (message "%s" (eval pcomplete-help t)) (save-window-excursion (info)) (declare-function Info-goto-node "info" (nodename &optional fork strict-case)) diff --git a/lisp/pixel-scroll.el b/lisp/pixel-scroll.el index 249484cf581..e3a17295217 100644 --- a/lisp/pixel-scroll.el +++ b/lisp/pixel-scroll.el @@ -67,6 +67,8 @@ ;;; Code: (require 'mwheel) +(require 'subr-x) +(require 'ring) (defvar pixel-wait 0 "Idle time on each step of pixel scroll specified in second. @@ -90,6 +92,103 @@ is always with pixel resolution.") (defvar pixel-last-scroll-time 0 "Time when the last scrolling was made, in second since the epoch.") +(defvar mwheel-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) + (define-key map [touch-end] 'pixel-scroll-start-momentum) + (define-key map [mode-line wheel-down] 'pixel-scroll-precision) + (define-key map [mode-line wheel-up] 'pixel-scroll-precision) + (define-key map [mode-line touch-end] 'pixel-scroll-start-momentum) + (define-key map [header-line wheel-down] 'pixel-scroll-precision) + (define-key map [header-line wheel-up] 'pixel-scroll-precision) + (define-key map [header-line touch-end] 'pixel-scroll-start-momentum) + (define-key map [vertical-scroll-bar wheel-down] 'pixel-scroll-precision) + (define-key map [vertical-scroll-bar wheel-up] 'pixel-scroll-precision) + (define-key map [vertical-scroll-bar touch-end] 'pixel-scroll-start-momentum) + (define-key map [left-margin wheel-down] 'pixel-scroll-precision) + (define-key map [left-margin wheel-up] 'pixel-scroll-precision) + (define-key map [left-margin touch-end] 'pixel-scroll-start-momentum) + (define-key map [right-margin wheel-down] 'pixel-scroll-precision) + (define-key map [right-margin wheel-up] 'pixel-scroll-precision) + (define-key map [right-margin touch-end] 'pixel-scroll-start-momentum) + (define-key map [left-fringe wheel-down] 'pixel-scroll-precision) + (define-key map [left-fringe wheel-up] 'pixel-scroll-precision) + (define-key map [left-fringe touch-end] 'pixel-scroll-start-momentum) + (define-key map [right-fringe wheel-down] 'pixel-scroll-precision) + (define-key map [right-fringe wheel-up] 'pixel-scroll-precision) + (define-key map [right-fringe touch-end] 'pixel-scroll-start-momentum) + (define-key map [next] 'pixel-scroll-interpolate-down) + (define-key map [prior] 'pixel-scroll-interpolate-up) + map) + "The key map used by `pixel-scroll-precision-mode'.") + +(defcustom pixel-scroll-precision-use-momentum nil + "If non-nil, continue to scroll the display after wheel movement stops. +This is only effective if supported by your mouse or touchpad." + :group 'mouse + :type 'boolean + :version "29.1") + +(defcustom pixel-scroll-precision-momentum-tick 0.01 + "Number of seconds between each momentum scroll." + :group 'mouse + :type 'float + :version "29.1") + +(defcustom pixel-scroll-precision-momentum-seconds 1.75 + "The maximum duration in seconds of momentum scrolling." + :group 'mouse + :type 'float + :version "29.1") + +(defcustom pixel-scroll-precision-momentum-min-velocity 10.0 + "The minimum scrolled pixels per second before momentum scrolling starts." + :group 'mouse + :type 'float + :version "29.1") + +(defcustom pixel-scroll-precision-initial-velocity-factor 0.25 + "Factor applied to the initial velocity before momentum scrolling begins." + :group 'mouse + :type 'float + :version "29.1") + +(defcustom pixel-scroll-precision-large-scroll-height nil + "Pixels that must be scrolled before an animation is performed. +Nil means to not interpolate such scrolls." + :group 'mouse + :type '(choice (const :tag "Do not interpolate large scrolls" nil) + number) + :version "29.1") + +(defcustom pixel-scroll-precision-interpolation-total-time 0.1 + "The total time in seconds to spend interpolating a large scroll." + :group 'mouse + :type 'float + :version "29.1") + +(defcustom pixel-scroll-precision-interpolation-factor 4.0 + "A factor to apply to the distance of an interpolated scroll." + :group 'mouse + :type 'float + :version "29.1") + +(defcustom pixel-scroll-precision-interpolation-between-scroll 0.001 + "The number of seconds between each step of an interpolated scroll." + :group 'mouse + :type 'float + :version "29.1") + +(defcustom pixel-scroll-precision-interpolate-page nil + "Whether or not to interpolate scrolling via the Page Down and Page Up keys. +This is only effective when `pixel-scroll-precision-mode' is enabled." + :group 'scrolling + :type 'boolean + :version "29.1") + (defun pixel-scroll-in-rush-p () "Return non-nil if next scroll should be non-smooth. When scrolling request is delivered soon after the previous one, @@ -323,28 +422,44 @@ 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." - (let* ((pos0 (window-start)) +(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 (save-excursion + (goto-char (window-start)) + (unless (bobp) + (beginning-of-visual-line)) + (point))) (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 + (cdr (window-text-pixel-size nil (point) pos0))) + (point))))) ;; restore initial position (set-window-start nil pos0 t) (set-window-vscroll nil vscroll0 t) - pos)) + (when (and line-height + (> (car (posn-x-y (posn-at-point pos0))) + (line-number-display-width t))) + (setq line-height (- line-height + (save-excursion + (goto-char pos0) + (line-pixel-height))))) + (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 +469,321 @@ Otherwise, redisplay will reset the window's vscroll." (set-window-start nil (pixel-point-at-unseen-line) t) (set-window-vscroll nil vscroll t)) +(defun pixel-scroll-precision-scroll-down-page (delta) + "Scroll the current window down by DELTA pixels. +Note that this function doesn't work if DELTA is larger than +the height of the current window." + (let* ((desired-pos (posn-at-x-y 0 (+ delta + (window-tab-line-height) + (window-header-line-height)))) + (desired-start (posn-point desired-pos)) + (current-vs (window-vscroll nil t)) + (start-posn (unless (eq desired-start (window-start)) + (posn-at-point desired-start))) + (desired-vscroll (if start-posn + (- delta (cdr (posn-x-y start-posn))) + (+ current-vs delta))) + (edges (window-edges nil t)) + (usable-height (- (nth 3 edges) + (nth 1 edges))) + (next-pos (save-excursion + (goto-char desired-start) + (when (zerop (vertical-motion (1+ scroll-margin))) + (set-window-start nil desired-start) + (signal 'end-of-buffer nil)) + (while (when-let ((posn (posn-at-point))) + (< (cdr (posn-x-y posn)) delta)) + (when (zerop (vertical-motion 1)) + (set-window-start nil desired-start) + (signal 'end-of-buffer nil))) + (point))) + (scroll-preserve-screen-position nil) + (auto-window-vscroll nil)) + (when (and (or (< (point) next-pos)) + (let ((pos-visibility (pos-visible-in-window-p next-pos nil t))) + (and pos-visibility + (or (eq (length pos-visibility) 2) + (when-let* ((posn (posn-at-point next-pos))) + (> (cdr (posn-object-width-height posn)) + usable-height)))))) + (goto-char next-pos)) + (set-window-start nil (if (zerop (window-hscroll)) + desired-start + (save-excursion + (goto-char desired-start) + (beginning-of-visual-line) + (point))) + t) + (set-window-vscroll nil desired-vscroll t))) + +(defun pixel-scroll-precision-scroll-down (delta) + "Scroll the current window down by DELTA pixels." + (let ((max-height (- (window-text-height nil t) + (frame-char-height)))) + (while (> delta max-height) + (pixel-scroll-precision-scroll-down-page max-height) + (setq delta (- delta max-height))) + (pixel-scroll-precision-scroll-down-page delta))) + +(defun pixel-scroll-precision-scroll-up-page (delta) + "Scroll the current window up by DELTA pixels. +Note that this function doesn't work if DELTA is larger than +the height of the current window." + (let* ((edges (window-edges nil t nil t)) + (max-y (- (nth 3 edges) + (nth 1 edges))) + (usable-height max-y) + (posn (posn-at-x-y 0 (+ (window-tab-line-height) + (window-header-line-height) + (- max-y delta)))) + (point (posn-point posn)) + (up-point (save-excursion + (goto-char point) + (vertical-motion (- (1+ scroll-margin))) + (point)))) + (when (> (point) up-point) + (when (let ((pos-visible (pos-visible-in-window-p up-point nil t))) + (or (eq (length pos-visible) 2) + (when-let* ((posn (posn-at-point up-point)) + (edges (window-edges nil t)) + (usable-height (- (nth 3 edges) + (nth 1 edges)))) + (> (cdr (posn-object-width-height posn)) + usable-height)))) + (goto-char up-point))) + (let ((current-vscroll (window-vscroll nil t))) + (setq delta (- delta current-vscroll)) + (set-window-vscroll nil 0 t) + (when (> delta 0) + (let* ((start (window-start)) + (dims (window-text-pixel-size nil (cons start (- delta)) + start nil nil nil t)) + (height (nth 1 dims)) + (position (nth 2 dims))) + (set-window-start nil 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 (> height usable-height) + (goto-char position)) + (when (or (not position) (eq position start)) + (signal 'beginning-of-buffer nil)) + (setq delta (- delta height)))) + (when (< delta 0) + (set-window-vscroll nil (- delta) t))))) + +(defun pixel-scroll-precision-interpolate (delta) + "Interpolate a scroll of DELTA pixels. +This results in the window being scrolled by DELTA pixels with an +animation." + (let ((percentage 0) + (total-time pixel-scroll-precision-interpolation-total-time) + (factor pixel-scroll-precision-interpolation-factor) + (last-time (float-time)) + (time-elapsed 0.0) + (between-scroll pixel-scroll-precision-interpolation-between-scroll) + (rem (window-parameter nil 'interpolated-scroll-remainder)) + (time (window-parameter nil 'interpolated-scroll-remainder-time))) + (when (and rem time + (< (- (float-time) time) 1.0) + (eq (< delta 0) (< rem 0))) + (setq delta (+ delta rem))) + (if (or (null rem) + (eq (< delta 0) (< rem 0))) + (while-no-input + (unwind-protect + (while (< percentage 1) + (redisplay t) + (sleep-for between-scroll) + (setq time-elapsed (+ time-elapsed + (- (float-time) last-time)) + percentage (/ time-elapsed total-time)) + (let ((throw-on-input nil)) + (if (< delta 0) + (pixel-scroll-precision-scroll-down + (ceiling (abs (* (* delta factor) + (/ between-scroll total-time))))) + (pixel-scroll-precision-scroll-up + (ceiling (* (* delta factor) + (/ between-scroll total-time)))))) + (setq last-time (float-time))) + (if (< percentage 1) + (progn + (set-window-parameter nil 'interpolated-scroll-remainder + (* delta (- 1 percentage))) + (set-window-parameter nil 'interpolated-scroll-remainder-time + (float-time))) + (set-window-parameter nil + 'interpolated-scroll-remainder + nil) + (set-window-parameter nil + 'interpolated-scroll-remainder-time + nil)))) + (set-window-parameter nil + 'interpolated-scroll-remainder + nil) + (set-window-parameter nil + 'interpolated-scroll-remainder-time + nil)))) + +(defun pixel-scroll-precision-scroll-up (delta) + "Scroll the current window up by DELTA pixels." + (let ((max-height (- (window-text-height nil t) + (frame-char-height)))) + (while (> delta max-height) + (pixel-scroll-precision-scroll-up-page max-height) + (setq delta (- delta max-height))) + (pixel-scroll-precision-scroll-up-page delta))) + +;; FIXME: This doesn't _always_ work when there's an image above the +;; current line that is taller than the window, and scrolling can +;; sometimes be jumpy in that case. +(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)) + (let ((delta (round (cdr (nth 4 event))))) + (unless (zerop delta) + (if (> (abs delta) (window-text-height window t)) + (mwheel-scroll event nil) + (with-selected-window window + (if (and pixel-scroll-precision-large-scroll-height + (> (abs delta) + pixel-scroll-precision-large-scroll-height) + (let* ((kin-state (pixel-scroll-kinetic-state)) + (ring (aref kin-state 0)) + (time (aref kin-state 1))) + (or (null time) + (> (- (float-time) time) 1.0) + (and (consp ring) + (ring-empty-p ring))))) + (progn + (let ((kin-state (pixel-scroll-kinetic-state))) + (aset kin-state 0 (make-ring 10)) + (aset kin-state 1 nil)) + (pixel-scroll-precision-interpolate delta)) + (condition-case nil + (progn + (if (< delta 0) + (pixel-scroll-precision-scroll-down (- delta)) + (pixel-scroll-precision-scroll-up delta)) + (pixel-scroll-accumulate-velocity delta)) + ;; Do not ding at buffer limits. Show a message instead. + (beginning-of-buffer + (message (error-message-string '(beginning-of-buffer)))) + (end-of-buffer + (message (error-message-string '(end-of-buffer)))))))))) + (mwheel-scroll event nil)))) + +(defun pixel-scroll-kinetic-state () + "Return the kinetic scroll state of the current window. +It is a vector of the form [ VELOCITY TIME SIGN ]." + (or (window-parameter nil 'kinetic-state) + (set-window-parameter nil 'kinetic-state + (vector (make-ring 10) nil nil)))) + +(defun pixel-scroll-accumulate-velocity (delta) + "Accumulate DELTA into the current window's kinetic scroll state." + (let* ((state (pixel-scroll-kinetic-state)) + (ring (aref state 0)) + (time (aref state 1))) + (when (or (and time (> (- (float-time) time) 0.5)) + (and (not (ring-empty-p ring)) + (not (eq (< delta 0) + (aref state 2))))) + (aset state 0 (make-ring 10))) + (aset state 2 (< delta 0)) + (ring-insert (aref state 0) + (cons (aset state 1 (float-time)) + delta)))) + +(defun pixel-scroll-calculate-velocity (state) + "Calculate velocity from the kinetic state vector STATE." + (let* ((ring (aref state 0)) + (elts (ring-elements ring)) + (total 0)) + (dolist (tem elts) + (setq total (+ total (cdr tem)))) + (/ total (* (- (float-time) (caar elts)) + 100)))) + +(defun pixel-scroll-start-momentum (event) + "Start kinetic scrolling for the touch event EVENT." + (interactive "e") + (when pixel-scroll-precision-use-momentum + (let ((window (mwheel-event-window event)) + (state nil)) + (with-selected-window window + (setq state (pixel-scroll-kinetic-state)) + (when (and (aref state 1) + (listp (aref state 0))) + (while-no-input + (unwind-protect (progn + (aset state 0 (pixel-scroll-calculate-velocity state)) + (when (> (abs (aref state 0)) + pixel-scroll-precision-momentum-min-velocity) + (let* ((velocity (* (aref state 0) + pixel-scroll-precision-initial-velocity-factor)) + (original-velocity velocity) + (time-spent 0)) + (if (> velocity 0) + (while (and (> velocity 0) + (<= time-spent + pixel-scroll-precision-momentum-seconds)) + (when (> (round velocity) 0) + (pixel-scroll-precision-scroll-up (round velocity))) + (setq velocity (- velocity + (/ original-velocity + (/ pixel-scroll-precision-momentum-seconds + pixel-scroll-precision-momentum-tick)))) + (redisplay t) + (sit-for pixel-scroll-precision-momentum-tick) + (setq time-spent (+ time-spent + pixel-scroll-precision-momentum-tick)))) + (while (and (< velocity 0) + (<= time-spent + pixel-scroll-precision-momentum-seconds)) + (when (> (round (abs velocity)) 0) + (pixel-scroll-precision-scroll-down (round + (abs velocity)))) + (setq velocity (+ velocity + (/ (abs original-velocity) + (/ pixel-scroll-precision-momentum-seconds + pixel-scroll-precision-momentum-tick)))) + (redisplay t) + (sit-for pixel-scroll-precision-momentum-tick) + (setq time-spent (+ time-spent + pixel-scroll-precision-momentum-tick)))))) + (aset state 0 (make-ring 10)) + (aset state 1 nil)))))))) + +(defun pixel-scroll-interpolate-down () + "Interpolate a scroll downwards by one page." + (interactive) + (if pixel-scroll-precision-interpolate-page + (pixel-scroll-precision-interpolate (- (window-text-height nil t))) + (scroll-up))) + +(defun pixel-scroll-interpolate-up () + "Interpolate a scroll upwards by one page." + (interactive) + (if pixel-scroll-precision-interpolate-page + (pixel-scroll-precision-interpolate (window-text-height nil t)) + (scroll-down))) + +;;;###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 mwheel-coalesce-scroll-events + (not pixel-scroll-precision-mode))) + (provide 'pixel-scroll) ;;; pixel-scroll.el ends here diff --git a/lisp/play/5x5.el b/lisp/play/5x5.el index 085c97f5d8e..155c08f0ade 100644 --- a/lisp/play/5x5.el +++ b/lisp/play/5x5.el @@ -107,39 +107,37 @@ (defvar 5x5-buffer-name "*5x5*" "Name of the 5x5 play buffer.") -(defvar 5x5-mode-map - (let ((map (make-sparse-keymap))) - (suppress-keymap map t) - (define-key map "?" #'describe-mode) - (define-key map "\r" #'5x5-flip-current) - (define-key map " " #'5x5-flip-current) - (define-key map [up] #'5x5-up) - (define-key map [down] #'5x5-down) - (define-key map [left] #'5x5-left) - (define-key map [tab] #'5x5-right) - (define-key map [right] #'5x5-right) - (define-key map [(control a)] #'5x5-bol) - (define-key map [(control e)] #'5x5-eol) - (define-key map [(control p)] #'5x5-up) - (define-key map [(control n)] #'5x5-down) - (define-key map [(control b)] #'5x5-left) - (define-key map [(control f)] #'5x5-right) - (define-key map [home] #'5x5-bol) - (define-key map [end] #'5x5-eol) - (define-key map [prior] #'5x5-first) - (define-key map [next] #'5x5-last) - (define-key map "r" #'5x5-randomize) - (define-key map [(control c) (control r)] #'5x5-crack-randomly) - (define-key map [(control c) (control c)] #'5x5-crack-mutating-current) - (define-key map [(control c) (control b)] #'5x5-crack-mutating-best) - (define-key map [(control c) (control x)] #'5x5-crack-xor-mutate) - (define-key map "n" #'5x5-new-game) - (define-key map "s" #'5x5-solve-suggest) - (define-key map "<" #'5x5-solve-rotate-left) - (define-key map ">" #'5x5-solve-rotate-right) - (define-key map "q" #'5x5-quit-game) - map) - "Local keymap for the 5x5 game.") +(defvar-keymap 5x5-mode-map + :doc "Local keymap for the 5x5 game." + :suppress 'nodigits + "?" #'describe-mode + "RET" #'5x5-flip-current + "SPC" #'5x5-flip-current + "<up>" #'5x5-up + "<down>" #'5x5-down + "<left>" #'5x5-left + "<tab>" #'5x5-right + "<right>" #'5x5-right + "C-a" #'5x5-bol + "C-e" #'5x5-eol + "C-p" #'5x5-up + "C-n" #'5x5-down + "C-b" #'5x5-left + "C-f" #'5x5-right + "<home>" #'5x5-bol + "<end>" #'5x5-eol + "<prior>" #'5x5-first + "<next>" #'5x5-last + "r" #'5x5-randomize + "C-c C-r" #'5x5-crack-randomly + "C-c C-c" #'5x5-crack-mutating-current + "C-c C-b" #'5x5-crack-mutating-best + "C-c C-x" #'5x5-crack-xor-mutate + "n" #'5x5-new-game + "s" #'5x5-solve-suggest + "<" #'5x5-solve-rotate-left + ">" #'5x5-solve-rotate-right + "q" #'5x5-quit-game) (defvar-local 5x5-solver-output nil "List that is the output of an arithmetic solver. 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/blackbox.el b/lisp/play/blackbox.el index 13bcdcc8595..d9375502089 100644 --- a/lisp/play/blackbox.el +++ b/lisp/play/blackbox.el @@ -85,32 +85,21 @@ (defvar bb-balls-placed nil "List of already placed balls.") -;; This is used below to remap existing bindings for cursor motion to -;; blackbox-specific bindings in blackbox-mode-map. This is so that -;; users who prefer non-default key bindings for cursor motion don't -;; lose that when they play Blackbox. -(defun blackbox-redefine-key (map oldfun newfun) - "Redefine keys that run the function OLDFUN to run NEWFUN instead." - (define-key map (vector 'remap oldfun) newfun)) - - -(defvar blackbox-mode-map - (let ((map (make-keymap))) - (suppress-keymap map t) - (blackbox-redefine-key map 'backward-char 'bb-left) - (blackbox-redefine-key map 'left-char 'bb-left) - (blackbox-redefine-key map 'forward-char 'bb-right) - (blackbox-redefine-key map 'right-char 'bb-right) - (blackbox-redefine-key map 'previous-line 'bb-up) - (blackbox-redefine-key map 'next-line 'bb-down) - (blackbox-redefine-key map 'move-end-of-line 'bb-eol) - (blackbox-redefine-key map 'move-beginning-of-line 'bb-bol) - (define-key map " " 'bb-romp) - (define-key map "q" 'bury-buffer) - (define-key map [insert] 'bb-romp) - (define-key map [return] 'bb-done) - (blackbox-redefine-key map 'newline 'bb-done) - map)) +(defvar-keymap blackbox-mode-map + :suppress 'nodigits + "SPC" #'bb-romp + "q" #'bury-buffer + "<insert>" #'bb-romp + "<return>" #'bb-done + "<remap> <backward-char>" #'bb-left + "<remap> <left-char>" #'bb-left + "<remap> <forward-char>" #'bb-right + "<remap> <right-char>" #'bb-right + "<remap> <previous-line>" #'bb-up + "<remap> <next-line>" #'bb-down + "<remap> <move-end-of-line>" #'bb-eol + "<remap> <move-beginning-of-line>" #'bb-bol + "<remap> <newline>" #'bb-done) ;; Blackbox mode is suitable only for specially formatted data. @@ -426,6 +415,11 @@ a reflection." (insert c) (backward-char 1))) +(defun blackbox-redefine-key (map oldfun newfun) + "Redefine keys that run the function OLDFUN to run NEWFUN instead." + (declare (obsolete define-key "29.1")) + (define-key map (vector 'remap oldfun) newfun)) + (provide 'blackbox) ;;; blackbox.el ends here diff --git a/lisp/play/bubbles.el b/lisp/play/bubbles.el index e695a75e083..471dea8d580 100644 --- a/lisp/play/bubbles.el +++ b/lisp/play/bubbles.el @@ -809,22 +809,21 @@ static char * dot3d_xpm[] = { (bubbles--update-faces-or-images)) -(defvar bubbles-mode-map - (let ((map (make-sparse-keymap 'bubbles-mode-map))) - ;; (suppress-keymap map t) - (define-key map "q" 'bubbles-quit) - (define-key map "\n" 'bubbles-plop) - (define-key map " " 'bubbles-plop) - (define-key map [double-down-mouse-1] 'bubbles-plop) - (define-key map [mouse-2] 'bubbles-plop) - (define-key map "\C-m" 'bubbles-plop) - (define-key map "u" 'bubbles-undo) - (define-key map "p" 'previous-line) - (define-key map "n" 'next-line) - (define-key map "f" 'forward-char) - (define-key map "b" 'backward-char) - map) - "Mode map for `bubbles'.") +(defvar-keymap bubbles-mode-map + :doc "Mode map for `bubbles'." + :name 'bubbles-mode-map + "q" #'bubbles-quit + "C-j" #'bubbles-plop + "SPC" #'bubbles-plop + "C-m" #'bubbles-plop + "u" #'bubbles-undo + "p" #'previous-line + "n" #'next-line + "f" #'forward-char + "b" #'backward-char + + "<double-down-mouse-1>" #'bubbles-plop + "<mouse-2>" #'bubbles-plop) (easy-menu-define bubbles-menu bubbles-mode-map "Menu for `bubbles'." diff --git a/lisp/play/decipher.el b/lisp/play/decipher.el index 5431d7f068a..613f254fd2d 100644 --- a/lisp/play/decipher.el +++ b/lisp/play/decipher.el @@ -138,36 +138,31 @@ the tail of the list." (2 font-lock-string-face))) "Font Lock keywords for Decipher mode.") -(defvar decipher-mode-map - (let ((map (make-keymap))) - (suppress-keymap map) - (define-key map "A" #'decipher-show-alphabet) - (define-key map "C" #'decipher-complete-alphabet) - (define-key map "D" #'decipher-digram-list) - (define-key map "F" #'decipher-frequency-count) - (define-key map "M" #'decipher-make-checkpoint) - (define-key map "N" #'decipher-adjacency-list) - (define-key map "R" #'decipher-restore-checkpoint) - (define-key map "U" #'decipher-undo) - (define-key map " " #'decipher-keypress) - (define-key map [remap undo] #'decipher-undo) - (define-key map [remap advertised-undo] #'decipher-undo) - (let ((key ?a)) - (while (<= key ?z) - (define-key map (vector key) #'decipher-keypress) - (cl-incf key))) - map) - "Keymap for Decipher mode.") - - -(defvar decipher-stats-mode-map - (let ((map (make-keymap))) - (suppress-keymap map) - (define-key map "D" #'decipher-digram-list) - (define-key map "F" #'decipher-frequency-count) - (define-key map "N" #'decipher-adjacency-list) - map) - "Keymap for Decipher-Stats mode.") +(defvar-keymap decipher-mode-map + :doc "Keymap for Decipher mode." + :suppress t + "A" #'decipher-show-alphabet + "C" #'decipher-complete-alphabet + "D" #'decipher-digram-list + "F" #'decipher-frequency-count + "M" #'decipher-make-checkpoint + "N" #'decipher-adjacency-list + "R" #'decipher-restore-checkpoint + "U" #'decipher-undo + "SPC" #'decipher-keypress + "<remap> <undo>" #'decipher-undo + "<remap> <advertised-undo>" #'decipher-undo) +(let ((key ?a)) + (while (<= key ?z) + (keymap-set decipher-mode-map (char-to-string key) #'decipher-keypress) + (cl-incf key))) + +(defvar-keymap decipher-stats-mode-map + :doc "Keymap for Decipher-Stats mode." + :suppress t + "D" #'decipher-digram-list + "F" #'decipher-frequency-count + "N" #'decipher-adjacency-list) (defvar decipher-mode-syntax-table diff --git a/lisp/play/doctor.el b/lisp/play/doctor.el index 33fecaa188a..e45619d1c79 100644 --- a/lisp/play/doctor.el +++ b/lisp/play/doctor.el @@ -126,11 +126,9 @@ (set what ww) first)) -(defvar doctor-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\n" 'doctor-read-print) - (define-key map "\r" 'doctor-ret-or-read) - map)) +(defvar-keymap doctor-mode-map + "C-j" #'doctor-read-print + "RET" #'doctor-ret-or-read) (define-derived-mode doctor-mode text-mode "Doctor" "Major mode for running the Doctor (Eliza) program. diff --git a/lisp/play/gametree.el b/lisp/play/gametree.el index cc9a6b7a4f0..b7ebe3dcd3a 100644 --- a/lisp/play/gametree.el +++ b/lisp/play/gametree.el @@ -554,54 +554,55 @@ buffer, it is replaced by the new value. See the documentation for (gametree-hack-file-layout)) nil) -;;;; Key bindings -(defvar gametree-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-c\C-j" 'gametree-break-line-here) - (define-key map "\C-c\C-v" 'gametree-insert-new-leaf) - (define-key map "\C-c\C-m" 'gametree-merge-line) - (define-key map "\C-c\C-r " 'gametree-layout-to-register) - (define-key map "\C-c\C-r/" 'gametree-layout-to-register) - (define-key map "\C-c\C-rj" 'gametree-apply-register-layout) - (define-key map "\C-c\C-y" 'gametree-save-and-hack-layout) - (define-key map "\C-c;" 'gametree-insert-score) - (define-key map "\C-c^" 'gametree-compute-and-insert-score) - map)) - -(define-derived-mode gametree-mode outline-mode "GameTree" - "Major mode for managing game analysis trees. -Useful to postal and email chess (and, it is hoped, also checkers, go, -shogi, etc.) players, it is a slightly modified version of Outline mode. - -\\{gametree-mode-map}" - (auto-fill-mode 0) - (add-hook 'write-contents-functions 'gametree-save-and-hack-layout nil t)) + +;;;; Mouse commands -;;;; Goodies for mousing users (defun gametree-mouse-break-line-here (event) (interactive "e") (mouse-set-point event) (gametree-break-line-here)) + (defun gametree-mouse-show-children-and-entry (event) (interactive "e") (mouse-set-point event) (gametree-show-children-and-entry)) + (defun gametree-mouse-show-subtree (event) (interactive "e") (mouse-set-point event) (outline-show-subtree)) + (defun gametree-mouse-hide-subtree (event) (interactive "e") (mouse-set-point event) (outline-hide-subtree)) -(define-key gametree-mode-map [M-down-mouse-2 M-mouse-2] - 'gametree-mouse-break-line-here) -(define-key gametree-mode-map [S-down-mouse-1 S-mouse-1] - 'gametree-mouse-show-children-and-entry) -(define-key gametree-mode-map [S-down-mouse-2 S-mouse-2] - 'gametree-mouse-show-subtree) -(define-key gametree-mode-map [S-down-mouse-3 S-mouse-3] - 'gametree-mouse-hide-subtree) + + +;;;; Key bindings + +(defvar-keymap gametree-mode-map + "C-c C-j" #'gametree-break-line-here + "C-c C-v" #'gametree-insert-new-leaf + "C-c C-m" #'gametree-merge-line + "C-c C-r SPC" #'gametree-layout-to-register + "C-c C-r /" #'gametree-layout-to-register + "C-c C-r j" #'gametree-apply-register-layout + "C-c C-y" #'gametree-save-and-hack-layout + "C-c ;" #'gametree-insert-score + "C-c ^" #'gametree-compute-and-insert-score + "M-<down-mouse-2> M-<mouse-2>" #'gametree-mouse-break-line-here + "S-<down-mouse-1> S-<mouse-1>" #'gametree-mouse-show-children-and-entry + "S-<down-mouse-2> S-<mouse-2>" #'gametree-mouse-show-subtree + "S-<down-mouse-3> S-<mouse-3>" #'gametree-mouse-hide-subtree) + +(define-derived-mode gametree-mode outline-mode "GameTree" + "Major mode for managing game analysis trees. +Useful to postal and email chess (and, it is hoped, also checkers, go, +shogi, etc.) players, it is a slightly modified version of Outline mode. + +\\{gametree-mode-map}" + (auto-fill-mode 0) + (add-hook 'write-contents-functions 'gametree-save-and-hack-layout nil t)) (provide 'gametree) diff --git a/lisp/play/gomoku.el b/lisp/play/gomoku.el index 0a45885b875..97726fcad76 100644 --- a/lisp/play/gomoku.el +++ b/lisp/play/gomoku.el @@ -100,65 +100,61 @@ SHOULD be at least 2 (MUST BE at least 1).") "Number of lines between the Gomoku board and the top of the window.") -(defvar gomoku-mode-map - (let ((map (make-sparse-keymap))) - - ;; Key bindings for cursor motion. - (define-key map "y" 'gomoku-move-nw) ; y - (define-key map "u" 'gomoku-move-ne) ; u - (define-key map "b" 'gomoku-move-sw) ; b - (define-key map "n" 'gomoku-move-se) ; n - (define-key map "h" 'gomoku-move-left) ; h - (define-key map "l" 'gomoku-move-right) ; l - (define-key map "j" 'gomoku-move-down) ; j - (define-key map "k" 'gomoku-move-up) ; k - - (define-key map [kp-7] 'gomoku-move-nw) - (define-key map [kp-9] 'gomoku-move-ne) - (define-key map [kp-1] 'gomoku-move-sw) - (define-key map [kp-3] 'gomoku-move-se) - (define-key map [kp-4] 'gomoku-move-left) - (define-key map [kp-6] 'gomoku-move-right) - (define-key map [kp-2] 'gomoku-move-down) - (define-key map [kp-8] 'gomoku-move-up) - - (define-key map "\C-b" 'gomoku-move-left) ; C-b - (define-key map "\C-f" 'gomoku-move-right) ; C-f - (define-key map "\C-n" 'gomoku-move-down) ; C-n - (define-key map "\C-p" 'gomoku-move-up) ; C-p - - ;; Key bindings for entering Human moves. - (define-key map "X" 'gomoku-human-plays) ; X - (define-key map "x" 'gomoku-human-plays) ; x - (define-key map " " 'gomoku-human-plays) ; SPC - (define-key map "\C-m" 'gomoku-human-plays) ; RET - (define-key map "\C-c\C-p" 'gomoku-human-plays) ; C-c C-p - (define-key map "\C-c\C-b" 'gomoku-human-takes-back) ; C-c C-b - (define-key map "\C-c\C-r" 'gomoku-human-resigns) ; C-c C-r - (define-key map "\C-c\C-e" 'gomoku-emacs-plays) ; C-c C-e - - (define-key map [kp-enter] 'gomoku-human-plays) - (define-key map [insert] 'gomoku-human-plays) - (define-key map [down-mouse-1] 'gomoku-click) - (define-key map [drag-mouse-1] 'gomoku-click) - (define-key map [mouse-1] 'gomoku-click) - (define-key map [down-mouse-2] 'gomoku-click) - (define-key map [mouse-2] 'gomoku-mouse-play) - (define-key map [drag-mouse-2] 'gomoku-mouse-play) - - (define-key map [remap backward-char] 'gomoku-move-left) - (define-key map [remap left-char] 'gomoku-move-left) - (define-key map [remap forward-char] 'gomoku-move-right) - (define-key map [remap right-char] 'gomoku-move-right) - (define-key map [remap previous-line] 'gomoku-move-up) - (define-key map [remap next-line] 'gomoku-move-down) - (define-key map [remap move-beginning-of-line] 'gomoku-beginning-of-line) - (define-key map [remap move-end-of-line] 'gomoku-end-of-line) - (define-key map [remap undo] 'gomoku-human-takes-back) - (define-key map [remap advertised-undo] 'gomoku-human-takes-back) - map) - - "Local keymap to use in Gomoku mode.") +(defvar-keymap gomoku-mode-map + :doc "Local keymap to use in Gomoku mode." + ;; Key bindings for cursor motion. + "y" #'gomoku-move-nw + "u" #'gomoku-move-ne + "b" #'gomoku-move-sw + "n" #'gomoku-move-se + "h" #'gomoku-move-left + "l" #'gomoku-move-right + "j" #'gomoku-move-down + "k" #'gomoku-move-up + + "<kp-7>" #'gomoku-move-nw + "<kp-9>" #'gomoku-move-ne + "<kp-1>" #'gomoku-move-sw + "<kp-3>" #'gomoku-move-se + "<kp-4>" #'gomoku-move-left + "<kp-6>" #'gomoku-move-right + "<kp-2>" #'gomoku-move-down + "<kp-8>" #'gomoku-move-up + + "C-b" #'gomoku-move-left + "C-f" #'gomoku-move-right + "C-n" #'gomoku-move-down + "C-p" #'gomoku-move-up + + ;; Key bindings for entering Human moves. + "X" #'gomoku-human-plays + "x" #'gomoku-human-plays + "SPC" #'gomoku-human-plays + "RET" #'gomoku-human-plays + "C-c C-p" #'gomoku-human-plays + "C-c C-b" #'gomoku-human-takes-back + "C-c C-r" #'gomoku-human-resigns + "C-c C-e" #'gomoku-emacs-plays + + "<kp-enter>" #'gomoku-human-plays + "<insert>" #'gomoku-human-plays + "<down-mouse-1>" #'gomoku-click + "<drag-mouse-1>" #'gomoku-click + "<mouse-1>" #'gomoku-click + "<down-mouse-2>" #'gomoku-click + "<mouse-2>" #'gomoku-mouse-play + "<drag-mouse-2>" #'gomoku-mouse-play + + "<remap> <backward-char>" #'gomoku-move-left + "<remap> <left-char>" #'gomoku-move-left + "<remap> <forward-char>" #'gomoku-move-right + "<remap> <right-char>" #'gomoku-move-right + "<remap> <previous-line>" #'gomoku-move-up + "<remap> <next-line>" #'gomoku-move-down + "<remap> <move-beginning-of-line>" #'gomoku-beginning-of-line + "<remap> <move-end-of-line>" #'gomoku-end-of-line + "<remap> <undo>" #'gomoku-human-takes-back + "<remap> <advertised-undo>" #'gomoku-human-takes-back) (defvar gomoku-emacs-won () diff --git a/lisp/play/mpuz.el b/lisp/play/mpuz.el index df2b6fc867a..6091016b7c3 100644 --- a/lisp/play/mpuz.el +++ b/lisp/play/mpuz.el @@ -76,17 +76,12 @@ The value t means never ding, and `error' means only ding on wrong input." "Hook to run upon entry to mpuz." :type 'hook) -(defvar mpuz-mode-map - (let ((map (make-sparse-keymap))) - (mapc (lambda (ch) - (define-key map (char-to-string ch) 'mpuz-try-letter)) - "abcdefghijABCDEFGHIJ") - (define-key map "\C-g" 'mpuz-offer-abort) - (define-key map "?" 'describe-mode) - map) - "Local keymap to use in Mult Puzzle.") - - +(defvar-keymap mpuz-mode-map + :doc "Local keymap to use in Mult Puzzle." + "C-g" #'mpuz-offer-abort + "?" #'describe-mode) +(dolist (ch (mapcar #'char-to-string "abcdefghijABCDEFGHIJ")) + (keymap-set mpuz-mode-map ch #'mpuz-try-letter)) (define-derived-mode mpuz-mode fundamental-mode "Mult Puzzle" :interactive nil diff --git a/lisp/play/pong.el b/lisp/play/pong.el index b8545dfa82f..f1426d8f0fa 100644 --- a/lisp/play/pong.el +++ b/lisp/play/pong.el @@ -173,23 +173,23 @@ ;;; Initialize maps -(defvar pong-mode-map - (let ((map (make-sparse-keymap 'pong-mode-map))) - (define-key map [left] 'pong-move-left) - (define-key map [right] 'pong-move-right) - (define-key map [up] 'pong-move-up) - (define-key map [down] 'pong-move-down) - (define-key map pong-left-key 'pong-move-left) - (define-key map pong-right-key 'pong-move-right) - (define-key map pong-up-key 'pong-move-up) - (define-key map pong-down-key 'pong-move-down) - (define-key map pong-quit-key 'pong-quit) - (define-key map pong-pause-key 'pong-pause) - map) - "Modemap for pong-mode.") - -(defvar pong-null-map - (make-sparse-keymap 'pong-null-map) "Null map for pong-mode.") +(defvar-keymap pong-mode-map + :doc "Modemap for pong-mode." + :name 'pong-mode-map + "<left>" #'pong-move-left + "<right>" #'pong-move-right + "<up>" #'pong-move-up + "<down>" #'pong-move-down + pong-left-key #'pong-move-left + pong-right-key #'pong-move-right + pong-up-key #'pong-move-up + pong-down-key #'pong-move-down + pong-quit-key #'pong-quit + pong-pause-key #'pong-pause) + +(defvar-keymap pong-null-map + :doc "Null map for pong-mode." + :name 'pong-null-map) 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))) - - (define-key map "n" 'snake-start-game) - (define-key map "q" 'snake-end-game) - (define-key map "p" 'snake-pause-game) - - (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) - - (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-mode-map + :doc "Keymap for Snake games." + :name 'snake-mode-map + "n" #'snake-start-game + "q" #'snake-end-game + "p" #'snake-pause-game + + "<left>" #'snake-move-left + "<right>" #'snake-move-right + "<up>" #'snake-move-up + "<down>" #'snake-move-down + + "C-b" #'snake-move-left + "C-f" #'snake-move-right + "C-p" #'snake-move-up + "C-n" #'snake-move-down) + +(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/solitaire.el b/lisp/play/solitaire.el index bc1a0e44cbf..19d7ba51bc2 100644 --- a/lisp/play/solitaire.el +++ b/lisp/play/solitaire.el @@ -40,48 +40,46 @@ "Hook to run upon entry to Solitaire." :type 'hook) -(defvar solitaire-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map special-mode-map) - - (define-key map "\C-f" 'solitaire-right) - (define-key map "\C-b" 'solitaire-left) - (define-key map "\C-p" 'solitaire-up) - (define-key map "\C-n" 'solitaire-down) - (define-key map "\r" 'solitaire-move) - (define-key map [remap undo] 'solitaire-undo) - (define-key map " " 'solitaire-do-check) - - (define-key map [right] 'solitaire-right) - (define-key map [left] 'solitaire-left) - (define-key map [up] 'solitaire-up) - (define-key map [down] 'solitaire-down) - - (define-key map [S-right] 'solitaire-move-right) - (define-key map [S-left] 'solitaire-move-left) - (define-key map [S-up] 'solitaire-move-up) - (define-key map [S-down] 'solitaire-move-down) - - (define-key map [kp-6] 'solitaire-right) - (define-key map [kp-4] 'solitaire-left) - (define-key map [kp-8] 'solitaire-up) - (define-key map [kp-2] 'solitaire-down) - (define-key map [kp-5] 'solitaire-center-point) - - (define-key map [S-kp-6] 'solitaire-move-right) - (define-key map [S-kp-4] 'solitaire-move-left) - (define-key map [S-kp-8] 'solitaire-move-up) - (define-key map [S-kp-2] 'solitaire-move-down) - - (define-key map [kp-enter] 'solitaire-move) - (define-key map [kp-0] 'solitaire-undo) - - ;; spoil it with s ;) - (define-key map [?s] 'solitaire-solve) - - ;; (define-key map [kp-0] 'solitaire-hint) - Not yet provided ;) - map) - "Keymap for playing Solitaire.") +(defvar-keymap solitaire-mode-map + :doc "Keymap for playing Solitaire." + :parent special-mode-map + "C-f" #'solitaire-right + "C-b" #'solitaire-left + "C-p" #'solitaire-up + "C-n" #'solitaire-down + "RET" #'solitaire-move + "SPC" #'solitaire-do-check + + "<right>" #'solitaire-right + "<left>" #'solitaire-left + "<up>" #'solitaire-up + "<down>" #'solitaire-down + + "S-<right>" #'solitaire-move-right + "S-<left>" #'solitaire-move-left + "S-<up>" #'solitaire-move-up + "S-<down>" #'solitaire-move-down + + "<kp-6>" #'solitaire-right + "<kp-4>" #'solitaire-left + "<kp-8>" #'solitaire-up + "<kp-2>" #'solitaire-down + "<kp-5>" #'solitaire-center-point + + "S-<kp-6>" #'solitaire-move-right + "S-<kp-4>" #'solitaire-move-left + "S-<kp-8>" #'solitaire-move-up + "S-<kp-2>" #'solitaire-move-down + + "<kp-enter>" #'solitaire-move + "<kp-0>" #'solitaire-undo + "<remap> <undo>" #'solitaire-undo + + ;; spoil it with s ;) + "s" #'solitaire-solve + + ;; "[kp-0]" #'solitaire-hint - Not yet provided ;) + ) ;; Solitaire mode is suitable only for specially formatted data. (put 'solitaire-mode 'mode-class 'special) 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) - - (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.") - -(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-mode-map + :doc "Keymap for Tetris games." + :name 'tetris-mode-map + "n" #'tetris-start-game + "q" #'tetris-end-game + "p" #'tetris-pause-game + + "SPC" #'tetris-move-bottom + "<left>" #'tetris-move-left + "<right>" #'tetris-move-right + "<up>" #'tetris-rotate-prev + "<down>" #'tetris-move-down) + +(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 3b754c24c5f..9e9793abece 100644 --- a/lisp/proced.el +++ b/lisp/proced.el @@ -658,6 +658,7 @@ After displaying or updating a Proced buffer, Proced runs the normal hook `proced-post-display-hook'. \\{proced-mode-map}" + :interactive nil (abbrev-mode 0) (auto-fill-mode 0) (setq buffer-read-only t @@ -721,7 +722,7 @@ Proced buffers." With prefix ARG, update this buffer automatically if ARG is positive, otherwise do not update. Sets the variable `proced-auto-update-flag'. The time interval for updates is specified via `proced-auto-update-interval'." - (interactive (list (or current-prefix-arg 'toggle))) + (interactive (list (or current-prefix-arg 'toggle)) proced-mode) (setq proced-auto-update-flag (cond ((eq arg 'toggle) (not proced-auto-update-flag)) (arg (> (prefix-numeric-value arg) 0)) @@ -733,19 +734,19 @@ The time interval for updates is specified via `proced-auto-update-interval'." (defun proced-mark (&optional count) "Mark the current (or next COUNT) processes." - (interactive "p") + (interactive "p" proced-mode) (proced-do-mark t count)) (defun proced-unmark (&optional count) "Unmark the current (or next COUNT) processes." - (interactive "p") + (interactive "p" proced-mode) (proced-do-mark nil count)) (defun proced-unmark-backward (&optional count) "Unmark the previous (or COUNT previous) processes." ;; Analogous to `dired-unmark-backward', ;; but `ibuffer-unmark-backward' behaves different. - (interactive "p") + (interactive "p" proced-mode) (proced-do-mark nil (- (or count 1)))) (defun proced-do-mark (mark &optional count) @@ -762,7 +763,7 @@ The time interval for updates is specified via `proced-auto-update-interval'." (defun proced-toggle-marks () "Toggle marks: marked processes become unmarked, and vice versa." - (interactive) + (interactive nil proced-mode) (let ((mark-re (proced-marker-regexp)) buffer-read-only) (save-excursion @@ -788,14 +789,14 @@ Otherwise move one line forward after inserting the mark." "Mark all processes. If `transient-mark-mode' is turned on and the region is active, mark the region." - (interactive) + (interactive nil proced-mode) (proced-do-mark-all t)) (defun proced-unmark-all () "Unmark all processes. If `transient-mark-mode' is turned on and the region is active, unmark the region." - (interactive) + (interactive nil proced-mode) (proced-do-mark-all nil)) (defun proced-do-mark-all (mark) @@ -830,14 +831,14 @@ mark the region." (defun proced-mark-children (ppid &optional omit-ppid) "Mark child processes of process PPID. Also mark process PPID unless prefix OMIT-PPID is non-nil." - (interactive (list (proced-pid-at-point) current-prefix-arg)) + (interactive (list (proced-pid-at-point) current-prefix-arg) proced-mode) (proced-mark-process-alist (proced-filter-children proced-process-alist ppid omit-ppid))) (defun proced-mark-parents (cpid &optional omit-cpid) "Mark parent processes of process CPID. Also mark CPID unless prefix OMIT-CPID is non-nil." - (interactive (list (proced-pid-at-point) current-prefix-arg)) + (interactive (list (proced-pid-at-point) current-prefix-arg) proced-mode) (proced-mark-process-alist (proced-filter-parents proced-process-alist cpid omit-cpid))) @@ -870,7 +871,7 @@ If `transient-mark-mode' is turned on and the region is active, omit the processes in region. If QUIET is non-nil suppress status message. Returns count of omitted lines." - (interactive "P") + (interactive "P" proced-mode) (let ((mark-re (proced-marker-regexp)) (count 0) buffer-read-only) @@ -947,7 +948,8 @@ Set variable `proced-filter' to SCHEME. Revert listing." (interactive (let ((scheme (completing-read "Filter: " proced-filter-alist nil t))) - (list (if (string= "" scheme) nil (intern scheme))))) + (list (if (string= "" scheme) nil (intern scheme)))) + proced-mode) ;; only update if necessary (unless (eq proced-filter scheme) (setq proced-filter scheme) @@ -1057,7 +1059,7 @@ Each parent process is followed by its child processes. The process tree inherits the chosen sorting order of the process listing, that is, child processes of the same parent process are sorted using the selected sorting order." - (interactive (list (or current-prefix-arg 'toggle))) + (interactive (list (or current-prefix-arg 'toggle)) proced-mode) (setq proced-tree-flag (cond ((eq arg 'toggle) (not proced-tree-flag)) (arg (> (prefix-numeric-value arg) 0)) @@ -1140,7 +1142,7 @@ This command refines an already existing process listing generated initially based on the value of the variable `proced-filter'. It does not change this variable. It does not revert the listing. If you frequently need a certain refinement, consider defining a new filter in `proced-filter-alist'." - (interactive (list last-input-event)) + (interactive (list last-input-event) proced-mode) (if event (posn-set-point (event-end event))) (let ((key (get-text-property (point) 'proced-key)) (pid (get-text-property (point) 'proced-pid))) @@ -1269,7 +1271,8 @@ in the mode line, using \"+\" or \"-\" for ascending or descending order." nil t))) (list (if (string= "" scheme) nil (intern scheme)) ;; like 'toggle in `define-derived-mode' - (or current-prefix-arg 'no-arg)))) + (or current-prefix-arg 'no-arg))) + proced-mode) (setq proced-descend ;; If `proced-sort-interactive' is called repeatedly for the same @@ -1290,37 +1293,37 @@ in the mode line, using \"+\" or \"-\" for ascending or descending order." (defun proced-sort-pcpu (&optional arg) "Sort Proced buffer by percentage CPU time (%CPU). Prefix ARG controls sort order, see `proced-sort-interactive'." - (interactive (list (or current-prefix-arg 'no-arg))) + (interactive (list (or current-prefix-arg 'no-arg)) proced-mode) (proced-sort-interactive 'pcpu arg)) (defun proced-sort-pmem (&optional arg) "Sort Proced buffer by percentage memory usage (%MEM). Prefix ARG controls sort order, see `proced-sort-interactive'." - (interactive (list (or current-prefix-arg 'no-arg))) + (interactive (list (or current-prefix-arg 'no-arg)) proced-mode) (proced-sort-interactive 'pmem arg)) (defun proced-sort-pid (&optional arg) "Sort Proced buffer by PID. Prefix ARG controls sort order, see `proced-sort-interactive'." - (interactive (list (or current-prefix-arg 'no-arg))) + (interactive (list (or current-prefix-arg 'no-arg)) proced-mode) (proced-sort-interactive 'pid arg)) (defun proced-sort-start (&optional arg) "Sort Proced buffer by time the command started (START). Prefix ARG controls sort order, see `proced-sort-interactive'." - (interactive (list (or current-prefix-arg 'no-arg))) + (interactive (list (or current-prefix-arg 'no-arg)) proced-mode) (proced-sort-interactive 'start arg)) (defun proced-sort-time (&optional arg) "Sort Proced buffer by CPU time (TIME). Prefix ARG controls sort order, see `proced-sort-interactive'." - (interactive (list (or current-prefix-arg 'no-arg))) + (interactive (list (or current-prefix-arg 'no-arg)) proced-mode) (proced-sort-interactive 'time arg)) (defun proced-sort-user (&optional arg) "Sort Proced buffer by USER. Prefix ARG controls sort order, see `proced-sort-interactive'." - (interactive (list (or current-prefix-arg 'no-arg))) + (interactive (list (or current-prefix-arg 'no-arg)) proced-mode) (proced-sort-interactive 'user arg)) (defun proced-sort-header (event &optional arg) @@ -1329,7 +1332,7 @@ EVENT is a mouse event with starting position in the header line. 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))) + (interactive (list last-input-event (or last-prefix-arg 'no-arg)) proced-mode) (let* ((start (event-start event)) (obj (posn-object start)) col key) @@ -1535,7 +1538,8 @@ With prefix REVERT non-nil revert listing." (let ((scheme (completing-read "Format: " proced-format-alist nil t))) (list (if (string= "" scheme) nil (intern scheme)) - current-prefix-arg))) + current-prefix-arg)) + proced-mode) ;; only update if necessary (when (or (not (eq proced-format scheme)) revert) (setq proced-format scheme) @@ -1567,7 +1571,7 @@ Suppress status information if QUIET is nil. After updating a displayed Proced buffer run the normal hook `proced-post-display-hook'." ;; This is the main function that generates and updates the process listing. - (interactive "P") + (interactive "P" proced-mode) (setq revert (or revert (not proced-process-alist))) (or quiet (message (if revert "Updating process information..." "Updating process display..."))) @@ -1773,11 +1777,12 @@ supported but discouraged. It will be removed in a future version of Emacs." `(:annotation-function ,(lambda (s) (cdr (assoc s proced-signal-list)))))) (proced-with-processes-buffer process-alist - (list (completing-read (concat "Send signal [" pnum - "] (default TERM): ") + (list (completing-read (format-prompt "Send signal [%s]" + "TERM" pnum) proced-signal-list nil nil nil nil "TERM") - process-alist)))) + process-alist))) + proced-mode) (unless (and signal process-alist) ;; Discouraged usage (supported for backward compatibility): @@ -1798,8 +1803,8 @@ supported but discouraged. It will be removed in a future version of Emacs." `(:annotation-function ,(lambda (s) (cdr (assoc s proced-signal-list)))))) (proced-with-processes-buffer process-alist - (setq signal (completing-read (concat "Send signal [" pnum - "] (default TERM): ") + (setq signal (completing-read (format-prompt "Send signal [%s]" + "TERM" pnum) proced-signal-list nil nil nil nil "TERM")))))) @@ -1862,7 +1867,8 @@ the normal hook `proced-after-send-signal-hook'." (let ((process-alist (proced-marked-processes))) (proced-with-processes-buffer process-alist (list (read-number "New priority: ") - process-alist)))) + process-alist))) + proced-mode) (if (numberp priority) (setq priority (number-to-string priority))) (let (failures) @@ -1894,7 +1900,7 @@ the normal hook `proced-after-send-signal-hook'." "Pop up a buffer with error log output from Proced. A group of errors from a single command ends with a formfeed. Thus, use \\[backward-page] to find the beginning of a group of errors." - (interactive) + (interactive nil proced-mode) (if (get-buffer proced-log-buffer) (save-selected-window ;; move `proced-log-buffer' to the front of the buffer list @@ -1946,7 +1952,7 @@ STRING is an overall summary of the failures." (defun proced-help () "Provide help for the Proced user." - (interactive) + (interactive nil proced-mode) (proced-why) (if (eq last-command 'proced-help) (describe-mode) @@ -1956,7 +1962,7 @@ STRING is an overall summary of the failures." "Undo in a Proced buffer. This doesn't recover killed processes, it just undoes changes in the Proced buffer. You can use it to recover marks." - (interactive) + (interactive nil proced-mode) (let (buffer-read-only) (undo)) (message "Change in Proced buffer undone. diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el index d7b12db2211..d7092a37d44 100644 --- a/lisp/progmodes/bug-reference.el +++ b/lisp/progmodes/bug-reference.el @@ -269,9 +269,9 @@ via the internet it might also be http.") ;; pull/17 page if 17 is a PR. Explicit user/project#17 links to ;; possibly different projects are also supported. (cl-defmethod bug-reference--build-forge-setup-entry - (host-domain (_forge-type (eql github)) protocol) + (host-domain (_forge-type (eql 'github)) protocol) `(,(concat "[/@]" (regexp-quote host-domain) - "[/:]\\([.A-Za-z0-9_/-]+\\)\\.git") + "[/:]\\([.A-Za-z0-9_/-]+?\\)\\(?:\\.git\\)?/?\\'") "\\(\\([.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\)\\>" ,(lambda (groups) (let ((ns-project (nth 1 groups))) @@ -285,9 +285,9 @@ via the internet it might also be http.") ;; namespace/project#18 or namespace/project!17 references to possibly ;; different projects are also supported. (cl-defmethod bug-reference--build-forge-setup-entry - (host-domain (_forge-type (eql gitlab)) protocol) + (host-domain (_forge-type (eql 'gitlab)) protocol) `(,(concat "[/@]" (regexp-quote host-domain) - "[/:]\\([.A-Za-z0-9_/-]+\\)\\.git") + "[/:]\\([.A-Za-z0-9_/-]+?\\)\\(?:\\.git\\)?/?\\'") "\\(\\([.A-Za-z0-9_/-]+\\)?\\([#!]\\)\\([0-9]+\\)\\)\\>" ,(lambda (groups) (let ((ns-project (nth 1 groups))) @@ -302,9 +302,9 @@ via the internet it might also be http.") ;; Gitea: The systematics is exactly as for Github projects. (cl-defmethod bug-reference--build-forge-setup-entry - (host-domain (_forge-type (eql gitea)) protocol) + (host-domain (_forge-type (eql 'gitea)) protocol) `(,(concat "[/@]" (regexp-quote host-domain) - "[/:]\\([.A-Za-z0-9_/-]+\\)\\.git") + "[/:]\\([.A-Za-z0-9_/-]+?\\)\\(?:\\.git\\)?/?\\'") "\\(\\([.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\)\\>" ,(lambda (groups) (let ((ns-project (nth 1 groups))) @@ -323,7 +323,7 @@ via the internet it might also be http.") ;; repo without tracker, or a repo with a tracker using a different ;; name, etc. So we can only try to make a good guess. (cl-defmethod bug-reference--build-forge-setup-entry - (host-domain (_forge-type (eql sourcehut)) protocol) + (host-domain (_forge-type (eql 'sourcehut)) protocol) `(,(concat "[/@]\\(?:git\\|hg\\)." (regexp-quote host-domain) "[/:]\\(~[.A-Za-z0-9_/-]+\\)") "\\(\\(~[.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\)\\>" diff --git a/lisp/progmodes/cc-cmds.el b/lisp/progmodes/cc-cmds.el index a9a52636b78..50249728048 100644 --- a/lisp/progmodes/cc-cmds.el +++ b/lisp/progmodes/cc-cmds.el @@ -1896,16 +1896,18 @@ defun." (if (< arg 0) (c-while-widening-to-decl-block (< (setq arg (- (c-forward-to-nth-EOF-\;-or-} (- arg) where))) 0))) - ;; Move forward to the next opening brace.... - (when (and (= arg 0) - (progn - (c-while-widening-to-decl-block - (not (c-syntactic-re-search-forward "{" nil 'eob))) - (eq (char-before) ?{))) - (backward-char) - ;; ... and backward to the function header. - (c-beginning-of-decl-1) - t)) + (prog1 + ;; Move forward to the next opening brace.... + (when (and (= arg 0) + (progn + (c-while-widening-to-decl-block + (not (c-syntactic-re-search-forward "{" nil 'eob))) + (eq (char-before) ?{))) + (backward-char) + ;; ... and backward to the function header. + (c-beginning-of-decl-1) + t) + (c-keep-region-active))) ;; Move backward to the opening brace of a function, making successively ;; larger portions of the buffer visible as necessary. @@ -3413,7 +3415,8 @@ to call `c-scan-conditionals' directly instead." (interactive "p") (let ((new-point (c-scan-conditionals count target-depth with-else))) (push-mark) - (goto-char new-point))) + (goto-char new-point)) + (c-keep-region-active)) (defun c-scan-conditionals (count &optional target-depth with-else) "Scan forward across COUNT preprocessor conditionals. diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el index 862652e2e5f..11f36681376 100644 --- a/lisp/progmodes/cc-engine.el +++ b/lisp/progmodes/cc-engine.el @@ -165,12 +165,16 @@ (defvar c-doc-line-join-end-ch) (defvar c-syntactic-context) (defvar c-syntactic-element) +(defvar c-new-id-start) +(defvar c-new-id-end) +(defvar c-new-id-is-type) (cc-bytecomp-defvar c-min-syn-tab-mkr) (cc-bytecomp-defvar c-max-syn-tab-mkr) (cc-bytecomp-defun c-clear-syn-tab) (cc-bytecomp-defun c-clear-string-fences) (cc-bytecomp-defun c-restore-string-fences) (cc-bytecomp-defun c-remove-string-fences) +(cc-bytecomp-defun c-fontify-new-found-type) ;; Make declarations for all the `c-lang-defvar' variables in cc-langs. @@ -6808,26 +6812,47 @@ 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 (make-hash-table :test #'equal :weakness nil))) -(defun c-add-type (from to) - ;; Add the given region as a type in `c-found-types'. If the region - ;; doesn't match an existing type but there is a type which is equal - ;; to the given one except that the last character is missing, then - ;; the shorter type is removed. That's done to avoid adding all - ;; prefixes of a type as it's being entered and font locked. This - ;; doesn't cover cases like when characters are removed from a type - ;; or added in the middle. We'd need the position of point when the - ;; font locking is invoked to solve this well. +(defun c-add-type-1 (from to) + ;; Add the given region as a type in `c-found-types'. Prepare occurrences + ;; of this new type for fontification throughout the buffer. ;; ;; This function might do hidden buffer changes. (let ((type (c-syntactic-content from to c-recognize-<>-arglists))) (unless (gethash type c-found-types) - (remhash (substring type 0 -1) c-found-types) - (puthash type t c-found-types)))) + (puthash type t c-found-types) + (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))))) + +(defun c-add-type (from to) + ;; Add the given region as a type in `c-found-types'. Also perform the + ;; actions of `c-add-type-1'. If the region is or overlaps an identifier + ;; which might be being typed in, don't record it. This is tested by + ;; checking `c-new-id-start' and `c-new-id-end'. That's done to avoid + ;; adding all prefixes of a type as it's being entered and font locked. + ;; This is a bit rough and ready, but now covers adding characters into the + ;; middle of an identifer. + ;; + ;; This function might do hidden buffer changes. + (if (and c-new-id-start c-new-id-end + (<= from c-new-id-end) (>= to c-new-id-start)) + (setq c-new-id-is-type t) + (c-add-type-1 from to))) (defun c-unfind-type (name) ;; Remove the "NAME" from c-found-types, if present. @@ -8210,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 @@ -8444,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. @@ -9169,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 @@ -9906,6 +9937,10 @@ This function might do hidden buffer changes." ;; Set when we have encountered a keyword (e.g. "extern") which ;; causes the following declaration to be treated as though top-level. make-top + ;; A list of found types in this declaration. This is an association + ;; list, the car being the buffer position, the cdr being the + ;; identifier. + found-type-list ;; Save `c-record-type-identifiers' and ;; `c-record-ref-identifiers' since ranges are recorded ;; speculatively and should be thrown away if it turns out @@ -9975,10 +10010,17 @@ This function might do hidden buffer changes." ;; If the previous identifier is a found type we ;; record it as a real one; it might be some sort of ;; alias for a prefix like "unsigned". - (save-excursion - (goto-char type-start) - (let ((c-promote-possible-types t)) - (c-forward-type)))) + ;; We postpone entering the new found type into c-found-types + ;; until we are sure of it, thus preventing rapid alternation + ;; of the fontification of the token throughout the buffer. + (push (cons type-start + (buffer-substring-no-properties + type-start + (save-excursion + (goto-char type-start) + (c-end-of-token) + (point)))) + found-type-list)) ;; Signal a type declaration for "struct foo {". (when (and backup-at-type-decl @@ -10224,13 +10266,10 @@ This function might do hidden buffer changes." (when (eq at-type 'found) ;; Remove the ostensible type from the found types list. (when type-start - (c-unfind-type - (buffer-substring-no-properties - type-start - (save-excursion - (goto-char type-start) - (c-end-of-token) - (point))))) + (let ((discard-t (assq type-start found-type-list))) + (when discard-t + (setq found-type-list + (remq discard-t found-type-list))))) t)) ;; The token which we assumed to be a type is actually the ;; identifier, and we have no explicit type. @@ -10844,6 +10883,14 @@ This function might do hidden buffer changes." ;; interactive refontification. (c-put-c-type-property (point) 'c-decl-arg-start)) + ;; Enter all the found types into `c-found-types'. + (when found-type-list + (save-excursion + (let ((c-promote-possible-types t)) + (dolist (ft found-type-list) + (goto-char (car ft)) + (c-forward-type))))) + ;; Record the type's coordinates in `c-record-type-identifiers' for ;; later fontification. (when (and c-record-type-identifiers at-type ;; (not (eq at-type t)) @@ -12092,7 +12139,10 @@ comment at the start of cc-engine.el for more info." (and (c-major-mode-is 'pike-mode) c-decl-block-key))) (while (eq braceassignp 'dontknow) - (cond ((eq (char-after) ?\;) + (cond ((or (eq (char-after) ?\;) + (save-excursion + (progn (c-backward-syntactic-ws) + (c-at-vsemi-p)))) (setq braceassignp nil)) ((and class-key (looking-at class-key)) @@ -14016,7 +14066,8 @@ comment at the start of cc-engine.el for more info." ;; clause - we assume only C++ needs it. (c-syntactic-skip-backward "^;,=" lim t)) (setq placeholder (point)) - (memq (char-before) '(?, ?= ?<))) + (and (memq (char-before) '(?, ?= ?<)) + (not (c-crosses-statement-barrier-p (point) indent-point)))) (cond ;; CASE 5D.6: Something like C++11's "using foo = <type-exp>" diff --git a/lisp/progmodes/cc-fonts.el b/lisp/progmodes/cc-fonts.el index bc0ae6cc95a..846c25f45a6 100644 --- a/lisp/progmodes/cc-fonts.el +++ b/lisp/progmodes/cc-fonts.el @@ -97,6 +97,7 @@ (cc-bytecomp-defun c-font-lock-declarators) (cc-bytecomp-defun c-font-lock-objc-method) (cc-bytecomp-defun c-font-lock-invalid-string) +(cc-bytecomp-defun c-font-lock-fontify-region) ;; Note that font-lock in XEmacs doesn't expand face names as @@ -919,13 +920,6 @@ casts and declarations are fontified. Used on level 2 and higher." ;; This function does hidden buffer changes. ;;(message "c-font-lock-complex-decl-prepare %s %s" (point) limit) - - ;; Clear the list of found types if we start from the start of the - ;; buffer, to make it easier to get rid of misspelled types and - ;; variables that have gotten recognized as types in malformed code. - (when (bobp) - (c-clear-found-types)) - (c-skip-comments-and-strings limit) (when (< (point) limit) @@ -2255,6 +2249,47 @@ higher." ;; defvar will install its default value later on. (makunbound def-var))) +;; `c-re-redisplay-timer' is a timer which, when triggered, causes a +;; redisplay. +(defvar c-re-redisplay-timer nil) + +(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)) + +(defun c-fontify-new-found-type (type) + ;; Cause the fontification of TYPE, a string, wherever it occurs in the + ;; 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 font-lock-mode + (boundp 'font-lock-support-mode) + (eq font-lock-support-mode 'jit-lock-mode)) + (c-save-buffer-state + ((window-boundaries + (mapcar (lambda (win) + (cons (window-start win) + (window-end win))) + (get-buffer-window-list (current-buffer) 'no-mini t))) + (target-re (concat "\\_<" type "\\_>"))) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (while (re-search-forward target-re nil t) + (put-text-property (match-beginning 0) (match-end 0) + 'fontified nil) + (dolist (win-boundary window-boundaries) + (when (and (< (match-beginning 0) (cdr win-boundary)) + (> (match-end 0) (car win-boundary)) + (not c-re-redisplay-timer)) + (setq c-re-redisplay-timer + (run-with-timer 0 nil #'c-force-redisplay + (match-beginning 0) (match-end 0))))))))))) + ;;; C. diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el index c9b7a95df60..ae2ca397661 100644 --- a/lisp/progmodes/cc-mode.el +++ b/lisp/progmodes/cc-mode.el @@ -179,6 +179,15 @@ (when c-buffer-is-cc-mode (save-restriction (widen) + (let ((lst (buffer-list))) + (catch 'found + (dolist (b lst) + (if (and (not (eq b (current-buffer))) + (with-current-buffer b + c-buffer-is-cc-mode)) + (throw 'found nil))) + (remove-hook 'post-command-hook 'c-post-command) + (remove-hook 'post-gc-hook 'c-post-gc-hook))) (c-save-buffer-state () (c-clear-char-properties (point-min) (point-max) 'category) (c-clear-char-properties (point-min) (point-max) 'syntax-table) @@ -745,6 +754,8 @@ that requires a literal mode spec at compile time." ;; would do since font-lock uses a(n implicit) depth of 0) so we don't need ;; c-after-font-lock-init. (add-hook 'after-change-functions 'c-after-change nil t) + (add-hook 'post-command-hook 'c-post-command) + (when (boundp 'font-lock-extend-after-change-region-function) (set (make-local-variable 'font-lock-extend-after-change-region-function) 'c-extend-after-change-region))) ; Currently (2009-05) used by all @@ -1950,6 +1961,43 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") ;; confused by already processed single quotes. (narrow-to-region (point) (point-max)))))) +;; The next two variables record the bounds of an identifier currently being +;; typed in. These are used to prevent such a partial identifier being +;; recorded as a found type by c-add-type. +(defvar c-new-id-start nil) +(make-variable-buffer-local 'c-new-id-start) +(defvar c-new-id-end nil) +(make-variable-buffer-local 'c-new-id-end) +;; The next variable, when non-nil, records that the previous two variables +;; define a type. +(defvar c-new-id-is-type nil) +(make-variable-buffer-local 'c-new-id-is-type) + +(defun c-update-new-id (end) + ;; Note the bounds of any identifier that END is in or just after, in + ;; `c-new-id-start' and `c-new-id-end'. Otherwise set these variables to + ;; nil. + (save-excursion + (goto-char end) + (let ((id-beg (c-on-identifier))) + (setq c-new-id-start id-beg + c-new-id-end (and id-beg + (progn (c-end-of-current-token) (point))))))) + + +(defun c-post-command () + ;; If point was inside of a new identifier and no longer is, record that + ;; fact. + (when (and c-buffer-is-cc-mode + c-new-id-start c-new-id-end + (or (> (point) c-new-id-end) + (< (point) c-new-id-start))) + (when c-new-id-is-type + (c-add-type-1 c-new-id-start c-new-id-end)) + (setq c-new-id-start nil + c-new-id-end nil + c-new-id-is-type nil))) + (defun c-before-change (beg end) ;; Function to be put on `before-change-functions'. Primarily, this calls ;; the language dependent `c-get-state-before-change-functions'. It is @@ -1969,11 +2017,16 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") (unless (c-called-from-text-property-change-p) (save-restriction (widen) + ;; Clear the list of found types if we make a change at the start of the + ;; buffer, to make it easier to get rid of misspelled types and + ;; variables that have gotten recognized as types in malformed code. + (when (eq beg (point-min)) + (c-clear-found-types)) (if c-just-done-before-change - ;; We have two consecutive calls to `before-change-functions' without - ;; an intervening `after-change-functions'. An example of this is bug - ;; #38691. To protect CC Mode, assume that the entire buffer has - ;; changed. + ;; We have two consecutive calls to `before-change-functions' + ;; without an intervening `after-change-functions'. An example of + ;; this is bug #38691. To protect CC Mode, assume that the entire + ;; buffer has changed. (setq beg (point-min) end (point-max) c-just-done-before-change 'whole-buffer) @@ -2151,6 +2204,7 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") c->-as-paren-syntax) (c-clear-char-property-with-value beg end 'syntax-table nil))) + (c-update-new-id end) (c-trim-found-types beg end old-len) ; maybe we don't ; need all of these. (c-invalidate-sws-region-after beg end old-len) @@ -2549,17 +2603,24 @@ This function is called from `c-common-init', once per mode initialization." At the time of call, point is just after the newly inserted CHAR. -When CHAR is \", t will be returned unless the \" is marked with -a string fence syntax-table text property. For other characters, -the default value of `electric-pair-inhibit-predicate' is called -and its value returned. +When CHAR is \" and not within a comment, t will be returned if +the quotes on the current line are already balanced (i.e. if the +last \" is not marked with a string fence syntax-table text +property). For other cases, the default value of +`electric-pair-inhibit-predicate' is called and its value +returned. This function is the appropriate value of `electric-pair-inhibit-predicate' for CC Mode modes, which mark invalid strings with such a syntax table text property on the opening \" and the next unescaped end of line." - (if (eq char ?\") - (not (equal (get-text-property (1- (point)) 'c-fl-syn-tab) '(15))) + (if (and (eq char ?\") + (not (memq (cadr (c-semi-pp-to-literal (1- (point)))) '(c c++)))) + (let ((last-quote (save-match-data + (save-excursion + (goto-char (c-point 'eoll)) + (search-backward "\""))))) + (not (equal (c-get-char-property last-quote 'c-fl-syn-tab) '(15)))) (funcall (default-value 'electric-pair-inhibit-predicate) char))) diff --git a/lisp/progmodes/cc-styles.el b/lisp/progmodes/cc-styles.el index c6b6be5b399..4d518838d11 100644 --- a/lisp/progmodes/cc-styles.el +++ b/lisp/progmodes/cc-styles.el @@ -444,17 +444,19 @@ STYLE using `c-set-style' if the optional SET-P flag is non-nil." defstr)) (prompt (concat symname " offset " defstr)) (keymap (make-sparse-keymap)) - (minibuffer-completion-table obarray) - (minibuffer-completion-predicate 'fboundp) offset input) ;; In principle completing-read is used here, but SPC is unbound ;; to make it less annoying to enter lists. (set-keymap-parent keymap minibuffer-local-completion-map) (define-key keymap " " 'self-insert-command) (while (not offset) - (setq input (read-from-minibuffer prompt nil keymap t - 'c-read-offset-history - (format "%s" oldoff))) + (minibuffer-with-setup-hook + (lambda () + (setq-local minibuffer-completion-table obarray) + (setq-local minibuffer-completion-predicate 'fboundp)) + (setq input (read-from-minibuffer prompt nil keymap t + 'c-read-offset-history + (format "%s" oldoff)))) (if (c-valid-offset input) (setq offset input) ;; error, but don't signal one, keep trying diff --git a/lisp/progmodes/cc-vars.el b/lisp/progmodes/cc-vars.el index d843c783ed0..83fd3da7c1d 100644 --- a/lisp/progmodes/cc-vars.el +++ b/lisp/progmodes/cc-vars.el @@ -179,7 +179,7 @@ STYLE stands for the choice where the value is taken from some style setting. PREAMBLE is optionally prepended to FOO; that is, if FOO contains :tag or :value, the respective two-element list component is ignored." - (declare (debug (symbolp form stringp &rest))) + (declare (debug (symbolp form stringp &rest)) (indent defun)) (let* ((expanded-doc (concat doc " This is a style variable. Apart from the valid values described diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index ac26f5e9341..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 @@ -2228,6 +2225,7 @@ The parent is always `compilation-mode' and the customizable `compilation-...' variables are also set from the name of the mode you have chosen, by replacing the first word, e.g., `compilation-scroll-output' from `grep-scroll-output' if that variable exists." + (declare (indent defun)) (let ((mode-name (replace-regexp-in-string "-mode\\'" "" (symbol-name mode)))) `(define-derived-mode ,mode compilation-mode ,name ,doc diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index 1afeb60ac5f..fe9612a09a9 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -1019,15 +1019,9 @@ Unless KEEP, removes the old indentation." (define-key map [(control ?c) (control ?h) ?v] ;;(concat (char-to-string help-char) "v") ; does not work 'cperl-get-help)) - (substitute-key-definition - 'indent-sexp 'cperl-indent-exp - map global-map) - (substitute-key-definition - 'indent-region 'cperl-indent-region - map global-map) - (substitute-key-definition - 'indent-for-comment 'cperl-indent-for-comment - map global-map) + (define-key map [remap indent-sexp] #'cperl-indent-exp) + (define-key map [remap indent-region] #'cperl-indent-region) + (define-key map [remap indent-for-comment] #'cperl-indent-for-comment) map) "Keymap used in CPerl mode.") @@ -5951,7 +5945,7 @@ default function." (eval cperl--basic-identifier-rx))) (0+ blank) "(") ;; '("\\<for\\(each\\)?\\([ \t]+\\(state\\|my\\|local\\|our\\)\\)?[ \t]*\\(\\$[a-zA-Z_][a-zA-Z_0-9]*\\)[ \t]*(" - 4 font-lock-variable-name-face) + 1 font-lock-variable-name-face) ;; Avoid $!, and s!!, qq!! etc. when not fontifying syntactically '("\\(?:^\\|[^smywqrx$]\\)\\(!\\)" 1 font-lock-negation-char-face) '("\\[\\(\\^\\)" 1 font-lock-negation-char-face prepend))) diff --git a/lisp/progmodes/cpp.el b/lisp/progmodes/cpp.el index d800365e66d..baee72b332d 100644 --- a/lisp/progmodes/cpp.el +++ b/lisp/progmodes/cpp.el @@ -702,11 +702,8 @@ BRANCH should be either nil (false branch), t (true branch) or `both'." (x-popup-menu cpp-button-event (list prompt (cons prompt cpp-face-default-list))) (let ((name (car (rassq default cpp-face-default-list)))) - (cdr (assoc (completing-read (if name - (concat prompt - " (default " name "): ") - (concat prompt ": ")) - cpp-face-default-list nil t) + (cdr (assoc (completing-read (format-prompt "%s" name prompt) + cpp-face-default-list nil t) cpp-face-all-list)))) default)) diff --git a/lisp/progmodes/ebrowse.el b/lisp/progmodes/ebrowse.el index ab0329d7eec..0713370da3c 100644 --- a/lisp/progmodes/ebrowse.el +++ b/lisp/progmodes/ebrowse.el @@ -1330,9 +1330,9 @@ Pop to member buffer if no prefix ARG, to tree buffer otherwise." "Set the indentation width of the tree display." (interactive) (let ((width (string-to-number (read-string - (concat "Indentation (default " - (int-to-string ebrowse--indentation) - "): ") + (format-prompt + "Indentation" + (int-to-string ebrowse--indentation)) nil nil ebrowse--indentation)))) (when (cl-plusp width) (setq-local ebrowse--indentation width) @@ -4045,23 +4045,27 @@ NUMBER-OF-STATIC-VARIABLES:" (defvar ebrowse-global-map nil "Keymap for Ebrowse commands.") - (defvar ebrowse-global-prefix-key "\C-c\C-m" "Prefix key for Ebrowse commands.") - -(defvar ebrowse-global-submap-4 nil - "Keymap used for `ebrowse-global-prefix' followed by `4'.") - - -(defvar ebrowse-global-submap-5 nil - "Keymap used for `ebrowse-global-prefix' followed by `5'.") - +(defvar-keymap ebrowse-global-submap-4 + :doc "Keymap used for `ebrowse-global-prefix' followed by `4'." + "." #'ebrowse-tags-find-definition-other-window + "f" #'ebrowse-tags-find-definition-other-window + "v" #'ebrowse-tags-find-declaration-other-window + "F" #'ebrowse-tags-view-definition-other-window + "V" #'ebrowse-tags-view-declaration-other-window) + +(defvar-keymap ebrowse-global-submap-5 + :doc "Keymap used for `ebrowse-global-prefix' followed by `5'." + "." #'ebrowse-tags-find-definition-other-frame + "f" #'ebrowse-tags-find-definition-other-frame + "v" #'ebrowse-tags-find-declaration-other-frame + "F" #'ebrowse-tags-view-definition-other-frame + "V" #'ebrowse-tags-view-declaration-other-frame) (unless ebrowse-global-map (setq ebrowse-global-map (make-sparse-keymap)) - (setq ebrowse-global-submap-4 (make-sparse-keymap)) - (setq ebrowse-global-submap-5 (make-sparse-keymap)) (define-key ebrowse-global-map "a" 'ebrowse-tags-apropos) (define-key ebrowse-global-map "b" 'ebrowse-pop-to-browser-buffer) (define-key ebrowse-global-map "-" 'ebrowse-back-in-position-stack) @@ -4082,17 +4086,7 @@ NUMBER-OF-STATIC-VARIABLES:" (define-key ebrowse-global-map " " 'ebrowse-electric-buffer-list) (define-key ebrowse-global-map "\t" 'ebrowse-tags-complete-symbol) (define-key ebrowse-global-map "4" ebrowse-global-submap-4) - (define-key ebrowse-global-submap-4 "." 'ebrowse-tags-find-definition-other-window) - (define-key ebrowse-global-submap-4 "f" 'ebrowse-tags-find-definition-other-window) - (define-key ebrowse-global-submap-4 "v" 'ebrowse-tags-find-declaration-other-window) - (define-key ebrowse-global-submap-4 "F" 'ebrowse-tags-view-definition-other-window) - (define-key ebrowse-global-submap-4 "V" 'ebrowse-tags-view-declaration-other-window) (define-key ebrowse-global-map "5" ebrowse-global-submap-5) - (define-key ebrowse-global-submap-5 "." 'ebrowse-tags-find-definition-other-frame) - (define-key ebrowse-global-submap-5 "f" 'ebrowse-tags-find-definition-other-frame) - (define-key ebrowse-global-submap-5 "v" 'ebrowse-tags-find-declaration-other-frame) - (define-key ebrowse-global-submap-5 "F" 'ebrowse-tags-view-definition-other-frame) - (define-key ebrowse-global-submap-5 "V" 'ebrowse-tags-view-declaration-other-frame) (define-key global-map ebrowse-global-prefix-key ebrowse-global-map)) diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index 9522055670d..efb5df8ebfb 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -45,15 +45,13 @@ It has `lisp-mode-abbrev-table' as its parent." table) "Syntax table used in `emacs-lisp-mode'.") -(defvar emacs-lisp-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map lisp-mode-shared-map) - (define-key map "\e\t" 'completion-at-point) - (define-key map "\e\C-x" 'eval-defun) - (define-key map "\e\C-q" 'indent-pp-sexp) - map) - "Keymap for Emacs Lisp mode. -All commands in `lisp-mode-shared-map' are inherited by this map.") +(defvar-keymap emacs-lisp-mode-map + :doc "Keymap for Emacs Lisp mode. +All commands in `lisp-mode-shared-map' are inherited by this map." + :parent lisp-mode-shared-map + "M-TAB" #'completion-at-point + "C-M-x" #'eval-defun + "C-M-q" #'indent-pp-sexp) (easy-menu-define emacs-lisp-mode-menu emacs-lisp-mode-map "Menu for Emacs Lisp mode." @@ -270,10 +268,8 @@ Comments in the form will be lost." (setq-local lexical-binding t) (add-file-local-variable-prop-line 'lexical-binding t interactive)))) -(defvar elisp--dynlex-modeline-map - (let ((map (make-sparse-keymap))) - (define-key map [mode-line mouse-1] 'elisp-enable-lexical-binding) - map)) +(defvar-keymap elisp--dynlex-modeline-map + "<mode-line> <mouse-1>" #'elisp-enable-lexical-binding) ;;;###autoload (define-derived-mode emacs-lisp-mode lisp-data-mode @@ -636,7 +632,8 @@ functions are annotated with \"<f>\" via the :company-kind #'elisp--company-kind :company-doc-buffer #'elisp--company-doc-buffer :company-docsig #'elisp--company-doc-string - :company-location #'elisp--company-location)) + :company-location #'elisp--company-location + :company-deprecated #'elisp--company-deprecated)) (quoted (list nil (elisp--completion-local-symbols) ;; Don't include all symbols (bug#16646). @@ -652,7 +649,8 @@ functions are annotated with \"<f>\" via the :company-kind #'elisp--company-kind :company-doc-buffer #'elisp--company-doc-buffer :company-docsig #'elisp--company-doc-string - :company-location #'elisp--company-location)) + :company-location #'elisp--company-location + :company-deprecated #'elisp--company-deprecated)) (t (list nil (completion-table-merge elisp--local-variables-completion-table @@ -667,7 +665,8 @@ functions are annotated with \"<f>\" via the 'variable)) :company-doc-buffer #'elisp--company-doc-buffer :company-docsig #'elisp--company-doc-string - :company-location #'elisp--company-location))) + :company-location #'elisp--company-location + :company-deprecated #'elisp--company-deprecated))) ;; Looks like a funcall position. Let's double check. (save-excursion (goto-char (1- beg)) @@ -714,13 +713,15 @@ functions are annotated with \"<f>\" via the :company-kind (lambda (_) 'variable) :company-doc-buffer #'elisp--company-doc-buffer :company-docsig #'elisp--company-doc-string - :company-location #'elisp--company-location)) + :company-location #'elisp--company-location + :company-deprecated #'elisp--company-deprecated)) (_ (list nil (elisp--completion-local-symbols) :predicate #'elisp--shorthand-aware-fboundp :company-kind #'elisp--company-kind :company-doc-buffer #'elisp--company-doc-buffer :company-docsig #'elisp--company-doc-string :company-location #'elisp--company-location + :company-deprecated #'elisp--company-deprecated )))))))) (nconc (list beg end) (if (null (car table-etc)) @@ -743,6 +744,11 @@ functions are annotated with \"<f>\" via the ((facep sym) 'color) (t 'text)))) +(defun elisp--company-deprecated (str) + (let ((sym (intern-soft str))) + (or (get sym 'byte-obsolete-variable) + (get sym 'byte-obsolete-info)))) + (defun lisp-completion-at-point (&optional _predicate) (declare (obsolete elisp-completion-at-point "25.1")) (elisp-completion-at-point)) @@ -1190,16 +1196,14 @@ namespace but with lower confidence." ;;; Elisp Interaction mode -(defvar lisp-interaction-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map lisp-mode-shared-map) - (define-key map "\e\C-x" 'eval-defun) - (define-key map "\e\C-q" 'indent-pp-sexp) - (define-key map "\e\t" 'completion-at-point) - (define-key map "\n" 'eval-print-last-sexp) - map) - "Keymap for Lisp Interaction mode. -All commands in `lisp-mode-shared-map' are inherited by this map.") +(defvar-keymap lisp-interaction-mode-map + :doc "Keymap for Lisp Interaction mode. +All commands in `lisp-mode-shared-map' are inherited by this map." + :parent lisp-mode-shared-map + "C-M-x" #'eval-defun + "C-M-q" #'indent-pp-sexp + "M-TAB" #'completion-at-point + "C-j" #'eval-print-last-sexp) (easy-menu-define lisp-interaction-mode-menu lisp-interaction-mode-map "Menu for Lisp Interaction mode." diff --git a/lisp/progmodes/erts-mode.el b/lisp/progmodes/erts-mode.el new file mode 100644 index 00000000000..a12c964c250 --- /dev/null +++ b/lisp/progmodes/erts-mode.el @@ -0,0 +1,225 @@ +;;; erts-mode.el --- major mode to edit erts files -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; Keywords: tools + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +(require 'ert) + +(defgroup erts-mode nil + "Major mode for editing Emacs test files." + :group 'lisp) + +(defface erts-mode-specification-name + '((((class color) + (background dark)) + :foreground "green") + (((class color) + (background light)) + :foreground "cornflower blue") + (t + :bold t)) + "Face used for displaying specification names." + :group 'erts-mode) + +(defface erts-mode-specification-value + '((((class color) + (background dark)) + :foreground "DeepSkyBlue1") + (((class color) + (background light)) + :foreground "blue") + (t + :bold t)) + "Face used for displaying specificaton values." + :group 'erts-mode) + +(defface erts-mode-start-test + '((t :inherit font-lock-keyword-face)) + "Face used for displaying specificaton test start markers." + :group 'erts-mode) + +(defface erts-mode-end-test + '((t :inherit font-lock-comment-face)) + "Face used for displaying specificaton test start markers." + :group 'erts-mode) + +(defvar erts-mode-map + (let ((map (make-keymap))) + (set-keymap-parent map prog-mode-map) + (define-key map "\C-c\C-r" 'erts-tag-region) + (define-key map "\C-c\C-c" 'erts-run-test) + map)) + +(defvar erts-mode-font-lock-keywords + ;; Specifications. + `((erts-mode--match-not-in-test + ("^\\([^ \t\n:]+:\\)[ \t]*\\(.*\\(\n[ \t].*\\)*\\)\n?" + (progn (goto-char (match-beginning 0)) (match-end 0)) nil + (1 'erts-mode-specification-name) + (2 'erts-mode-specification-value))) + ("^=-=$" 0 'erts-mode-start-test) + ("^=-=-=$" 0 'erts-mode-end-test))) + +(defun erts-mode--match-not-in-test (_limit) + (when (erts-mode--in-test-p (point)) + (erts-mode--end-of-test)) + (let ((start (point))) + (goto-char + (if (re-search-forward "^=-=$" nil t) + (match-beginning 0) + (point-max))) + (if (< (point) start) + nil + ;; Here we disregard LIMIT so that we may extend the area again. + (set-match-data (list start (point))) + (point)))) + +(defun erts-mode--end-of-test () + (search-forward "^=-=-=\n" nil t)) + +(defun erts-mode--in-test-p (point) + "Say whether POINT is in a test." + (save-excursion + (goto-char point) + (beginning-of-line) + (if (looking-at "=-=\\(-=\\)?$") + t + (let ((test-start (save-excursion + (re-search-backward "^=-=\n" nil t)))) + ;; Before the first test. + (and test-start + (let ((test-end (re-search-backward "^=-=-=\n" nil t))) + (or (null test-end) + ;; Between tests. + (> test-start test-end)))))))) + +;;;###autoload +(define-derived-mode erts-mode prog-mode "erts" + "Major mode for editing erts (Emacs testing) files. +This mode mainly provides some font locking. + +\\{erts-mode-map}" + (setq-local font-lock-defaults '(erts-mode-font-lock-keywords t))) + +(defun erts-tag-region (start end name) + "Tag the region between START and END as a test. +Interactively, this is the region. + +NAME should be a string appropriate for output by ert if the test fails. +If NAME is nil or the empty string, a name will be auto-generated." + (interactive "r\nsTest name: " erts-mode) + ;; Automatically make a name. + (when (zerop (length name)) + (save-excursion + (goto-char (point-min)) + (let ((names nil)) + (while (re-search-forward "^Name:[ \t]*\\(.*\\)" nil t) + (let ((name (match-string 1))) + (unless (erts-mode--in-test-p (point)) + (push name names)))) + (setq name + (cl-loop with base = (file-name-sans-extension (buffer-name)) + for i from 1 + for name = (format "%s%d" base i) + unless (member name names) + return name))))) + (save-excursion + (goto-char end) + (unless (bolp) + (insert "\n")) + (insert "=-=-=\n") + (goto-char start) + (insert "Name: " name "\n\n") + (insert "=-=\n"))) + +(defun erts-mode--preceding-spec (name) + (save-excursion + ;; Find the name, but skip if it's in a test. + (while (and (re-search-backward (format "^%s:" name) nil t) + (erts-mode--in-test-p (point)))) + (and (not (erts-mode--in-test-p (point))) + (re-search-forward "^=-=$" nil t) + (progn + (goto-char (match-beginning 0)) + (cdr (assq (intern (downcase name)) + (ert--erts-specifications (point)))))))) + +(defun erts-run-test (test-function &optional verbose) + "Run the current test. +If the current erts file doesn't define a test function, the user +will be prompted for one. + +If VERBOSE (interactively, the prefix), display a diff of the +expected results and the actual results in a separate buffer." + (interactive + (list (or (erts-mode--preceding-spec "Code") + (read-string "Transformation function: ")) + current-prefix-arg) + erts-mode) + (save-excursion + (erts-mode--goto-start-of-test) + (condition-case arg + (ert-test--erts-test + (list (cons 'dummy t) + (cons 'code (car (read-from-string test-function))) + (cons 'point-char (erts-mode--preceding-spec "Point-Char"))) + (buffer-file-name)) + (:success (message "Test successful")) + (ert-test-failed + (if (not verbose) + (message "Test failure; result: \n%s" + (substring-no-properties (cadr (cadr arg)))) + (message "Test failure") + (let (expected got) + (unwind-protect + (progn + (with-current-buffer + (setq expected (generate-new-buffer "erts expected")) + (insert (nth 1 (cadr arg)))) + (with-current-buffer + (setq got (generate-new-buffer "erts results")) + (insert (nth 2 (cadr arg)))) + (diff-buffers expected got)) + (kill-buffer expected) + (kill-buffer got)))))))) + +(defun erts-mode--goto-start-of-test () + (if (not (erts-mode--in-test-p (point))) + (re-search-forward "^=-=\n" nil t) + (re-search-backward "^=-=\n" nil t) + (let ((potential-start (match-end 0))) + ;; See if we're in a two-clause ("before" and "after") test or not. + (if-let ((start (and (save-excursion (re-search-backward "^=-=\n" nil t)) + (match-end 0)))) + (let ((end (save-excursion (re-search-backward "^=-=-=\n" nil t)))) + (if (or (not end) + (> start end)) + ;; We are, so go to the real start. + (goto-char start) + (goto-char potential-start))) + (goto-char potential-start))))) + +(provide 'erts-mode) + +;;; erts-mode.el ends here diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el index a63c3f33974..348160ef50d 100644 --- a/lisp/progmodes/etags.el +++ b/lisp/progmodes/etags.el @@ -145,7 +145,9 @@ Otherwise, `find-tag-default' is used." :type '(choice (const nil) function)) (define-obsolete-variable-alias 'find-tag-marker-ring-length - 'xref-marker-ring-length "25.1") + 'tags-location-ring-length "25.1") + +(defvar tags-location-ring-length 16) (defcustom tags-tag-face 'default "Face for tags in the output of `tags-apropos'." @@ -180,10 +182,11 @@ Example value: (sexp :tag "Tags to search"))) :version "21.1") -(defvaralias 'find-tag-marker-ring 'xref--marker-ring) +;; Obsolete variable kept for compatibility. We don't use it in any way. +(defvar find-tag-marker-ring (make-ring 16)) (make-obsolete-variable 'find-tag-marker-ring - "use `xref-push-marker-stack' or `xref-pop-marker-stack' instead." + "use `xref-push-marker-stack' or `xref-go-back' instead." "25.1") (defvar default-tags-table-function nil @@ -191,7 +194,7 @@ Example value: This function receives no arguments and should return the default tags table file to use for the current buffer.") -(defvar tags-location-ring (make-ring xref-marker-ring-length) +(defvar tags-location-ring (make-ring tags-location-ring-length) "Ring of markers which are locations visited by \\[find-tag]. Pop back to the last location with \\[negative-argument] \\[find-tag].") @@ -292,7 +295,7 @@ file the tag was in." (or (locate-dominating-file default-directory "TAGS") default-directory))) (list (read-file-name - "Visit tags table (default TAGS): " + (format-prompt "Visit tags table" "TAGS") ;; default to TAGS from default-directory up to root. default-tag-dir (expand-file-name "TAGS" default-tag-dir) @@ -625,7 +628,7 @@ Returns t if it visits a tags table, or nil if there are no more in the list." (car list)) ;; Finally, prompt the user for a file name. (expand-file-name - (read-file-name "Visit tags table (default TAGS): " + (read-file-name (format-prompt "Visit tags table" "TAGS") default-directory "TAGS" t)))))) @@ -731,13 +734,13 @@ Returns t if it visits a tags table, or nil if there are no more in the list." (interactive) ;; Clear out the markers we are throwing away. (let ((i 0)) - (while (< i xref-marker-ring-length) + (while (< i tags-location-ring-length) (if (aref (cddr tags-location-ring) i) (set-marker (aref (cddr tags-location-ring) i) nil)) (setq i (1+ i)))) (xref-clear-marker-stack) (setq tags-file-name nil - tags-location-ring (make-ring xref-marker-ring-length) + tags-location-ring (make-ring tags-location-ring-length) tags-table-list nil tags-table-computed-list nil tags-table-computed-list-for nil @@ -1068,7 +1071,7 @@ See documentation of variable `tags-file-name'." regexp next-p t)) ;;;###autoload -(defalias 'pop-tag-mark 'xref-pop-marker-stack) +(defalias 'pop-tag-mark 'xref-go-back) (defvar tag-lines-already-matched nil @@ -1989,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/f90.el b/lisp/progmodes/f90.el index f9e6101e7ab..eb6da20ff7f 100644 --- a/lisp/progmodes/f90.el +++ b/lisp/progmodes/f90.el @@ -345,6 +345,7 @@ The options are `downcase-word', `upcase-word', `capitalize-word' and nil." ;; there are spaces. "contiguous" "submodule" "concurrent" "codimension" "sync all" "sync memory" "critical" "image_index" "error stop" + "impure" )) "\\_>") "Regexp used by the function `f90-change-keywords'.") @@ -646,7 +647,7 @@ do\\([ \t]*while\\)?\\|select[ \t]*\\(?:case\\|type\\)\\|where\\|\ forall\\|block\\|critical\\)\\)\\_>" (2 font-lock-constant-face nil t) (3 font-lock-keyword-face)) ;; Implicit declaration. - '("\\_<\\(implicit\\)[ \t]*\\(real\\|integer\\|c\\(haracter\\|omplex\\)\ + '("\\_<\\(implicit\\)[ \t]+\\(real\\|integer\\|c\\(haracter\\|omplex\\)\ \\|enumerator\\|procedure\\|\ logical\\|double[ \t]*precision\\|type[ \t]*(\\(?:\\sw\\|\\s_\\)+)\\|none\\)[ \t]*" (1 font-lock-keyword-face) (2 font-lock-type-face)) @@ -656,8 +657,10 @@ logical\\|double[ \t]*precision\\|type[ \t]*(\\(?:\\sw\\|\\s_\\)+)\\|none\\)[ \t '("\\(&\\)[ \t]*\\(!\\|$\\)" (1 font-lock-keyword-face)) "\\_<\\(then\\|continue\\|format\\|include\\|\\(?:error[ \t]+\\)?stop\\|\ return\\)\\_>" - '("\\_<\\(exit\\|cycle\\)[ \t]*\\(\\(?:\\sw\\|\\s_\\)+\\)?\\_>" + '("\\_<\\(exit\\|cycle\\)[ \t]+\\(\\(?:\\sw\\|\\s_\\)+\\)?\\_>" (1 font-lock-keyword-face) (2 font-lock-constant-face nil t)) + '("\\_<\\(exit\\|cycle\\)\\_>" + (1 font-lock-keyword-face)) '("\\_<\\(case\\)[ \t]*\\(default\\|(\\)" . 1) ;; F2003 "class default". '("\\_<\\(class\\)[ \t]*default" . 1) diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el index 66adc4e9ef8..409ff940d96 100644 --- a/lisp/progmodes/gdb-mi.el +++ b/lisp/progmodes/gdb-mi.el @@ -1266,7 +1266,7 @@ Used by Speedbar." :version "22.1") (define-key gud-minor-mode-map "\C-c\C-w" 'gud-watch) -(define-key global-map (vconcat gud-key-prefix "\C-w") 'gud-watch) +(keymap-set gud-global-map "C-w" 'gud-watch) (declare-function tooltip-identifier-from-point "tooltip" (point)) @@ -1612,6 +1612,7 @@ this trigger is subscribed to `gdb-buf-publisher' and called with ;; Used to display windows with thread-bound buffers (defmacro def-gdb-preempt-display-buffer (name buffer &optional doc split-horizontal) + (declare (indent defun)) `(defun ,name (&optional thread) ,(when doc doc) (message "%s" thread) @@ -3012,6 +3013,7 @@ calling `gdb-current-context-command'). Triggers defined by this command are meant to be used as a trigger argument when describing buffer types with `gdb-set-buffer-rules'." + (declare (indent defun)) `(defun ,trigger-name (&optional signal) (when (or (not ,signal-list) @@ -3032,6 +3034,7 @@ Erase current buffer and evaluate CUSTOM-DEFUN. Then call `gdb-update-buffer-name'. If NOPRESERVE is non-nil, window point is not restored after CUSTOM-DEFUN." + (declare (indent defun)) `(defun ,handler-name () (let* ((inhibit-read-only t) ,@(unless nopreserve @@ -3055,6 +3058,7 @@ See `def-gdb-auto-update-trigger'. HANDLER-NAME handler uses customization of CUSTOM-DEFUN. See `def-gdb-auto-update-handler'." + (declare (indent defun)) `(progn (def-gdb-auto-update-trigger ,trigger-name ,gdb-command @@ -3473,6 +3477,7 @@ corresponding to the mode line clicked." CUSTOM-DEFUN may use locally bound `thread' variable, which will be the value of `gdb-thread' property of the current line. If `gdb-thread' is nil, error is signaled." + (declare (indent defun)) `(defun ,name (&optional event) ,(when doc doc) (interactive (list last-input-event)) @@ -3488,6 +3493,7 @@ If `gdb-thread' is nil, error is signaled." &optional doc) "Define a NAME which will call BUFFER-COMMAND with id of thread on the current line." + (declare (indent defun)) `(def-gdb-thread-buffer-command ,name (,buffer-command (gdb-mi--field thread 'id)) ,doc)) @@ -3543,6 +3549,7 @@ on the current line." "Define a NAME which will execute GUD-COMMAND with `gdb-thread-number' locally bound to id of thread on the current line." + (declare (indent defun)) `(def-gdb-thread-buffer-command ,name (if gdb-non-stop (let ((gdb-thread-number (gdb-mi--field thread 'id)) @@ -3711,6 +3718,7 @@ in `gdb-memory-format'." (defmacro def-gdb-set-positive-number (name variable echo-string &optional doc) "Define a function NAME which reads new VAR value from minibuffer." + (declare (indent defun)) `(defun ,name (event) ,(when doc doc) (interactive "e") @@ -3739,6 +3747,7 @@ in `gdb-memory-format'." "Define a function NAME to switch memory buffer to use FORMAT. DOC is an optional documentation string." + (declare (indent defun)) `(defun ,name () ,(when doc doc) (interactive) (customize-set-variable 'gdb-memory-format ,format) @@ -3808,6 +3817,7 @@ DOC is an optional documentation string." "Define a function NAME to switch memory unit size to UNIT-SIZE. DOC is an optional documentation string." + (declare (indent defun)) `(defun ,name () ,(when doc doc) (interactive) (customize-set-variable 'gdb-memory-unit ,unit-size) @@ -3832,6 +3842,7 @@ The defined function switches Memory buffer to show address stored in ADDRESS-VAR variable. DOC is an optional documentation string." + (declare (indent defun)) `(defun ,name ,(when doc doc) (interactive) diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el index 9be3af79f9d..70c55c01dd7 100644 --- a/lisp/progmodes/grep.el +++ b/lisp/progmodes/grep.el @@ -1057,11 +1057,9 @@ REGEXP is used as a string in the prompt." default-extension (car grep-files-history) (car (car grep-files-aliases)))) - (files (completing-read - (concat "Search for \"" regexp - "\" in files matching wildcard" - (if default (concat " (default " default ")")) - ": ") + (files (completing-read + (format-prompt "Search for \"%s\" in files matching wildcard" + default regexp) #'read-file-name-internal nil nil nil 'grep-files-history (delete-dups diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el index 2061d414802..d5bd2655174 100644 --- a/lisp/progmodes/gud.el +++ b/lisp/progmodes/gud.el @@ -90,8 +90,10 @@ pdb (Python), and jdb." "Prefix of all GUD commands valid in C buffers." :type 'key-sequence) -(global-set-key (vconcat gud-key-prefix "\C-l") #'gud-refresh) -;; (define-key ctl-x-map " " 'gud-break); backward compatibility hack +(defvar-keymap gud-global-map + "C-l" #'gud-refresh) + +(global-set-key gud-key-prefix gud-global-map) (defvar gud-marker-filter nil) (put 'gud-marker-filter 'permanent-local t) @@ -433,7 +435,7 @@ we're in the GUD buffer)." ;; Unused lexical warning if cmd does not use "arg". cmd)))) ,(if key `(local-set-key ,(concat "\C-c" key) #',func)) - ,(if key `(global-set-key (vconcat gud-key-prefix ,key) #',func)))) + ,(if key `(define-key gud-global-map ,key #',func)))) ;; Where gud-display-frame should put the debugging arrow; a cons of ;; (filename . line-number). This is set by the marker-filter, which scans @@ -3539,8 +3541,8 @@ Treats actions as defuns." #'gdb-script-end-of-defun) (setq-local font-lock-defaults '(gdb-script-font-lock-keywords nil nil ((?_ . "w")) nil - (font-lock-syntactic-face-function - . gdb-script-font-lock-syntactic-face))) + (font-lock-syntactic-face-function + . gdb-script-font-lock-syntactic-face))) ;; Recognize docstrings. (setq-local syntax-propertize-function gdb-script-syntax-propertize-function) diff --git a/lisp/progmodes/hideif.el b/lisp/progmodes/hideif.el index a18a67249ae..538ec4df804 100644 --- a/lisp/progmodes/hideif.el +++ b/lisp/progmodes/hideif.el @@ -181,30 +181,24 @@ Effective only if `hide-ifdef-expand-reinclusion-guard' is t." :type 'regexp :version "25.1") -(defvar hide-ifdef-mode-submap +(defvar-keymap hide-ifdef-mode-submap + :doc "Keymap used by `hide-ifdef-mode' under `hide-ifdef-mode-prefix-key'." ;; Set up the submap that goes after the prefix key. - (let ((map (make-sparse-keymap))) - (define-key map "d" 'hide-ifdef-define) - (define-key map "u" 'hide-ifdef-undef) - (define-key map "D" 'hide-ifdef-set-define-alist) - (define-key map "U" 'hide-ifdef-use-define-alist) - - (define-key map "h" 'hide-ifdefs) - (define-key map "s" 'show-ifdefs) - (define-key map "\C-d" 'hide-ifdef-block) - (define-key map "\C-s" 'show-ifdef-block) - (define-key map "e" 'hif-evaluate-macro) - (define-key map "C" 'hif-clear-all-ifdef-defined) - - (define-key map "\C-q" 'hide-ifdef-toggle-read-only) - (define-key map "\C-w" 'hide-ifdef-toggle-shadowing) - (substitute-key-definition - 'read-only-mode 'hide-ifdef-toggle-outside-read-only map) - ;; `toggle-read-only' is obsoleted by `read-only-mode'. - (substitute-key-definition - 'toggle-read-only 'hide-ifdef-toggle-outside-read-only map) - map) - "Keymap used by `hide-ifdef-mode' under `hide-ifdef-mode-prefix-key'.") + "d" #'hide-ifdef-define + "u" #'hide-ifdef-undef + "D" #'hide-ifdef-set-define-alist + "U" #'hide-ifdef-use-define-alist + "h" #'hide-ifdefs + "s" #'show-ifdefs + "C-d" #'hide-ifdef-block + "C-s" #'show-ifdef-block + "e" #'hif-evaluate-macro + "C" #'hif-clear-all-ifdef-defined + "C-q" #'hide-ifdef-toggle-read-only + "C-w" #'hide-ifdef-toggle-shadowing + "<remap> <read-only-mode>" #'hide-ifdef-toggle-outside-read-only + ;; `toggle-read-only' is obsoleted by `read-only-mode'. + "<remap> <toggle-read-only>" #'hide-ifdef-toggle-outside-read-only) (defcustom hide-ifdef-mode-prefix-key "\C-c@" "Prefix key for all Hide-Ifdef mode commands." @@ -2456,7 +2450,7 @@ This allows #ifdef VAR to be hidden." (t nil)))) (var (read-minibuffer "Define what? " default)) - (val (read-from-minibuffer (format "Set %s to? (default 1): " var) + (val (read-from-minibuffer (format-prompt "Set %s to?" "1" var) nil nil t nil "1"))) (list var val))) (hif-set-var var (or val 1)) 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/inf-lisp.el b/lisp/progmodes/inf-lisp.el index e69a9ff394e..2d2061e7cfe 100644 --- a/lisp/progmodes/inf-lisp.el +++ b/lisp/progmodes/inf-lisp.el @@ -308,7 +308,7 @@ quoted using shell quote syntax. "inferior-lisp" (car cmdlist) nil (cdr cmdlist))) (inferior-lisp-mode))) (setq inferior-lisp-buffer "*inferior-lisp*") - (pop-to-buffer-same-window "*inferior-lisp*")) + (pop-to-buffer "*inferior-lisp*" display-comint-buffer-action)) ;;;###autoload (defalias 'run-lisp 'inferior-lisp) diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el index 845ca8609d7..9303f1ecb91 100644 --- a/lisp/progmodes/js.el +++ b/lisp/progmodes/js.el @@ -33,7 +33,7 @@ ;; The main features of this JavaScript mode are syntactic ;; highlighting (enabled with `font-lock-mode' or ;; `global-font-lock-mode'), automatic indentation and filling of -;; comments, C preprocessor fontification, and MozRepl integration. +;; comments, and C preprocessor fontification. ;; ;; General Remarks: ;; @@ -51,7 +51,6 @@ (require 'cc-fonts)) (require 'newcomment) (require 'imenu) -(require 'moz nil t) (require 'json) (require 'prog-mode) @@ -59,12 +58,9 @@ (require 'cl-lib) (require 'ido)) -(defvar inferior-moz-buffer) -(defvar moz-repl-name) (defvar ido-cur-list) (defvar electric-layout-rules) (declare-function ido-mode "ido" (&optional arg)) -(declare-function inferior-moz-process "ext:mozrepl" ()) ;;; Constants @@ -95,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.") @@ -485,25 +481,22 @@ seldom use, either globally or on a per-buffer basis." (list 'const x)) js--available-frameworks))) -(defcustom js-js-switch-tabs - (and (memq system-type '(darwin)) t) +(defvar js-js-switch-tabs (and (memq system-type '(darwin)) t) "Whether `js-mode' should display tabs while selecting them. This is useful only if the windowing system has a good mechanism -for preventing Firefox from stealing the keyboard focus." - :type 'boolean) +for preventing Firefox from stealing the keyboard focus.") +(make-obsolete-variable 'js-js-switch-tabs "MozRepl no longer exists" "28.1") -(defcustom js-js-tmpdir - (locate-user-emacs-file "js/js") +(defvar js-js-tmpdir (locate-user-emacs-file "js/js") "Temporary directory used by `js-mode' to communicate with Mozilla. -This directory must be readable and writable by both Mozilla and Emacs." - :type 'directory - :version "28.1") +This directory must be readable and writable by both Mozilla and Emacs.") +(make-obsolete-variable 'js-js-tmpdir "MozRepl no longer exists" "28.1") -(defcustom js-js-timeout 5 +(defvar js-js-timeout 5 "Reply timeout for executing commands in Mozilla via `js-mode'. The value is given in seconds. Increase this value if you are -getting timeout messages." - :type 'integer) +getting timeout messages.") +(make-obsolete-variable 'js-js-timeout "MozRepl no longer exists" "28.1") (defcustom js-indent-first-init nil "Non-nil means specially indent the first variable declaration's initializer. @@ -671,18 +664,7 @@ This variable is like `sgml-attribute-offset'." (defvar js-mode-map (let ((keymap (make-sparse-keymap))) - (define-key keymap [(control ?c) (meta ?:)] #'js-eval) - (define-key keymap [(control ?c) (control ?j)] #'js-set-js-context) - (define-key keymap [(control meta ?x)] #'js-eval-defun) (define-key keymap [(meta ?.)] #'js-find-symbol) - (easy-menu-define nil keymap "JavaScript Menu" - '("JavaScript" - ["Select New Mozilla Context..." js-set-js-context - (fboundp #'inferior-moz-process)] - ["Evaluate Expression in Mozilla Context..." js-eval - (fboundp #'inferior-moz-process)] - ["Send Current Function to Mozilla..." js-eval-defun - (fboundp #'inferior-moz-process)])) keymap) "Keymap for `js-mode'.") @@ -932,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 "\\_<function\\_>")) + (unless (looking-at "\\(\\_<async\\_>[ \t\n]+\\)?\\_<function\\_>") + (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) @@ -970,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 "\\_<function\\_>") - (js--re-search-backward "\\_<function\\_>" 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 "\\_<function\\_>") + (js--re-search-backward "\\_<function\\_>" nil t)) + (progn + (setq start (match-beginning 0)) + (goto-char start) + (when (looking-back "\\_<async\\_>[ \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'. @@ -1247,7 +1233,6 @@ LIMIT defaults to point." ;; Regular function declaration ((and (looking-at "\\_<function\\_>") (setq name (js--forward-function-decl))) - (when (eq name t) (setq name (js--guess-function-name orig-match-end)) (if name @@ -1259,6 +1244,11 @@ LIMIT defaults to point." (cl-assert (eq (char-after) ?{)) (forward-char) + (save-excursion + (goto-char orig-match-start) + (when (looking-back "\\_<async\\_>[ \t\n]+" + (- (point) 30)) + (setq orig-match-start (match-beginning 0)))) (make-js--pitem :paren-depth orig-depth :h-begin orig-match-start @@ -3308,10 +3298,7 @@ marker." (setf (car bounds) (point)))) (buffer-substring (car bounds) (cdr bounds))))) -(defvar find-tag-marker-ring) ; etags - -;; etags loads ring. -(declare-function ring-insert "ring" (ring item)) +(declare-function xref-push-marker-stack "xref" (&optional m)) (defun js-find-symbol (&optional arg) "Read a JavaScript symbol and jump to it. @@ -3319,7 +3306,7 @@ With a prefix argument, restrict symbols to those from the current buffer. Pushes a mark onto the tag ring just like `find-tag'." (interactive "P") - (require 'etags) + (require 'xref) (let (symbols marker) (if (not arg) (setq symbols (js--get-all-known-symbols)) @@ -3331,1111 +3318,11 @@ current buffer. Pushes a mark onto the tag ring just like symbols "Jump to: " (js--guess-symbol-at-point)))) - (ring-insert find-tag-marker-ring (point-marker)) + (xref-push-marker-stack) (switch-to-buffer (marker-buffer marker)) (push-mark) (goto-char marker))) -;;; MozRepl integration - -(define-error 'js-moz-bad-rpc "Mozilla RPC Error") ;; '(timeout error)) -(define-error 'js-js-error "JavaScript Error") ;; '(js-error error)) - -(defun js--wait-for-matching-output - (process regexp timeout &optional start) - "Wait TIMEOUT seconds for PROCESS to output a match for REGEXP. -On timeout, return nil. On success, return t with match data -set. If START is non-nil, look for output starting from START. -Otherwise, use the current value of `process-mark'." - (with-current-buffer (process-buffer process) - (cl-loop with start-pos = (or start - (marker-position (process-mark process))) - with end-time = (time-add nil timeout) - for time-left = (float-time (time-subtract end-time nil)) - do (goto-char (point-max)) - if (looking-back regexp start-pos) return t - while (> time-left 0) - do (accept-process-output process time-left nil t) - do (goto-char (process-mark process)) - finally do (signal - 'js-moz-bad-rpc - (list (format "Timed out waiting for output matching %S" regexp)))))) - -(cl-defstruct js--js-handle - ;; Integer, mirrors the value we see in JS - (id nil :read-only t) - - ;; Process to which this thing belongs - (process nil :read-only t)) - -(defun js--js-handle-expired-p (x) - (not (eq (js--js-handle-process x) - (inferior-moz-process)))) - -(defvar js--js-references nil - "Maps Elisp JavaScript proxy objects to their JavaScript IDs.") - -(defvar js--js-process nil - "The most recent MozRepl process object.") - -(defvar js--js-gc-idle-timer nil - "Idle timer for cleaning up JS object references.") - -(defvar js--js-last-gcs-done nil) - -(defconst js--moz-interactor - (replace-regexp-in-string - "[ \n]+" " " - ; */" Make Emacs happy -"(function(repl) { - repl.defineInteractor('js', { - onStart: function onStart(repl) { - if(!repl._jsObjects) { - repl._jsObjects = {}; - repl._jsLastID = 0; - repl._jsGC = this._jsGC; - } - this._input = ''; - }, - - _jsGC: function _jsGC(ids_in_use) { - var objects = this._jsObjects; - var keys = []; - var num_freed = 0; - - for(var pn in objects) { - keys.push(Number(pn)); - } - - keys.sort(function(x, y) x - y); - ids_in_use.sort(function(x, y) x - y); - var i = 0; - var j = 0; - - while(i < ids_in_use.length && j < keys.length) { - var id = ids_in_use[i++]; - while(j < keys.length && keys[j] !== id) { - var k_id = keys[j++]; - delete objects[k_id]; - ++num_freed; - } - ++j; - } - - while(j < keys.length) { - var k_id = keys[j++]; - delete objects[k_id]; - ++num_freed; - } - - return num_freed; - }, - - _mkArray: function _mkArray() { - var result = []; - for(var i = 0; i < arguments.length; ++i) { - result.push(arguments[i]); - } - return result; - }, - - _parsePropDescriptor: function _parsePropDescriptor(parts) { - if(typeof parts === 'string') { - parts = [ parts ]; - } - - var obj = parts[0]; - var start = 1; - - if(typeof obj === 'string') { - obj = window; - start = 0; - } else if(parts.length < 2) { - throw new Error('expected at least 2 arguments'); - } - - for(var i = start; i < parts.length - 1; ++i) { - obj = obj[parts[i]]; - } - - return [obj, parts[parts.length - 1]]; - }, - - _getProp: function _getProp(/*...*/) { - if(arguments.length === 0) { - throw new Error('no arguments supplied to getprop'); - } - - if(arguments.length === 1 && - (typeof arguments[0]) !== 'string') - { - return arguments[0]; - } - - var [obj, propname] = this._parsePropDescriptor(arguments); - return obj[propname]; - }, - - _putProp: function _putProp(properties, value) { - var [obj, propname] = this._parsePropDescriptor(properties); - obj[propname] = value; - }, - - _delProp: function _delProp(propname) { - var [obj, propname] = this._parsePropDescriptor(arguments); - delete obj[propname]; - }, - - _typeOf: function _typeOf(thing) { - return typeof thing; - }, - - _callNew: function(constructor) { - if(typeof constructor === 'string') - { - constructor = window[constructor]; - } else if(constructor.length === 1 && - typeof constructor[0] !== 'string') - { - constructor = constructor[0]; - } else { - var [obj,propname] = this._parsePropDescriptor(constructor); - constructor = obj[propname]; - } - - /* Hacky, but should be robust */ - var s = 'new constructor('; - for(var i = 1; i < arguments.length; ++i) { - if(i != 1) { - s += ','; - } - - s += 'arguments[' + i + ']'; - } - - s += ')'; - return eval(s); - }, - - _callEval: function(thisobj, js) { - return eval.call(thisobj, js); - }, - - getPrompt: function getPrompt(repl) { - return 'EVAL>' - }, - - _lookupObject: function _lookupObject(repl, id) { - if(typeof id === 'string') { - switch(id) { - case 'global': - return window; - case 'nil': - return null; - case 't': - return true; - case 'false': - return false; - case 'undefined': - return undefined; - case 'repl': - return repl; - case 'interactor': - return this; - case 'NaN': - return NaN; - case 'Infinity': - return Infinity; - case '-Infinity': - return -Infinity; - default: - throw new Error('No object with special id:' + id); - } - } - - var ret = repl._jsObjects[id]; - if(ret === undefined) { - throw new Error('No object with id:' + id + '(' + typeof id + ')'); - } - return ret; - }, - - _findOrAllocateObject: function _findOrAllocateObject(repl, value) { - if(typeof value !== 'object' && typeof value !== 'function') { - throw new Error('_findOrAllocateObject called on non-object(' - + typeof(value) + '): ' - + value) - } - - for(var id in repl._jsObjects) { - id = Number(id); - var obj = repl._jsObjects[id]; - if(obj === value) { - return id; - } - } - - var id = ++repl._jsLastID; - repl._jsObjects[id] = value; - return id; - }, - - _fixupList: function _fixupList(repl, list) { - for(var i = 0; i < list.length; ++i) { - if(list[i] instanceof Array) { - this._fixupList(repl, list[i]); - } else if(typeof list[i] === 'object') { - var obj = list[i]; - if(obj.funcall) { - var parts = obj.funcall; - this._fixupList(repl, parts); - var [thisobj, func] = this._parseFunc(parts[0]); - list[i] = func.apply(thisobj, parts.slice(1)); - } else if(obj.objid) { - list[i] = this._lookupObject(repl, obj.objid); - } else { - throw new Error('Unknown object type: ' + obj.toSource()); - } - } - } - }, - - _parseFunc: function(func) { - var thisobj = null; - - if(typeof func === 'string') { - func = window[func]; - } else if(func instanceof Array) { - if(func.length === 1 && typeof func[0] !== 'string') { - func = func[0]; - } else { - [thisobj, func] = this._parsePropDescriptor(func); - func = thisobj[func]; - } - } - - return [thisobj,func]; - }, - - _encodeReturn: function(value, array_as_mv) { - var ret; - - if(value === null) { - ret = ['special', 'null']; - } else if(value === true) { - ret = ['special', 'true']; - } else if(value === false) { - ret = ['special', 'false']; - } else if(value === undefined) { - ret = ['special', 'undefined']; - } else if(typeof value === 'number') { - if(isNaN(value)) { - ret = ['special', 'NaN']; - } else if(value === Infinity) { - ret = ['special', 'Infinity']; - } else if(value === -Infinity) { - ret = ['special', '-Infinity']; - } else { - ret = ['atom', value]; - } - } else if(typeof value === 'string') { - ret = ['atom', value]; - } else if(array_as_mv && value instanceof Array) { - ret = ['array', value.map(this._encodeReturn, this)]; - } else { - ret = ['objid', this._findOrAllocateObject(repl, value)]; - } - - return ret; - }, - - _handleInputLine: function _handleInputLine(repl, line) { - var ret; - var array_as_mv = false; - - try { - if(line[0] === '*') { - array_as_mv = true; - line = line.substring(1); - } - var parts = eval(line); - this._fixupList(repl, parts); - var [thisobj, func] = this._parseFunc(parts[0]); - ret = this._encodeReturn( - func.apply(thisobj, parts.slice(1)), - array_as_mv); - } catch(x) { - ret = ['error', x.toString() ]; - } - - var JSON = Components.classes['@mozilla.org/dom/json;1'].createInstance(Components.interfaces.nsIJSON); - repl.print(JSON.encode(ret)); - repl._prompt(); - }, - - handleInput: function handleInput(repl, chunk) { - this._input += chunk; - var match, line; - while(match = this._input.match(/.*\\n/)) { - line = match[0]; - - if(line === 'EXIT\\n') { - repl.popInteractor(); - repl._prompt(); - return; - } - - this._input = this._input.substring(line.length); - this._handleInputLine(repl, line); - } - } - }); -}) -") - - "String to set MozRepl up into a simple-minded evaluation mode.") - -(defun js--js-encode-value (x) - "Marshall the given value for JS. -Strings and numbers are JSON-encoded. Lists (including nil) are -made into JavaScript array literals and their contents encoded -with `js--js-encode-value'." - (cond ((or (stringp x) (numberp x)) (json-encode x)) - ((symbolp x) (format "{objid:%S}" (symbol-name x))) - ((js--js-handle-p x) - - (when (js--js-handle-expired-p x) - (error "Stale JS handle")) - - (format "{objid:%s}" (js--js-handle-id x))) - - ((sequencep x) - (if (eq (car-safe x) 'js--funcall) - (format "{funcall:[%s]}" - (mapconcat #'js--js-encode-value (cdr x) ",")) - (concat - "[" (mapconcat #'js--js-encode-value x ",") "]"))) - (t - (error "Unrecognized item: %S" x)))) - -(defconst js--js-prompt-regexp "\\(repl[0-9]*\\)> $") -(defconst js--js-repl-prompt-regexp "^EVAL>$") -(defvar js--js-repl-depth 0) - -(defun js--js-wait-for-eval-prompt () - (js--wait-for-matching-output - (inferior-moz-process) - js--js-repl-prompt-regexp js-js-timeout - - ;; start matching against the beginning of the line in - ;; order to catch a prompt that's only partially arrived - (save-excursion (forward-line 0) (point)))) - -;; Presumably "inferior-moz-process" loads comint. -(declare-function comint-send-string "comint" (process string)) -(declare-function comint-send-input "comint" - (&optional no-newline artificial)) - -(defun js--js-enter-repl () - (inferior-moz-process) ; called for side-effect - (with-current-buffer inferior-moz-buffer - (goto-char (point-max)) - - ;; Do some initialization the first time we see a process - (unless (eq (inferior-moz-process) js--js-process) - (setq js--js-process (inferior-moz-process)) - (setq js--js-references (make-hash-table :test 'eq :weakness t)) - (setq js--js-repl-depth 0) - - ;; Send interactor definition - (comint-send-string js--js-process js--moz-interactor) - (comint-send-string js--js-process - (concat "(" moz-repl-name ")\n")) - (js--wait-for-matching-output - (inferior-moz-process) js--js-prompt-regexp - js-js-timeout)) - - ;; Sanity check - (when (looking-back js--js-prompt-regexp - (save-excursion (forward-line 0) (point))) - (setq js--js-repl-depth 0)) - - (if (> js--js-repl-depth 0) - ;; If js--js-repl-depth > 0, we *should* be seeing an - ;; EVAL> prompt. If we don't, give Mozilla a chance to catch - ;; up with us. - (js--js-wait-for-eval-prompt) - - ;; Otherwise, tell Mozilla to enter the interactor mode - (insert (match-string-no-properties 1) - ".pushInteractor('js')") - (comint-send-input nil t) - (js--wait-for-matching-output - (inferior-moz-process) js--js-repl-prompt-regexp - js-js-timeout)) - - (cl-incf js--js-repl-depth))) - -(defun js--js-leave-repl () - (cl-assert (> js--js-repl-depth 0)) - (when (= 0 (cl-decf js--js-repl-depth)) - (with-current-buffer inferior-moz-buffer - (goto-char (point-max)) - (js--js-wait-for-eval-prompt) - (insert "EXIT") - (comint-send-input nil t) - (js--wait-for-matching-output - (inferior-moz-process) js--js-prompt-regexp - js-js-timeout)))) - -(defsubst js--js-not (value) - (memq value '(nil null false undefined))) - -(defsubst js--js-true (value) - (not (js--js-not value))) - -(eval-and-compile - (defun js--optimize-arglist (arglist) - "Convert immediate js< and js! references to deferred ones." - (cl-loop for item in arglist - if (eq (car-safe item) 'js<) - collect (append (list 'list ''js--funcall - '(list 'interactor "_getProp")) - (js--optimize-arglist (cdr item))) - else if (eq (car-safe item) 'js>) - collect (append (list 'list ''js--funcall - '(list 'interactor "_putProp")) - - (if (atom (cadr item)) - (list (cadr item)) - (list - (append - (list 'list ''js--funcall - '(list 'interactor "_mkArray")) - (js--optimize-arglist (cadr item))))) - (js--optimize-arglist (cddr item))) - else if (eq (car-safe item) 'js!) - collect (pcase-let ((`(,_ ,function . ,body) item)) - (append (list 'list ''js--funcall - (if (consp function) - (cons 'list - (js--optimize-arglist function)) - function)) - (js--optimize-arglist body))) - else - collect item))) - -(defmacro js--js-get-service (class-name interface-name) - `(js! ("Components" "classes" ,class-name "getService") - (js< "Components" "interfaces" ,interface-name))) - -(defmacro js--js-create-instance (class-name interface-name) - `(js! ("Components" "classes" ,class-name "createInstance") - (js< "Components" "interfaces" ,interface-name))) - -(defmacro js--js-qi (object interface-name) - `(js! (,object "QueryInterface") - (js< "Components" "interfaces" ,interface-name))) - -(defmacro with-js (&rest forms) - "Run FORMS with the Mozilla repl set up for js commands. -Inside the lexical scope of `with-js', `js?', `js!', -`js-new', `js-eval', `js-list', `js<', `js>', `js-get-service', -`js-create-instance', and `js-qi' are defined." - (declare (indent 0) (debug t)) - `(progn - (js--js-enter-repl) - (unwind-protect - (cl-macrolet ((js? (&rest body) `(js--js-true ,@body)) - (js! (function &rest body) - `(js--js-funcall - ,(if (consp function) - (cons 'list - (js--optimize-arglist function)) - function) - ,@(js--optimize-arglist body))) - - (js-new (function &rest body) - `(js--js-new - ,(if (consp function) - (cons 'list - (js--optimize-arglist function)) - function) - ,@body)) - - (js-eval (thisobj js) - `(js--js-eval - ,@(js--optimize-arglist - (list thisobj js)))) - - (js-list (&rest args) - `(js--js-list - ,@(js--optimize-arglist args))) - - (js-get-service (&rest args) - `(js--js-get-service - ,@(js--optimize-arglist args))) - - (js-create-instance (&rest args) - `(js--js-create-instance - ,@(js--optimize-arglist args))) - - (js-qi (&rest args) - `(js--js-qi - ,@(js--optimize-arglist args))) - - (js< (&rest body) `(js--js-get - ,@(js--optimize-arglist body))) - (js> (props value) - `(js--js-funcall - '(interactor "_putProp") - ,(if (consp props) - (cons 'list - (js--optimize-arglist props)) - props) - ,@(js--optimize-arglist (list value)) - )) - (js-handle? (arg) `(js--js-handle-p ,arg))) - ,@forms) - (js--js-leave-repl)))) - -(defvar js--js-array-as-list nil - "Whether to listify any Array returned by a Mozilla function. -If nil, the whole Array is treated as a JS symbol.") - -(defun js--js-decode-retval (result) - (pcase (intern (cl-first result)) - ('atom (cl-second result)) - ('special (intern (cl-second result))) - ('array - (mapcar #'js--js-decode-retval (cl-second result))) - ('objid - (or (gethash (cl-second result) - js--js-references) - (puthash (cl-second result) - (make-js--js-handle - :id (cl-second result) - :process (inferior-moz-process)) - js--js-references))) - - ('error (signal 'js-js-error (list (cl-second result)))) - (x (error "Unmatched case in js--js-decode-retval: %S" x)))) - -(defvar comint-last-input-end) - -(defun js--js-funcall (function &rest arguments) - "Call the Mozilla function FUNCTION with arguments ARGUMENTS. -If function is a string, look it up as a property on the global -object and use the global object for `this'. -If FUNCTION is a list with one element, use that element as the -function with the global object for `this', except that if that -single element is a string, look it up on the global object. -If FUNCTION is a list with more than one argument, use the list -up to the last value as a property descriptor and the last -argument as a function." - - (with-js - (let ((argstr (js--js-encode-value - (cons function arguments)))) - - (with-current-buffer inferior-moz-buffer - ;; Actual funcall - (when js--js-array-as-list - (insert "*")) - (insert argstr) - (comint-send-input nil t) - (js--wait-for-matching-output - (inferior-moz-process) "EVAL>" - js-js-timeout) - (goto-char comint-last-input-end) - - ;; Read the result - (let* ((json-array-type 'list) - (result (prog1 (json-read) - (goto-char (point-max))))) - (js--js-decode-retval result)))))) - -(defun js--js-new (constructor &rest arguments) - "Call CONSTRUCTOR as a constructor, with arguments ARGUMENTS. -CONSTRUCTOR is a JS handle, a string, or a list of these things." - (apply #'js--js-funcall - '(interactor "_callNew") - constructor arguments)) - -(defun js--js-eval (thisobj js) - (js--js-funcall '(interactor "_callEval") thisobj js)) - -(defun js--js-list (&rest arguments) - "Return a Lisp array resulting from evaluating each of ARGUMENTS." - (let ((js--js-array-as-list t)) - (apply #'js--js-funcall '(interactor "_mkArray") - arguments))) - -(defun js--js-get (&rest props) - (apply #'js--js-funcall '(interactor "_getProp") props)) - -(defun js--js-put (props value) - (js--js-funcall '(interactor "_putProp") props value)) - -(defun js-gc (&optional force) - "Tell the repl about any objects we don't reference anymore. -With argument, run even if no intervening GC has happened." - (interactive) - - (when force - (setq js--js-last-gcs-done nil)) - - (let ((this-gcs-done gcs-done) keys num) - (when (and js--js-references - (boundp 'inferior-moz-buffer) - (buffer-live-p inferior-moz-buffer) - - ;; Don't bother running unless we've had an intervening - ;; garbage collection; without a gc, nothing is deleted - ;; from the weak hash table, so it's pointless telling - ;; MozRepl about that references we still hold - (not (eq js--js-last-gcs-done this-gcs-done)) - - ;; Are we looking at a normal prompt? Make sure not to - ;; interrupt the user if he's doing something - (with-current-buffer inferior-moz-buffer - (save-excursion - (goto-char (point-max)) - (looking-back js--js-prompt-regexp - (save-excursion (forward-line 0) (point)))))) - - (setq keys (cl-loop for x being the hash-keys - of js--js-references - collect x)) - (setq num (js--js-funcall '(repl "_jsGC") (or keys []))) - - (setq js--js-last-gcs-done this-gcs-done) - (when (called-interactively-p 'interactive) - (message "Cleaned %s entries" num)) - - num))) - -(run-with-idle-timer 30 t #'js-gc) - -(defun js-eval (js) - "Evaluate the JavaScript in JS and return JSON-decoded result." - (interactive "MJavaScript to evaluate: ") - (with-js - (let* ((content-window (js--js-content-window - (js--get-js-context))) - (result (js-eval content-window js))) - (when (called-interactively-p 'interactive) - (message "%s" (js! "String" result))) - result))) - -(defun js--get-tabs () - "Enumerate all JavaScript contexts available. -Each context is a list: - (TITLE URL BROWSER TAB TABBROWSER) for content documents - (TITLE URL WINDOW) for windows - -All tabs of a given window are grouped together. The most recent -window is first. Within each window, the tabs are returned -left-to-right." - (with-js - (let (windows) - - (cl-loop with window-mediator = (js! ("Components" "classes" - "@mozilla.org/appshell/window-mediator;1" - "getService") - (js< "Components" "interfaces" - "nsIWindowMediator")) - with enumerator = (js! (window-mediator "getEnumerator") nil) - - while (js? (js! (enumerator "hasMoreElements"))) - for window = (js! (enumerator "getNext")) - for window-info = (js-list window - (js< window "document" "title") - (js! (window "location" "toString")) - (js< window "closed") - (js< window "windowState")) - - unless (or (js? (cl-fourth window-info)) - (eq (cl-fifth window-info) 2)) - do (push window-info windows)) - - (cl-loop for (window title location) in windows - collect (list title location window) - - for gbrowser = (js< window "gBrowser") - if (js-handle? gbrowser) - nconc (cl-loop - for x below (js< gbrowser "browsers" "length") - collect (js-list (js< gbrowser - "browsers" - x - "contentDocument" - "title") - - (js! (gbrowser - "browsers" - x - "contentWindow" - "location" - "toString")) - (js< gbrowser - "browsers" - x) - - (js! (gbrowser - "tabContainer" - "childNodes" - "item") - x) - - gbrowser)))))) - -(defvar js-read-tab-history nil) - -(declare-function ido-chop "ido" (items elem)) - -(defun js--read-tab (prompt) - "Read a Mozilla tab with prompt PROMPT. -Return a cons of (TYPE . OBJECT). TYPE is either `window' or -`tab', and OBJECT is a JavaScript handle to a ChromeWindow or a -browser, respectively." - - ;; Prime IDO - (unless ido-mode - (ido-mode 1) - (ido-mode -1)) - - (with-js - (let ((tabs (js--get-tabs)) selected-tab-cname - selected-tab prev-hitab) - - ;; Disambiguate names - (setq tabs - (cl-loop with tab-names = (make-hash-table :test 'equal) - for tab in tabs - for cname = (format "%s (%s)" - (cl-second tab) (cl-first tab)) - for num = (cl-incf (gethash cname tab-names -1)) - if (> num 0) - do (setq cname (format "%s <%d>" cname num)) - collect (cons cname tab))) - - (cl-labels - ((find-tab-by-cname - (cname) - (cl-loop for tab in tabs - if (equal (car tab) cname) - return (cdr tab))) - - (mogrify-highlighting - (hitab unhitab) - - ;; Hack to reduce the number of - ;; round-trips to mozilla - (let (cmds) - (cond - ;; Highlighting tab - ((cl-fourth hitab) - (push '(js! ((cl-fourth hitab) "setAttribute") - "style" - "color: red; font-weight: bold") - cmds) - - ;; Highlight window proper - (push '(js! ((cl-third hitab) - "setAttribute") - "style" - "border: 8px solid red") - cmds) - - ;; Select tab, when appropriate - (when js-js-switch-tabs - (push - '(js> ((cl-fifth hitab) "selectedTab") (cl-fourth hitab)) - cmds))) - - ;; Highlighting whole window - ((cl-third hitab) - (push '(js! ((cl-third hitab) "document" - "documentElement" "setAttribute") - "style" - (concat "-moz-appearance: none;" - "border: 8px solid red;")) - cmds))) - - (cond - ;; Unhighlighting tab - ((cl-fourth unhitab) - (push '(js! ((cl-fourth unhitab) "setAttribute") "style" "") - cmds) - (push '(js! ((cl-third unhitab) "setAttribute") "style" "") - cmds)) - - ;; Unhighlighting window - ((cl-third unhitab) - (push '(js! ((cl-third unhitab) "document" - "documentElement" "setAttribute") - "style" "") - cmds))) - - (eval `(with-js - (js-list ,@(nreverse cmds))) - t))) - - (command-hook - () - (let* ((tab (find-tab-by-cname (car ido-matches)))) - (mogrify-highlighting tab prev-hitab) - (setq prev-hitab tab))) - - (setup-hook - () - ;; Fiddle with the match list a bit: if our first match - ;; is a tabbrowser window, rotate the match list until - ;; the active tab comes up - (let ((matched-tab (find-tab-by-cname (car ido-matches)))) - (when (and matched-tab - (null (cl-fourth matched-tab)) - (equal "navigator:browser" - (js! ((cl-third matched-tab) - "document" - "documentElement" - "getAttribute") - "windowtype"))) - - (cl-loop with tab-to-match = (js< (cl-third matched-tab) - "gBrowser" - "selectedTab") - - for match in ido-matches - for candidate-tab = (find-tab-by-cname match) - if (eq (cl-fourth candidate-tab) tab-to-match) - do (setq ido-cur-list - (ido-chop ido-cur-list match)) - and return t))) - - (add-hook 'post-command-hook #'command-hook t t))) - - - (unwind-protect - ;; FIXME: Don't impose IDO on the user. - (setq selected-tab-cname - (let ((ido-minibuffer-setup-hook - (cons #'setup-hook ido-minibuffer-setup-hook))) - (ido-completing-read - prompt - (mapcar #'car tabs) - nil t nil - 'js-read-tab-history))) - - (when prev-hitab - (mogrify-highlighting nil prev-hitab) - (setq prev-hitab nil))) - - (add-to-history 'js-read-tab-history selected-tab-cname) - - (setq selected-tab (cl-loop for tab in tabs - if (equal (car tab) selected-tab-cname) - return (cdr tab))) - - (cons (if (cl-fourth selected-tab) 'browser 'window) - (cl-third selected-tab)))))) - -(defun js--guess-eval-defun-info (pstate) - "Helper function for `js-eval-defun'. -Return a list (NAME . CLASSPARTS), where CLASSPARTS is a list of -strings making up the class name and NAME is the name of the -function part." - (cond ((and (= (length pstate) 3) - (eq (js--pitem-type (cl-first pstate)) 'function) - (= (length (js--pitem-name (cl-first pstate))) 1) - (consp (js--pitem-type (cl-second pstate)))) - - (append (js--pitem-name (cl-second pstate)) - (list (cl-first (js--pitem-name (cl-first pstate)))))) - - ((and (= (length pstate) 2) - (eq (js--pitem-type (cl-first pstate)) 'function)) - - (append - (butlast (js--pitem-name (cl-first pstate))) - (list (car (last (js--pitem-name (cl-first pstate))))))) - - (t (error "Function not a toplevel defun or class member")))) - -(defvar js--js-context nil - "The current JavaScript context. -This is a cons like the one returned from `js--read-tab'. -Change with `js-set-js-context'.") - -(defconst js--js-inserter - "(function(func_info,func) { - func_info.unshift('window'); - var obj = window; - for(var i = 1; i < func_info.length - 1; ++i) { - var next = obj[func_info[i]]; - if(typeof next !== 'object' && typeof next !== 'function') { - next = obj.prototype && obj.prototype[func_info[i]]; - if(typeof next !== 'object' && typeof next !== 'function') { - alert('Could not find ' + func_info.slice(0, i+1).join('.') + - ' or ' + func_info.slice(0, i+1).join('.') + '.prototype'); - return; - } - - func_info.splice(i+1, 0, 'prototype'); - ++i; - } - } - - obj[func_info[i]] = func; - alert('Successfully updated '+func_info.join('.')); - })") - -(defun js-set-js-context (context) - "Set the JavaScript context to CONTEXT. -When called interactively, prompt for CONTEXT." - (interactive (list (js--read-tab "JavaScript Context: "))) - (setq js--js-context context)) - -(defun js--get-js-context () - "Return a valid JavaScript context. -If one hasn't been set, or if it's stale, prompt for a new one." - (with-js - (when (or (null js--js-context) - (js--js-handle-expired-p (cdr js--js-context)) - (pcase (car js--js-context) - ('window (js? (js< (cdr js--js-context) "closed"))) - ('browser (not (js? (js< (cdr js--js-context) - "contentDocument")))) - (x (error "Unmatched case in js--get-js-context: %S" x)))) - (setq js--js-context (js--read-tab "JavaScript Context: "))) - js--js-context)) - -(defun js--js-content-window (context) - (with-js - (pcase (car context) - ('window (cdr context)) - ('browser (js< (cdr context) - "contentWindow" "wrappedJSObject")) - (x (error "Unmatched case in js--js-content-window: %S" x))))) - -(defun js--make-nsilocalfile (path) - (with-js - (let ((file (js-create-instance "@mozilla.org/file/local;1" - "nsILocalFile"))) - (js! (file "initWithPath") path) - file))) - -(defun js--js-add-resource-alias (alias path) - (with-js - (let* ((io-service (js-get-service "@mozilla.org/network/io-service;1" - "nsIIOService")) - (res-prot (js! (io-service "getProtocolHandler") "resource")) - (res-prot (js-qi res-prot "nsIResProtocolHandler")) - (path-file (js--make-nsilocalfile path)) - (path-uri (js! (io-service "newFileURI") path-file))) - (js! (res-prot "setSubstitution") alias path-uri)))) - -(cl-defun js-eval-defun () - "Update a Mozilla tab using the JavaScript defun at point." - (interactive) - - ;; This function works by generating a temporary file that contains - ;; the function we'd like to insert. We then use the elisp-js bridge - ;; to command mozilla to load this file by inserting a script tag - ;; into the document we set. This way, debuggers and such will have - ;; a way to find the source of the just-inserted function. - ;; - ;; We delete the temporary file if there's an error, but otherwise - ;; we add an unload event listener on the Mozilla side to delete the - ;; file. - - (save-excursion - (let (begin end pstate defun-info temp-name defun-body) - (js-end-of-defun) - (setq end (point)) - (js--ensure-cache) - (js-beginning-of-defun) - (re-search-forward "\\_<function\\_>") - (setq begin (match-beginning 0)) - (setq pstate (js--forward-pstate)) - - (when (or (null pstate) - (> (point) end)) - (error "Could not locate function definition")) - - (setq defun-info (js--guess-eval-defun-info pstate)) - - (let ((overlay (make-overlay begin end))) - (overlay-put overlay 'face 'highlight) - (unwind-protect - (unless (y-or-n-p (format "Send %s to Mozilla? " - (mapconcat #'identity defun-info "."))) - (message "") ; question message lingers until next command - (cl-return-from js-eval-defun)) - (delete-overlay overlay))) - - (setq defun-body (buffer-substring-no-properties begin end)) - - (make-directory js-js-tmpdir t) - - ;; (Re)register a Mozilla resource URL to point to the - ;; temporary directory - (js--js-add-resource-alias "js" js-js-tmpdir) - - (setq temp-name (make-temp-file (concat js-js-tmpdir - "/js-") - nil ".js")) - (unwind-protect - (with-js - (with-temp-buffer - (insert js--js-inserter) - (insert "(") - (let ((standard-output (current-buffer))) - (json--print-list defun-info)) - (insert ",\n") - (insert defun-body) - (insert "\n)") - (write-region (point-min) (point-max) temp-name - nil 1)) - - ;; Give Mozilla responsibility for deleting this file - (let* ((content-window (js--js-content-window - (js--get-js-context))) - (content-document (js< content-window "document")) - (head (if (js? (js< content-document "body")) - ;; Regular content - (js< (js! (content-document "getElementsByTagName") - "head") - 0) - ;; Chrome - (js< content-document "documentElement"))) - (elem (js! (content-document "createElementNS") - "http://www.w3.org/1999/xhtml" "script"))) - - (js! (elem "setAttribute") "type" "text/javascript") - (js! (elem "setAttribute") "src" - (format "resource://js/%s" - (file-name-nondirectory temp-name))) - - (js! (head "appendChild") elem) - - (js! (content-window "addEventListener") "unload" - (js! ((js-new - "Function" "file" - "return function() { file.remove(false) }")) - (js--make-nsilocalfile temp-name)) - 'false) - (setq temp-name nil) - - - - )) - - ;; temp-name is set to nil on success - (when temp-name - (delete-file temp-name)))))) - ;;; Syntax extensions (defvar js-syntactic-mode-name t diff --git a/lisp/progmodes/make-mode.el b/lisp/progmodes/make-mode.el index df17b87c013..caf8f1ea6d5 100644 --- a/lisp/progmodes/make-mode.el +++ b/lisp/progmodes/make-mode.el @@ -542,8 +542,8 @@ not be enclosed in { } or ( )." This should identify a `make' command that can handle the `-q' option." :type 'string) -(defvaralias 'makefile-query-one-target-method - 'makefile-query-one-target-method-function) +(define-obsolete-variable-alias 'makefile-query-one-target-method + 'makefile-query-one-target-method-function "29.1") (defcustom makefile-query-one-target-method-function 'makefile-query-by-make-minus-q diff --git a/lisp/progmodes/octave.el b/lisp/progmodes/octave.el index 6bf070cf9e5..79530f81673 100644 --- a/lisp/progmodes/octave.el +++ b/lisp/progmodes/octave.el @@ -1814,18 +1814,18 @@ If the environment variable OCTAVE_SRCDIR is set, it is searched first." (user-error "Aborted"))) (_ name))) -(defvar find-tag-marker-ring) +(declare-function xref-push-marker-stack "xref" (&optional m)) (defun octave-find-definition (fn) "Find the definition of FN. Functions implemented in C++ can be found if variable `octave-source-directories' is set correctly." (interactive (list (octave-completing-read))) - (require 'etags) + (require 'xref) (let ((orig (point))) (if (and (derived-mode-p 'octave-mode) (octave-goto-function-definition fn)) - (ring-insert find-tag-marker-ring (copy-marker orig)) + (xref-push-marker-stack (copy-marker orig)) (inferior-octave-send-list-and-digest ;; help NAME is more verbose (list (format "\ @@ -1840,7 +1840,7 @@ if iskeyword('%s') disp('`%s'' is a keyword') else which('%s') endif\n" (setq file (match-string 1 line)))) (if (not file) (user-error "%s" (or line (format-message "`%s' not found" fn))) - (ring-insert find-tag-marker-ring (point-marker)) + (xref-push-marker-stack) (setq file (funcall octave-find-definition-filename-function file)) (when file (find-file file) diff --git a/lisp/progmodes/pascal.el b/lisp/progmodes/pascal.el index e6e6e40aa19..5938da542ac 100644 --- a/lisp/progmodes/pascal.el +++ b/lisp/progmodes/pascal.el @@ -1357,9 +1357,7 @@ The default is a name found in the buffer around point." default "")) (label ;; Do completion with default. - (completing-read (if (not (string= default "")) - (concat "Label (default " default "): ") - "Label: ") + (completing-read (format-prompt "Label" default) ;; Complete with the defuns found in the ;; current-buffer. (let ((buf (current-buffer))) diff --git a/lisp/progmodes/perl-mode.el b/lisp/progmodes/perl-mode.el index 20834dd2e1e..d4e4f07b76b 100644 --- a/lisp/progmodes/perl-mode.el +++ b/lisp/progmodes/perl-mode.el @@ -191,7 +191,9 @@ ,(concat "\\<" (regexp-opt '("if" "until" "while" "elsif" "else" "unless" "do" "dump" "for" "foreach" "exit" "die" - "BEGIN" "END" "return" "exec" "eval") t) + "BEGIN" "END" "return" "exec" "eval" + "when" "given" "default") + t) "\\>") ;; ;; Fontify declarators and prefixes as types. @@ -212,7 +214,7 @@ (eval-and-compile (defconst perl--syntax-exp-intro-keywords - '("split" "if" "unless" "until" "while" "print" + '("split" "if" "unless" "until" "while" "print" "printf" "grep" "map" "not" "or" "and" "for" "foreach" "return")) (defconst perl--syntax-exp-intro-regexp diff --git a/lisp/progmodes/prog-mode.el b/lisp/progmodes/prog-mode.el index e43f2ff90b5..496b0810183 100644 --- a/lisp/progmodes/prog-mode.el +++ b/lisp/progmodes/prog-mode.el @@ -49,9 +49,15 @@ (define-key-after menu [prog-separator] menu-bar-separator 'middle-separator) + (unless (xref-forward-history-empty-p) + (define-key-after menu [xref-forward] + '(menu-item "Go Forward" xref-go-forward + :help "Forward to the position gone Back from") + 'prog-separator)) + (unless (xref-marker-stack-empty-p) (define-key-after menu [xref-pop] - '(menu-item "Go Back" xref-pop-marker-stack + '(menu-item "Go Back" xref-go-back :help "Back to the position of the last search") 'prog-separator)) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index da7435cddf3..62dba7b3933 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -322,7 +322,15 @@ to find the list of ignores for each directory." (process-file-shell-command command nil t)) (pt (point-min))) (unless (zerop status) - (error "File listing failed: %s" (buffer-string))) + (goto-char (point-min)) + (if (and + (not (eql status 127)) + (search-forward "Permission denied\n" nil t)) + (let ((end (1- (point)))) + (re-search-backward "\\`\\|\0") + (error "File listing failed: %s" + (buffer-substring (1+ (point)) end))) + (error "File listing failed: %s" (buffer-string)))) (goto-char pt) (while (search-forward "\0" nil t) (push (buffer-substring-no-properties (1+ pt) (1- (point))) @@ -840,28 +848,36 @@ pattern to search for." project-regexp-history-variable))) ;;;###autoload -(defun project-find-file () +(defun project-find-file (&optional include-all) "Visit a file (with completion) in the current project. The filename at point (determined by `thing-at-point'), if any, -is available as part of \"future history\"." - (interactive) +is available as part of \"future history\". + +If INCLUDE-ALL is non-nil, or with prefix argument when called +interactively, include all files under the project root, except +for VCS directories listed in `vc-directory-exclusion-list'." + (interactive "P") (let* ((pr (project-current t)) (dirs (list (project-root pr)))) - (project-find-file-in (thing-at-point 'filename) dirs pr))) + (project-find-file-in (thing-at-point 'filename) dirs pr include-all))) ;;;###autoload -(defun project-or-external-find-file () +(defun project-or-external-find-file (&optional include-all) "Visit a file (with completion) in the current project or external roots. The filename at point (determined by `thing-at-point'), if any, -is available as part of \"future history\"." - (interactive) +is available as part of \"future history\". + +If INCLUDE-ALL is non-nil, or with prefix argument when called +interactively, include all files under the project root, except +for VCS directories listed in `vc-directory-exclusion-list'." + (interactive "P") (let* ((pr (project-current t)) (dirs (cons (project-root pr) (project-external-roots pr)))) - (project-find-file-in (thing-at-point 'filename) dirs pr))) + (project-find-file-in (thing-at-point 'filename) dirs pr include-all))) (defcustom project-read-file-name-function #'project--read-file-cpd-relative "Function to call to read a file name from a list. @@ -914,12 +930,25 @@ by the user at will." predicate hist mb-default)) -(defun project-find-file-in (suggested-filename dirs project) +(defun project-find-file-in (suggested-filename dirs project &optional include-all) "Complete a file name in DIRS in PROJECT and visit the result. SUGGESTED-FILENAME is a relative file name, or part of it, which -is used as part of \"future history\"." - (let* ((all-files (project-files project dirs)) +is used as part of \"future history\". + +If INCLUDE-ALL is non-nil, or with prefix argument when called +interactively, include all files from DIRS, except for VCS +directories listed in `vc-directory-exclusion-list'." + (let* ((vc-dirs-ignores (mapcar + (lambda (dir) + (concat dir "/")) + vc-directory-exclusion-list)) + (all-files + (if include-all + (mapcan + (lambda (dir) (project--files-in-directory dir vc-dirs-ignores)) + dirs) + (project-files project dirs))) (completion-ignore-case read-file-name-completion-ignore-case) (file (funcall project-read-file-name-function "Find file" all-files nil nil @@ -986,7 +1015,7 @@ if one already exists." (default-project-shell-name (project-prefixed-buffer-name "shell")) (shell-buffer (get-buffer default-project-shell-name))) (if (and shell-buffer (not current-prefix-arg)) - (pop-to-buffer-same-window shell-buffer) + (pop-to-buffer shell-buffer display-comint-buffer-action) (shell (generate-new-buffer-name default-project-shell-name))))) ;;;###autoload @@ -1002,7 +1031,7 @@ if one already exists." (eshell-buffer-name (project-prefixed-buffer-name "eshell")) (eshell-buffer (get-buffer eshell-buffer-name))) (if (and eshell-buffer (not current-prefix-arg)) - (pop-to-buffer-same-window eshell-buffer) + (pop-to-buffer eshell-buffer display-comint-buffer-action) (eshell t)))) ;;;###autoload @@ -1144,7 +1173,10 @@ displayed." (not (major-mode . help-mode))) (derived-mode . compilation-mode) (derived-mode . dired-mode) - (derived-mode . diff-mode)) + (derived-mode . diff-mode) + (derived-mode . comint-mode) + (derived-mode . eshell-mode) + (derived-mode . change-log-mode)) "List of conditions to kill buffers related to a project. This list is used by `project-kill-buffers'. Each condition is either: @@ -1177,9 +1209,18 @@ current project, it will be killed." (const and) sexp) (cons :tag "Disjunction" (const or) sexp))) - :version "28.1" + :version "29.1" :group 'project - :package-version '(project . "0.6.0")) + :package-version '(project . "0.8.2")) + +(defcustom project-kill-buffers-display-buffer-list nil + "Non-nil to display list of buffers to kill before killing project buffers. +Used by `project-kill-buffers'." + :type 'boolean + :version "29.1" + :group 'project + :package-version '(project . "0.8.2") + :safe #'booleanp) (defun project--buffer-list (pr) "Return the list of all buffers in project PR." @@ -1247,14 +1288,35 @@ NO-CONFIRM is always nil when the command is invoked interactively." (interactive) (let* ((pr (project-current t)) - (bufs (project--buffers-to-kill pr))) + (bufs (project--buffers-to-kill pr)) + (query-user (lambda () + (yes-or-no-p + (format "Kill %d buffers in %s? " + (length bufs) + (project-root pr)))))) (cond (no-confirm (mapc #'kill-buffer bufs)) ((null bufs) (message "No buffers to kill")) - ((yes-or-no-p (format "Kill %d buffers in %s? " - (length bufs) - (project-root pr))) + (project-kill-buffers-display-buffer-list + (when + (with-current-buffer-window + (get-buffer-create "*Buffer List*") + `(display-buffer--maybe-at-bottom + (dedicated . t) + (window-height . (fit-window-to-buffer)) + (preserve-size . (nil . t)) + (body-function + . ,#'(lambda (_window) + (list-buffers-noselect nil bufs)))) + #'(lambda (window _value) + (with-selected-window window + (unwind-protect + (funcall query-user) + (when (window-live-p window) + (quit-restore-window window 'kill)))))) + (mapc #'kill-buffer bufs))) + ((funcall query-user) (mapc #'kill-buffer bufs))))) diff --git a/lisp/progmodes/prolog.el b/lisp/progmodes/prolog.el index 59004e413eb..c36082bb6d0 100644 --- a/lisp/progmodes/prolog.el +++ b/lisp/progmodes/prolog.el @@ -2484,11 +2484,8 @@ Interaction supports completion." (if (eq (try-completion default prolog-info-alist) nil) (setq default nil)) ;; Read the PredSpec from the user - (completing-read - (if (zerop (length default)) - "Help on predicate: " - (concat "Help on predicate (default " default "): ")) - prolog-info-alist nil t nil nil default))) + (completing-read (format-prompt "Help on predicate" default) + prolog-info-alist nil t nil nil default))) (defun prolog-build-info-alist (&optional verbose) "Build an alist of all builtins and library predicates. diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 6357c4f2d3e..b403de8b7a6 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -5,7 +5,7 @@ ;; Author: Fabián E. Gallina <fgallina@gnu.org> ;; URL: https://github.com/fgallina/python.el ;; Version: 0.28 -;; Package-Requires: ((emacs "24.2") (cl-lib "1.0")) +;; Package-Requires: ((emacs "24.4") (cl-lib "1.0")) ;; Maintainer: emacs-devel@gnu.org ;; Created: Jul 2010 ;; Keywords: languages @@ -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. @@ -1518,7 +1525,10 @@ Returns nil if point is not in a def or class." (python-util-forward-comment -1) (forward-line 1) ;; Ensure point moves forward. - (and (> beg-pos (point)) (goto-char beg-pos))))) + (and (> beg-pos (point)) (goto-char beg-pos)) + ;; Return non-nil if we did something (because then we were in a + ;; def/class). + (/= beg-pos (point))))) (defun python-nav--syntactically (fn poscompfn &optional contextfn) "Move point using FN avoiding places with specific context. @@ -2724,20 +2734,12 @@ goes wrong and syntax highlighting in the shell gets messed up." (deactivate-mark nil) (start-pos prompt-end) (buffer-undo-list t) - (font-lock-buffer-pos nil) (replacement (python-shell-font-lock-with-font-lock-buffer - (delete-region (line-beginning-position) - (point-max)) - (setq font-lock-buffer-pos (point)) + (delete-region (point-min) (point-max)) (insert input) - ;; Ensure buffer is fontified, keeping it - ;; compatible with Emacs < 24.4. - (if (fboundp 'font-lock-ensure) - (funcall 'font-lock-ensure) - (font-lock-default-fontify-buffer)) - (buffer-substring font-lock-buffer-pos - (point-max)))) + (font-lock-ensure) + (buffer-string))) (replacement-length (length replacement)) (i 0)) ;; Inject text properties to get input fontified. @@ -3763,7 +3765,8 @@ With argument MSG show activation/deactivation message." (format "was t and %S is not part of the " (file-name-nondirectory python-shell-interpreter)) "`python-shell-completion-native-disabled-interpreters' " - "list. Native completions have been disabled locally. ")) + "list. Native completions have been disabled locally. " + "Consider installing the python package \"readline\". ")) (python-shell-completion-native-turn-off msg)))))) (defun python-shell-completion-native-turn-on-maybe-with-msg () @@ -3810,7 +3813,7 @@ With argument MSG show activation/deactivation message." (comint-redirect-perform-sanity-check nil) (comint-redirect-insert-matching-regexp t) (comint-redirect-finished-regexp - "1__dummy_completion__[[:space:]]*\n") + "1__dummy_completion__.*\n") (comint-redirect-output-buffer redirect-buffer)) ;; Compatibility with Emacs 24.x. Comint changed and ;; now `comint-redirect-filter' gets 3 args. This @@ -4670,7 +4673,10 @@ See `python-check-command' for the default." target = obj objtype = 'def' if target: - args = inspect.formatargspec(*argspec_function(target)) + if hasattr(inspect, 'signature'): + args = str(inspect.signature(target)) + else: + args = inspect.formatargspec(*argspec_function(target)) name = obj.__name__ doc = '{objtype} {name}{args}'.format( objtype=objtype, name=name, args=args @@ -4769,10 +4775,14 @@ Interactively, prompt for symbol." (interactive (let ((symbol (python-eldoc--get-symbol-at-point)) (enable-recursive-minibuffers t)) - (list (read-string (if symbol - (format "Describe symbol (default %s): " symbol) - "Describe symbol: ") - nil nil symbol)))) + (list (read-string + ;; `format-prompt' is new in Emacs 28.1. + (if (fboundp 'format-prompt) + (format-prompt "Describe symbol" symbol) + (if symbol + (format "Describe symbol (default %s): " symbol) + "Describe symbol: ")) + nil nil symbol)))) (message (python-eldoc--get-doc-at-point symbol))) (defun python-describe-at-point (symbol process) @@ -5569,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/scheme.el b/lisp/progmodes/scheme.el index 57351a7308d..abcdcb3349e 100644 --- a/lisp/progmodes/scheme.el +++ b/lisp/progmodes/scheme.el @@ -143,7 +143,6 @@ (setq-local comment-start-skip ";+[ \t]*") (setq-local comment-use-syntax t) (setq-local comment-column 40) - (setq-local parse-sexp-ignore-comments t) (setq-local lisp-indent-function 'scheme-indent-function) (setq mode-line-process '("" scheme-mode-line-process)) (setq-local imenu-case-fold-search t) diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el index 0dd9f2b4fa2..0ff6aec8d91 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el @@ -402,45 +402,42 @@ This is buffer-local in every such buffer.") (rpm . (,sh-mode-syntax-table ?\' "."))) "Syntax-table used in Shell-Script mode. See `sh-feature'.") -(defvar sh-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-c(" 'sh-function) - (define-key map "\C-c\C-w" 'sh-while) - (define-key map "\C-c\C-u" 'sh-until) - (define-key map "\C-c\C-t" 'sh-tmp-file) - (define-key map "\C-c\C-s" 'sh-select) - (define-key map "\C-c\C-r" 'sh-repeat) - (define-key map "\C-c\C-o" 'sh-while-getopts) - (define-key map "\C-c\C-l" 'sh-indexed-loop) - (define-key map "\C-c\C-i" 'sh-if) - (define-key map "\C-c\C-f" 'sh-for) - (define-key map "\C-c\C-c" 'sh-case) - (define-key map "\C-c?" #'smie-config-show-indent) - (define-key map "\C-c=" #'smie-config-set-indent) - (define-key map "\C-c<" #'smie-config-set-indent) - (define-key map "\C-c>" #'smie-config-guess) - (define-key map "\C-c\C-\\" 'sh-backslash-region) - - (define-key map "\C-c+" 'sh-add) - (define-key map "\C-\M-x" 'sh-execute-region) - (define-key map "\C-c\C-x" 'executable-interpret) - (define-key map "\C-c\C-n" 'sh-send-line-or-region-and-step) - (define-key map "\C-c\C-d" 'sh-cd-here) - (define-key map "\C-c\C-z" 'sh-show-shell) - - (define-key map [remap delete-backward-char] - 'backward-delete-char-untabify) - (define-key map "\C-c:" 'sh-set-shell) - (define-key map [remap backward-sentence] 'sh-beginning-of-command) - (define-key map [remap forward-sentence] 'sh-end-of-command) - map) - "Keymap used in Shell-Script mode.") +(defvar-keymap sh-mode-map + :doc "Keymap used in Shell-Script mode." + "C-c (" #'sh-function + "C-c C-w" #'sh-while + "C-c C-u" #'sh-until + "C-c C-t" #'sh-tmp-file + "C-c C-s" #'sh-select + "C-c C-r" #'sh-repeat + "C-c C-o" #'sh-while-getopts + "C-c C-l" #'sh-indexed-loop + "C-c C-i" #'sh-if + "C-c C-f" #'sh-for + "C-c C-c" #'sh-case + "C-c ?" #'smie-config-show-indent + "C-c =" #'smie-config-set-indent + "C-c <" #'smie-config-set-indent + "C-c >" #'smie-config-guess + "C-c C-\\" #'sh-backslash-region + + "C-c +" #'sh-add + "C-M-x" #'sh-execute-region + "C-c C-x" #'executable-interpret + "C-c C-n" #'sh-send-line-or-region-and-step + "C-c C-d" #'sh-cd-here + "C-c C-z" #'sh-show-shell + "C-c :" #'sh-set-shell + + "<remap> <delete-backward-char>" #'backward-delete-char-untabify + "<remap> <backward-sentence>" #'sh-beginning-of-command + "<remap> <forward-sentence>" #'sh-end-of-command) (easy-menu-define sh-mode-menu sh-mode-map "Menu for Shell-Script mode." '("Sh-Script" ["Backslash region" sh-backslash-region - :help "Insert, align, or delete end-of-line backslashes on the lines in the region."] + :help "Insert, align, or delete end-of-line backslashes on the lines in the region"] ["Set shell type..." sh-set-shell :help "Set this buffer's shell to SHELL (a string)"] ["Execute script..." executable-interpret @@ -458,7 +455,7 @@ This is buffer-local in every such buffer.") ["Select Statement" sh-select :help "Insert a select statement "] ["Indexed Loop" sh-indexed-loop - :help "Insert an indexed loop from 1 to n."] + :help "Insert an indexed loop from 1 to n"] ["Options Loop" sh-while-getopts :help "Insert a while getopts loop."] ["While Loop" sh-while @@ -482,7 +479,7 @@ This is buffer-local in every such buffer.") ["Show indentation" smie-config-show-indent :help "Show the how the current line would be indented"] ["Learn buffer indentation" smie-config-guess - :help "Learn how to indent the buffer the way it currently is."])) + :help "Learn how to indent the buffer the way it currently is"])) (defvar sh-skeleton-pair-default-alist '((?\( _ ?\)) (?\)) (?\[ ?\s _ ?\s ?\]) (?\]) @@ -628,7 +625,8 @@ removed when closing the here document." (wksh sh-append ksh88) (zsh sh-append ksh88 - "autoload" "bindkey" "builtin" "chdir" "compctl" "declare" "dirs" + "autoload" "always" + "bindkey" "builtin" "chdir" "compctl" "declare" "dirs" "disable" "disown" "echotc" "enable" "functions" "getln" "hash" "history" "integer" "limit" "local" "log" "popd" "pushd" "r" "readonly" "rehash" "sched" "setopt" "source" "suspend" "true" @@ -866,7 +864,7 @@ See `sh-feature'.") "\\(?:\\(?:.*[^\\\n]\\)?\\(?:\\\\\\\\\\)*\\\\\n\\)*.*") (defconst sh-here-doc-open-re - (concat "[^<]<<-?\\s-*\\\\?\\(\\(?:['\"][^'\"]+['\"]\\|\\sw\\|[-/~._]\\)+\\)" + (concat "[^<]<<-?\\s-*\\\\?\\(\\(?:['\"][^'\"]+['\"]\\|\\sw\\|[-/~._@]\\)+\\)" sh-escaped-line-re "\\(\n\\)"))) (defun sh--inside-noncommand-expression (pos) diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el index 5dfbf87e452..9e40fbd6efc 100644 --- a/lisp/progmodes/sql.el +++ b/lisp/progmodes/sql.el @@ -481,9 +481,9 @@ file. Since that is a plaintext file, this could be dangerous." :list-all ("\\d+" . "\\dS+") :list-table ("\\d+ %s" . "\\dS+ %s") :completion-object sql-postgres-completion-object - :prompt-regexp "^[[:alnum:]_]*=[#>] " + :prompt-regexp "^[-[:alnum:]_]*[-=][#>] " :prompt-length 5 - :prompt-cont-regexp "^[[:alnum:]_]*[-(][#>] " + :prompt-cont-regexp "^[-[:alnum:]_]*[-'(][#>] " :statement sql-postgres-statement-starters :input-filter sql-remove-tabs-filter :terminator ("\\(^\\s-*\\\\g\\|;\\)" . "\\g")) @@ -700,8 +700,17 @@ making new SQLi sessions." (sexp :tag "Value Expression"))))) :version "24.1") -(defvaralias 'sql-dialect 'sql-product) +(defun sql-add-connection (connection params) + "Add a new connection to `sql-connection-alist'. +If CONNECTION already exists, it is replaced with PARAMS." + (setq sql-connection-alist + (assoc-delete-all connection sql-connection-alist)) + (push + (cons connection params) + sql-connection-alist)) + +(defvaralias 'sql-dialect 'sql-product) (defcustom sql-product 'ansi "Select the SQL database product used. This allows highlighting buffers properly when you open them." @@ -963,12 +972,7 @@ If set to \"\\n\", each line in the history file will be interpreted as one command. Multi-line commands are split into several commands when the input ring is initialized from a history file. -This variable used to initialize `comint-input-ring-separator'. -`comint-input-ring-separator' is part of Emacs 21; if your Emacs -does not have it, setting `sql-input-ring-separator' will have no -effect. In that case multiline commands will be split into several -commands when the input history is read, as if you had set -`sql-input-ring-separator' to \"\\n\"." +This variable used to initialize `comint-input-ring-separator'." :type 'string) ;; The usual hooks @@ -1357,8 +1361,6 @@ specified, it's `sql-product' or `sql-connection' must match." (defvar sql-interactive-mode-map (let ((map (make-sparse-keymap))) (set-keymap-parent map comint-mode-map) - (if (fboundp 'set-keymap-name) - (set-keymap-name map 'sql-interactive-mode-map)); XEmacs (define-key map (kbd "C-j") 'sql-accumulate-and-indent) (define-key map (kbd "C-c C-w") 'sql-copy-column) (define-key map (kbd "O") 'sql-magic-go) @@ -2832,16 +2834,6 @@ configured." (font-lock-mode-internal nil) (font-lock-mode-internal t)) - (add-hook 'font-lock-mode-hook - (lambda () - ;; Provide defaults for new font-lock faces. - (defvar font-lock-builtin-face - (if (boundp 'font-lock-preprocessor-face) - font-lock-preprocessor-face - font-lock-keyword-face)) - (defvar font-lock-doc-face font-lock-string-face)) - nil t) - ;; Setup imenu; it needs the same syntax-alist. (when imenu (setq imenu-syntax-alist syntax-alist)))) @@ -3219,14 +3211,7 @@ For both `:file' and `:completion', there can also be a symbol (let* ((default (plist-get plist :default)) (last-value (sql-default-value symbol)) - (prompt-def - (if default - (if (string-match "\\(\\):[ \t]*\\'" prompt) - (replace-match (format " (default \"%s\")" default) t t prompt 1) - (replace-regexp-in-string "[ \t]*\\'" - (format " (default \"%s\") " default) - prompt t t)) - prompt)) + (prompt-def (format-prompt prompt default)) (use-dialog-box nil)) (cond ((plist-member plist :file) @@ -3311,7 +3296,7 @@ function like this: (sql-get-login \\='user \\='password \\='database)." (let ((plist (cdr-safe w))) (pcase (or (car-safe w) w) ('user - (sql-get-login-ext 'sql-user "User: " 'sql-user-history plist)) + (sql-get-login-ext 'sql-user "User" 'sql-user-history plist)) ('password (setq-default sql-password @@ -3330,14 +3315,14 @@ function like this: (sql-get-login \\='user \\='password \\='database)." (read-passwd "Password: " nil (sql-default-value 'sql-password))))) ('server - (sql-get-login-ext 'sql-server "Server: " 'sql-server-history plist)) + (sql-get-login-ext 'sql-server "Server" 'sql-server-history plist)) ('database (sql-get-login-ext 'sql-database "Database: " 'sql-database-history plist)) ('port - (sql-get-login-ext 'sql-port "Port: " + (sql-get-login-ext 'sql-port "Port" nil (append '(:number t) plist))))))) (defun sql-find-sqli-buffer (&optional product connection) @@ -4182,10 +4167,6 @@ must tell Emacs. Here's how to do that in your init file: (modify-syntax-entry ?\\\\ \"\\\\\" sql-mode-syntax-table)))" :abbrev-table sql-mode-abbrev-table - (when (and (featurep 'xemacs) - sql-mode-menu) - (easy-menu-add sql-mode-menu)) - ;; (smie-setup sql-smie-grammar #'sql-smie-rules) (setq-local comment-start "--") ;; Make each buffer in sql-mode remember the "current" SQLi buffer. @@ -4308,9 +4289,6 @@ you entered, right above the output it created. (setq mode-name (concat "SQLi[" (or (sql-get-product-feature sql-product :name) (symbol-name sql-product)) "]")) - (when (and (featurep 'xemacs) - sql-interactive-mode-menu) - (easy-menu-add sql-interactive-mode-menu)) ;; Note that making KEYWORDS-ONLY nil will cause havoc if you try ;; SELECT 'x' FROM DUAL with SQL*Plus, because the title of the column @@ -4681,6 +4659,14 @@ the call to \\[sql-product-interactive] with (get-buffer new-sqli-buffer))))) (user-error "No default SQL product defined: set `sql-product'"))) +(defun sql-comint-automatic-password (_) + "Intercept password prompts when we know the password. +This must also do the job of detecting password prompts." + (when (and + sql-password + (not (string= "" sql-password))) + sql-password)) + (defun sql-comint (product params &optional buf-name) "Set up a comint buffer to run the SQL processor. @@ -4705,6 +4691,13 @@ buffer. If nil, a name is chosen for it." (setq buf-name (sql-generate-unique-sqli-buffer-name product nil))) (set-text-properties 0 (length buf-name) nil buf-name) + ;; Create the buffer first, because we want to set it up before + ;; comint starts to run. + (set-buffer (get-buffer-create buf-name)) + ;; Set up the automatic population of passwords, if supported. + (when (sql-get-product-feature product :password-in-comint) + (setq comint-password-function #'sql-comint-automatic-password)) + ;; Start the command interpreter in the buffer ;; PROC-NAME is BUF-NAME without enclosing asterisks (let ((proc-name (replace-regexp-in-string "\\`[*]\\(.*\\)[*]\\'" "\\1" buf-name))) diff --git a/lisp/progmodes/verilog-mode.el b/lisp/progmodes/verilog-mode.el index 52c34d9fbc6..14f252b42d4 100644 --- a/lisp/progmodes/verilog-mode.el +++ b/lisp/progmodes/verilog-mode.el @@ -9,7 +9,7 @@ ;; Keywords: languages ;; The "Version" is the date followed by the decimal rendition of the Git ;; commit hex. -;; Version: 2021.09.23.089128420 +;; Version: 2021.10.14.127365406 ;; Yoni Rabkin <yoni@rabkins.net> contacted the maintainer of this ;; file on 19/3/2008, and the maintainer agreed that when a bug is @@ -124,7 +124,7 @@ ;; ;; This variable will always hold the version number of the mode -(defconst verilog-mode-version "2021-09-23-54ffde4-vpo-GNU" +(defconst verilog-mode-version "2021-10-14-797711e-vpo-GNU" "Version of this Verilog mode.") (defconst verilog-mode-release-emacs t "If non-nil, this version of Verilog mode was released with Emacs itself.") @@ -1264,7 +1264,9 @@ See `verilog-auto-inst-param-value'." Also affects AUTOINSTPARAM. Declaration order is the default for backward compatibility, and as some teams prefer signals that are declared together to remain together. Sorted order reduces -changes when declarations are moved around in a file. +changes when declarations are moved around in a file. Sorting is +within input/output/inout groupings, there is intentionally no +option to intermix between input/output/inouts. See also `verilog-auto-arg-sort'." :version "24.1" ; rev688 @@ -5478,8 +5480,11 @@ becomes: (let* ((pop-up-windows t)) (let ((name (expand-file-name (read-file-name - (format "Find this error in: (default %s) " - file) + ;; `format-prompt' is new in Emacs 28.1. + (if (fboundp 'format-prompt) + (format-prompt "Find this error in" file) + (format "Find this error in (default %s): " + file)) nil ;; dir file t)))) (setq buffer @@ -6598,7 +6603,8 @@ Also move point to constraint." (equal (char-before) ?\;) (equal (char-before) ?\})) ;; skip what looks like bus repetition operator {#{ - (not (string-match "^{\\s-*[\\(\\)0-9a-zA-Z_]*\\s-*{" (buffer-substring p (point))))))))) + (not (string-match "^{\\s-*[()0-9a-zA-Z_\\]*\\s-*{" + (buffer-substring p (point))))))))) (progn (let ( (pt (point)) (pass 0)) (verilog-backward-ws&directives) @@ -7863,14 +7869,14 @@ If search fails, other files are checked based on (let* ((default (verilog-get-default-symbol)) ;; The following variable is used in verilog-comp-function (verilog-buffer-to-use (current-buffer)) - (label (if (not (string= default "")) - ;; Do completion with default - (completing-read (concat "Goto-Label: (default " - default ") ") - #'verilog-comp-defun nil nil "") - ;; There is no default value. Complete without it - (completing-read "Goto-Label: " - #'verilog-comp-defun nil nil ""))) + (label + (completing-read (cond ((fboundp 'format-prompt) + ;; `format-prompt' is new in Emacs 28.1. + (format-prompt "Goto-Label" default)) + ((not (string= default "")) + (concat "Goto-Label (default " default "): ")) + (t "Goto-Label: ")) + #'verilog-comp-defun nil nil "")) pt) ;; Make sure library paths are correct, in case need to resolve module (verilog-auto-reeval-locals) diff --git a/lisp/progmodes/vhdl-mode.el b/lisp/progmodes/vhdl-mode.el index 3a9185b334f..f3a7d96c63b 100644 --- a/lisp/progmodes/vhdl-mode.el +++ b/lisp/progmodes/vhdl-mode.el @@ -10683,8 +10683,9 @@ Include a library specification, if not already there." (replace-match "" t t) (vhdl-template-insert-date)) (goto-char beg) - (while (search-forward "<year>" end t) - (replace-match (format-time-string "%Y" nil) t t)) + (let ((year (format-time-string "%Y"))) + (while (search-forward "<year>" end t) + (replace-match year t t))) (goto-char beg) (when file-title (while (search-forward "<title string>" end t) diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index fd59a7b98c8..c1981cc1ce0 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -1,7 +1,7 @@ ;;; xref.el --- Cross-referencing commands -*-lexical-binding:t-*- ;; Copyright (C) 2014-2021 Free Software Foundation, Inc. -;; Version: 1.3.0 +;; Version: 1.3.2 ;; Package-Requires: ((emacs "26.1")) ;; This is a GNU ELPA :core package. Avoid functionality that is not @@ -75,7 +75,7 @@ (require 'project) (eval-and-compile - (when (version< emacs-version "28") + (when (version< emacs-version "28.0.60") ;; etags.el in Emacs 26 and 27 uses EIEIO, and its location type ;; inherits from `xref-location'. (require 'eieio) @@ -195,9 +195,16 @@ is not known." ;;; Cross-reference -(cl-defstruct (xref-item - (:constructor xref-make (summary location)) - (:noinline t)) +(defmacro xref--defstruct (name &rest fields) + (declare (indent 1)) + `(cl-defstruct ,(if (>= emacs-major-version 27) + name + (remq (assq :noinline name) name)) + ,@fields)) + +(xref--defstruct (xref-item + (:constructor xref-make (summary location)) + (:noinline t)) "An xref item describes a reference to a location somewhere." (summary nil :documentation "String which describes the location. @@ -213,10 +220,10 @@ locations point to the same line. This behavior is new in Emacs 28.") location) -(cl-defstruct (xref-match-item - (:include xref-item) - (:constructor xref-make-match (summary location length)) - (:noinline t)) +(xref--defstruct (xref-match-item + (:include xref-item) + (:constructor xref-make-match (summary location length)) + (:noinline t)) "A match xref item describes a search result." length) @@ -346,15 +353,9 @@ backward." (t (goto-char start) nil)))) -;;; Marker stack (M-. pushes, M-, pops) - -(defcustom xref-marker-ring-length 16 - "Length of the xref marker ring. -If this variable is not set through Customize, you must call -`xref-set-marker-ring-length' for changes to take effect." - :type 'integer - :initialize #'custom-initialize-default - :set #'xref-set-marker-ring-length) +;; Dummy variable retained for compatibility. +(defvar xref-marker-ring-length 16) +(make-obsolete-variable 'xref-marker-ring-length nil "29.1") (defcustom xref-prompt-for-identifier '(not xref-find-definitions xref-find-definitions-other-window @@ -425,29 +426,59 @@ or earlier: it can break `dired-do-find-regexp-and-replace'." :version "28.1" :package-version '(xref . "1.2.0")) -(defvar xref--marker-ring (make-ring xref-marker-ring-length) - "Ring of markers to implement the marker stack.") +(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-set-marker-ring-length (var val) - "Set `xref-marker-ring-length'. -VAR is the symbol `xref-marker-ring-length' and VAL is the new -value." - (set-default var val) - (if (ring-p xref--marker-ring) - (ring-resize xref--marker-ring val))) +(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." - (ring-insert xref--marker-ring (or m (point-marker)))) + "Add point M (defaults to `point-marker') to the marker stack. +The future stack is erased." + (xref--push-backward (or m (point-marker))) + (dolist (mk (cdr xref--history)) + (set-marker mk nil nil)) + (setcdr xref--history nil)) + +;;;###autoload +(define-obsolete-function-alias 'xref-pop-marker-stack #'xref-go-back "29.1") + +;;;###autoload +(defun xref-go-back () + "Go back to the previous position in xref history. +To undo, use \\[xref-go-forward]." + (interactive) + (if (null (car xref--history)) + (user-error "At start of xref history") + (let ((marker (pop (car 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)) + (set-marker marker nil nil) + (run-hooks 'xref-after-return-hook)))) ;;;###autoload -(defun xref-pop-marker-stack () - "Pop back to where \\[xref-find-definitions] was last invoked." +(defun xref-go-forward () + "Got to the point where a previous \\[xref-go-back] was invoked." (interactive) - (let ((ring xref--marker-ring)) - (when (ring-empty-p ring) - (user-error "Marker stack is empty")) - (let ((marker (ring-remove ring 0))) + (if (null (cdr xref--history)) + (user-error "At end of xref history") + (let ((marker (pop (cdr 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)) @@ -470,17 +501,23 @@ value." ;; etags.el needs this (defun xref-clear-marker-stack () - "Discard all markers from the marker stack." - (let ((ring xref--marker-ring)) - (while (not (ring-empty-p ring)) - (let ((marker (ring-remove ring))) - (set-marker marker nil nil))))) + "Discard all markers from the xref history." + (dolist (l (list (car xref--history) (cdr xref--history))) + (dolist (m l) + (set-marker m nil nil))) + (setq xref--history (cons nil nil)) + nil) ;;;###autoload (defun xref-marker-stack-empty-p () - "Return t if the marker stack is empty; nil otherwise." - (ring-empty-p xref--marker-ring)) + "Whether the xref back-history is empty." + (null (car xref--history))) +;; FIXME: rename this to `xref-back-history-empty-p'. +;;;###autoload +(defun xref-forward-history-empty-p () + "Whether the xref forward-history is empty." + (null (cdr xref--history))) (defun xref--goto-char (pos) @@ -695,7 +732,7 @@ quit the *xref* buffer." "Quit *xref* buffer, then pop the xref marker stack." (interactive) (quit-window) - (xref-pop-marker-stack)) + (xref-go-back)) (defun xref-query-replace-in-results (from to) "Perform interactive replacement of FROM with TO in all displayed xrefs. @@ -1334,12 +1371,17 @@ definitions." (xref--prompt-p this-command)) (let ((id (completing-read - (if def - (format "%s (default %s): " - (substring prompt 0 (string-match - "[ :]+\\'" prompt)) - def) - prompt) + ;; `format-prompt' is new in Emacs 28.1 + (if (fboundp 'format-prompt) + (format-prompt (substring prompt 0 (string-match + "[ :]+\\'" prompt)) + def) + (if def + (format "%s (default %s): " + (substring prompt 0 (string-match + "[ :]+\\'" prompt)) + def) + prompt)) (xref-backend-identifier-completion-table backend) nil nil nil 'xref--read-identifier-history def))) @@ -1400,7 +1442,7 @@ definition for IDENTIFIER, display it in the selected window. Otherwise, display the list of the possible definitions in a buffer where the user can select from the list. -Use \\[xref-pop-marker-stack] to return back to where you invoked this command." +Use \\[xref-go-back] to return back to where you invoked this command." (interactive (list (xref--read-identifier "Find definitions of: "))) (xref--find-definitions identifier nil)) @@ -1491,7 +1533,8 @@ output of this command when the backend is etags." ;;; Key bindings ;;;###autoload (define-key esc-map "." #'xref-find-definitions) -;;;###autoload (define-key esc-map "," #'xref-pop-marker-stack) +;;;###autoload (define-key esc-map "," #'xref-go-back) +;;;###autoload (define-key esc-map [?\C-,] #'xref-go-forward) ;;;###autoload (define-key esc-map "?" #'xref-find-references) ;;;###autoload (define-key esc-map [?\C-.] #'xref-find-apropos) ;;;###autoload (define-key ctl-x-4-map "." #'xref-find-definitions-other-window) diff --git a/lisp/progmodes/xscheme.el b/lisp/progmodes/xscheme.el index 26ffe33b83e..e7667ebf51f 100644 --- a/lisp/progmodes/xscheme.el +++ b/lisp/progmodes/xscheme.el @@ -574,9 +574,8 @@ See also the commands \\[xscheme-yank-pop] and \\[xscheme-yank-push]." (if (consp arg) (exchange-point-and-mark))) -;; Old name, to avoid errors in users' init files. -(fset 'xscheme-yank-previous-send - 'xscheme-yank) +(define-obsolete-function-alias 'xscheme-yank-previous-send + #'xscheme-yank "29.1") (defun xscheme-yank-pop (arg) "Insert or replace a just-yanked expression with an older expression. diff --git a/lisp/ps-mule.el b/lisp/ps-mule.el index ab8af40628a..2d1dcd2b686 100644 --- a/lisp/ps-mule.el +++ b/lisp/ps-mule.el @@ -1209,8 +1209,8 @@ V%s 0 /%s-latin1 /%s Latin1Encoding put\n" (ps-output-prologue (format "ETOP%d %d %d put\n" i (car font) index)) (setq index (1+ index)))) (ps-output-prologue (format "/VTOP%d [%s] def\n" i - (mapconcat #'(lambda (x) - (format "F%02X" (cdr x))) + (mapconcat (lambda (x) + (format "F%02X" (cdr x))) font-list " "))))) ;; Redefine fonts f0, f1, f2, f3, h0, h1, H0. diff --git a/lisp/ps-print.el b/lisp/ps-print.el index b1d03fda1d4..0fc95546794 100644 --- a/lisp/ps-print.el +++ b/lisp/ps-print.el @@ -3855,7 +3855,7 @@ It can be retrieved with `(ps-get ALIST-SYM KEY)'." (defun ps-color-scale (color) ;; Scale 16-bit X-COLOR-VALUE to PostScript color value in [0, 1] interval. - (mapcar #'(lambda (value) (/ value ps-print-color-scale)) + (mapcar (lambda (value) (/ value ps-print-color-scale)) (color-values color))) @@ -4747,11 +4747,11 @@ page-height == ((floor print-height ((th + ls) * zh)) * ((th + ls) * zh)) - th (defun ps-background-pages (page-list func) (if page-list (mapcar - #'(lambda (pages) - (let ((start (if (consp pages) (car pages) pages)) - (end (if (consp pages) (cdr pages) pages))) - (and (integerp start) (integerp end) (<= start end) - (add-to-list 'ps-background-pages (vector start end func))))) + (lambda (pages) + (let ((start (if (consp pages) (car pages) pages)) + (end (if (consp pages) (cdr pages) pages))) + (and (integerp start) (integerp end) (<= start end) + (add-to-list 'ps-background-pages (vector start end func))))) page-list) (setq ps-background-all-pages (cons func ps-background-all-pages)))) @@ -4789,76 +4789,76 @@ page-height == ((floor print-height ((th + ls) * zh)) * ((th + ls) * zh)) - th (defun ps-background-text () (mapcar - #'(lambda (text) - (setq ps-background-text-count (1+ ps-background-text-count)) - (ps-output (format "/ShowBackText-%d{\n" ps-background-text-count)) - (ps-output-string (nth 0 text)) ; text - (ps-output - "\n" - (ps-float-format (nth 4 text) 200.0) ; font size - (format "/%s " (or (nth 3 text) "Times-Roman")) ; font name - (ps-float-format (nth 6 text) - "PrintHeight PrintPageWidth atan") ; rotation - (ps-float-format (nth 5 text) 0.85) ; gray - (ps-float-format (nth 1 text) "0") ; x position - (ps-float-format (nth 2 text) "0") ; y position - "\nShowBackText}def\n") - (ps-background-pages (nthcdr 7 text) ; page list - (format "ShowBackText-%d\n" - ps-background-text-count))) + (lambda (text) + (setq ps-background-text-count (1+ ps-background-text-count)) + (ps-output (format "/ShowBackText-%d{\n" ps-background-text-count)) + (ps-output-string (nth 0 text)) ; text + (ps-output + "\n" + (ps-float-format (nth 4 text) 200.0) ; font size + (format "/%s " (or (nth 3 text) "Times-Roman")) ; font name + (ps-float-format (nth 6 text) + "PrintHeight PrintPageWidth atan") ; rotation + (ps-float-format (nth 5 text) 0.85) ; gray + (ps-float-format (nth 1 text) "0") ; x position + (ps-float-format (nth 2 text) "0") ; y position + "\nShowBackText}def\n") + (ps-background-pages (nthcdr 7 text) ; page list + (format "ShowBackText-%d\n" + ps-background-text-count))) ps-print-background-text)) (defun ps-background-image () (mapcar - #'(lambda (image) - (let ((image-file (expand-file-name (nth 0 image)))) - (when (file-readable-p image-file) - (setq ps-background-image-count (1+ ps-background-image-count)) - (ps-output - (format "/ShowBackImage-%d{\n--back-- " - ps-background-image-count) - (ps-float-format (nth 5 image) 0.0) ; rotation - (ps-float-format (nth 3 image) 1.0) ; x scale - (ps-float-format (nth 4 image) 1.0) ; y scale - (ps-float-format (nth 1 image) ; x position - "PrintPageWidth 2 div") - (ps-float-format (nth 2 image) ; y position - "PrintHeight 2 div BottomMargin add") - "\nBeginBackImage\n") - (ps-insert-file image-file) - ;; coordinate adjustment to center image - ;; around x and y position - (let ((box (ps-get-boundingbox))) - (with-current-buffer ps-spool-buffer - (save-excursion - (if (re-search-backward "^--back--" nil t) - (replace-match - (format "%s %s" - (ps-float-format - (- (+ (/ (- (aref box 2) (aref box 0)) 2.0) - (aref box 0)))) - (ps-float-format - (- (+ (/ (- (aref box 3) (aref box 1)) 2.0) - (aref box 1))))) - t))))) - (ps-output "\nEndBackImage}def\n") - (ps-background-pages (nthcdr 6 image) ; page list - (format "ShowBackImage-%d\n" - ps-background-image-count))))) + (lambda (image) + (let ((image-file (expand-file-name (nth 0 image)))) + (when (file-readable-p image-file) + (setq ps-background-image-count (1+ ps-background-image-count)) + (ps-output + (format "/ShowBackImage-%d{\n--back-- " + ps-background-image-count) + (ps-float-format (nth 5 image) 0.0) ; rotation + (ps-float-format (nth 3 image) 1.0) ; x scale + (ps-float-format (nth 4 image) 1.0) ; y scale + (ps-float-format (nth 1 image) ; x position + "PrintPageWidth 2 div") + (ps-float-format (nth 2 image) ; y position + "PrintHeight 2 div BottomMargin add") + "\nBeginBackImage\n") + (ps-insert-file image-file) + ;; coordinate adjustment to center image + ;; around x and y position + (let ((box (ps-get-boundingbox))) + (with-current-buffer ps-spool-buffer + (save-excursion + (if (re-search-backward "^--back--" nil t) + (replace-match + (format "%s %s" + (ps-float-format + (- (+ (/ (- (aref box 2) (aref box 0)) 2.0) + (aref box 0)))) + (ps-float-format + (- (+ (/ (- (aref box 3) (aref box 1)) 2.0) + (aref box 1))))) + t))))) + (ps-output "\nEndBackImage}def\n") + (ps-background-pages (nthcdr 6 image) ; page list + (format "ShowBackImage-%d\n" + ps-background-image-count))))) ps-print-background-image)) (defun ps-background (page-number) (let (has-local-background) - (mapc #'(lambda (range) - (and (<= (aref range 0) page-number) - (<= page-number (aref range 1)) - (if has-local-background - (ps-output (aref range 2)) - (setq has-local-background t) - (ps-output "/printLocalBackground{\n" - (aref range 2))))) + (mapc (lambda (range) + (and (<= (aref range 0) page-number) + (<= page-number (aref range 1)) + (if has-local-background + (ps-output (aref range 2)) + (setq has-local-background t) + (ps-output "/printLocalBackground{\n" + (aref range 2))))) ps-background-pages) (and has-local-background (ps-output "}def\n")))) @@ -5697,8 +5697,8 @@ XSTART YSTART are the relative position for the first page in a sheet.") (> (car page) 0) (<= (car page) (cdr page)) (setq new (cons page new)))))) - (setq ps-selected-pages (sort new #'(lambda (one other) - (< (car one) (car other)))) + (setq ps-selected-pages (sort new (lambda (one other) + (< (car one) (car other)))) ps-last-selected-pages ps-selected-pages ps-first-page nil ps-last-page nil)) @@ -5782,8 +5782,8 @@ XSTART YSTART are the relative position for the first page in a sheet.") "unspecified-fg" 0.0) ps-foreground-list (mapcar - #'(lambda (arg) - (ps-rgb-color arg "unspecified-fg" 0.0)) + (lambda (arg) + (ps-rgb-color arg "unspecified-fg" 0.0)) (append (and (not (member ps-print-color-p '(nil black-white))) ps-fg-list) @@ -6012,9 +6012,9 @@ XSTART YSTART are the relative position for the first page in a sheet.") (if (and (boundp 'ucs-mule-8859-to-mule-unicode) (char-table-p ucs-mule-8859-to-mule-unicode)) (map-char-table - #'(lambda (k v) - (if (and v (eq (char-charset v) 'latin-iso8859-1) (/= k v)) - (aset tbl k v))) + (lambda (k v) + (if (and v (eq (char-charset v) 'latin-iso8859-1) (/= k v)) + (aset tbl k v))) ucs-mule-8859-to-mule-unicode)) tbl) "Translation table for PostScript printing. diff --git a/lisp/recentf.el b/lisp/recentf.el index 57cbaf0debb..6b5a47c66fd 100644 --- a/lisp/recentf.el +++ b/lisp/recentf.el @@ -674,55 +674,55 @@ Return nil if file NAME is not one of the ten more recent." "Sort the list of menu elements L in ascending order. The MENU-ITEM part of each menu element is compared." (sort (copy-sequence l) - #'(lambda (e1 e2) - (recentf-string-lessp - (recentf-menu-element-item e1) - (recentf-menu-element-item e2))))) + (lambda (e1 e2) + (recentf-string-lessp + (recentf-menu-element-item e1) + (recentf-menu-element-item e2))))) (defsubst recentf-sort-descending (l) "Sort the list of menu elements L in descending order. The MENU-ITEM part of each menu element is compared." (sort (copy-sequence l) - #'(lambda (e1 e2) - (recentf-string-lessp - (recentf-menu-element-item e2) - (recentf-menu-element-item e1))))) + (lambda (e1 e2) + (recentf-string-lessp + (recentf-menu-element-item e2) + (recentf-menu-element-item e1))))) (defsubst recentf-sort-basenames-ascending (l) "Sort the list of menu elements L in ascending order. Only filenames sans directory are compared." (sort (copy-sequence l) - #'(lambda (e1 e2) - (recentf-string-lessp - (file-name-nondirectory (recentf-menu-element-value e1)) - (file-name-nondirectory (recentf-menu-element-value e2)))))) + (lambda (e1 e2) + (recentf-string-lessp + (file-name-nondirectory (recentf-menu-element-value e1)) + (file-name-nondirectory (recentf-menu-element-value e2)))))) (defsubst recentf-sort-basenames-descending (l) "Sort the list of menu elements L in descending order. Only filenames sans directory are compared." (sort (copy-sequence l) - #'(lambda (e1 e2) - (recentf-string-lessp - (file-name-nondirectory (recentf-menu-element-value e2)) - (file-name-nondirectory (recentf-menu-element-value e1)))))) + (lambda (e1 e2) + (recentf-string-lessp + (file-name-nondirectory (recentf-menu-element-value e2)) + (file-name-nondirectory (recentf-menu-element-value e1)))))) (defsubst recentf-sort-directories-ascending (l) "Sort the list of menu elements L in ascending order. Compares directories then filenames to order the list." (sort (copy-sequence l) - #'(lambda (e1 e2) - (recentf-directory-compare - (recentf-menu-element-value e1) - (recentf-menu-element-value e2))))) + (lambda (e1 e2) + (recentf-directory-compare + (recentf-menu-element-value e1) + (recentf-menu-element-value e2))))) (defsubst recentf-sort-directories-descending (l) "Sort the list of menu elements L in descending order. Compares directories then filenames to order the list." (sort (copy-sequence l) - #'(lambda (e1 e2) - (recentf-directory-compare - (recentf-menu-element-value e2) - (recentf-menu-element-value e1))))) + (lambda (e1 e2) + (recentf-directory-compare + (recentf-menu-element-value e2) + (recentf-menu-element-value e1))))) (defun recentf-show-basenames (l &optional no-dir) "Filter the list of menu elements L to show filenames sans directory. @@ -1382,5 +1382,5 @@ buffers you switch to a lot, you can say something like the following: (provide 'recentf) (run-hooks 'recentf-load-hook) - + ;;; recentf.el ends here diff --git a/lisp/register.el b/lisp/register.el index e48a09f1574..38ee87cd775 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -279,6 +279,8 @@ ARG is the value of the prefix argument or nil." (goto-char (cadr val))) ((eq (car val) 'file) (find-file (cdr val))) + ((eq (car val) 'buffer) + (switch-to-buffer (cdr val))) ((eq (car val) 'file-query) (or (find-buffer-visiting (nth 1 val)) (y-or-n-p (format "Visit file %s again? " (nth 1 val))) @@ -417,6 +419,11 @@ Interactively, reads the register using `register-read-with-preview'." (prin1 (cdr val)) (princ ".")) + ((eq (car val) 'buffer) + (princ "the buffer ") + (prin1 (cdr val)) + (princ ".")) + ((eq (car val) 'file-query) (princ "a file-query reference:\n file ") (prin1 (car (cdr val))) diff --git a/lisp/repeat.el b/lisp/repeat.el index 308ba46a265..ea6da5d7f9b 100644 --- a/lisp/repeat.el +++ b/lisp/repeat.el @@ -546,31 +546,32 @@ See `describe-repeat-maps' for a list of all repeatable commands." Used in `repeat-mode'." (interactive) (require 'help-fns) - (help-setup-xref (list #'describe-repeat-maps) - (called-interactively-p 'interactive)) - (let ((keymaps nil)) - (all-completions - "" obarray (lambda (s) - (and (commandp s) - (get s 'repeat-map) - (push s (alist-get (get s 'repeat-map) keymaps))))) - (with-help-window (help-buffer) - (with-current-buffer standard-output - (princ "A list of keymaps used by commands with the symbol property `repeat-map'.\n\n") - - (dolist (keymap (sort keymaps (lambda (a b) (string-lessp (car a) (car b))))) - (princ (format-message "`%s' keymap is repeatable by these commands:\n" - (car keymap))) - (dolist (command (sort (cdr keymap) 'string-lessp)) - (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")))))) + (let ((help-buffer-under-preparation t)) + (help-setup-xref (list #'describe-repeat-maps) + (called-interactively-p 'interactive)) + (let ((keymaps nil)) + (all-completions + "" obarray (lambda (s) + (and (commandp s) + (get s 'repeat-map) + (push s (alist-get (get s 'repeat-map) keymaps))))) + (with-help-window (help-buffer) + (with-current-buffer standard-output + (princ "A list of keymaps used by commands with the symbol property `repeat-map'.\n\n") + + (dolist (keymap (sort keymaps (lambda (a b) (string-lessp (car a) (car b))))) + (princ (format-message "`%s' keymap is repeatable by these commands:\n" + (car keymap))) + (dolist (command (sort (cdr keymap) 'string-lessp)) + (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 84ec042f455..70d3ec73f88 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -2263,11 +2263,11 @@ See also `multi-occur'." (defun occur-engine-add-prefix (lines &optional prefix-face) (mapcar - #'(lambda (line) - (concat (if prefix-face - (propertize " :" 'font-lock-face prefix-face) - " :") - line "\n")) + (lambda (line) + (concat (if prefix-face + (propertize " :" 'font-lock-face prefix-face) + " :") + line "\n")) lines)) (defun occur-accumulate-lines (count &optional keep-props pt) @@ -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'.") @@ -2621,6 +2621,15 @@ It is used by `query-replace-regexp', `replace-regexp', It is called with three arguments, as if it were `re-search-forward'.") +(defvar replace-regexp-function nil + "Function to convert the FROM string of query-replace commands to a regexp. +This is used by `query-replace', `query-replace-regexp', etc. as +the value of `isearch-regexp-function' when they search for the +occurences of the string/regexp to be replaced. This is intended +to be used when the string to be replaced, as typed by the user, +is not to be interpreted literally, but instead should be converted +to a regexp that is actually used for the search.") + (defun replace-search (search-string limit regexp-flag delimited-flag case-fold &optional backward) "Search for the next occurrence of SEARCH-STRING to replace." @@ -2633,7 +2642,8 @@ It is called with three arguments, as if it were ;; outside of this function because then another I-search ;; used after `recursive-edit' might override them. (let* ((isearch-regexp regexp-flag) - (isearch-regexp-function (or delimited-flag + (isearch-regexp-function (or replace-regexp-function + delimited-flag (and replace-char-fold (not regexp-flag) #'char-fold-to-regexp))) @@ -2690,7 +2700,8 @@ It is called with three arguments, as if it were (if query-replace-lazy-highlight (let ((isearch-string search-string) (isearch-regexp regexp-flag) - (isearch-regexp-function (or delimited-flag + (isearch-regexp-function (or replace-regexp-function + delimited-flag (and replace-char-fold (not regexp-flag) #'char-fold-to-regexp))) 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/saveplace.el b/lisp/saveplace.el index 4191a3fa62e..3eff816fa07 100644 --- a/lisp/saveplace.el +++ b/lisp/saveplace.el @@ -328,11 +328,18 @@ may have changed) back to `save-place-alist'." (with-current-buffer (car buf-list) ;; save-place checks buffer-file-name too, but we can avoid ;; overhead of function call by checking here too. - (and (or buffer-file-name (and (derived-mode-p 'dired-mode) - (boundp 'dired-subdir-alist) - dired-subdir-alist - (dired-current-directory))) - (save-place-to-alist)) + (when (and (or buffer-file-name + (and (derived-mode-p 'dired-mode) + (boundp 'dired-subdir-alist) + dired-subdir-alist + (dired-current-directory))) + ;; Don't save place in literally-visited file + ;; because this will commonly differ from the place + ;; when visiting literally (and + ;; `find-file-literally' always places point at the + ;; start of the buffer). + (not find-file-literally)) + (save-place-to-alist)) (setq buf-list (cdr buf-list)))))) (defun save-place-find-file-hook () diff --git a/lisp/select.el b/lisp/select.el index 15e171c13f9..5e7f4a696a3 100644 --- a/lisp/select.el +++ b/lisp/select.el @@ -140,24 +140,27 @@ MS-Windows does not have a \"primary\" selection." (defcustom x-select-request-type nil "Data type request for X selection. The value is one of the following data types, a list of them, or nil: - `COMPOUND_TEXT', `UTF8_STRING', `STRING', `TEXT' + `COMPOUND_TEXT', `UTF8_STRING', `STRING', `TEXT', `text/plain\\;charset=utf-8' If the value is one of the above symbols, try only the specified type. If the value is a list of them, try each of them in the specified order until succeed. -The value nil is the same as the list (UTF8_STRING COMPOUND_TEXT STRING)." +The value nil is the same as the list (UTF8_STRING COMPOUND_TEXT STRING +text/plain\\;charset=utf-8)." :type '(choice (const :tag "Default" nil) (const COMPOUND_TEXT) (const UTF8_STRING) (const STRING) (const TEXT) + (const text/plain\;charset=utf-8) (set :tag "List of values" (const COMPOUND_TEXT) (const UTF8_STRING) (const STRING) - (const TEXT))) + (const TEXT) + (const text/plain\;charset=utf-8))) :group 'killing) (defun gui--selection-value-internal (type) @@ -165,9 +168,9 @@ The value nil is the same as the list (UTF8_STRING COMPOUND_TEXT STRING)." Call `gui-get-selection' with an appropriate DATA-TYPE argument decided by `x-select-request-type'. The return value is already decoded. If `gui-get-selection' signals an error, return nil." - (let ((request-type (if (eq window-system 'x) + (let ((request-type (if (memq window-system '(x pgtk)) (or x-select-request-type - '(UTF8_STRING COMPOUND_TEXT STRING)) + '(UTF8_STRING COMPOUND_TEXT STRING text/plain\;charset=utf-8)) 'STRING)) text) (with-demoted-errors "gui-get-selection: %S" @@ -304,22 +307,33 @@ the formats available in the clipboard if TYPE is `CLIPBOARD'." (let ((data (gui-backend-get-selection (or type 'PRIMARY) (or data-type 'STRING)))) (when (and (stringp data) - (setq data-type (get-text-property 0 'foreign-selection data))) + ;; If this text property is set, then the data needs to + ;; be decoded -- otherwise it has already been decoded + ;; by the lower level functions. + (get-text-property 0 'foreign-selection data)) (let ((coding (or next-selection-coding-system selection-coding-system (pcase data-type ('UTF8_STRING 'utf-8) + ('text/plain\;charset=utf-8 'utf-8) ('COMPOUND_TEXT 'compound-text-with-extensions) ('C_STRING nil) - ('STRING 'iso-8859-1) - (_ (error "Unknown selection data type: %S" - type)))))) - (setq data (if coding (decode-coding-string data coding) - ;; This is for C_STRING case. + ('STRING 'iso-8859-1))))) + (setq data + (cond (coding (decode-coding-string data coding)) ;; We want to convert each non-ASCII byte to the ;; corresponding eight-bit character, which has ;; a codepoint >= #x3FFF00. - (string-to-multibyte data)))) + ((eq data-type 'C_STRING) + (string-to-multibyte data)) + ;; Guess at the charset for types like text/html + ;; -- it can be anything, and different + ;; applications use different encodings. + ((string-match-p "\\`text/" (symbol-name data-type)) + (decode-coding-string + data (car (detect-coding-string data)))) + ;; Do nothing. + (t data)))) (setq next-selection-coding-system nil) (put-text-property 0 (length data) 'foreign-selection data-type data)) data)) @@ -440,13 +454,13 @@ two markers or an overlay. Otherwise, it is nil." (setq type 'C_STRING)) (t (let (non-latin-1 non-unicode eight-bit) - (mapc #'(lambda (x) - (if (>= x #x100) - (if (< x #x110000) - (setq non-latin-1 t) - (if (< x #x3FFF80) - (setq non-unicode t) - (setq eight-bit t))))) + (mapc (lambda (x) + (if (>= x #x100) + (if (< x #x110000) + (setq non-latin-1 t) + (if (< x #x3FFF80) + (setq non-unicode t) + (setq eight-bit t))))) str) (setq type (if (or non-unicode (and diff --git a/lisp/server.el b/lisp/server.el index 6359a761994..d510df1208a 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -90,12 +90,12 @@ (defcustom server-use-tcp nil "If non-nil, use TCP sockets instead of local sockets." - :set #'(lambda (sym val) - (unless (featurep 'make-network-process '(:family local)) - (setq val t) - (unless load-in-progress - (message "Local sockets unsupported, using TCP sockets"))) - (set-default sym val)) + :set (lambda (sym val) + (unless (featurep 'make-network-process '(:family local)) + (setq val t) + (unless load-in-progress + (message "Local sockets unsupported, using TCP sockets"))) + (set-default sym val)) :type 'boolean :version "22.1") @@ -485,11 +485,11 @@ If CLIENT is non-nil, add a description of it to the logged message." (when (and (frame-live-p frame) proc ;; See if this is the last frame for this client. - (>= 1 (let ((frame-num 0)) - (dolist (f (frame-list)) - (when (eq proc (frame-parameter f 'client)) - (setq frame-num (1+ frame-num)))) - frame-num))) + (not (seq-some + (lambda (f) + (and (not (eq frame f)) + (eq proc (frame-parameter f 'client)))) + (frame-list)))) (server-log (format "server-handle-delete-frame, frame %s" frame) proc) (server-delete-client proc 'noframe)))) ; Let delete-frame delete the frame later. @@ -900,12 +900,17 @@ This handles splitting the command if it would be bigger than ) (cond (w - (server--create-frame - nowait proc - `((display . ,display) - ,@(if parent-id - `((parent-id . ,(string-to-number parent-id)))) - ,@parameters))) + (condition-case nil + (server--create-frame + nowait proc + `((display . ,display) + ,@(if parent-id + `((parent-id . ,(string-to-number parent-id)))) + ,@parameters)) + (error + (server-log "Window system unsupported" proc) + (server-send-string proc "-window-system-unsupported \n") + nil))) (t (server-log "Window system unsupported" proc) @@ -1580,13 +1585,13 @@ specifically for the clients and did not exist before their request for it." (server-buffer-done (current-buffer)))) (defun server-kill-emacs-query-function () - "Ask before exiting Emacs if it has live clients." - (or (not (let (live-client) - (dolist (proc server-clients) - (when (memq t (mapcar #'buffer-live-p - (process-get proc 'buffers))) - (setq live-client t))) - live-client)) + "Ask before exiting Emacs if it has live clients. +A \"live client\" is a client with at least one live buffer +associated with it." + (or (not (seq-some (lambda (proc) + (seq-some #'buffer-live-p + (process-get proc 'buffers))) + server-clients)) (yes-or-no-p "This Emacs session has clients; exit anyway? "))) (defun server-kill-buffer () @@ -1716,6 +1721,9 @@ be a cons cell (LINENUMBER . COLUMNNUMBER)." (when server-raise-frame (select-frame-set-input-focus (window-frame))))) +(defvar server-stop-automatically nil + "Internal status variable for `server-stop-automatically'.") + ;;;###autoload (defun server-save-buffers-kill-terminal (arg) ;; Called from save-buffers-kill-terminal in files.el. @@ -1724,27 +1732,103 @@ With ARG non-nil, silently save all file-visiting buffers, then kill. If emacsclient was started with a list of filenames to edit, then only these files will be asked to be saved." - (let ((proc (frame-parameter nil 'client))) - (cond ((eq proc 'nowait) - ;; Nowait frames have no client buffer list. - (if (cdr (frame-list)) - (progn (save-some-buffers arg) - (delete-frame)) - ;; If we're the last frame standing, kill Emacs. - (save-buffers-kill-emacs arg))) - ((processp proc) - (let ((buffers (process-get proc 'buffers))) - (save-some-buffers - arg (if buffers - ;; Only files from emacsclient file list. - (lambda () (memq (current-buffer) buffers)) - ;; No emacsclient file list: don't override - ;; `save-some-buffers-default-predicate' (unless - ;; ARG is non-nil), since we're not killing - ;; Emacs (unlike `save-buffers-kill-emacs'). - (and arg t))) - (server-delete-client proc))) - (t (error "Invalid client frame"))))) + (if server-stop-automatically + (server-stop-automatically--handle-delete-frame (selected-frame)) + (let ((proc (frame-parameter nil 'client))) + (cond ((eq proc 'nowait) + ;; Nowait frames have no client buffer list. + (if (cdr (frame-list)) + (progn (save-some-buffers arg) + (delete-frame)) + ;; If we're the last frame standing, kill Emacs. + (save-buffers-kill-emacs arg))) + ((processp proc) + (let ((buffers (process-get proc 'buffers))) + (save-some-buffers + arg (if buffers + ;; Only files from emacsclient file list. + (lambda () (memq (current-buffer) buffers)) + ;; No emacsclient file list: don't override + ;; `save-some-buffers-default-predicate' (unless + ;; ARG is non-nil), since we're not killing + ;; Emacs (unlike `save-buffers-kill-emacs'). + (and arg t))) + (server-delete-client proc))) + (t (error "Invalid client frame")))))) + +(defun server-stop-automatically--handle-delete-frame (frame) + "Handle deletion of FRAME when `server-stop-automatically' is used." + (when server-stop-automatically + (if (if (and (processp (frame-parameter frame 'client)) + (eq this-command 'save-buffers-kill-terminal)) + (progn + (dolist (f (frame-list)) + (when (and (eq (frame-parameter frame 'client) + (frame-parameter f 'client)) + (not (eq frame f))) + (set-frame-parameter f 'client nil) + (let ((server-stop-automatically nil)) + (delete-frame f)))) + (if (cddr (frame-list)) + (let ((server-stop-automatically nil)) + (delete-frame frame) + nil) + t)) + (null (cddr (frame-list)))) + (let ((server-stop-automatically nil)) + (save-buffers-kill-emacs) + (delete-frame frame))))) + +(defun server-stop-automatically--maybe-kill-emacs () + "Handle closing of Emacs daemon when `server-stop-automatically' is used." + (unless (cdr (frame-list)) + (when (and + (not (memq t (mapcar (lambda (b) + (and (buffer-file-name b) + (buffer-modified-p b))) + (buffer-list)))) + (not (memq t (mapcar (lambda (p) + (and (memq (process-status p) + '(run stop open listen)) + (process-query-on-exit-flag p))) + (process-list))))) + (kill-emacs)))) + +;;;###autoload +(defun server-stop-automatically (arg) + "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." + (when (daemonp) + (setq server-stop-automatically arg) + (cond + ((eq arg 'empty) + (setq server-stop-automatically nil) + (run-with-timer 10 2 + #'server-stop-automatically--maybe-kill-emacs)) + ((eq arg 'delete-frame) + (add-hook 'delete-frame-functions + #'server-stop-automatically--handle-delete-frame)) + ((eq arg 'kill-terminal)) + (t + (error "Unexpected argument"))))) (define-key ctl-x-map "#" 'server-edit) diff --git a/lisp/ses.el b/lisp/ses.el index ea966295b18..8496aeec8e8 100644 --- a/lisp/ses.el +++ b/lisp/ses.el @@ -227,12 +227,6 @@ Used for listing local printers or renamed cells.") "w" ses-set-column-width "x" ses-export-keymap "\M-p" ses-read-column-printer)) - (repl '(;;We'll replace these wherever they appear in the keymap - clipboard-kill-region ses-kill-override - end-of-line ses-end-of-line - kill-line ses-delete-row - kill-region ses-kill-override - open-line ses-insert-row)) (numeric "0123456789.-") (newmap (make-keymap))) ;;Get rid of printables @@ -240,13 +234,11 @@ Used for listing local printers or renamed cells.") ;;These keys insert themselves as the beginning of a numeric value (dotimes (x (length numeric)) (define-key newmap (substring numeric x (1+ x)) 'ses-read-cell)) - ;;Override these global functions wherever they're bound - (while repl - (substitute-key-definition (car repl) (cadr repl) newmap - (current-global-map)) - (setq repl (cddr repl))) - ;;Apparently substitute-key-definition doesn't catch this? - (define-key newmap [(menu-bar) edit cut] 'ses-kill-override) + (define-key newmap [remap clipboard-kill-region] #'ses-kill-override) + (define-key newmap [remap end-of-line] #'ses-end-of-line) + (define-key newmap [remap kill-line] #'ses-delete-row) + (define-key newmap [remap kill-region] #'ses-kill-override) + (define-key newmap [remap open-line] #'ses-insert-row) ;;Define our other local keys (while keys (define-key newmap (car keys) (cadr keys)) @@ -3554,7 +3546,7 @@ With prefix, sorts in REVERSE order." (push (cons (buffer-substring-no-properties (point) end) (+ minrow x)) keys)) - (setq keys (sort keys #'(lambda (x y) (string< (car x) (car y))))) + (setq keys (sort keys (lambda (x y) (string< (car x) (car y))))) ;;Extract the lines in reverse sorted order (or reverse (setq keys (nreverse keys))) @@ -3774,7 +3766,9 @@ function is redefined." (setq name (intern name)) (let* ((cur-printer (gethash name ses--local-printer-hashmap)) (default (and cur-printer (ses--locprn-def cur-printer)))) - (setq def (ses-read-printer (format "Enter definition of printer %S" name) + (setq def (ses-read-printer (format-prompt + "Enter definition of printer %S" + default name) default))) (list name def))) diff --git a/lisp/shell.el b/lisp/shell.el index cb4afe6dea8..1860e4691d3 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -758,7 +758,7 @@ Make the shell buffer the current buffer, and return it. (current-buffer))) ;; The buffer's window must be correctly set when we call comint ;; (so that comint sets the COLUMNS env var properly). - (pop-to-buffer-same-window buffer) + (pop-to-buffer buffer) (with-connection-local-variables ;; On remote hosts, the local `shell-file-name' might be useless. @@ -785,7 +785,8 @@ Make the shell buffer the current buffer, and return it. (startfile (concat "~/.emacs_" name)) (xargs-name (intern-soft (concat "explicit-" name "-args")))) (unless (file-exists-p startfile) - (setq startfile (concat user-emacs-directory "init_" name ".sh"))) + (setq startfile (locate-user-emacs-file + (concat "init_" name ".sh")))) (setq-local shell--start-prog (file-name-nondirectory prog)) (apply #'make-comint-in-buffer "shell" buffer prog (if (file-exists-p startfile) startfile) diff --git a/lisp/simple.el b/lisp/simple.el index 94a459b7795..73918a52044 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -527,21 +527,28 @@ Other major modes are defined by comparison with this one." (kill-all-local-variables) (run-mode-hooks)) +(define-derived-mode clean-mode fundamental-mode "Clean" + "A mode that removes all overlays and text properties." + (kill-all-local-variables t) + (let ((inhibit-read-only t)) + (dolist (overlay (overlays-in (point-min) (point-max))) + (delete-overlay overlay)) + (set-text-properties (point-min) (point-max) nil) + (setq-local yank-excluded-properties t))) + ;; Special major modes to view specially formatted data rather than files. -(defvar special-mode-map - (let ((map (make-sparse-keymap))) - (suppress-keymap map) - (define-key map "q" 'quit-window) - (define-key map " " 'scroll-up-command) - (define-key map [?\S-\ ] 'scroll-down-command) - (define-key map "\C-?" 'scroll-down-command) - (define-key map "?" 'describe-mode) - (define-key map "h" 'describe-mode) - (define-key map ">" 'end-of-buffer) - (define-key map "<" 'beginning-of-buffer) - (define-key map "g" 'revert-buffer) - map)) +(defvar-keymap special-mode-map + :suppress t + "q" #'quit-window + "SPC" #'scroll-up-command + "S-SPC" #'scroll-down-command + "DEL" #'scroll-down-command + "?" #'describe-mode + "h" #'describe-mode + ">" #'end-of-buffer + "<" #'beginning-of-buffer + "g" #'revert-buffer) (put 'special-mode 'mode-class 'special) (define-derived-mode special-mode nil "Special" @@ -703,9 +710,10 @@ When called from Lisp code, ARG may be a prefix string to copy." :height 0.1 :background "#505050") (((type graphic) (background light)) :height 0.1 :background "#a0a0a0") - (t :foreground "ForestGreen")) + (t + :foreground "ForestGreen" :underline t)) "Face for separator lines." - :version "28.1" + :version "29.1" :group 'text) (defun make-separator-line (&optional length) @@ -713,11 +721,13 @@ When called from Lisp code, ARG may be a prefix string to copy." This uses the `separator-line' face. If LENGTH is nil, use the window width." - (if (display-graphic-p) + (if (or (display-graphic-p) + (display-supports-face-attributes-p '(:underline t))) (if length (concat (propertize (make-string length ?\s) 'face 'separator-line) "\n") (propertize "\n" 'face '(:inherit separator-line :extend t))) + ;; In terminals (that don't support underline), use a line of dashes. (concat (propertize (make-string (or length (1- (window-width))) ?-) 'face 'separator-line) "\n"))) @@ -3104,7 +3114,7 @@ Interactively, ARG is the prefix numeric argument and defaults to 1." (let ((undo-in-progress t)) (while (and (consp ul) (eq (car ul) nil)) (setq ul (cdr ul))) - (primitive-undo arg ul))) + (primitive-undo (or arg 1) ul))) (new-pul (undo--last-change-was-undo-p new-ul))) (message "Redo%s" (if undo-in-region " in region" "")) (setq this-command 'undo) @@ -4692,6 +4702,8 @@ File name handlers might not support pty association, if PROGRAM is nil." (forward-line -1) (beginning-of-line)))) +(declare-function thread-name "thread.c") + (defun list-processes--refresh () "Recompute the list of processes for the Process List buffer. Also, delete any process that is exited or signaled." @@ -5069,10 +5081,11 @@ interact nicely with `interprogram-cut-function' and interaction; you may want to use them instead of manipulating the kill ring directly.") -(defcustom kill-ring-max 60 +(defcustom kill-ring-max 120 "Maximum length of kill ring before oldest elements are thrown away." :type 'integer - :group 'killing) + :group 'killing + :version "29.1") (defvar kill-ring-yank-pointer nil "The tail of the kill ring whose car is the last thing yanked.") @@ -8573,40 +8586,43 @@ The function should return non-nil if the two tokens do not match.") (current-buffer)) (sit-for blink-matching-delay)) (delete-overlay blink-matching--overlay))))) - (t - (let ((open-paren-line-string - (save-excursion - (goto-char blinkpos) - ;; Show what precedes the open in its line, if anything. - (cond - ((save-excursion (skip-chars-backward " \t") (not (bolp))) - (buffer-substring (line-beginning-position) - (1+ blinkpos))) - ;; Show what follows the open in its line, if anything. - ((save-excursion - (forward-char 1) - (skip-chars-forward " \t") - (not (eolp))) - (buffer-substring blinkpos - (line-end-position))) - ;; Otherwise show the previous nonblank line, - ;; if there is one. - ((save-excursion (skip-chars-backward "\n \t") (not (bobp))) - (concat - (buffer-substring (progn - (skip-chars-backward "\n \t") - (line-beginning-position)) - (progn (end-of-line) - (skip-chars-backward " \t") - (point))) - ;; Replace the newline and other whitespace with `...'. - "..." - (buffer-substring blinkpos (1+ blinkpos)))) - ;; There is nothing to show except the char itself. - (t (buffer-substring blinkpos (1+ blinkpos))))))) - (minibuffer-message - "Matches %s" - (substring-no-properties open-paren-line-string)))))))) + ((not show-paren-context-when-offscreen) + (minibuffer-message + "Matches %s" + (substring-no-properties + (blink-paren-open-paren-line-string blinkpos)))))))) + +(defun blink-paren-open-paren-line-string (pos) + "Return the line string that contains the openparen at POS." + (save-excursion + (goto-char pos) + ;; Show what precedes the open in its line, if anything. + (cond + ((save-excursion (skip-chars-backward " \t") (not (bolp))) + (buffer-substring (line-beginning-position) + (1+ pos))) + ;; Show what follows the open in its line, if anything. + ((save-excursion + (forward-char 1) + (skip-chars-forward " \t") + (not (eolp))) + (buffer-substring pos + (line-end-position))) + ;; Otherwise show the previous nonblank line, + ;; if there is one. + ((save-excursion (skip-chars-backward "\n \t") (not (bobp))) + (concat + (buffer-substring (progn + (skip-chars-backward "\n \t") + (line-beginning-position)) + (progn (end-of-line) + (skip-chars-backward " \t") + (point))) + ;; Replace the newline and other whitespace with `...'. + "..." + (buffer-substring pos (1+ pos)))) + ;; There is nothing to show except the char itself. + (t (buffer-substring pos (1+ pos)))))) (defvar blink-paren-function 'blink-matching-open "Function called, if non-nil, whenever a close parenthesis is inserted. @@ -8898,7 +8914,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)) @@ -8966,6 +8982,7 @@ makes it easier to edit it." (define-key map [down-mouse-2] nil) (define-key map "\C-m" 'choose-completion) (define-key map "\e\e\e" 'delete-completion-window) + (define-key map [remap keyboard-quit] #'delete-completion-window) (define-key map [left] 'previous-completion) (define-key map [right] 'next-completion) (define-key map [?\t] 'next-completion) @@ -9013,38 +9030,68 @@ Go to the window from which completion was requested." (if (get-buffer-window buf) (select-window (get-buffer-window buf)))))) +(defcustom completion-wrap-movement t + "Non-nil means to wrap around when selecting completion options. +This affects the commands `next-completion' and +`previous-completion'." + :type 'boolean + :version "29.1" + :group 'completion) + (defun previous-completion (n) - "Move to the previous item in the completion list." + "Move to the previous item in the completion list. +With prefix argument N, move back N items (negative N means move +forward)." (interactive "p") (next-completion (- n))) (defun next-completion (n) "Move to the next item in the completion list. -With prefix argument N, move N items (negative N means move backward)." +With prefix argument N, move N items (negative N means move +backward)." (interactive "p") (let ((beg (point-min)) (end (point-max))) - (while (and (> n 0) (not (eobp))) - ;; If in a completion, move to the end of it. - (when (get-text-property (point) 'mouse-face) - (goto-char (next-single-property-change (point) 'mouse-face nil end))) - ;; Move to start of next one. - (unless (get-text-property (point) 'mouse-face) - (goto-char (next-single-property-change (point) 'mouse-face nil end))) - (setq n (1- n))) - (while (and (< n 0) (not (bobp))) - (let ((prop (get-text-property (1- (point)) 'mouse-face))) - ;; If in a completion, move to the start of it. - (when (and prop (eq prop (get-text-property (point) 'mouse-face))) - (goto-char (previous-single-property-change - (point) 'mouse-face nil beg))) - ;; Move to end of the previous completion. - (unless (or (bobp) (get-text-property (1- (point)) 'mouse-face)) - (goto-char (previous-single-property-change - (point) 'mouse-face nil beg))) - ;; Move to the start of that one. - (goto-char (previous-single-property-change - (point) 'mouse-face nil beg)) - (setq n (1+ n)))))) + (catch 'bound + (while (> n 0) + ;; If in a completion, move to the end of it. + (when (get-text-property (point) 'mouse-face) + (goto-char (next-single-property-change (point) 'mouse-face nil end))) + ;; If at the last completion option, wrap or skip to the + ;; minibuffer, if requested. + (when (and completion-wrap-movement (eobp)) + (if (and (member (this-command-keys) '("\t" [backtab])) + completion-auto-select) + (throw 'bound nil) + (goto-char (point-min)))) + ;; Move to start of next one. + (unless (get-text-property (point) 'mouse-face) + (goto-char (next-single-property-change (point) 'mouse-face nil end))) + (setq n (1- n))) + (while (< n 0) + (let ((prop (get-text-property (1- (point)) 'mouse-face))) + ;; If in a completion, move to the start of it. + (when (and prop (eq prop (get-text-property (point) 'mouse-face))) + (goto-char (previous-single-property-change + (point) 'mouse-face nil beg))) + ;; Move to end of the previous completion. + (unless (or (bobp) (get-text-property (1- (point)) 'mouse-face)) + (goto-char (previous-single-property-change + (point) 'mouse-face nil beg))) + ;; If at the first completion option, wrap or skip to the + ;; minibuffer, if requested. + (when (and completion-wrap-movement (bobp)) + (if (and (member (this-command-keys) '("\t" [backtab])) + completion-auto-select) + (progn + (goto-char (next-single-property-change (point) 'mouse-face nil end)) + (throw 'bound nil)) + (goto-char (point-max)))) + ;; Move to the start of that one. + (goto-char (previous-single-property-change + (point) 'mouse-face nil beg)) + (setq n (1+ n))))) + (when (/= 0 n) + (switch-to-minibuffer)))) (defun choose-completion (&optional event) "Choose the completion at point. @@ -9212,6 +9259,12 @@ Called from `temp-buffer-show-hook'." :version "22.1" :group 'completion) +(defcustom completion-auto-select nil + "Non-nil means to automatically select the *Completions* buffer." + :type 'boolean + :version "29.1" + :group 'completion) + ;; This function goes in completion-setup-hook, so that it is called ;; after the text of the completion list buffer is written. (defun completion-setup-function () @@ -9248,7 +9301,9 @@ Called from `temp-buffer-show-hook'." (insert "Click on a completion to select it.\n")) (insert (substitute-command-keys "In this buffer, type \\[choose-completion] to \ -select the completion near point.\n\n")))))) +select the completion near point.\n\n"))))) + (when completion-auto-select + (switch-to-completions))) (add-hook 'completion-setup-hook #'completion-setup-function) @@ -9261,10 +9316,16 @@ select the completion near point.\n\n")))))) (get-buffer-window "*Completions*" 0))))) (when window (select-window window) - ;; In the new buffer, go to the first completion. - ;; FIXME: Perhaps this should be done in `minibuffer-completion-help'. - (when (bobp) - (next-completion 1))))) + (cond + ((and (memq this-command '(completion-at-point minibuffer-complete)) + (equal (this-command-keys) [backtab]) + (bobp)) + (goto-char (point-max)) + (previous-completion 1)) + ;; In the new buffer, go to the first completion. + ;; FIXME: Perhaps this should be done in `minibuffer-completion-help'. + ((bobp) + (next-completion 1)))))) (defun read-expression-switch-to-completions () "Select the completion list window while reading an expression." @@ -9602,7 +9663,7 @@ call `normal-erase-is-backspace-mode' (which see) instead." (if (if (eq normal-erase-is-backspace 'maybe) (and (not noninteractive) (or (memq system-type '(ms-dos windows-nt)) - (memq window-system '(w32 ns)) + (memq window-system '(w32 ns pgtk)) (and (eq window-system 'x) (fboundp 'x-backspace-delete-keys-p) (x-backspace-delete-keys-p)) @@ -9776,24 +9837,7 @@ If it does not exist, create it and switch it to `messages-buffer-mode'." ;; versions together with bad values. This is therefore not as ;; flexible as it could be. See the thread: ;; https://lists.gnu.org/r/emacs-devel/2007-08/msg00300.html -(defconst bad-packages-alist - ;; Not sure exactly which semantic versions have problems. - ;; Definitely 2.0pre3, probably all 2.0pre's before this. - '((semantic semantic-version "\\`2\\.0pre[1-3]\\'" - "The version of `semantic' loaded does not work in Emacs 22. -It can cause constant high CPU load. -Upgrade to at least Semantic 2.0pre4 (distributed with CEDET 1.0pre4).") - ;; CUA-mode does not work with GNU Emacs version 22.1 and newer. - ;; Except for version 1.2, all of the 1.x and 2.x version of cua-mode - ;; provided the `CUA-mode' feature. Since this is no longer true, - ;; we can warn the user if the `CUA-mode' feature is ever provided. - (CUA-mode t nil -"CUA-mode is now part of the standard GNU Emacs distribution, -so you can now enable CUA via the Options menu or by customizing `cua-mode'. - -You have loaded an older version of CUA-mode which does not work -correctly with this version of Emacs. You should remove the old -version and use the one distributed with Emacs.")) +(defconst bad-packages-alist nil "Alist of packages known to cause problems in this version of Emacs. Each element has the form (PACKAGE SYMBOL REGEXP STRING). PACKAGE is either a regular expression to match file names, or a @@ -9801,9 +9845,11 @@ symbol (a feature name), like for `with-eval-after-load'. SYMBOL is either the name of a string variable, or t. Upon loading PACKAGE, if SYMBOL is t or matches REGEXP, display a warning using STRING as the message.") +(make-obsolete-variable 'bad-packages-alist nil "29.1") (defun bad-package-check (package) "Run a check using the element from `bad-packages-alist' matching PACKAGE." + (declare (obsolete nil "29.1")) (condition-case nil (let* ((list (assoc package bad-packages-alist)) (symbol (nth 1 list))) @@ -9815,11 +9861,6 @@ warning using STRING as the message.") (display-warning package (nth 3 list) :warning))) (error nil))) -(dolist (elem bad-packages-alist) - (let ((pkg (car elem))) - (with-eval-after-load pkg - (bad-package-check pkg)))) - ;;; Generic dispatcher commands @@ -9856,6 +9897,7 @@ does not have any effect until this variable is set. CUSTOMIZATIONS, if non-nil, should be composed of alternating `defcustom' keywords and values to add to the declaration of `COMMAND-alternatives' (typically :group and :version)." + (declare (indent defun)) (let* ((command-name (symbol-name command)) (varalt-name (concat command-name "-alternatives")) (varalt-sym (intern varalt-name)) diff --git a/lisp/skeleton.el b/lisp/skeleton.el index c363fb2c489..36cc4239d47 100644 --- a/lisp/skeleton.el +++ b/lisp/skeleton.el @@ -37,7 +37,8 @@ ;; page 2: paired insertion ;; page 3: mirror-mode, an example for setting up paired insertion -(defvaralias 'skeleton-transformation 'skeleton-transformation-function) +(define-obsolete-variable-alias 'skeleton-transformation + 'skeleton-transformation-function "29.1") (defvar skeleton-transformation-function 'identity "If non-nil, function applied to literal strings before they are inserted. @@ -65,7 +66,8 @@ region.") "Hook called at end of skeleton but before going to point of interest. The variables `v1' and `v2' are still set when calling this.") -(defvaralias 'skeleton-filter 'skeleton-filter-function) +(define-obsolete-variable-alias 'skeleton-filter + 'skeleton-filter-function "29.1") ;;;###autoload (defvar skeleton-filter-function 'identity @@ -113,7 +115,8 @@ are integer buffer positions in the reverse order of the insertion order.") "Define a user-configurable COMMAND that enters a statement skeleton. DOCUMENTATION is that of the command. SKELETON is as defined under `skeleton-insert'." - (declare (doc-string 2) (debug (&define name stringp skeleton-edebug-spec))) + (declare (doc-string 2) (debug (&define name stringp skeleton-edebug-spec)) + (indent defun)) (if skeleton-debug (set command skeleton)) `(progn diff --git a/lisp/sort.el b/lisp/sort.el index d6767ed5098..09259805415 100644 --- a/lisp/sort.el +++ b/lisp/sort.el @@ -540,8 +540,8 @@ Use \\[untabify] to convert tabs to spaces before sorting." (narrow-to-region beg1 end1) (goto-char beg1) (sort-subr reverse 'forward-line 'end-of-line - #'(lambda () (move-to-column col-start) nil) - #'(lambda () (move-to-column col-end) nil)))))))) + (lambda () (move-to-column col-start) nil) + (lambda () (move-to-column col-end) nil)))))))) ;;;###autoload (defun reverse-region (beg end) diff --git a/lisp/speedbar.el b/lisp/speedbar.el index 3cc3e276067..cfa96608bff 100644 --- a/lisp/speedbar.el +++ b/lisp/speedbar.el @@ -3694,27 +3694,21 @@ regular expression EXPR." ;;; BUFFER DISPLAY mode. ;; -(defvar speedbar-buffers-key-map nil +(defvar speedbar-buffers-key-map + (let ((map (speedbar-make-specialized-keymap))) + ;; Basic tree features + (define-key map "e" #'speedbar-edit-line) + (define-key map "\C-m" #'speedbar-edit-line) + (define-key map "+" #'speedbar-expand-line) + (define-key map "=" #'speedbar-expand-line) + (define-key map "-" #'speedbar-contract-line) + (define-key map " " #'speedbar-toggle-line-expansion) + ;; Buffer specific keybindings + (define-key map "k" #'speedbar-buffer-kill-buffer) + (define-key map "r" #'speedbar-buffer-revert-buffer) + map) "Keymap used when in the buffers display mode.") -(if speedbar-buffers-key-map - nil - (setq speedbar-buffers-key-map (speedbar-make-specialized-keymap)) - - ;; Basic tree features - (define-key speedbar-buffers-key-map "e" 'speedbar-edit-line) - (define-key speedbar-buffers-key-map "\C-m" 'speedbar-edit-line) - (define-key speedbar-buffers-key-map "+" 'speedbar-expand-line) - (define-key speedbar-buffers-key-map "=" 'speedbar-expand-line) - (define-key speedbar-buffers-key-map "-" 'speedbar-contract-line) - (define-key speedbar-buffers-key-map " " 'speedbar-toggle-line-expansion) - - ;; Buffer specific keybindings - (define-key speedbar-buffers-key-map "k" 'speedbar-buffer-kill-buffer) - (define-key speedbar-buffers-key-map "r" 'speedbar-buffer-revert-buffer) - - ) - (defvar speedbar-buffer-easymenu-definition '(["Jump to buffer" speedbar-edit-line t] ["Expand File Tags" speedbar-expand-line diff --git a/lisp/sqlite-mode.el b/lisp/sqlite-mode.el new file mode 100644 index 00000000000..082eb8276e8 --- /dev/null +++ b/lisp/sqlite-mode.el @@ -0,0 +1,216 @@ +;;; sqlite-mode.el --- Mode for examining sqlite3 database files -*- 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'cl-lib) + +(declare-function sqlite-execute "sqlite.c") +(declare-function sqlite-more-p "sqlite.c") +(declare-function sqlite-next "sqlite.c") +(declare-function sqlite-columns "sqlite.c") +(declare-function sqlite-finalize "sqlite.c") +(declare-function sqlite-select "sqlite.c") +(declare-function sqlite-open "sqlite.c") + +(defvar-keymap sqlite-mode-map + "g" #'sqlite-mode-list-tables + "c" #'sqlite-mode-list-columns + "RET" #'sqlite-mode-list-data + "DEL" #'sqlite-mode-delete) + +(define-derived-mode sqlite-mode special-mode "Sqlite" + "This mode lists the contents of an .sqlite3 file" + :interactive nil + (buffer-disable-undo) + (setq-local buffer-read-only t + truncate-lines t)) + +(defvar sqlite--db nil) + +;;;###autoload +(defun sqlite-mode-open-file (file) + "Browse the contents of an sqlite file." + (interactive "fSQLite file name: ") + (unless (sqlite-available-p) + (error "This Emacs doesn't have SQLite support, so it can't view SQLite files")) + (pop-to-buffer (get-buffer-create + (format "*SQLite %s*" (file-name-nondirectory file)))) + (sqlite-mode) + (setq-local sqlite--db (sqlite-open file)) + (sqlite-mode-list-tables)) + +(defun sqlite-mode-list-tables () + "Re-list the tables from the currently selected database." + (interactive nil sqlite-mode) + (let ((inhibit-read-only t) + (db sqlite--db) + (entries nil)) + (erase-buffer) + (dolist (table (sqlite-select db "select name from sqlite_master where type = 'table' and name not like 'sqlite_%' order by name")) + (push (list (car table) + (caar (sqlite-select db (format "select count(*) from %s" + (car table))))) + entries)) + (sqlite-mode--tablify '("Table Name" "Number of Rows") + (nreverse entries) + 'table) + (goto-char (point-min)))) + +(defun sqlite-mode--tablify (columns rows type &optional prefix) + (let ((widths + (mapcar + (lambda (i) + (1+ (seq-max (mapcar (lambda (row) + (length (format "%s" (nth i row)))) + (cons columns rows))))) + (number-sequence 0 (1- (length columns)))))) + (when prefix + (insert prefix)) + (dotimes (i (length widths)) + (insert (propertize (format (format "%%-%ds " (nth i widths)) + (nth i columns)) + 'face 'header-line))) + (insert "\n") + (dolist (row rows) + (let ((start (point))) + (when prefix + (insert prefix)) + (dotimes (i (length widths)) + (let ((elem (nth i row))) + (insert (format (format "%%%s%ds " + (if (numberp elem) + "" "-") + (nth i widths)) + (if (numberp elem) + (nth i row) + (string-replace "\n" " " (or elem ""))))))) + (put-text-property start (point) 'sqlite--row row) + (put-text-property start (point) 'sqlite--type type) + (insert "\n"))))) + +(defun sqlite-mode-list-columns () + "List the columns of the table under point." + (interactive nil sqlite-mode) + (let ((row (get-text-property (point) 'sqlite--row))) + (unless row + (user-error "No table under point")) + (let ((columns (sqlite-mode--column-names (car row))) + (inhibit-read-only t)) + (save-excursion + (forward-line 1) + (if (looking-at " ") + ;; Delete the info. + (delete-region (point) (if (re-search-forward "^[^ ]" nil t) + (match-beginning 0) + (point-max))) + ;; Insert the info. + (dolist (column columns) + (insert (format " %s\n" column)))))))) + +(defun sqlite-mode--column-names (table) + (let ((sql + (caar + (sqlite-select + sqlite--db + "select sql from sqlite_master where tbl_name = ? AND type = 'table'" + (list table))))) + (mapcar + #'string-trim + (split-string (replace-regexp-in-string "^.*(\\|)$" "" sql) ",")))) + +(defun sqlite-mode-list-data () + "List the data from the table under point." + (interactive nil sqlite-mode) + (let ((row (and (eq (get-text-property (point) 'sqlite--type) 'table) + (get-text-property (point) 'sqlite--row)))) + (unless row + (user-error "No table under point")) + (let ((inhibit-read-only t)) + (save-excursion + (forward-line 1) + (if (looking-at " ") + ;; Delete the info. + (delete-region (point) (if (re-search-forward "^[^ ]" nil t) + (match-beginning 0) + (point-max))) + (sqlite--mode--list-data (list (car row) 0))))))) + +(defun sqlite-mode--more-data (stmt) + (let ((inhibit-read-only t)) + (beginning-of-line) + (delete-region (point) (progn (forward-line 1) (point))) + (sqlite--mode--list-data stmt))) + +(defun sqlite--mode--list-data (data) + (let* ((table (car data)) + (rowid (cadr data)) + stmt) + (unwind-protect + (progn + (setq stmt + (sqlite-select + sqlite--db + (format "select rowid, * from %s where rowid >= ?" table) + (list rowid) + 'set)) + (sqlite-mode--tablify (sqlite-columns stmt) + (cl-loop for i from 0 upto 1000 + for row = (sqlite-next stmt) + while row + do (setq rowid (car row)) + collect row) + (cons 'row table) + " ") + (when (sqlite-more-p stmt) + (insert (buttonize " More data...\n" #'sqlite-mode--more-data + (list table rowid))))) + (when stmt + (sqlite-finalize stmt))))) + +(defun sqlite-mode-delete () + "Delete the row under point." + (interactive nil sqlite-mode) + (let ((table (get-text-property (point) 'sqlite--type)) + (row (get-text-property (point) 'sqlite--row)) + (inhibit-read-only t)) + (when (or (not (consp table)) + (not (eq (car table) 'row))) + (user-error "No row under point")) + (unless (yes-or-no-p "Really delete the row under point? ") + (user-error "Not deleting")) + (sqlite-execute + sqlite--db + (format "delete from %s where %s" + (cdr table) + (string-join + (mapcar (lambda (column) + (format "%s = ?" (car (split-string column " ")))) + (cons "rowid" (sqlite-mode--column-names (cdr table)))) + " and ")) + row) + (delete-region (line-beginning-position) (progn (forward-line 1) (point))))) + +(provide 'sqlite-mode) + +;;; sqlite-mode.el ends here diff --git a/lisp/sqlite.el b/lisp/sqlite.el new file mode 100644 index 00000000000..6d32a0468f3 --- /dev/null +++ b/lisp/sqlite.el @@ -0,0 +1,43 @@ +;;; sqlite.el --- Functions for interacting with sqlite3 databases -*- 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(defmacro with-sqlite-transaction (db &rest body) + "Execute BODY while holding a transaction for DB." + (declare (indent 1) (debug (form body))) + (let ((db-var (gensym)) + (func-var (gensym))) + `(let ((,db-var ,db) + (,func-var (lambda () ,@body))) + (if (sqlite-available-p) + (unwind-protect + (progn + (sqlite-transaction ,db-var) + (funcall ,func-var)) + (sqlite-commit ,db-var)) + (funcall ,func-var))))) + +(provide 'sqlite) + +;;; sqlite.el ends here diff --git a/lisp/startup.el b/lisp/startup.el index 505d7b83f48..76cc9b2ca32 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -519,6 +519,19 @@ DIRS are relative." xdg-dir) (t emacs-d-dir)))) +(defvar comp--delayed-sources) +(defvar comp--loadable) +(declare-function native--compile-async "comp.el" + (files &optional recursively load selector)) +(defun startup--honor-delayed-native-compilations () + "Honor pending delayed deferred native compilations." + (when (and (native-comp-available-p) + comp--delayed-sources) + (require 'comp) + (setq comp--loadable t) + (native--compile-async comp--delayed-sources nil 'late) + (setq comp--delayed-sources nil))) + (defvar native-comp-eln-load-path) (defun normal-top-level () "Emacs calls this function when it first starts up. @@ -785,7 +798,8 @@ It is the default value of the variable `top-level'." (if (string-match "\\`DISPLAY=" varval) (setq display varval)))) (when display - (delete display process-environment))))) + (delete display process-environment)))) + (startup--honor-delayed-native-compilations)) ;; Precompute the keyboard equivalents in the menu bar items. ;; Command-line options supported by tty's: @@ -1042,6 +1056,9 @@ the `--debug-init' option to view a complete error backtrace." (when debug-on-error-should-be-set (setq debug-on-error debug-on-error-from-init-file)))) +(defvar lisp-directory nil + "Directory where Emacs's own *.el and *.elc Lisp files are installed.") + (defun command-line () "A subroutine of `normal-top-level'. Amongst another things, it parses the command-line arguments." @@ -1073,8 +1090,7 @@ Amongst another things, it parses the command-line arguments." (let ((simple-file-name ;; Look for simple.el or simple.elc and use their directory ;; as the place where all Lisp files live. - (locate-file "simple" load-path (get-load-suffixes))) - lisp-dir) + (locate-file "simple" load-path (get-load-suffixes)))) ;; Don't abort if simple.el cannot be found, but print a warning. ;; Although in most usage we are going to cryptically abort a moment ;; later anyway, due to missing required bidi data files (eg bug#13430). @@ -1090,12 +1106,13 @@ please check its value") (unless (file-readable-p lispdir) (princ (format "Lisp directory %s not readable?" lispdir)) (terpri))) - (setq lisp-dir (file-truename (file-name-directory simple-file-name))) + (setq lisp-directory + (file-truename (file-name-directory simple-file-name))) (setq load-history (mapcar (lambda (elt) (if (and (stringp (car elt)) (not (file-name-absolute-p (car elt)))) - (cons (concat lisp-dir + (cons (concat lisp-directory (car elt)) (cdr elt)) elt)) @@ -1556,17 +1573,22 @@ If this is nil, no message will be displayed." `((:face (variable-pitch font-lock-comment-face) "Welcome to " :link ("GNU Emacs" - ,(lambda (_button) (browse-url "https://www.gnu.org/software/emacs/")) + ,(lambda (_button) + (let ((browse-url-browser-function 'eww-browse-url)) + (browse-url "https://www.gnu.org/software/emacs/"))) "Browse https://www.gnu.org/software/emacs/") ", one component of the " :link ,(lambda () (if (eq system-type 'gnu/linux) `("GNU/Linux" - ,(lambda (_button) (browse-url "https://www.gnu.org/gnu/linux-and-gnu.html")) + ,(lambda (_button) + (let ((browse-url-browser-function 'eww-browse-url)) + (browse-url "https://www.gnu.org/gnu/linux-and-gnu.html"))) "Browse https://www.gnu.org/gnu/linux-and-gnu.html") `("GNU" ,(lambda (_button) - (browse-url "https://www.gnu.org/gnu/thegnuproject.html")) + (let ((browse-url-browser-function 'eww-browse-url)) + (browse-url "https://www.gnu.org/gnu/thegnuproject.html"))) "Browse https://www.gnu.org/gnu/thegnuproject.html"))) " operating system.\n\n" :face variable-pitch @@ -1599,7 +1621,8 @@ If this is nil, no message will be displayed." "\n" :link ("Emacs Guided Tour" ,(lambda (_button) - (browse-url "https://www.gnu.org/software/emacs/tour/")) + (let ((browse-url-browser-function 'eww-browse-url)) + (browse-url "https://www.gnu.org/software/emacs/tour/"))) "Browse https://www.gnu.org/software/emacs/tour/") "\tOverview of Emacs features at gnu.org\n" :link ("View Emacs Manual" ,(lambda (_button) (info-emacs-manual))) @@ -1622,22 +1645,31 @@ Each element in the list should be a list of strings or pairs `((:face (variable-pitch font-lock-comment-face) "This is " :link ("GNU Emacs" - ,(lambda (_button) (browse-url "https://www.gnu.org/software/emacs/")) + ,(lambda (_button) + (let ((browse-url-browser-function 'eww-browse-url)) + (browse-url "https://www.gnu.org/software/emacs/"))) "Browse https://www.gnu.org/software/emacs/") - ", one component of the " + ", a text editor and more.\nIt's a component of the " :link ,(lambda () (if (eq system-type 'gnu/linux) `("GNU/Linux" ,(lambda (_button) - (browse-url "https://www.gnu.org/gnu/linux-and-gnu.html")) + (let ((browse-url-browser-function 'eww-browse-url)) + (browse-url "https://www.gnu.org/gnu/linux-and-gnu.html"))) "Browse https://www.gnu.org/gnu/linux-and-gnu.html") - `("GNU" ,(lambda (_button) (describe-gnu-project)) + `("GNU" ,(lambda (_button) + (let ((browse-url-browser-function 'eww-browse-url)) + (describe-gnu-project))) "Display info on the GNU project."))) " operating system.\n" :face (variable-pitch font-lock-builtin-face) "\n" - ,(lambda () (emacs-version)) + ,(lambda () + (with-temp-buffer + (insert (emacs-version)) + (fill-region (point-min) (point-max)) + (buffer-string))) "\n" :face (variable-pitch (:height 0.8)) ,(lambda () emacs-copyright) @@ -1652,7 +1684,9 @@ Each element in the list should be a list of strings or pairs ,(lambda (_button) (info "(emacs)Contributing"))) "\tHow to report bugs and contribute improvements to Emacs\n" "\n" - :link ("GNU and Freedom" ,(lambda (_button) (describe-gnu-project))) + :link ("GNU and Freedom" ,(lambda (_button) + (let ((browse-url-browser-function 'eww-browse-url)) + (describe-gnu-project)))) "\tWhy we developed GNU Emacs, and the GNU operating system\n" :link ("Absence of Warranty" ,(lambda (_button) (describe-no-warranty))) "\tGNU Emacs comes with " @@ -1690,7 +1724,8 @@ Each element in the list should be a list of strings or pairs "\n" :link ("Emacs Guided Tour" ,(lambda (_button) - (browse-url "https://www.gnu.org/software/emacs/tour/")) + (let ((browse-url-browser-function 'eww-browse-url)) + (browse-url "https://www.gnu.org/software/emacs/tour/"))) "Browse https://www.gnu.org/software/emacs/tour/") "\tSee an overview of Emacs features at gnu.org\n" :link ("Emacs Manual" ,(lambda (_button) (info-emacs-manual))) @@ -1812,7 +1847,9 @@ a face or button specification." (make-button (prog1 (point) (insert-image img)) (point) 'face 'default 'help-echo "mouse-2, RET: Browse https://www.gnu.org/" - 'action (lambda (_button) (browse-url "https://www.gnu.org/")) + 'action (lambda (_button) + (let ((browse-url-browser-function 'eww-browse-url)) + (browse-url "https://www.gnu.org/"))) 'follow-link t) (insert "\n\n"))))) @@ -1821,28 +1858,35 @@ a face or button specification." (unless concise (fancy-splash-insert :face 'variable-pitch - "\nTo start... " + "\nTo start...\t" :link `("Open a File" ,(lambda (_button) (call-interactively 'find-file)) "Specify a new file's name, to edit the file") - " " + "\t\t" :link `("Open Home Directory" ,(lambda (_button) (dired "~")) "Open your home directory, to operate on its files") - " " + "\n\t" :link `("Customize Startup" ,(lambda (_button) (customize-group 'initialization)) "Change initialization settings including this screen") + "\t" + :link `("Explore Packages" + ,(lambda (_button) (call-interactively 'package-list-packages)) + "Explore, install and remove Emacs packages (requires Internet connection)") "\n")) (fancy-splash-insert :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 @@ -1926,7 +1970,6 @@ splash screen in another window." (insert "\n") (fancy-startup-tail concise)) (use-local-map splash-screen-keymap) - (setq-local browse-url-browser-function 'eww-browse-url) (setq tab-width 22 buffer-read-only t) (set-buffer-modified-p nil) @@ -1964,11 +2007,11 @@ splash screen in another window." (goto-char (point-min)) (force-mode-line-update)) (use-local-map splash-screen-keymap) - (setq-local browse-url-browser-function 'eww-browse-url) (setq tab-width 22) (setq buffer-read-only t) + ;; Place point somewhere it doesn't cover a character. (goto-char (point-min)) - (forward-line 3)))) + (re-search-forward "\n$" nil nil 2)))) (defun fancy-splash-frame () "Return the frame to use for the fancy splash screen. @@ -1980,6 +2023,8 @@ we put it on this frame." ;; frame visible. (if (eq (window-system) 'w32) (sit-for 0 t)) + (if (eq (window-system) 'pgtk) + (sit-for 0.1 t)) (dolist (frame (append (frame-list) (list (selected-frame)))) (if (and (frame-visible-p frame) (not (window-minibuffer-p (frame-selected-window frame)))) @@ -2121,8 +2166,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." @@ -2202,7 +2250,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 ")) @@ -2242,7 +2294,9 @@ Type \\[describe-distribution] for information on ")) (insert "\tHow to report bugs and contribute improvements to Emacs\n\n") (insert-button "GNU and Freedom" - 'action (lambda (_button) (describe-gnu-project)) + 'action (lambda (_button) + (let ((browse-url-browser-function 'eww-browse-url)) + (describe-gnu-project))) 'follow-link t) (insert "\t\tWhy we developed GNU Emacs and the GNU system\n") @@ -2383,6 +2437,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))) @@ -2526,7 +2581,15 @@ nil default-directory" name) (let* ((file (command-line-normalize-file-name (or argval (pop command-line-args-left)))) ;; Take file from default dir. - (file-ex (file-truename (expand-file-name file)))) + (file-ex (expand-file-name file)) + (truename (file-truename file-ex))) + ;; We want to use the truename here if we can, + ;; because that makes `eval-after-load' work + ;; more reliably. But if the file is, for + ;; instance, /dev/stdin, the truename doesn't + ;; actually exist on some systems. + (when (file-exists-p truename) + (setq file-ex truename)) (load file-ex nil t t))) ((equal argi "-insert") @@ -2536,6 +2599,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/strokes.el b/lisp/strokes.el index 91ddefd3738..db0eb83a3e6 100644 --- a/lisp/strokes.el +++ b/lisp/strokes.el @@ -1395,14 +1395,19 @@ Encode/decode your strokes with \\[strokes-encode-buffer], (strokes-load-user-strokes)) (add-hook 'kill-emacs-query-functions #'strokes-prompt-user-save-strokes) - (add-hook 'select-frame-hook - #'strokes-update-window-configuration) + ;; FIXME: Should this be something like `focus-in-hook'? + ;; That variable is obsolete, but `select-frame-hook' has + ;; never existed in Emacs. + ;;(add-hook 'select-frame-hook + ;; #'strokes-update-window-configuration) (strokes-update-window-configuration)) (t ; turn off strokes (if (get-buffer strokes-buffer-name) - (kill-buffer (get-buffer strokes-buffer-name))) - (remove-hook 'select-frame-hook - #'strokes-update-window-configuration)))) + (kill-buffer (get-buffer strokes-buffer-name))) + ;; FIXME: Same as above. + ;;(remove-hook 'select-frame-hook + ;; #'strokes-update-window-configuration) + ))) ;;;; strokes-xpm stuff (later may be separate)... diff --git a/lisp/subr.el b/lisp/subr.el index 8ff403e1139..29f375884b0 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -61,7 +61,8 @@ must be the first non-whitespace on a line. For more information, see Info node `(elisp)Declaring Functions'." (declare (advertised-calling-convention (fn file &optional arglist fileonly) nil)) - ;; Does nothing - byte-compile-declare-function does the work. + ;; Does nothing - `byte-compile-macroexpand-declare-function' does + ;; the work. nil) @@ -193,7 +194,7 @@ set earlier in the `setq-local'. The return value of the "Define VAR as a buffer-local variable with default value VAL. Like `defvar' but additionally marks the variable as being automatically buffer-local wherever it is set." - (declare (debug defvar) (doc-string 3)) + (declare (debug defvar) (doc-string 3) (indent 2)) ;; Can't use backquote here, it's too early in the bootstrap. (list 'progn (list 'defvar var val docstring) (list 'make-variable-buffer-local (list 'quote var)))) @@ -929,15 +930,29 @@ side-effects, and the argument LIST is not modified." "Convert KEYS to the internal Emacs key representation. KEYS should be a string in the format returned by commands such as `C-h k' (`describe-key'). + This is the same format used for saving keyboard macros (see `edmacro-mode'). +Here's some example key sequences: + + \"f\" + \"C-c C-c\" + \"H-<left>\" + \"M-RET\" + \"C-M-<return>\" + For an approximate inverse of this, see `key-description'." - ;; Don't use a defalias, since the `pure' property is true only for - ;; the calling convention of `kbd'. (declare (pure t) (side-effect-free t)) - ;; A pure function is expected to preserve the match data. - (save-match-data (read-kbd-macro keys))) + (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." @@ -988,6 +1003,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 @@ -1000,6 +1018,7 @@ 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)) (unless after (setq after t)) (or (keymapp keymap) (signal 'wrong-type-argument (list 'keymapp keymap))) @@ -1157,6 +1176,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) @@ -1168,6 +1190,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 @@ -1189,6 +1214,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 @@ -1207,12 +1235,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) @@ -1221,6 +1255,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. @@ -1232,6 +1269,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' @@ -1250,6 +1290,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. @@ -1511,22 +1554,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. @@ -1752,6 +1795,7 @@ be a list of the form returned by `event-start' and `event-end'." (make-obsolete 'window-redisplay-end-trigger nil "23.1") (make-obsolete 'set-window-redisplay-end-trigger nil "23.1") (make-obsolete-variable 'operating-system-release nil "28.1") +(make-obsolete-variable 'inhibit-changing-match-data 'save-match-data "29.1") (make-obsolete 'run-window-configuration-change-hook nil "27.1") @@ -1868,7 +1912,7 @@ performance impact when running `add-hook' and `remove-hook'." (when (or (get hook 'hook--depth-alist) (not (zerop depth))) ;; Note: The main purpose of the above `when' test is to avoid running ;; this `setf' before `gv' is loaded during bootstrap. - (push (cons function depth) (get hook 'hook--depth-alist))) + (setf (alist-get function (get hook 'hook--depth-alist) 0) depth)) (setq hook-value (if (< 0 depth) (append hook-value (list function)) @@ -3077,7 +3121,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' @@ -3368,6 +3412,29 @@ user can undo the change normally." (accept-change-group ,handle) (cancel-change-group ,handle)))))) +(defmacro with-undo-amalgamate (&rest body) + "Like `progn' but perform BODY with amalgamated undo barriers. + +This allows multiple operations to be undone in a single step. +When undo is disabled this behaves like `progn'." + (declare (indent 0) (debug t)) + (let ((handle (make-symbol "--change-group-handle--"))) + `(let ((,handle (prepare-change-group)) + ;; Don't truncate any undo data in the middle of this, + ;; otherwise Emacs might truncate part of the resulting + ;; undo step: we want to mimic the behavior we'd get if the + ;; undo-boundaries were never added in the first place. + (undo-outer-limit nil) + (undo-limit most-positive-fixnum) + (undo-strong-limit most-positive-fixnum)) + (unwind-protect + (progn + (activate-change-group ,handle) + ,@body) + (progn + (accept-change-group ,handle) + (undo-amalgamate-change-group ,handle)))))) + (defun prepare-change-group (&optional buffer) "Return a handle for the current buffer's state, for a change group. If you specify BUFFER, make a handle for BUFFER's state instead. @@ -3567,6 +3634,9 @@ If either NAME or VAL are specified, both should be specified." (defvar suspend-resume-hook nil "Normal hook run by `suspend-emacs', after Emacs is continued.") +(defvar after-pdump-load-hook nil + "Normal hook run after loading the .pdmp file.") + (defvar temp-buffer-show-hook nil "Normal hook run by `with-output-to-temp-buffer' after displaying the buffer. When the hook runs, the temporary buffer is current, and the window it @@ -3987,7 +4057,7 @@ BUFFER is the buffer (or buffer name) to associate with the process. Process output goes at end of that buffer, unless you specify an output stream or filter function to handle the output. BUFFER may be also nil, meaning that this process is not associated - with any buffer + with any buffer. COMMAND is the shell command to run." ;; We used to use `exec' to replace the shell with the command, ;; but that failed to handle (...) and semicolon, etc. @@ -4386,11 +4456,6 @@ is allowed once again. (Immediately, if `inhibit-quit' is nil.)" ;; that intends to handle the quit signal next time. (eval '(ignore nil))))) -;; Don't throw `throw-on-input' on those events by default. -(setq while-no-input-ignore-events - '(focus-in focus-out help-echo iconify-frame - make-frame-visible selection-request)) - (defmacro while-no-input (&rest body) "Execute BODY only as long as there's no pending input. If input arrives, that ends the execution of BODY, @@ -4763,14 +4828,12 @@ wherever possible, since it is slow." (defsubst looking-at-p (regexp) "\ Same as `looking-at' except this function does not change the match data." - (let ((inhibit-changing-match-data t)) - (looking-at regexp))) + (looking-at regexp t)) (defsubst string-match-p (regexp string &optional start) "\ Same as `string-match' except this function does not change the match data." - (let ((inhibit-changing-match-data t)) - (string-match regexp string start))) + (string-match regexp string start t)) (defun subregexp-context-p (regexp pos &optional start) "Return non-nil if POS is in a normal subregexp context in REGEXP. @@ -5575,6 +5638,7 @@ If HOOKVAR is nil, `mail-send-hook' is used. The properties used on SYMBOL are `composefunc', `sendfunc', `abortfunc', and `hookvar'." + (declare (indent defun)) (put symbol 'composefunc composefunc) (put symbol 'sendfunc sendfunc) (put symbol 'abortfunc (or abortfunc #'kill-buffer)) @@ -6462,4 +6526,145 @@ 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/DEFINITION pairs as key bindings. +The new keymap is returned. + +Options can be given as keywords before the KEY/DEFINITION +pairs. Available keywords are: + +:full If non-nil, create a chartable alist (see `make-keymap'). + If nil (i.e., the default), create a sparse keymap (see + `make-sparse-keymap'). + +:suppress If non-nil, the keymap will be suppressed (see `suppress-keymap'). + If `nodigits', treat digits like other chars. + +:parent If non-nil, this should be a keymap to use as the parent + (see `set-keymap-parent'). + +:keymap If non-nil, instead of creating a new keymap, the given keymap + will be destructively modified instead. + +:name If non-nil, this should be a string to use as the menu for + the keymap in case you use it as a menu with `x-popup-menu'. + +:prefix If non-nil, this should be a symbol to be used as a prefix + 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 `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) + (compiler-macro define-keymap--compile)) + (let (full suppress parent name prefix keymap) + ;; Handle keywords. + (while (and definitions + (keywordp (car definitions)) + (not (eq (car definitions) :menu))) + (let ((keyword (pop definitions))) + (unless definitions + (error "Missing keyword value for %s" keyword)) + (let ((value (pop definitions))) + (pcase keyword + (:full (setq full value)) + (:keymap (setq keymap value)) + (:parent (setq parent value)) + (:suppress (setq suppress value)) + (:name (setq name value)) + (:prefix (setq prefix value)) + (_ (error "Invalid keyword: %s" keyword)))))) + + (when (and prefix + (or full parent suppress keymap)) + (error "A prefix keymap can't be defined with :full/:parent/:suppress/:keymap keywords")) + + (when (and keymap full) + (error "Invalid combination: :keymap with :full")) + + (let ((keymap (cond + (keymap keymap) + (prefix (define-prefix-command prefix nil name)) + (full (make-keymap name)) + (t (make-sparse-keymap name))))) + (when suppress + (suppress-keymap keymap (eq suppress 'nodigits))) + (when parent + (set-keymap-parent keymap parent)) + + ;; Do the bindings. + (while definitions + (let ((key (pop definitions))) + (unless definitions + (error "Uneven number of key/definition pairs")) + (let ((def (pop definitions))) + (if (eq key :menu) + (easy-menu-define nil keymap "" def) + (keymap-set keymap key def))))) + keymap))) + +(defmacro defvar-keymap (variable-name &rest defs) + "Define VARIABLE-NAME as a variable with a keymap definition. +See `define-keymap' for an explanation of the keywords and KEY/DEFINITION. + +In addition to the keywords accepted by `define-keymap', this +macro also accepts a `:doc' keyword, which (if present) is used +as the variable documentation string. + +\(fn VARIABLE-NAME &key DOC FULL PARENT SUPPRESS NAME PREFIX KEYMAP &rest [KEY DEFINITION]...)" + (declare (indent 1)) + (let ((opts nil) + doc) + (while (and defs + (keywordp (car defs)) + (not (eq (car defs) :menu))) + (let ((keyword (pop defs))) + (unless defs + (error "Uneven number of keywords")) + (if (eq keyword :doc) + (setq doc (pop defs)) + (push keyword opts) + (push (pop defs) opts)))) + (unless (zerop (% (length defs) 2)) + (error "Uneven number of key/definition pairs: %s" defs)) + `(defvar ,variable-name + (define-keymap ,@(nreverse opts) ,@defs) + ,@(and doc (list doc))))) + +(defmacro with-delayed-message (args &rest body) + "Like `progn', but display MESSAGE if BODY takes longer than TIMEOUT seconds. +The MESSAGE form will be evaluated immediately, but the resulting +string will be displayed only if BODY takes longer than TIMEOUT seconds. + +\(fn (timeout message) &rest body)" + (declare (indent 1)) + `(funcall-with-delayed-message ,(car args) ,(cadr args) + (lambda () + ,@body))) + ;;; subr.el ends here diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index 68d28306dd9..7dcd0bdc7bb 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -982,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) @@ -1126,19 +1127,21 @@ Negative TAB-NUMBER counts tabs from the end of 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)) @@ -1193,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 \ \\<minibuffer-local-map>\\[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)) @@ -1201,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) @@ -1388,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))) @@ -1803,30 +1817,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. @@ -1866,6 +1884,10 @@ This navigates forward in the history of window configurations." (goto-char wc-point))) (message "No more tab forward history")))) +(defvar-keymap tab-bar-history-mode-map + "C-c <left>" #'tab-bar-history-back + "C-c <right>" #'tab-bar-history-forward) + (define-minor-mode tab-bar-history-mode "Toggle tab history mode for the tab bar. Tab history mode remembers window configurations used in every tab, diff --git a/lisp/tab-line.el b/lisp/tab-line.el index 5affae79138..003bfe1fbe3 100644 --- a/lisp/tab-line.el +++ b/lisp/tab-line.el @@ -495,6 +495,8 @@ which the tab will represent." (apply 'propertize (concat (propertize name 'keymap tab-line-tab-map + 'help-echo (if selected-p "Current tab" + "Click to select tab") ;; Don't turn mouse-1 into mouse-2 (bug#49247) 'follow-link 'ignore) (or (and (or buffer-p (assq 'buffer tab) (assq 'close tab)) @@ -792,7 +794,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 +820,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 +899,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/tar-mode.el b/lisp/tar-mode.el index db655619bed..0ca26f770c4 100644 --- a/lisp/tar-mode.el +++ b/lisp/tar-mode.el @@ -467,8 +467,8 @@ checksum before doing the check." (defun tar-clip-time-string (time) (declare (obsolete format-time-string "27.1")) - (let ((str (current-time-string time))) - (concat " " (substring str 4 16) (format-time-string " %Y" time)))) + (let ((system-time-locale "C")) + (format-time-string " %b %e %H:%M %Y" time))) (defun tar-grind-file-mode (mode) "Construct a `rw-r--r--' string indicating MODE. diff --git a/lisp/term.el b/lisp/term.el index e76eb77647f..cb13f60c1de 100644 --- a/lisp/term.el +++ b/lisp/term.el @@ -303,6 +303,7 @@ (require 'ange-ftp) (require 'cl-lib)) (require 'comint) ; Password regexp. +(require 'ansi-color) (require 'ehelp) (require 'ring) (require 'shell) @@ -710,13 +711,20 @@ Buffer local variable.") (defvar term-ansi-at-save-pwd nil) (defvar term-ansi-at-save-anon nil) (defvar term-ansi-current-bold nil) +(defvar term-ansi-current-faint nil) +(defvar term-ansi-current-italic nil) +(defvar term-ansi-current-underline nil) +(defvar term-ansi-current-slow-blink nil) +(defvar term-ansi-current-fast-blink nil) (defvar term-ansi-current-color 0) (defvar term-ansi-face-already-done nil) (defvar term-ansi-current-bg-color 0) -(defvar term-ansi-current-underline nil) (defvar term-ansi-current-reverse nil) (defvar term-ansi-current-invisible nil) +(make-obsolete-variable 'term-ansi-face-already-done + "it doesn't have any effect." "29.1") + ;;; Faces (defvar ansi-term-color-vector [term @@ -765,12 +773,36 @@ Buffer local variable.") :group 'term :version "28.1") +(defface term-faint + '((t :inherit ansi-color-faint)) + "Default face to use for faint text." + :group 'term + :version "29.1") + +(defface term-italic + '((t :inherit ansi-color-italic)) + "Default face to use for italic text." + :group 'term + :version "29.1") + (defface term-underline '((t :inherit ansi-color-underline)) "Default face to use for underlined text." :group 'term :version "28.1") +(defface term-slow-blink + '((t :inherit ansi-color-slow-blink)) + "Default face to use for slowly blinking text." + :group 'term + :version "29.1") + +(defface term-fast-blink + '((t :inherit ansi-color-fast-blink)) + "Default face to use for rapidly blinking text." + :group 'term + :version "29.1") + (defface term-color-black '((t :inherit ansi-color-black)) "Face used to render black color code." @@ -1034,15 +1066,15 @@ is buffer-local." (defun term-ansi-reset () (setq term-current-face 'term) - (setq term-ansi-current-underline nil) (setq term-ansi-current-bold nil) + (setq term-ansi-current-faint nil) + (setq term-ansi-current-italic nil) + (setq term-ansi-current-underline nil) + (setq term-ansi-current-slow-blink nil) + (setq term-ansi-current-fast-blink nil) (setq term-ansi-current-reverse nil) (setq term-ansi-current-color 0) (setq term-ansi-current-invisible nil) - ;; Stefan thought this should be t, but could not remember why. - ;; Setting it to t seems to cause bug#11785. Setting it to nil - ;; again to see if there are other consequences... - (setq term-ansi-face-already-done nil) (setq term-ansi-current-bg-color 0)) (define-derived-mode term-mode fundamental-mode "Term" @@ -1499,9 +1531,8 @@ commands to use in that buffer. (getenv "ESHELL") shell-file-name)))) (set-buffer (make-term "terminal" program)) - (term-mode) (term-char-mode) - (switch-to-buffer "*terminal*")) + (pop-to-buffer-same-window "*terminal*")) (defun term-exec (buffer name command startfile switches) "Start up a process in buffer for term modes. @@ -1581,10 +1612,12 @@ Using \"emacs\" loses, because bash disables editing if $TERM == emacs.") :nd=\\E[C:up=\\E[A:ce=\\E[K:ho=\\E[H:pt\ :al=\\E[L:dl=\\E[M:DL=\\E[%%dM:AL=\\E[%%dL:cs=\\E[%%i%%d;%%dr:sf=^J\ :dc=\\E[P:DC=\\E[%%dP:IC=\\E[%%d@:im=\\E[4h:ei=\\E[4l:mi:\ +:mb=\\E[5m:mh=\\E[2m:ZR=\\E[23m:ZH=\\E[3m\ :so=\\E[7m:se=\\E[m:us=\\E[4m:ue=\\E[m:md=\\E[1m:mr=\\E[7m:me=\\E[m\ :UP=\\E[%%dA:DO=\\E[%%dB:LE=\\E[%%dD:RI=\\E[%%dC\ :kl=\\EOD:kd=\\EOB:kr=\\EOC:ku=\\EOA:kN=\\E[6~:kP=\\E[5~:@7=\\E[4~:kh=\\E[1~\ -:mk=\\E[8m:cb=\\E[1K:op=\\E[39;49m:Co#8:pa#64:AB=\\E[4%%dm:AF=\\E[3%%dm:cr=^M\ +:mk=\\E[8m:cb=\\E[1K:op=\\E[39;49m:Co#256:pa#32767\ +:AB=\\E[48;5;%%dm:AF=\\E[38;5;%%dm:cr=^M\ :bl=^G:do=^J:le=^H:ta=^I:se=\\E[27m:ue=\\E[24m\ :kb=^?:kD=^[[3~:sc=\\E7:rc=\\E8:r1=\\Ec:" ;; : -undefine ic @@ -2375,7 +2408,14 @@ Checks if STRING contains a password prompt as defined by (when (term-in-line-mode) (when (let ((case-fold-search t)) (string-match comint-password-prompt-regexp string)) - (term-send-invisible (read-passwd string))))) + ;; Use `run-at-time' in order not to pause execution of the + ;; process filter with a minibuffer + (run-at-time + 0 nil + (lambda (current-buf) + (with-current-buffer current-buf + (term-send-invisible (read-passwd string)))) + (current-buffer))))) ;;; Low-level process communication @@ -3104,30 +3144,34 @@ See `term-prompt-regexp'." (term-horizontal-column) term-ansi-current-bg-color term-ansi-current-bold + term-ansi-current-faint + term-ansi-current-italic + term-ansi-current-underline + term-ansi-current-slow-blink + term-ansi-current-fast-blink term-ansi-current-color term-ansi-current-invisible term-ansi-current-reverse - term-ansi-current-underline term-current-face))) (?8 ;; Restore cursor (terminfo: rc, [ctlseqs] ;; "DECRC"). (when term-saved-cursor (term-goto (nth 0 term-saved-cursor) (nth 1 term-saved-cursor)) - (setq term-ansi-current-bg-color - (nth 2 term-saved-cursor) - term-ansi-current-bold - (nth 3 term-saved-cursor) - term-ansi-current-color - (nth 4 term-saved-cursor) - term-ansi-current-invisible - (nth 5 term-saved-cursor) - term-ansi-current-reverse - (nth 6 term-saved-cursor) - term-ansi-current-underline - (nth 7 term-saved-cursor) - term-current-face - (nth 8 term-saved-cursor)))) + (pcase-setq + `( ,_ ,_ + ,term-ansi-current-bg-color + ,term-ansi-current-bold + ,term-ansi-current-faint + ,term-ansi-current-italic + ,term-ansi-current-underline + ,term-ansi-current-slow-blink + ,term-ansi-current-fast-blink + ,term-ansi-current-color + ,term-ansi-current-invisible + ,term-ansi-current-reverse + ,term-current-face) + term-saved-cursor))) (?c ;; \Ec - Reset (terminfo: rs1, [ctlseqs] "RIS"). ;; This is used by the "clear" program. (term-reset-terminal)) @@ -3256,13 +3300,16 @@ Called as a buffer-local `post-command-hook' function in `term-char-mode' to prevent commands from putting the buffer into an inconsistent state by unexpectedly moving point. -Mouse events are ignored so that mouse selection is unimpeded. +Mouse and wheel events are ignored so that mouse selection and +mouse wheel scrolling are unimpeded. Only acts when the pre-command position of point was equal to the process mark, and the `term-char-mode-point-at-process-mark' option is enabled. See `term-set-goto-process-mark'." (when term-goto-process-mark - (unless (mouse-event-p last-command-event) + (unless (or (mouse-event-p last-command-event) + (memq (event-basic-type last-command-event) + '(wheel-down wheel-up))) (goto-char (term-process-mark))))) (defun term-process-mark () @@ -3285,133 +3332,141 @@ option is enabled. See `term-set-goto-process-mark'." (setq term-current-row 0) (setq term-current-column 1) (term--reset-scroll-region) - (setq term-insert-mode nil) - ;; FIXME: No idea why this is here, it looks wrong. --Stef - (setq term-ansi-face-already-done nil)) - -(defun term--maybe-brighten-color (color bold) - "Possibly convert COLOR to its bright variant. -COLOR is an index into `ansi-term-color-vector'. If BOLD and -`ansi-color-bold-is-bright' are non-nil and COLOR is a regular color, -return the bright version of COLOR; otherwise, return COLOR." - (if (and ansi-color-bold-is-bright bold (<= 1 color 8)) - (+ color 8) - color)) + (setq term-insert-mode nil)) + +(defun term--color-as-hex (for-foreground) + "Return the current ANSI color as a hexadecimal color string. +Use the current background color if FOR-FOREGROUND is nil, +otherwise use the current foreground color." + (let ((color (if for-foreground term-ansi-current-color + term-ansi-current-bg-color))) + (or (ansi-color--code-as-hex (1- color)) + (progn + (and ansi-color-bold-is-bright term-ansi-current-bold + (<= 1 color 8) + (setq color (+ color 8))) + (if for-foreground + (face-foreground (elt ansi-term-color-vector color) + nil 'default) + (face-background (elt ansi-term-color-vector color) + nil 'default)))))) ;; New function to deal with ansi colorized output, as you can see you can ;; have any bold/underline/fg/bg/reverse combination. -mm (defun term-handle-colors-array (parameter) - (cond - - ;; Bold (terminfo: bold) - ((eq parameter 1) - (setq term-ansi-current-bold t)) - - ;; Underline - ((eq parameter 4) - (setq term-ansi-current-underline t)) - - ;; Blink (unsupported by Emacs), will be translated to bold. - ;; This may change in the future though. - ((eq parameter 5) - (setq term-ansi-current-bold t)) - - ;; Reverse (terminfo: smso) - ((eq parameter 7) - (setq term-ansi-current-reverse t)) - - ;; Invisible - ((eq parameter 8) - (setq term-ansi-current-invisible t)) - - ;; Reset underline (terminfo: rmul) - ((eq parameter 24) - (setq term-ansi-current-underline nil)) - - ;; Reset reverse (terminfo: rmso) - ((eq parameter 27) - (setq term-ansi-current-reverse nil)) - - ;; Foreground - ((and (>= parameter 30) (<= parameter 37)) - (setq term-ansi-current-color (- parameter 29))) - - ;; Bright foreground - ((and (>= parameter 90) (<= parameter 97)) - (setq term-ansi-current-color (- parameter 81))) - - ;; Reset foreground - ((eq parameter 39) - (setq term-ansi-current-color 0)) - - ;; Background - ((and (>= parameter 40) (<= parameter 47)) - (setq term-ansi-current-bg-color (- parameter 39))) - - ;; Bright foreground - ((and (>= parameter 100) (<= parameter 107)) - (setq term-ansi-current-bg-color (- parameter 91))) - - ;; Reset background - ((eq parameter 49) - (setq term-ansi-current-bg-color 0)) - - ;; 0 (Reset) or unknown (reset anyway) - (t - (term-ansi-reset))) - - ;; (message "Debug: U-%d R-%d B-%d I-%d D-%d F-%d B-%d" - ;; term-ansi-current-underline - ;; term-ansi-current-reverse - ;; term-ansi-current-bold - ;; term-ansi-current-invisible - ;; term-ansi-face-already-done - ;; term-ansi-current-color - ;; term-ansi-current-bg-color) - - (unless term-ansi-face-already-done - (let ((current-color (term--maybe-brighten-color - term-ansi-current-color - term-ansi-current-bold)) - (current-bg-color (term--maybe-brighten-color - term-ansi-current-bg-color - term-ansi-current-bold))) - (if term-ansi-current-invisible - (let ((color - (if term-ansi-current-reverse - (face-foreground - (elt ansi-term-color-vector current-color) - nil 'default) - (face-background - (elt ansi-term-color-vector current-bg-color) - nil 'default)))) - (setq term-current-face - (list :background color - :foreground color)) - ) ;; No need to bother with anything else if it's invisible. - (setq term-current-face - (list :foreground - (face-foreground - (elt ansi-term-color-vector current-color) - nil 'default) - :background - (face-background - (elt ansi-term-color-vector current-bg-color) - nil 'default) - :inverse-video term-ansi-current-reverse)) - - (when term-ansi-current-bold - (setq term-current-face - `(,term-current-face :inherit term-bold))) - - (when term-ansi-current-underline - (setq term-current-face - `(,term-current-face :inherit term-underline)))))) - - ;; (message "Debug %S" term-current-face) - ;; FIXME: shouldn't we set term-ansi-face-already-done to t here? --Stef - (setq term-ansi-face-already-done nil)) + (declare (obsolete term--handle-colors-list "29.1")) + (term--handle-colors-list (list parameter))) + +(defun term--handle-colors-list (parameters) + (while parameters + (pcase (pop parameters) + (1 (setq term-ansi-current-bold t)) ; (terminfo: bold) + (2 (setq term-ansi-current-faint t)) ; (terminfo: dim) + (3 (setq term-ansi-current-italic t)) ; (terminfo: sitm) + (4 (setq term-ansi-current-underline t)) ; (terminfo: smul) + (5 (setq term-ansi-current-slow-blink t)) ; (terminfo: blink) + (6 (setq term-ansi-current-fast-blink t)) + (7 (setq term-ansi-current-reverse t)) ; (terminfo: smso, rev) + (8 (setq term-ansi-current-invisible t)) ; (terminfo: invis) + (21 (setq term-ansi-current-bold nil)) + (22 (setq term-ansi-current-bold nil) + (setq term-ansi-current-faint nil)) + (23 (setq term-ansi-current-italic nil)) ; (terminfo: ritm) + (24 (setq term-ansi-current-underline nil)) ; (terminfo: rmul) + (25 (setq term-ansi-current-slow-blink nil) + (setq term-ansi-current-fast-blink nil)) + (27 (setq term-ansi-current-reverse nil)) ; (terminfo: rmso) + + ;; Foreground (terminfo: setaf) + ((and param (guard (<= 30 param 37))) + (setq term-ansi-current-color (- param 29))) + + ;; Bright foreground (terminfo: setaf) + ((and param (guard (<= 90 param 97))) + (setq term-ansi-current-color (- param 81))) + + ;; Extended foreground (terminfo: setaf) + (38 + (pcase (pop parameters) + ;; 256 color + (5 (if (setq term-ansi-current-color (pop parameters)) + (cl-incf term-ansi-current-color) + (term-ansi-reset))) + ;; Full 24-bit color + (2 (cl-loop with color = (1+ 256) ; Base + for i from 16 downto 0 by 8 + if (pop parameters) + do (setq color (+ color (ash it i))) + else return (term-ansi-reset) + finally + (if (> color (+ 1 256 #xFFFFFF)) + (term-ansi-reset) + (setq term-ansi-current-color color)))) + (_ (term-ansi-reset)))) + + ;; Reset foreground (terminfo: op) + (39 (setq term-ansi-current-color 0)) + + ;; Background (terminfo: setab) + ((and param (guard (<= 40 param 47))) + (setq term-ansi-current-bg-color (- param 39))) + + ;; Bright background (terminfo: setab) + ((and param (guard (<= 100 param 107))) + (setq term-ansi-current-bg-color (- param 91))) + + ;; Extended background (terminfo: setab) + (48 + (pcase (pop parameters) + ;; 256 color + (5 (if (setq term-ansi-current-bg-color (pop parameters)) + (cl-incf term-ansi-current-bg-color) + (term-ansi-reset))) + ;; Full 24-bit color + (2 (cl-loop with color = (1+ 256) ; Base + for i from 16 downto 0 by 8 + if (pop parameters) + do (setq color (+ color (ash it i))) + else return (term-ansi-reset) + finally + (if (> color (+ 1 256 #xFFFFFF)) + (term-ansi-reset) + (setq term-ansi-current-bg-color color)))) + (_ (term-ansi-reset)))) + + ;; Reset background (terminfo: op) + (49 (setq term-ansi-current-bg-color 0)) + + ;; 0 (Reset) (terminfo: sgr0) or unknown (reset anyway) + (_ (term-ansi-reset)))) + + (let (fg bg) + (if term-ansi-current-invisible + (setq bg (term--color-as-hex term-ansi-current-reverse) + fg bg) + (setq fg (term--color-as-hex t) + bg (term--color-as-hex nil))) + (setq term-current-face + `( :foreground ,fg + :background ,bg + ,@(unless term-ansi-current-invisible + (list :inverse-video term-ansi-current-reverse))))) + + (setq term-current-face + `(,term-current-face + ,@(when term-ansi-current-bold + '(term-bold)) + ,@(when term-ansi-current-faint + '(term-faint)) + ,@(when term-ansi-current-italic + '(term-italic)) + ,@(when term-ansi-current-underline + '(term-underline)) + ,@(when term-ansi-current-slow-blink + '(term-slow-blink)) + ,@(when term-ansi-current-fast-blink + '(term-fast-blink))))) ;; Handle a character assuming (eq terminal-state 2) - @@ -3497,9 +3552,9 @@ return the bright version of COLOR; otherwise, return COLOR." ;; Modified to allow ansi coloring -mm ;; \E[m - Set/reset modes, set bg/fg - ;;(terminfo: smso,rmso,smul,rmul,rev,bold,sgr0,invis,op,setab,setaf) + ;;(terminfo: smso,rmso,smul,rmul,rev,bold,dim,sitm,ritm,blink,sgr0,invis,op,setab,setaf) ((eq char ?m) - (mapc #'term-handle-colors-array params)) + (term--handle-colors-list params)) ;; \E[6n - Report cursor position (terminfo: u7) ((eq char ?n) 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 <https://www.gnu.org/licenses/>. + +;;; 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/term/ns-win.el b/lisp/term/ns-win.el index 1a3811a37c2..67a417c1161 100644 --- a/lisp/term/ns-win.el +++ b/lisp/term/ns-win.el @@ -867,10 +867,10 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") ;; For Darwin nothing except UTF-8 makes sense. (when (eq system-type 'darwin) (add-hook 'before-init-hook - #'(lambda () - (setq locale-coding-system 'utf-8-unix) - (setq default-process-coding-system - '(utf-8-unix . utf-8-unix))))) + (lambda () + (setq locale-coding-system 'utf-8-unix) + (setq default-process-coding-system + '(utf-8-unix . utf-8-unix))))) ;; Mac OS X Lion introduces PressAndHold, which is unsupported by this port. ;; See this thread for more details: diff --git a/lisp/term/pgtk-win.el b/lisp/term/pgtk-win.el new file mode 100644 index 00000000000..bd925a01299 --- /dev/null +++ b/lisp/term/pgtk-win.el @@ -0,0 +1,516 @@ +;;; xterm.el --- define function key sequences and standard colors for xterm -*- lexical-binding: t -*- + +;; Copyright (C) 1995, 2001-2020 Free Software Foundation, Inc. + +;; Author: FSF +;; Keywords: terminals + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: +(eval-when-compile (require 'cl-lib)) +(or (featurep 'pgtk) + (error "%s: Loading pgtk-win.el but not compiled for pure Gtk+-3." + invocation-name)) + +;; Documentation-purposes only: actually loaded in loadup.el. +(require 'term/common-win) +(require 'frame) +(require 'mouse) +(require 'scroll-bar) +(require 'faces) +(require 'menu-bar) +(require 'fontset) +(require 'dnd) + +(defgroup pgtk nil + "Pure-GTK specific features." + :group 'environment) + +;;;; Command line argument handling. + +(defvar x-invocation-args) +;; Set in term/common-win.el; currently unused by Gtk's x-open-connection. +(defvar x-command-line-resources) + +;; pgtkterm.c. +(defvar pgtk-input-file) + +(declare-function pgtk-use-im-context "pgtkim.c") +(defvar pgtk-use-im-context-on-new-connection) + +(defun pgtk-handle-nxopen (_switch &optional temp) + (setq unread-command-events (append unread-command-events + (if temp '(pgtk-open-temp-file) + '(pgtk-open-file))) + pgtk-input-file (append pgtk-input-file (list (pop x-invocation-args))))) + +(defun pgtk-handle-nxopentemp (switch) + (pgtk-handle-nxopen switch t)) + +(defun pgtk-ignore-1-arg (_switch) + (setq x-invocation-args (cdr x-invocation-args))) + +;;;; File handling. + +(declare-function pgtk-hide-emacs "pgtkfns.c" (on)) + + +(defun pgtk-drag-n-drop (event &optional new-frame force-text) + "Edit the files listed in the drag-n-drop EVENT. +Switch to a buffer editing the last file dropped." + (interactive "e") + (let* ((window (posn-window (event-start event))) + (arg (car (cdr (cdr event)))) + (type (car arg)) + (data (car (cdr arg))) + (url-or-string (cond ((eq type 'file) + (concat "file:" data)) + (t data)))) + (set-frame-selected-window nil window) + (when new-frame + (select-frame (make-frame))) + (raise-frame) + (setq window (selected-window)) + (if force-text + (dnd-insert-text window 'private data) + (dnd-handle-one-url window 'private url-or-string)))) + + +(defun pgtk-drag-n-drop-other-frame (event) + "Edit the files listed in the drag-n-drop EVENT, in other frames. +May create new frames, or reuse existing ones. The frame editing +the last file dropped is selected." + (interactive "e") + (pgtk-drag-n-drop event t)) + +(defun pgtk-drag-n-drop-as-text (event) + "Drop the data in EVENT as text." + (interactive "e") + (pgtk-drag-n-drop event nil t)) + +(defun pgtk-drag-n-drop-as-text-other-frame (event) + "Drop the data in EVENT as text in a new frame." + (interactive "e") + (pgtk-drag-n-drop event t t)) + +(global-set-key [drag-n-drop] 'pgtk-drag-n-drop) +(global-set-key [C-drag-n-drop] 'pgtk-drag-n-drop-other-frame) +(global-set-key [M-drag-n-drop] 'pgtk-drag-n-drop-as-text) +(global-set-key [C-M-drag-n-drop] 'pgtk-drag-n-drop-as-text-other-frame) + +;;;; Frame-related functions. + +;; pgtkterm.c +(defvar pgtk-alternate-modifier) +(defvar pgtk-right-alternate-modifier) +(defvar pgtk-right-command-modifier) +(defvar pgtk-right-control-modifier) + +;; You say tomAYto, I say tomAHto.. +(with-no-warnings + (defvaralias 'pgtk-option-modifier 'pgtk-alternate-modifier) + (defvaralias 'pgtk-right-option-modifier 'pgtk-right-alternate-modifier)) + +(defun pgtk-do-hide-emacs () + (interactive) + (pgtk-hide-emacs t)) + +(declare-function pgtk-hide-others "pgtkfns.c" ()) + +(defun pgtk-do-hide-others () + (interactive) + (pgtk-hide-others)) + +(declare-function pgtk-emacs-info-panel "pgtkfns.c" ()) + +(defun pgtk-do-emacs-info-panel () + (interactive) + (pgtk-emacs-info-panel)) + +(defun pgtk-next-frame () + "Switch to next visible frame." + (interactive) + (other-frame 1)) + +(defun pgtk-prev-frame () + "Switch to previous visible frame." + (interactive) + (other-frame -1)) + +;; Frame will be focused anyway, so select it +;; (if this is not done, mode line is dimmed until first interaction) +;; FIXME: Sounds like we're working around a bug in the underlying code. +(add-hook 'after-make-frame-functions 'select-frame) + +(defvar tool-bar-mode) +(declare-function tool-bar-mode "tool-bar" (&optional arg)) + +;; Based on a function by David Reitter <dreitter@inf.ed.ac.uk> ; +;; see https://lists.gnu.org/archive/html/emacs-devel/2005-09/msg00681.html . +(defun pgtk-toggle-toolbar (&optional frame) + "Switches the tool bar on and off in frame FRAME. + If FRAME is nil, the change applies to the selected frame." + (interactive) + (modify-frame-parameters + frame (list (cons 'tool-bar-lines + (if (> (or (frame-parameter frame 'tool-bar-lines) 0) 0) + 0 1)) )) + (if (not tool-bar-mode) (tool-bar-mode t))) + + +;;;; Dialog-related functions. + +;; Ask user for confirm before printing. Due to Kevin Rodgers. +(defun pgtk-print-buffer () + "Interactive front-end to `print-buffer': asks for user confirmation first." + (interactive) + (if (and (called-interactively-p 'interactive) + (or (listp last-nonmenu-event) + (and (char-or-string-p (event-basic-type last-command-event)) + (memq 'super (event-modifiers last-command-event))))) + (let ((last-nonmenu-event (if (listp last-nonmenu-event) + last-nonmenu-event + ;; Fake it: + `(mouse-1 POSITION 1)))) + (if (y-or-n-p (format "Print buffer %s? " (buffer-name))) + (print-buffer) + (error "Canceled"))) + (print-buffer))) + +;;;; Font support. + +;; Needed for font listing functions under both backend and normal +(setq scalable-fonts-allowed t) + +;; Default fontset. This is mainly here to show how a fontset +;; can be set up manually. Ordinarily, fontsets are auto-created whenever +;; a font is chosen by +(defvar pgtk-standard-fontset-spec + ;; Only some code supports this so far, so use uglier XLFD version + ;; "-pgtk-*-*-*-*-*-10-*-*-*-*-*-fontset-standard,latin:Courier,han:Kai" + (mapconcat 'identity + '("-*-Monospace-*-*-*-*-10-*-*-*-*-*-fontset-standard" + "latin:-*-Courier-*-*-*-*-10-*-*-*-*-*-iso10646-1") + ",") + "String of fontset spec of the standard fontset. +This defines a fontset consisting of the Courier and other fonts. +See the documentation of `create-fontset-from-fontset-spec' for the format.") + + +;;;; Pasteboard support. + +(define-obsolete-function-alias 'pgtk-store-cut-buffer-internal + 'gui-set-selection "24.1") + + +(defun pgtk-copy-including-secondary () + (interactive) + (call-interactively 'kill-ring-save) + (gui-set-selection 'SECONDARY (buffer-substring (point) (mark t)))) + +(defun pgtk-paste-secondary () + (interactive) + (insert (gui-get-selection 'SECONDARY))) + + +(defun pgtk-suspend-error () + ;; Don't allow suspending if any of the frames are PGTK frames. + (if (memq 'pgtk (mapcar 'window-system (frame-list))) + (error "Cannot suspend Emacs while a PGTK GUI frame exists"))) + + + +(defvar pgtk-initialized nil + "Non-nil if pure-GTK windowing has been initialized.") + +(declare-function x-handle-args "common-win" (args)) +(declare-function x-open-connection "pgtkfns.c" + (display &optional xrm-string must-succeed)) +(declare-function pgtk-set-resource "pgtkfns.c" (owner name value)) + +;; Do the actual pure-GTK Windows setup here; the above code just +;; defines functions and variables that we use now. +(cl-defmethod window-system-initialization (&context (window-system pgtk) + &optional display) + "Initialize Emacs for pure-GTK windowing." + (cl-assert (not pgtk-initialized)) + + ;; PENDING: not needed? + (setq command-line-args (x-handle-args command-line-args)) + + ;; Make sure we have a valid resource name. + (or (stringp x-resource-name) + (let (i) + (setq x-resource-name (copy-sequence invocation-name)) + + ;; Change any . or * characters in x-resource-name to hyphens, + ;; so as not to choke when we use it in X resource queries. + (while (setq i (string-match "[.*]" x-resource-name)) + (aset x-resource-name i ?-)))) + + ;; Setup the default fontset. + (create-default-fontset) + ;; Create the standard fontset. + (condition-case err + (create-fontset-from-fontset-spec pgtk-standard-fontset-spec t) + (error (display-warning + 'initialization + (format "Creation of the standard fontset failed: %s" err) + :error))) + + (x-open-connection (or display + x-display-name) + x-command-line-resources + ;; Exit Emacs with fatal error if this fails and we + ;; are the initial display. + (= (length (frame-list)) 0)) + + (x-apply-session-resources) + + ;; Don't let Emacs suspend under PGTK. + (add-hook 'suspend-hook 'pgtk-suspend-error) + + (setq pgtk-initialized t)) + +;; Any display name is OK. +(add-to-list 'display-format-alist '(".*" . pgtk)) +(cl-defmethod handle-args-function (args &context (window-system pgtk)) + (x-handle-args args)) + +(cl-defmethod frame-creation-function (params &context (window-system pgtk)) + (x-create-frame-with-faces params)) + +(declare-function pgtk-own-selection-internal "pgtkselect.c" (selection value &optional frame)) +(declare-function pgtk-disown-selection-internal "pgtkselect.c" (selection &optional time_object terminal)) +(declare-function pgtk-selection-owner-p "pgtkselect.c" (&optional selection terminal)) +(declare-function pgtk-selection-exists-p "pgtkselect.c" (&optional selection terminal)) +(declare-function pgtk-get-selection-internal "pgtkselect.c" (selection-symbol target-type &optional time_stamp terminal)) + +(cl-defmethod gui-backend-set-selection (selection value + &context (window-system pgtk)) + (if value (pgtk-own-selection-internal selection value) + (pgtk-disown-selection-internal selection))) + +(cl-defmethod gui-backend-selection-owner-p (selection + &context (window-system pgtk)) + (pgtk-selection-owner-p selection)) + +(cl-defmethod gui-backend-selection-exists-p (selection + &context (window-system pgtk)) + (pgtk-selection-exists-p selection)) + +(cl-defmethod gui-backend-get-selection (selection-symbol target-type + &context (window-system pgtk)) + (pgtk-get-selection-internal selection-symbol target-type)) + + +(defvar pgtk-preedit-overlay nil) + +(defun pgtk-preedit-text (event) + "An internal function to display preedit text from input method. + +EVENT is an event of PGTK_PREEDIT_TEXT_EVENT. +It contains colors and texts." + (interactive "e") + (when pgtk-preedit-overlay + (delete-overlay pgtk-preedit-overlay)) + (setq pgtk-preedit-overlay nil) + + (let ((ovstr "") + (idx 0) + atts ov str color face-name) + (dolist (part (nth 1 event)) + (setq str (car part)) + (setq face-name (intern (format "pgtk-im-%d" idx))) + (eval + `(defface ,face-name nil "face of input method preedit")) + (setq atts nil) + (when (setq color (cdr-safe (assq 'fg (cdr part)))) + (setq atts (append atts `(:foreground ,color)))) + (when (setq color (cdr-safe (assq 'bg (cdr part)))) + (setq atts (append atts `(:background ,color)))) + (when (setq color (cdr-safe (assq 'ul (cdr part)))) + (setq atts (append atts `(:underline ,color)))) + (face-spec-set face-name `((t . ,atts))) + (add-text-properties 0 (length str) `(face ,face-name) str) + (setq ovstr (concat ovstr str)) + (setq idx (1+ idx))) + + (setq ov (make-overlay (point) (point))) + (overlay-put ov 'before-string ovstr) + (setq pgtk-preedit-overlay ov))) + + +(add-hook 'after-init-hook + (function + (lambda () + (when (eq window-system 'pgtk) + (pgtk-use-im-context pgtk-use-im-context-on-new-connection))))) + + +;;; + +(defcustom x-gtk-stock-map + (mapcar (lambda (arg) + (cons (purecopy (car arg)) (purecopy (cdr arg)))) + '( + ("etc/images/new" . ("document-new" "gtk-new")) + ("etc/images/open" . ("document-open" "gtk-open")) + ("etc/images/diropen" . "n:system-file-manager") + ("etc/images/close" . ("window-close" "gtk-close")) + ("etc/images/save" . ("document-save" "gtk-save")) + ("etc/images/saveas" . ("document-save-as" "gtk-save-as")) + ("etc/images/undo" . ("edit-undo" "gtk-undo")) + ("etc/images/cut" . ("edit-cut" "gtk-cut")) + ("etc/images/copy" . ("edit-copy" "gtk-copy")) + ("etc/images/paste" . ("edit-paste" "gtk-paste")) + ("etc/images/search" . ("edit-find" "gtk-find")) + ("etc/images/print" . ("document-print" "gtk-print")) + ("etc/images/preferences" . ("preferences-system" "gtk-preferences")) + ("etc/images/help" . ("help-browser" "gtk-help")) + ("etc/images/left-arrow" . ("go-previous" "gtk-go-back")) + ("etc/images/right-arrow" . ("go-next" "gtk-go-forward")) + ("etc/images/home" . ("go-home" "gtk-home")) + ("etc/images/jump-to" . ("go-jump" "gtk-jump-to")) + ("etc/images/index" . ("gtk-search" "gtk-index")) + ("etc/images/exit" . ("application-exit" "gtk-quit")) + ("etc/images/cancel" . "gtk-cancel") + ("etc/images/info" . ("dialog-information" "gtk-info")) + ("etc/images/bookmark_add" . "n:bookmark_add") + ;; Used in Gnus and/or MH-E: + ("etc/images/attach" . ("mail-attachment" "gtk-attach")) + ("etc/images/connect" . "gtk-connect") + ("etc/images/contact" . "gtk-contact") + ("etc/images/delete" . ("edit-delete" "gtk-delete")) + ("etc/images/describe" . ("document-properties" "gtk-properties")) + ("etc/images/disconnect" . "gtk-disconnect") + ;; ("etc/images/exit" . "gtk-exit") + ("etc/images/lock-broken" . "gtk-lock_broken") + ("etc/images/lock-ok" . "gtk-lock_ok") + ("etc/images/lock" . "gtk-lock") + ("etc/images/next-page" . "gtk-next-page") + ("etc/images/refresh" . ("view-refresh" "gtk-refresh")) + ("etc/images/search-replace" . "edit-find-replace") + ("etc/images/sort-ascending" . ("view-sort-ascending" "gtk-sort-ascending")) + ("etc/images/sort-column-ascending" . "gtk-sort-column-ascending") + ("etc/images/sort-criteria" . "gtk-sort-criteria") + ("etc/images/sort-descending" . ("view-sort-descending" + "gtk-sort-descending")) + ("etc/images/sort-row-ascending" . "gtk-sort-row-ascending") + ("etc/images/spell" . ("tools-check-spelling" "gtk-spell-check")) + ("images/gnus/toggle-subscription" . "gtk-task-recurring") + ("images/mail/compose" . ("mail-message-new" "gtk-mail-compose")) + ("images/mail/copy" . "gtk-mail-copy") + ("images/mail/forward" . "gtk-mail-forward") + ("images/mail/inbox" . "gtk-inbox") + ("images/mail/move" . "gtk-mail-move") + ("images/mail/not-spam" . "gtk-not-spam") + ("images/mail/outbox" . "gtk-outbox") + ("images/mail/reply-all" . "gtk-mail-reply-to-all") + ("images/mail/reply" . "gtk-mail-reply") + ("images/mail/save-draft" . "gtk-mail-handling") + ("images/mail/send" . ("mail-send" "gtk-mail-send")) + ("images/mail/spam" . "gtk-spam") + ;; Used for GDB Graphical Interface + ("images/gud/break" . "gtk-no") + ("images/gud/recstart" . ("media-record" "gtk-media-record")) + ("images/gud/recstop" . ("media-playback-stop" "gtk-media-stop")) + ;; No themed versions available: + ;; mail/preview (combining stock_mail and stock_zoom) + ;; mail/save (combining stock_mail, stock_save and stock_convert) + )) + "How icons for tool bars are mapped to Gtk+ stock items. +Emacs must be compiled with the Gtk+ toolkit for this to have any effect. +A value that begins with n: denotes a named icon instead of a stock icon." + :version "22.2" + :type '(choice (repeat + (choice symbol + (cons (string :tag "Emacs icon") + (choice (group (string :tag "Named") + (string :tag "Stock")) + (string :tag "Stock/named")))))) + :group 'pgtk) + +(defcustom icon-map-list '(x-gtk-stock-map) + "A list of alists that map icon file names to stock/named icons. +The alists are searched in the order they appear. The first match is used. +The keys in the alists are file names without extension and with two directory +components. For example, to map /usr/share/emacs/22.1.1/etc/images/open.xpm +to stock item gtk-open, use: + + (\"etc/images/open\" . \"gtk-open\") + +Themes also have named icons. To map to one of those, use n: before the name: + + (\"etc/images/diropen\" . \"n:system-file-manager\") + +The list elements are either the symbol name for the alist or the +alist itself. + +If you don't want stock icons, set the variable to nil." + :version "22.2" + :type '(choice (const :tag "Don't use stock icons" nil) + (repeat (choice symbol + (cons (string :tag "Emacs icon") + (string :tag "Stock/named"))))) + :group 'pgtk) + +(defconst x-gtk-stock-cache (make-hash-table :weakness t :test 'equal)) + +(defun x-gtk-map-stock (file) + "Map icon with file name FILE to a Gtk+ stock name. +This uses `icon-map-list' to map icon file names to stock icon names." + (when (stringp file) + (or (gethash file x-gtk-stock-cache) + (puthash + file + (save-match-data + (let* ((file-sans (file-name-sans-extension file)) + (key (and (string-match "/\\([^/]+/[^/]+/[^/]+$\\)" + file-sans) + (match-string 1 file-sans))) + (icon-map icon-map-list) + elem value) + (while (and (null value) icon-map) + (setq elem (car icon-map) + value (assoc-string (or key file-sans) + (if (symbolp elem) + (symbol-value elem) + elem)) + icon-map (cdr icon-map))) + (and value (cdr value)))) + x-gtk-stock-cache)))) + +(declare-function accelerate-menu "pgtkmenu.c" (&optional frame) t) + +(defun pgtk-menu-bar-open (&optional frame) + "Open the menu bar if it is shown. +`popup-menu' is used if it is off." + (interactive "i") + (cond + ((and (not (zerop (or (frame-parameter nil 'menu-bar-lines) 0))) + (fboundp 'accelerate-menu)) + (accelerate-menu frame)) + (t + (popup-menu (mouse-menu-bar-map) last-nonmenu-event)))) + +(provide 'pgtk-win) +(provide 'term/pgtk-win) + +;;; pgtk-win.el ends here diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el index 5d1dc606676..0ee010b6c87 100644 --- a/lisp/term/w32-win.el +++ b/lisp/term/w32-win.el @@ -274,6 +274,8 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") '(gif "libgif-6.dll" "giflib5.dll" "gif.dll") '(gif "libgif-5.dll" "giflib4.dll" "libungif4.dll" "libungif.dll"))) '(svg "librsvg-2-2.dll") + '(webp "libwebp-7.dll" "libwebp.dll") + '(sqlite3 "libsqlite3-0.dll") '(gdk-pixbuf "libgdk_pixbuf-2.0-0.dll") '(glib "libglib-2.0-0.dll") '(gio "libgio-2.0-0.dll") diff --git a/lisp/textmodes/artist.el b/lisp/textmodes/artist.el index c42286e5bc3..9c9ef9fb634 100644 --- a/lisp/textmodes/artist.el +++ b/lisp/textmodes/artist.el @@ -338,7 +338,8 @@ Example: (defvar artist-pointer-shape (if (eq window-system 'x) x-pointer-crosshair nil) "If in X Windows, use this pointer shape while drawing with the mouse.") -(defvaralias 'artist-text-renderer 'artist-text-renderer-function) +(define-obsolete-variable-alias 'artist-text-renderer + 'artist-text-renderer-function "29.1") (defcustom artist-text-renderer-function 'artist-figlet "Function for doing text rendering." @@ -2840,9 +2841,8 @@ Returns a list of strings." (if (memq system-type '(windows-nt ms-dos)) (artist-figlet-get-font-list-windows) (artist-figlet-get-font-list))) - (font (completing-read (concat "Select font (default " - artist-figlet-default-font - "): ") + (font (completing-read (format-prompt "Select font" + artist-figlet-default-font) (mapcar (lambda (font) (cons font font)) avail-fonts)))) diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el index 237a1d99353..c721c035d7c 100644 --- a/lisp/textmodes/bibtex.el +++ b/lisp/textmodes/bibtex.el @@ -839,6 +839,24 @@ for a new entry." ("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4) ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5) ("url") ("urldate"))) + ("PhdThesis" "PhD Thesis" + (("author") + ("title" "Title of the PhD thesis") + ("school" "School where the PhD thesis was written") + ("year")) + nil + (("type" "Type of the PhD thesis") + ("address" "Address of the school (if not part of field \"school\") or country") + ("month") ("note"))) + ("TechReport" "Technical Report" + (("author") + ("title" "Title of the technical report (BibTeX converts it to lowercase)") + ("institution" "Sponsoring institution of the report") + ("year")) + nil + (("type" "Type of the report (if other than \"technical report\")") + ("number" "Number of the technical report") + ("address") ("month") ("note"))) ("Unpublished" "Unpublished" (("author") ("title") ("date" nil nil 1) ("year" nil nil -1)) nil @@ -1193,8 +1211,8 @@ See `bibtex-generate-autokey' for details." :type '(repeat (cons (regexp :tag "Old") (string :tag "New")))) -(defvaralias 'bibtex-autokey-name-case-convert - 'bibtex-autokey-name-case-convert-function) +(define-obsolete-variable-alias 'bibtex-autokey-name-case-convert + 'bibtex-autokey-name-case-convert-function "29.1") (defcustom bibtex-autokey-name-case-convert-function #'downcase "Function called for each name to perform case conversion. @@ -1268,8 +1286,8 @@ Case is significant. See `bibtex-generate-autokey' for details." :group 'bibtex-autokey :type '(repeat regexp)) -(defvaralias 'bibtex-autokey-titleword-case-convert - 'bibtex-autokey-titleword-case-convert-function) +(define-obsolete-variable-alias 'bibtex-autokey-titleword-case-convert + 'bibtex-autokey-titleword-case-convert-function "29.1") (defcustom bibtex-autokey-titleword-case-convert-function #'downcase "Function called for each titleword to perform case conversion. @@ -4317,8 +4335,6 @@ for a crossref key, t otherwise." (eqb (goto-char pos)) (t (set-buffer buffer) (goto-char pos))) pos)) -;; backward compatibility -(defalias 'bibtex-find-crossref 'bibtex-search-crossref) (defun bibtex-dist (pos beg end) "Return distance between POS and region delimited by BEG and END." @@ -4381,8 +4397,6 @@ A prefix arg negates the value of `bibtex-search-entry-globally'." (if display (bibtex-reposition-window))) (display (message "Key `%s' not found" key))) pnt))) -;; backward compatibility -(defalias 'bibtex-find-entry 'bibtex-search-entry) (defun bibtex-prepare-new-entry (index) "Prepare a new BibTeX entry with index INDEX. @@ -5608,5 +5622,8 @@ If APPEND is non-nil, append ENTRIES to those already displayed." (setq buffer-read-only t) (goto-char (point-min))) +(define-obsolete-function-alias 'bibtex-find-crossref #'bibtex-search-crossref "29.1") +(define-obsolete-function-alias 'bibtex-find-entry #'bibtex-search-entry "29.1") + (provide 'bibtex) ;;; bibtex.el ends here diff --git a/lisp/textmodes/etc-authors-mode.el b/lisp/textmodes/etc-authors-mode.el index 8b5fefd3b7d..a79a1ecf4bb 100644 --- a/lisp/textmodes/etc-authors-mode.el +++ b/lisp/textmodes/etc-authors-mode.el @@ -115,12 +115,10 @@ With a prefix arg ARG, move point that many authors backward." (interactive "p" etc-authors-mode) (etc-authors-next-author (- arg))) -(defvar etc-authors-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "n" #'etc-authors-next-author) - (define-key map "p" #'etc-authors-prev-author) - map) - "Keymap for `etc-authors-mode'.") +(defvar-keymap etc-authors-mode-map + :doc "Keymap for `etc-authors-mode'." + "n" #'etc-authors-next-author + "p" #'etc-authors-prev-author) ;;;###autoload (define-derived-mode etc-authors-mode special-mode "Authors View" diff --git a/lisp/textmodes/fill.el b/lisp/textmodes/fill.el index decce88573b..4e161099cd6 100644 --- a/lisp/textmodes/fill.el +++ b/lisp/textmodes/fill.el @@ -396,12 +396,8 @@ and `fill-nobreak-invisible'." (save-excursion (skip-chars-backward " ") (and (eq (preceding-char) ?.) - (looking-at " \\([^ ]\\|$\\)")))) - ;; Another approach to the same problem. - (save-excursion - (skip-chars-backward " ") - (and (eq (preceding-char) ?.) - (not (progn (forward-char -1) (looking-at (sentence-end)))))) + ;; There's something more after the space. + (looking-at " [^ \n]")))) ;; Don't split a line if the rest would look like a new paragraph. (unless use-hard-newlines (save-excursion @@ -709,7 +705,10 @@ space does not end a sentence, so don't break a line there." (goto-char from-plus-indent)) (if (not (> to (point))) - nil ;; There is no paragraph, only whitespace: exit now. + ;; There is no paragraph, only whitespace: exit now. + (progn + (set-marker to nil) + nil) (or justify (setq justify (current-justification))) @@ -795,6 +794,7 @@ space does not end a sentence, so don't break a line there." ;; Leave point after final newline. (goto-char to) (unless (eobp) (forward-char 1)) + (set-marker to nil) ;; Return the fill-prefix we used fill-prefix))) diff --git a/lisp/textmodes/flyspell.el b/lisp/textmodes/flyspell.el index 258e5fde674..2a9cae29f79 100644 --- a/lisp/textmodes/flyspell.el +++ b/lisp/textmodes/flyspell.el @@ -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/glyphless-mode.el b/lisp/textmodes/glyphless-mode.el new file mode 100644 index 00000000000..177ba42c9c8 --- /dev/null +++ b/lisp/textmodes/glyphless-mode.el @@ -0,0 +1,68 @@ +;;; glyphless-mode.el --- minor mode for displaying glyphless characters -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; Maintainer: emacs-devel@gnu.org + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(defcustom glyphless-mode-types '(all) + "Which glyphless characters to display. +The value can be any of the groups supported by +`glyphless-char-display-control' (which see), and in addition +`all', for all glyphless characters." + :version "29.1" + :type '(repeat (choice (const :tag "All" all) + (const :tag "No font" no-font) + (const :tag "C0 Control" c0-control) + (const :tag "C1 Control" c1-control) + (const :tag "Format Control" format-control) + (const :tag "Bidirectional Control" bidi-control) + (const :tag "Variation Selectors" variation-selectors) + (const :tag "No Font" no-font))) + :group 'display) + +;;;###autoload +(define-minor-mode glyphless-display-mode + "Minor mode for displaying glyphless characters in the current buffer. +If enabled, all glyphless characters will be displayed as boxes +that display their acronyms." + :lighter " Glyphless" + (if glyphless-display-mode + (progn + (setq-local glyphless-char-display + (let ((table (make-display-table))) + (set-char-table-parent table glyphless-char-display) + table)) + (glyphless-mode--setup)) + (kill-local-variable 'glyphless-char-display))) + +(defun glyphless-mode--setup () + (let ((types (if (memq 'all glyphless-mode-types) + '(c0-control c1-control format-control + variation-selectors no-font) + glyphless-mode-types))) + (when types + (update-glyphless-char-display + nil (mapcar (lambda (e) (cons e 'acronym)) types))))) + +(provide 'glyphless-mode) + +;;; glyphless-mode.el ends here diff --git a/lisp/textmodes/ispell.el b/lisp/textmodes/ispell.el index 0a3a49d868a..c4dd452c0df 100644 --- a/lisp/textmodes/ispell.el +++ b/lisp/textmodes/ispell.el @@ -296,7 +296,8 @@ The following values are supported: "Non-nil means suppress messages in `ispell-word'." :type 'boolean) -(defvaralias 'ispell-format-word 'ispell-format-word-function) +(define-obsolete-variable-alias 'ispell-format-word + 'ispell-format-word-function "29.1") (defcustom ispell-format-word-function (function upcase) "Formatting function for displaying word being spell checked. @@ -2398,24 +2399,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 +2429,28 @@ SPC: Accept word this time. ;;(if (< (window-height) 15) ;; (enlarge-window ;; (- 15 (ispell-adjusted-window-height)))) - (princ "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.") + (princ + (substitute-command-keys + "Selections are: + +\\`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 +3886,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: @@ -3975,7 +3978,7 @@ You can bind this to the key C-c i in GNUS or mail by adding to (if (re-search-forward "^Subject: *" end-of-headers t) (progn (goto-char (match-end 0)) - (if (and (not (looking-at ".*Re\\>")) + (if (and (not (looking-at ".*\\<Re\\>")) (not (looking-at "\\["))) (progn (setq case-fold-search old-case-fold-search) diff --git a/lisp/textmodes/paragraphs.el b/lisp/textmodes/paragraphs.el index 59b15e82a81..788230141e7 100644 --- a/lisp/textmodes/paragraphs.el +++ b/lisp/textmodes/paragraphs.el @@ -479,18 +479,38 @@ sentences. Also, every paragraph boundary terminates sentences as well." (setq arg (1- arg))) (constrain-to-field nil opoint t))) -(defun repunctuate-sentences (&optional no-query) +(defun repunctuate-sentences-filter (_start _end) + "Search filter used by `repunctuate-sentences' to skip unneeded spaces. +By default, it skips occurrences that already have two spaces. +It is advised to put `advice-add' on this function to add more filters, +for example, `(looking-back (rx (or \"e.g.\" \"i.e.\") \" \") 5)' +with a set of predefined abbreviations to skip from adding two spaces." + (not (length= (match-string 4) 2))) + +(defun repunctuate-sentences (&optional no-query start end) "Put two spaces at the end of sentences from point to the end of buffer. -It works using `query-replace-regexp'. +It works using `query-replace-regexp'. In Transient Mark mode, +if the mark is active, operate on the contents of the region. +Second and third arg START and END specify the region to operate on. If optional argument NO-QUERY is non-nil, make changes without asking for confirmation." - (interactive) - (let ((regexp "\\([]\"')]?\\)\\([.?!]\\)\\([]\"')]?\\) +") + (interactive (list nil + (if (use-region-p) (region-beginning)) + (if (use-region-p) (region-end)))) + (let ((regexp "\\([]\"')]?\\)\\([.?!]\\)\\([]\"')]?\\)\\( +\\)") (to-string "\\1\\2\\3 ")) (if no-query - (while (re-search-forward regexp nil t) - (replace-match to-string)) - (query-replace-regexp regexp to-string)))) + (progn + (when start (goto-char start)) + (while (re-search-forward regexp end t) + (replace-match to-string))) + (unwind-protect + (progn + (add-function :after-while isearch-filter-predicate + #'repunctuate-sentences-filter) + (query-replace-regexp regexp to-string nil start end)) + (remove-function isearch-filter-predicate + #'repunctuate-sentences-filter))))) (defun backward-sentence (&optional arg) diff --git a/lisp/textmodes/pixel-fill.el b/lisp/textmodes/pixel-fill.el new file mode 100644 index 00000000000..0a0f0eb8b66 --- /dev/null +++ b/lisp/textmodes/pixel-fill.el @@ -0,0 +1,240 @@ +;;; pixel-fill.el --- variable pitch filling functions -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; Maintainer: emacs-devel@gnu.org +;; Keywords: filling + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; The main entry point is `pixel-fill-region', but +;; `pixel-fill-find-fill-point' can also be useful by itself. + +;;; Code: + +(require 'kinsoku) + +(defgroup pixel-fill nil + "Filling based on pixel widths." + :group 'fill + :version "29.1") + +(defcustom pixel-fill-respect-kinsoku t + "If nil, fill even if we can't find a good kinsoku point. +Kinsoku is a Japanese word meaning a rule that should not be violated. +In Emacs, it is a term used for characters, e.g. punctuation marks, +parentheses, and so on, that should not be placed in the beginning +of a line or the end of a line." + :type 'boolean + :version "29.1") + +(defun pixel-fill-width (&optional columns window) + "Return the pixel width corresponding to COLUMNS in WINDOW. +If COLUMNS in nil, use the enture window width. + +If WINDOW is nil, this defaults to the current window." + (unless window + (setq window (selected-window))) + (let ((frame (window-frame window))) + (if columns + (* (frame-char-width frame) columns) + (- (window-body-width nil t) + (* 2 (frame-char-width frame)) + ;; We need to adjust the available width for when the user + ;; disables the fringes, which will cause the display + ;; engine usurp one column for the continuation glyph. + (if (and (fboundp 'fringe-columns) + (or (not (zerop (fringe-columns 'right))) + (not (zerop (fringe-columns 'left))))) + 0 + (* (frame-char-width frame) 2)) + 1)))) + +(defun pixel-fill-region (start end pixel-width) + "Fill the region between START and END. +This will attempt to reformat the text in the region to have no +lines that are visually wider than PIXEL-WIDTH. + +If START isn't at the start of a line, the horizontal position of +START, converted to pixel units, will be used as the indentation +prefix on subsequent lines." + (save-excursion + (goto-char start) + (let ((indentation + (car (window-text-pixel-size nil (line-beginning-position) + (point)))) + (newline-end nil)) + (when (> indentation pixel-width) + (error "The indentation (%s) is wider than the fill width (%s)" + indentation pixel-width)) + (save-restriction + (narrow-to-region start end) + (goto-char (point-max)) + (when (looking-back "\n[ \t]*" (point-min)) + (setq newline-end t)) + (goto-char (point-min)) + ;; First replace all whitespace with space. + (while (re-search-forward "[ \t\n]+" nil t) + (cond + ((or (= (match-beginning 0) start) + (= (match-end 0) end)) + (delete-region (match-beginning 0) (match-end 0))) + ;; If there's just a single space here, don't replace. + ((not (and (= (- (match-end 0) (match-beginning 0)) 1) + (= (char-after (match-beginning 0)) ?\s))) + (replace-match + ;; We need to use a space that has an appropriate width. + (propertize " " 'face + (get-text-property (match-beginning 0) 'face)))))) + (goto-char start) + (pixel-fill--fill-line pixel-width indentation) + (goto-char (point-max)) + (when newline-end + (insert "\n")))))) + +(defun pixel-fill--goto-pixel (width) + (vertical-motion (cons (/ width (frame-char-width)) 0))) + +(defun pixel-fill--fill-line (width &optional indentation) + (let ((start (point))) + (pixel-fill--goto-pixel width) + (while (not (eolp)) + ;; We have to do some folding. First find the first previous + ;; point suitable for folding. + (when (or (not (pixel-fill-find-fill-point (line-beginning-position))) + (= (point) start)) + ;; We had unbreakable text (for this width), so just go to + ;; the first space and carry on. + (beginning-of-line) + (skip-chars-forward " ") + (search-forward " " (line-end-position) 'move)) + (when (= (preceding-char) ?\s) + (delete-char -1)) + (unless (eobp) + (insert ?\n) + (when (> indentation 0) + (insert (propertize " " 'display + (list 'space :align-to (list indentation)))))) + (setq start (point)) + (unless (eobp) + (pixel-fill--goto-pixel width))))) + +(define-inline pixel-fill--char-breakable-p (char) + "Return non-nil if a line can be broken before and after CHAR." + (inline-quote (aref fill-find-break-point-function-table ,char))) + +(define-inline pixel-fill--char-nospace-p (char) + "Return non-nil if no space is required before and after CHAR." + (inline-quote (aref fill-nospace-between-words-table ,char))) + +(define-inline pixel-fill--char-kinsoku-bol-p (char) + "Return non-nil if a line ought not to begin with CHAR." + (inline-letevals (char) + (inline-quote (and (not (eq ,char ?')) + (aref (char-category-set ,char) ?>))))) + +(define-inline pixel-fill--char-kinsoku-eol-p (char) + "Return non-nil if a line ought not to end with CHAR." + (inline-quote (aref (char-category-set ,char) ?<))) + +(defun pixel-fill-find-fill-point (start) + "Find a place suitable for breaking the current line. +START should be the earliest buffer position that should be considered +(typically the start of the line), and this function will search +backward in the current buffer from the current position." + (let ((bp (point)) + (end (point)) + failed) + (while (not + (or (setq failed (<= (point) start)) + (eq (preceding-char) ?\s) + (eq (following-char) ?\s) + (pixel-fill--char-breakable-p (preceding-char)) + (pixel-fill--char-breakable-p (following-char)) + (and (pixel-fill--char-kinsoku-bol-p (preceding-char)) + (pixel-fill--char-breakable-p (following-char)) + (not (pixel-fill--char-kinsoku-bol-p (following-char)))) + (pixel-fill--char-kinsoku-eol-p (following-char)) + (bolp))) + (backward-char 1)) + (if failed + ;; There's no breakable point, so we give it up. + (let (found) + (goto-char bp) + ;; Don't overflow the window edge, even if + ;; `pixel-fill-respect-kinsoku' is t. + (when pixel-fill-respect-kinsoku + (while (setq found (re-search-forward + "\\(\\c>\\)\\| \\|\\c<\\|\\c|" + (line-end-position) 'move))) + (if (and found + (not (match-beginning 1))) + (goto-char (match-beginning 0))))) + (or + (eolp) + ;; Don't put kinsoku-bol characters at the beginning of a line, + ;; or kinsoku-eol characters at the end of a line. + (cond + ;; Don't overflow the window edge, even if `pixel-fill-respect-kinsoku' + ;; is t. + ((not pixel-fill-respect-kinsoku) + (while (and (not (eq (preceding-char) ?\s)) + (or (pixel-fill--char-kinsoku-eol-p (preceding-char)) + (pixel-fill--char-kinsoku-bol-p (following-char)))) + (backward-char 1)) + (when (setq failed (<= (point) start)) + ;; There's no breakable point that doesn't violate kinsoku, + ;; so we look for the second best position. + (while (and (progn + (forward-char 1) + (<= (point) end)) + (progn + (setq bp (point)) + (pixel-fill--char-kinsoku-eol-p (following-char))))) + (goto-char bp))) + ((pixel-fill--char-kinsoku-eol-p (preceding-char)) + ;; Find backward the point where kinsoku-eol characters begin. + (let ((count 4)) + (while + (progn + (backward-char 1) + (and (> (setq count (1- count)) 0) + (not (eq (preceding-char) ?\s)) + (or (pixel-fill--char-kinsoku-eol-p (preceding-char)) + (pixel-fill--char-kinsoku-bol-p (following-char))))))) + (when (setq failed (<= (point) start)) + ;; There's no breakable point that doesn't violate kinsoku, + ;; so we go to the second best position. + (if (looking-at "\\(\\c<+\\)\\c<") + (goto-char (match-end 1)) + (forward-char 1)))) + ((pixel-fill--char-kinsoku-bol-p (following-char)) + ;; Find forward the point where kinsoku-bol characters end. + (let ((count 4)) + (while (progn + (forward-char 1) + (and (>= (setq count (1- count)) 0) + (pixel-fill--char-kinsoku-bol-p (following-char)) + (pixel-fill--char-breakable-p (following-char)))))))) + (when (eq (following-char) ?\s) + (forward-char 1)))) + (not failed))) + +(provide 'pixel-fill) + +;;; pixel-fill.el ends here 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-parse.el b/lisp/textmodes/reftex-parse.el index c521a07f192..b8c75cb21b6 100644 --- a/lisp/textmodes/reftex-parse.el +++ b/lisp/textmodes/reftex-parse.el @@ -345,7 +345,17 @@ of master file." ;; Find external document specifications (goto-char 1) - (while (re-search-forward "[\n\r][ \t]*\\\\externaldocument\\(\\[\\([^]]*\\)\\]\\)?{\\([^}]+\\)}" nil t) + (while (re-search-forward + (concat "[\n\r][ \t]*" + ;; Support \externalcitedocument macro + "\\\\external\\(?:cite\\)?document" + ;; The optional prefix + "\\(\\[\\([^]]*\\)\\]\\)?" + ;; The 2nd opt. arg can only be nocite + "\\(?:\\[nocite\\]\\)?" + ;; Mandatory file argument + "{\\([^}]+\\)}") + nil t) (push (list 'xr-doc (reftex-match-string 2) (reftex-match-string 3)) docstruct)) diff --git a/lisp/textmodes/reftex-vars.el b/lisp/textmodes/reftex-vars.el index d57a7678553..dedd74607ae 100644 --- a/lisp/textmodes/reftex-vars.el +++ b/lisp/textmodes/reftex-vars.el @@ -70,12 +70,16 @@ ("tabwindow" ?f nil nil 1))) (rotating "Sidewaysfigure and table" - (("sidewaysfigure" ?f nil nil caption) - ("sidewaystable" ?t nil nil caption))) + (("sidewaysfigure" ?f nil nil caption) + ("sidewaysfigure*" ?f nil nil caption) + ("sidewaystable" ?t nil nil caption) + ("sidewaystable*" ?t nil nil caption))) - (sidecap "CSfigure and SCtable" - (("SCfigure" ?f nil nil caption) - ("SCtable" ?t nil nil caption))) + (sidecap "SCfigure and SCtable" + (("SCfigure" ?f nil nil caption) + ("SCfigure*" ?f nil nil caption) + ("SCtable" ?t nil nil caption) + ("SCtable*" ?t nil nil caption))) (subfigure "Subfigure environments/macro" (("subfigure" ?f nil nil caption) @@ -392,19 +396,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 +426,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 +1631,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 +1867,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 +1917,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 +1969,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/textmodes/sgml-mode.el b/lisp/textmodes/sgml-mode.el index 7ef8161ab5c..3acf0e8965c 100644 --- a/lisp/textmodes/sgml-mode.el +++ b/lisp/textmodes/sgml-mode.el @@ -75,7 +75,8 @@ a DOCTYPE or an XML declaration." :type 'boolean :version "22.1") -(defvaralias 'sgml-transformation 'sgml-transformation-function) +(define-obsolete-variable-alias 'sgml-transformation + 'sgml-transformation-function "29.1") (defcustom sgml-transformation-function 'identity "Default value for `skeleton-transformation-function' in SGML mode." @@ -440,7 +441,8 @@ These have to be run via `sgml-syntax-propertize'")) ;; internal (defvar sgml-face-tag-alist () - "Alist of face and tag name for facemenu.") + "Alist of face and tag name for facemenu. +The tag name can be a string or a list of strings.") (defvar sgml-tag-face-alist () "Tag names and face or list of faces to fontify with when invisible. @@ -528,11 +530,13 @@ an optional alist of possible values." (comment-indent-new-line soft))) (defun sgml-mode-facemenu-add-face-function (face _end) - (let ((tag-face (cdr (assq face sgml-face-tag-alist)))) + "Add \"face\" tags with `facemenu-keymap' commands." + (let ((tag-face (ensure-list (cdr (assq face sgml-face-tag-alist))))) (cond (tag-face (setq tag-face (funcall skeleton-transformation-function tag-face)) - (setq facemenu-end-add-face (concat "</" tag-face ">")) - (concat "<" tag-face ">")) + (setq facemenu-end-add-face + (mapconcat (lambda (f) (concat "</" f ">")) (reverse tag-face) "")) + (mapconcat (lambda (f) (concat "<" f ">")) tag-face "")) ((and (consp face) (consp (car face)) (null (cdr face)) @@ -620,6 +624,7 @@ Do \\[describe-key] on the following bindings to discover what they do. (setq-local comment-indent-function 'sgml-comment-indent) (setq-local comment-line-break-function 'sgml-comment-indent-new-line) (setq-local skeleton-further-elements '((completion-ignore-case t))) + (setq-local skeleton-end-newline nil) (setq-local skeleton-end-hook (lambda () (or (eolp) @@ -1868,6 +1873,7 @@ This takes effect when first loading the library.") (defvar html-face-tag-alist '((bold . "strong") (italic . "em") + (bold-italic . ("strong" "em")) (underline . "u") (mode-line . "rev")) "Value of `sgml-face-tag-alist' for HTML mode.") @@ -2411,6 +2417,8 @@ To work around that, do: (setq-local css-id-list-function #'html-current-buffer-ids)) (setq imenu-create-index-function 'html-imenu-index) + (yank-media-handler 'text/html #'html-mode--html-yank-handler) + (yank-media-handler "image/.*" #'html-mode--image-yank-handler) (setq-local sgml-empty-tags ;; From HTML-4.01's loose.dtd, parsed with @@ -2426,6 +2434,30 @@ To work around that, do: ;; (setq imenu-sort-function nil) ; sorting the menu defeats the purpose ) +(defun html-mode--html-yank-handler (_type html) + (save-restriction + (insert html) + (ignore-errors + (sgml-pretty-print (point-min) (point-max))))) + +(defun html-mode--image-yank-handler (type image) + (let ((file (read-file-name (format "Save %s image to: " type)))) + (when (file-directory-p file) + (user-error "%s is a directory")) + (when (and (file-exists-p file) + (not (yes-or-no-p (format "%s exists; overwrite?" file)))) + (user-error "%s exists")) + (with-temp-buffer + (set-buffer-multibyte nil) + (insert image) + (write-region (point-min) (point-max) file)) + (insert (format "<img src=%S>\n" (file-relative-name file))) + (insert-image + (create-image file (mailcap-mime-type-to-extension type) nil + :max-width 200 + :max-height 200) + " "))) + (defvar html-imenu-regexp "\\s-*<h\\([1-9]\\)[^\n<>]*>\\(<[^\n<>]*>\\)*\\s-*\\([^\n<>]*\\)" "A regular expression matching a head line to be added to the menu. diff --git a/lisp/textmodes/table.el b/lisp/textmodes/table.el index fef5ad2c7ac..ca99d562e40 100644 --- a/lisp/textmodes/table.el +++ b/lisp/textmodes/table.el @@ -1195,6 +1195,21 @@ executing body forms.") (easy-menu-add-item (current-global-map) '("menu-bar" "tools") table-global-menu-map) +;;;###autoload +(define-minor-mode table-fixed-width-mode + "Cell width is fixed when this is non-nil. +Normally it should be nil for allowing automatic cell width expansion +that widens a cell when it is necessary. When non-nil, typing in a +cell does not automatically expand the cell width. A word that is too +long to fit in a cell is chopped into multiple lines. The chopped +location is indicated by `table-word-continuation-char'. This +variable's value can be toggled by \\[table-fixed-width-mode] at +run-time." + :tag "Fix Cell Width" + :group 'table + (table--finish-delayed-tasks) + (table--update-cell-face)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Macros @@ -1219,43 +1234,49 @@ original buffer's point is moved to the location that corresponds to the last cache point coordinate." (declare (debug (body)) (indent 0)) (let ((height-expansion (make-symbol "height-expansion-var-symbol")) - (width-expansion (make-symbol "width-expansion-var-symbol"))) - `(let (,height-expansion ,width-expansion) + (width-expansion (make-symbol "width-expansion-var-symbol")) + (fixed-width (make-symbol "fixed-width"))) + `(let ((,fixed-width table-fixed-width-mode) + ,height-expansion ,width-expansion) ;; make sure cache has valid data unless it is explicitly inhibited. (unless table-inhibit-update (table-recognize-cell)) (with-current-buffer (get-buffer-create table-cache-buffer-name) - ;; goto the cell coordinate based on `table-cell-cache-point-coordinate'. - (set-mark (table--goto-coordinate table-cell-cache-mark-coordinate)) - (table--goto-coordinate table-cell-cache-point-coordinate) - (table--untabify-line) - ;; always reset before executing body forms because auto-fill behavior is the default. - (setq table-inhibit-auto-fill-paragraph nil) - ;; do the body - ,@body - ;; fill paragraph unless the body does not want to by setting `table-inhibit-auto-fill-paragraph'. - (unless table-inhibit-auto-fill-paragraph - (if (and table-cell-info-justify - (not (eq table-cell-info-justify 'left))) - (table--fill-region (point-min) (point-max)) - (table--fill-region - (save-excursion (forward-paragraph -1) (point)) - (save-excursion (forward-paragraph 1) (point))))) - ;; keep the updated cell coordinate. - (setq table-cell-cache-point-coordinate (table--get-coordinate)) - ;; determine the cell width expansion. - (setq ,width-expansion (table--measure-max-width)) - (if (<= ,width-expansion table-cell-info-width) nil - (table--fill-region (point-min) (point-max) ,width-expansion) - ;; keep the updated cell coordinate. - (setq table-cell-cache-point-coordinate (table--get-coordinate))) - (setq ,width-expansion (- ,width-expansion table-cell-info-width)) - ;; determine the cell height expansion. - (if (looking-at "\\s *\\'") nil - (goto-char (point-min)) - (if (re-search-forward "\\(\\s *\\)\\'" nil t) - (goto-char (match-beginning 1)))) - (setq ,height-expansion (- (cdr (table--get-coordinate)) (1- table-cell-info-height)))) + (let ((table-fixed-width-mode ,fixed-width)) + ;; Go to the cell coordinate based on + ;; `table-cell-cache-point-coordinate'. + (set-mark (table--goto-coordinate table-cell-cache-mark-coordinate)) + (table--goto-coordinate table-cell-cache-point-coordinate) + (table--untabify-line) + ;; Always reset before executing body forms because + ;; auto-fill behavior is the default. + (setq table-inhibit-auto-fill-paragraph nil) + ;; Do the body + ,@body + ;; Fill paragraph unless the body does not want to by + ;; setting `table-inhibit-auto-fill-paragraph'. + (unless table-inhibit-auto-fill-paragraph + (if (and table-cell-info-justify + (not (eq table-cell-info-justify 'left))) + (table--fill-region (point-min) (point-max)) + (table--fill-region + (save-excursion (forward-paragraph -1) (point)) + (save-excursion (forward-paragraph 1) (point))))) + ;; Keep the updated cell coordinate. + (setq table-cell-cache-point-coordinate (table--get-coordinate)) + ;; Determine the cell width expansion. + (setq ,width-expansion (table--measure-max-width)) + (if (<= ,width-expansion table-cell-info-width) nil + (table--fill-region (point-min) (point-max) ,width-expansion) + ;; Keep the updated cell coordinate. + (setq table-cell-cache-point-coordinate (table--get-coordinate))) + (setq ,width-expansion (- ,width-expansion table-cell-info-width)) + ;; Determine the cell height expansion. + (if (looking-at "\\s *\\'") nil + (goto-char (point-min)) + (if (re-search-forward "\\(\\s *\\)\\'" nil t) + (goto-char (match-beginning 1)))) + (setq ,height-expansion (- (cdr (table--get-coordinate)) (1- table-cell-info-height))))) ;; now back to the table buffer. ;; expand the cell width in the table buffer if necessary. (if (> ,width-expansion 0) @@ -2823,21 +2844,6 @@ or `top', `middle', `bottom' or `none' for vertical." (table--justify-cell-contents justify)))))) ;;;###autoload -(define-minor-mode table-fixed-width-mode - "Cell width is fixed when this is non-nil. -Normally it should be nil for allowing automatic cell width expansion -that widens a cell when it is necessary. When non-nil, typing in a -cell does not automatically expand the cell width. A word that is too -long to fit in a cell is chopped into multiple lines. The chopped -location is indicated by `table-word-continuation-char'. This -variable's value can be toggled by \\[table-fixed-width-mode] at -run-time." - :tag "Fix Cell Width" - :group 'table - (table--finish-delayed-tasks) - (table--update-cell-face)) - -;;;###autoload (defun table-query-dimension (&optional where) "Return the dimension of the current cell and the current table. The result is a list (cw ch tw th c r cells) where cw is the cell diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el index 6fd66b2502f..0c112b2ecf5 100644 --- a/lisp/textmodes/tex-mode.el +++ b/lisp/textmodes/tex-mode.el @@ -2037,7 +2037,7 @@ In the tex shell buffer this command behaves like `comint-send-input'." (defun tex-display-shell () "Make the TeX shell buffer visible in a window." - (display-buffer (tex-shell-buf)) + (display-buffer (tex-shell-buf) display-comint-buffer-action) (tex-recenter-output-buffer nil)) (defun tex-shell-sentinel (proc _msg) @@ -2441,7 +2441,7 @@ Only applies the FSPEC to the args part of FORMAT." (if cmds (tex-format-cmd (caar cmds) fspec)))))) (defun tex-cmd-doc-view (file) - (pop-to-buffer (find-file-noselect file))) + (pop-to-buffer (find-file-noselect file) display-comint-buffer-action)) (defun tex-compile (dir cmd) "Run a command CMD on current TeX buffer's file in DIR." @@ -2457,7 +2457,7 @@ Only applies the FSPEC to the args part of FORMAT." (default (tex-compile-default fspec))) (list default-directory (completing-read - (format "Command [%s]: " (tex-summarize-command default)) + (format-prompt "Command" (tex-summarize-command default)) (mapcar (lambda (x) (list (tex-format-cmd (eval (car x) t) fspec))) tex-compile-commands) @@ -2698,7 +2698,7 @@ line LINE of the window, or centered if LINE is nil." (window)) (if (null tex-shell) (message "No TeX output buffer") - (setq window (display-buffer tex-shell)) + (setq window (display-buffer tex-shell display-comint-buffer-action)) (with-selected-window window (bury-buffer tex-shell) (goto-char (point-max)) diff --git a/lisp/textmodes/texinfo.el b/lisp/textmodes/texinfo.el index 7876a87a281..dbf30dabe59 100644 --- a/lisp/textmodes/texinfo.el +++ b/lisp/textmodes/texinfo.el @@ -4,7 +4,6 @@ ;; Foundation, Inc. ;; Author: Robert J. Chassell -;; Date: [See date below for texinfo-version] ;; Maintainer: emacs-devel@gnu.org ;; Keywords: maint, tex, docs @@ -411,13 +410,13 @@ value of `texinfo-mode-hook'." "\\)\\>")) (setq-local require-final-newline mode-require-final-newline) (setq-local indent-tabs-mode nil) - (setq-local paragraph-separate - (concat "@[a-zA-Z]*[ \n]\\|" - paragraph-separate)) (setq-local paragraph-start (concat "@[a-zA-Z]*[ \n]\\|" paragraph-start)) + (setq-local fill-paragraph-function 'texinfo--fill-paragraph) (setq-local sentence-end-base "\\(@\\(end\\)?dots{}\\|[.?!]\\)[]\"'”)}]*") (setq-local fill-column 70) + (setq-local beginning-of-defun-function #'texinfo--beginning-of-defun) + (setq-local end-of-defun-function #'texinfo--end-of-defun) (setq-local comment-start "@c ") (setq-local comment-start-skip "@c +\\|@comment +") (setq-local words-include-escapes t) @@ -457,6 +456,58 @@ value of `texinfo-mode-hook'." prevent-filling (concat auto-fill-inhibit-regexp "\\|" prevent-filling))))) +(defvar texinfo-fillable-commands '("@noindent") + "A list of commands that can be filled.") + +(defun texinfo--fill-paragraph (justify) + "Function to fill a paragraph in `texinfo-mode'." + (let ((command-re "\\(@[a-zA-Z]+\\)[ \t\n]")) + (catch 'no-fill + (save-restriction + ;; First check whether we're on a command line that can be + ;; filled by itself. + (or + (save-excursion + (beginning-of-line) + (when (looking-at command-re) + (let ((command (match-string 1))) + (if (member command texinfo-fillable-commands) + (progn + (narrow-to-region (point) (progn (forward-line 1) (point))) + t) + (throw 'no-fill nil))))) + ;; We're not on such a line, so fill the region. + (save-excursion + (let ((regexp (concat command-re "\\|^[ \t]*$\\|\f"))) + (narrow-to-region + (if (re-search-backward regexp nil t) + (progn + (forward-line 1) + (point)) + (point-min)) + (if (re-search-forward regexp nil t) + (match-beginning 0) + (point-max))) + (goto-char (point-min))))) + ;; We've now narrowed to the region we want to fill. + (let ((fill-paragraph-function nil) + (adaptive-fill-mode nil)) + (fill-paragraph justify)))) + t)) + +(defun texinfo--beginning-of-defun (&optional arg) + "Go to the previous @node line." + (while (and (> arg 0) + (re-search-backward "^@node " nil t)) + (setq arg (1- arg)))) + +(defun texinfo--end-of-defun () + "Go to the start of the next @node line." + (when (looking-at-p "@node") + (forward-line)) + (if (re-search-forward "^@node " nil t) + (goto-char (match-beginning 0)) + (goto-char (point-max)))) ;;; Insert string commands diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el index 4d3e68ec9c4..d9ec66a3f61 100644 --- a/lisp/thingatpt.el +++ b/lisp/thingatpt.el @@ -106,8 +106,17 @@ valid THING. Return a cons cell (START . END) giving the start and end positions of the thing found." - (if (get thing 'bounds-of-thing-at-point) - (funcall (get thing 'bounds-of-thing-at-point)) + (cond + ((get thing 'bounds-of-thing-at-point) + (funcall (get thing 'bounds-of-thing-at-point))) + ;; If the buffer is totally empty, give up. + ((and (not (eq thing 'whitespace)) + (save-excursion + (goto-char (point-min)) + (not (re-search-forward "[^\t\n ]" nil t)))) + nil) + ;; Find the thing. + (t (let ((orig (point))) (ignore-errors (save-excursion @@ -149,7 +158,7 @@ positions of the thing found." (lambda () (forward-thing thing -1)))) (point)))) (if (and (<= real-beg orig) (<= orig end) (< real-beg end)) - (cons real-beg end)))))))))) + (cons real-beg end))))))))))) ;;;###autoload (defun thing-at-point (thing &optional no-properties) diff --git a/lisp/thread.el b/lisp/thread.el index efb058c4361..10b88dd93a1 100644 --- a/lisp/thread.el +++ b/lisp/thread.el @@ -30,6 +30,13 @@ (eval-when-compile (require 'pcase)) (eval-when-compile (require 'subr-x)) +(declare-function thread-name "thread.c") +(declare-function thread-signal "thread.c") +(declare-function thread--blocker "thread.c") +(declare-function current-thread "thread.c") +(declare-function thread-live-p "thread.c") +(declare-function all-threads "thread.c") + ;;;###autoload (defun thread-handle-event (event) "Handle thread events, propagated by `thread-signal'. diff --git a/lisp/thumbs.el b/lisp/thumbs.el index 4c863883ba4..001b2c8e770 100644 --- a/lisp/thumbs.el +++ b/lisp/thumbs.el @@ -91,7 +91,7 @@ When it reaches that size (in bytes), a warning is sent." (defcustom thumbs-conversion-program (if (eq system-type 'windows-nt) ;; FIXME is this necessary, or can a sane PATHEXE be assumed? - ;; Eg find-program does not do this. + ;; E.g. find-program does not do this. "convert.exe" "convert") "Name of conversion program for thumbnails generation. @@ -292,22 +292,11 @@ smaller according to whether INCREMENT is 1 or -1." (thumbs-call-convert fn tn "sample" thumbs-geometry)) tn)) -(defun thumbs-image-type (img) - "Return image type from filename IMG." - (cond ((string-match ".*\\.jpe?g\\'" img) 'jpeg) - ((string-match ".*\\.xpm\\'" img) 'xpm) - ((string-match ".*\\.xbm\\'" img) 'xbm) - ((string-match ".*\\.pbm\\'" img) 'pbm) - ((string-match ".*\\.gif\\'" img) 'gif) - ((string-match ".*\\.bmp\\'" img) 'bmp) - ((string-match ".*\\.png\\'" img) 'png) - ((string-match ".*\\.tiff?\\'" img) 'tiff))) - (declare-function image-size "image.c" (spec &optional pixels frame)) (defun thumbs-file-size (img) (let ((i (image-size - (find-image `((:type ,(thumbs-image-type img) :file ,img))) t))) + (find-image `((:type ,(image-type-from-file-name img) :file ,img))) t))) (concat (number-to-string (round (car i))) "x" (number-to-string (round (cdr i)))))) @@ -410,7 +399,7 @@ and SAME-WINDOW to show thumbs in the same window." thumbs-image-num (or num 0)) (delete-region (point-min)(point-max)) (save-excursion - (thumbs-insert-image img (thumbs-image-type img) 0))))) + (thumbs-insert-image img (image-type-from-file-name img) 0))))) (defun thumbs-find-image-at-point (&optional img otherwin) "Display image IMG for thumbnail at point. @@ -544,7 +533,7 @@ Open another window." " - " (number-to-string num))) (let ((inhibit-read-only t)) (erase-buffer) - (thumbs-insert-image img (thumbs-image-type img) 0) + (thumbs-insert-image img (image-type-from-file-name img) 0) (goto-char (point-min)))) (setq thumbs-image-num num thumbs-current-image-filename img)))) @@ -775,6 +764,9 @@ ACTION and ARG should be a valid convert command." (define-key dired-mode-map "\C-tm" 'thumbs-dired-show-marked) (define-key dired-mode-map "\C-tw" 'thumbs-dired-setroot) +(define-obsolete-function-alias 'thumbs-image-type + #'image-type-from-file-name "29.1") + (provide 'thumbs) ;;; thumbs.el ends here diff --git a/lisp/time.el b/lisp/time.el index 8496adec228..b67315cf630 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)) @@ -355,7 +355,7 @@ update which can wait for the next redisplay." (am-pm (if (>= hour 12) "pm" "am")) (minutes (substring time 14 16)) (seconds (substring time 17 19)) - (time-zone (car (cdr (current-time-zone now)))) + (time-zone (format-time-string "%Z" now)) (day (substring time 8 10)) (year (format-time-string "%Y" now)) (monthname (substring time 4 7)) @@ -526,11 +526,9 @@ If the value is t instead of an alist, use the value of '((t :inherit font-lock-variable-name-face)) "Face for time zone label in `world-clock' buffer.") -(defvar world-clock-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "n" #'next-line) - (define-key map "p" #'previous-line) - map)) +(defvar-keymap world-clock-mode-map + "n" #'next-line + "p" #'previous-line) (define-derived-mode world-clock-mode special-mode "World clock" "Major mode for buffer that displays times in various time zones. diff --git a/lisp/timezone.el b/lisp/timezone.el index 2c96343a74b..7a461c4e22d 100644 --- a/lisp/timezone.el +++ b/lisp/timezone.el @@ -95,10 +95,7 @@ if nil, the local time zone is assumed." Optional argument TIMEZONE specifies a time zone." (let ((zone (if (listp timezone) - (let* ((m (timezone-zone-to-minute timezone)) - (absm (if (< m 0) (- m) m))) - (format "%c%02d%02d" - (if (< m 0) ?- ?+) (/ absm 60) (% absm 60))) + (format-time-string "%z" 0 (or timezone 0)) timezone))) (format "%02d %s %04d %s %s" day @@ -302,11 +299,10 @@ Return a list in the same format as `current-time-zone's result, or nil if the local time zone could not be computed. DATE is the number of days elapsed since the (imaginary) Gregorian date Sunday, December 31, 1 BC." - (and (fboundp 'current-time-zone) - (let ((utc-time (timezone-time-from-absolute date seconds))) - (and utc-time - (let ((zone (current-time-zone utc-time))) - (and (car zone) zone)))))) + (let ((utc-time (timezone-time-from-absolute date seconds))) + (and utc-time + (let ((zone (current-time-zone utc-time))) + (and (car zone) zone))))) (defun timezone-fix-time (date local timezone) "Convert DATE (default timezone LOCAL) to YYYY-MM-DD-HH-MM-SS-ZONE vector. 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/tree-widget.el b/lisp/tree-widget.el index d40a628b994..8691f03f86d 100644 --- a/lisp/tree-widget.el +++ b/lisp/tree-widget.el @@ -214,8 +214,8 @@ Give the image the specified properties PROPS." See also the option `widget-image-conversion'." (delq nil (mapcar - #'(lambda (fmt) - (and (image-type-available-p (car fmt)) fmt)) + (lambda (fmt) + (and (image-type-available-p (car fmt)) fmt)) widget-image-conversion))) ;; Buffer local cache of theme data. 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/uniquify.el b/lisp/uniquify.el index ffb5ecc9024..b9a4c3c6835 100644 --- a/lisp/uniquify.el +++ b/lisp/uniquify.el @@ -476,34 +476,32 @@ For use on `kill-buffer-hook'." ;; rename-buffer and create-file-buffer. (Setting find-file-hook isn't ;; sufficient.) -(advice-add 'rename-buffer :around #'uniquify--rename-buffer-advice) -(defun uniquify--rename-buffer-advice (rb-fun newname &optional unique &rest args) +;; (advice-add 'rename-buffer :around #'uniquify--rename-buffer-advice) +(defun uniquify--rename-buffer-advice (newname &optional unique) + ;; BEWARE: This is called directly from `buffer.c'! "Uniquify buffer names with parts of directory name." - (let ((retval (apply rb-fun newname unique args))) (uniquify-maybe-rerationalize-w/o-cb) - (if (null unique) + (if (null unique) ;; Mark this buffer so it won't be renamed by uniquify. (setq uniquify-managed nil) (when uniquify-buffer-name-style ;; Rerationalize w.r.t the new name. (uniquify-rationalize-file-buffer-names - newname + newname (uniquify-buffer-file-name (current-buffer)) - (current-buffer)) - (setq retval (buffer-name (current-buffer))))) - retval)) + (current-buffer))))) -(advice-add 'create-file-buffer :around #'uniquify--create-file-buffer-advice) -(defun uniquify--create-file-buffer-advice (cfb-fun filename &rest args) +;; (advice-add 'create-file-buffer :around #'uniquify--create-file-buffer-advice) +(defun uniquify--create-file-buffer-advice (buf filename) + ;; BEWARE: This is called directly from `files.el'! "Uniquify buffer names with parts of directory name." - (let ((retval (apply cfb-fun filename args))) - (if uniquify-buffer-name-style - (let ((filename (expand-file-name (directory-file-name filename)))) - (uniquify-rationalize-file-buffer-names - (file-name-nondirectory filename) - (file-name-directory filename) retval))) - retval)) + (when uniquify-buffer-name-style + (let ((filename (expand-file-name (directory-file-name filename)))) + (uniquify-rationalize-file-buffer-names + (file-name-nondirectory filename) + (file-name-directory filename) + buf)))) (defun uniquify-unload-function () "Unload the uniquify library." @@ -513,8 +511,6 @@ For use on `kill-buffer-hook'." (set-buffer buf) (when uniquify-managed (push (cons buf (uniquify-item-base (car uniquify-managed))) buffers))) - (advice-remove 'rename-buffer #'uniquify--rename-buffer-advice) - (advice-remove 'create-file-buffer #'uniquify--create-file-buffer-advice) (dolist (buf buffers) (set-buffer (car buf)) (rename-buffer (cdr buf) t)))) diff --git a/lisp/url/url-handlers.el b/lisp/url/url-handlers.el index 650c610e04c..8f35a43bd23 100644 --- a/lisp/url/url-handlers.el +++ b/lisp/url/url-handlers.el @@ -396,7 +396,8 @@ if it had been inserted from a file named URL." (url-handlers-create-wrapper file-writable-p (url)) (url-handlers-create-wrapper file-directory-p (url)) (url-handlers-create-wrapper file-executable-p (url)) -(url-handlers-create-wrapper directory-files (url &optional full match nosort)) +(url-handlers-create-wrapper + directory-files (url &optional full match nosort count)) (url-handlers-create-wrapper file-truename (url &optional counter prev-dirs)) (add-hook 'find-file-hook #'url-handlers-set-buffer-mode) diff --git a/lisp/url/url-privacy.el b/lisp/url/url-privacy.el index 58ae6efbfc1..ebba87ebbb5 100644 --- a/lisp/url/url-privacy.el +++ b/lisp/url/url-privacy.el @@ -48,6 +48,7 @@ (pcase (or window-system 'tty) ('x "X11") ('ns "OpenStep") + ('pgtk "PureGTK") ('tty "TTY") (_ nil))))) 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. - -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"))) +If you say \\`n', the change you started to make will be aborted. + +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/add-log.el b/lisp/vc/add-log.el index 1290d7e03a5..6f45186837f 100644 --- a/lisp/vc/add-log.el +++ b/lisp/vc/add-log.el @@ -590,9 +590,8 @@ Compatibility function for \\[next-error] invocations." ["Go To Source" change-log-goto-source :help "Go to source location of ChangeLog tag near point"])) -;; It used to be called change-log-time-zone-rule but really should be -;; called add-log-time-zone-rule since it's only used from add-log-* code. -(defvaralias 'change-log-time-zone-rule 'add-log-time-zone-rule) +(define-obsolete-variable-alias 'change-log-time-zone-rule + 'add-log-time-zone-rule "29.1") (defvar add-log-time-zone-rule nil "Time zone rule used for calculating change log time stamps. If nil, use local time. If t, use Universal Time. diff --git a/lisp/vc/cvs-status.el b/lisp/vc/cvs-status.el index 63b886362ba..7886cc1eae2 100644 --- a/lisp/vc/cvs-status.el +++ b/lisp/vc/cvs-status.el @@ -29,23 +29,22 @@ ;;; Code: (require 'cl-lib) -(require 'pcvs-util) +(require 'pcvs) +(require 'easy-mmode) ;;; -(easy-mmode-defmap cvs-status-mode-map - '(("n" . next-line) - ("p" . previous-line) - ("N" . cvs-status-next) - ("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)) - "CVS-Status' keymap." - :group 'cvs-status - :inherit 'cvs-mode-map) +(defvar-keymap cvs-status-mode-map + :parent 'cvs-mode-map + "n" #'next-line + "p" #'previous-line + "N" #'cvs-status-next + "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) ;;(easy-menu-define cvs-status-menu cvs-status-mode-map ;; "Menu for `cvs-status-mode'." diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 057ffcd06e3..60d210ca220 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -55,6 +55,7 @@ ;;; Code: (eval-when-compile (require 'cl-lib)) (eval-when-compile (require 'subr-x)) +(require 'easy-mmode) (autoload 'vc-find-revision "vc") (autoload 'vc-find-revision-no-save "vc") @@ -162,57 +163,55 @@ and hunk-based syntax highlighting otherwise as a fallback." ;;;; keymap, menu, ... ;;;; -(easy-mmode-defmap diff-mode-shared-map - '(("n" . diff-hunk-next) - ("N" . diff-file-next) - ("p" . diff-hunk-prev) - ("P" . diff-file-prev) - ("\t" . diff-hunk-next) - ([backtab] . diff-hunk-prev) - ("k" . diff-hunk-kill) - ("K" . diff-file-kill) - ("}" . diff-file-next) ; From compilation-minor-mode. - ("{" . diff-file-prev) - ("\C-m" . diff-goto-source) - ([mouse-2] . 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)) - "Basic keymap for `diff-mode', bound to various prefix keys." - :inherit special-mode-map) - -(easy-mmode-defmap diff-mode-map - `(("\e" . ,(let ((map (make-sparse-keymap))) - ;; We want to inherit most bindings from diff-mode-shared-map, - ;; but not all since they may hide useful M-<foo> global - ;; bindings when editing. - (set-keymap-parent map diff-mode-shared-map) - (dolist (key '("A" "r" "R" "g" "q" "W" "z")) - (define-key map key nil)) - map)) - ;; From compilation-minor-mode. - ("\C-c\C-c" . diff-goto-source) - ;; By analogy with the global C-x 4 a binding. - ("\C-x4A" . 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) - ;; `d' because it duplicates the context :-( --Stef - ("\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)) - "Keymap for `diff-mode'. See also `diff-mode-shared-map'.") +(defvar-keymap diff-mode-shared-map + :parent special-mode-map + "n" #'diff-hunk-next + "N" #'diff-file-next + "p" #'diff-hunk-prev + "P" #'diff-file-prev + "TAB" #'diff-hunk-next + "<backtab>" #'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 + "W" #'widen + "o" #'diff-goto-source ; other-window + "A" #'diff-ediff-patch + "r" #'diff-restrict-view + "R" #'diff-reverse-direction + "<remap> <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-<foo>' 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 + ;; By analogy with the global C-x 4 a binding. + "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 + ;; `d' because it duplicates the context :-( --Stef + "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) (easy-menu-define diff-mode-menu diff-mode-map "Menu for `diff-mode'." @@ -267,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)) -(easy-mmode-defmap diff-minor-mode-map - `((,diff-minor-mode-prefix . ,diff-mode-shared-map)) - "Keymap for `diff-minor-mode'. See also `diff-mode-shared-map'.") +(defvar-keymap diff-minor-mode-map + :doc "Keymap for `diff-minor-mode'. See also `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). @@ -894,6 +894,9 @@ data such as \"Index: ...\" and such." ;; Fix the original hunk-header. (diff-fixup-modifs start pos)))) +(defun diff--outline-level () + (if (string-match-p diff-hunk-header-re (match-string 0)) + 2 1)) ;;;; ;;;; jump to other buffers @@ -1494,7 +1497,6 @@ a diff with \\[diff-reverse-direction]. (setq-local font-lock-defaults diff-font-lock-defaults) (add-hook 'font-lock-mode-hook #'diff--font-lock-cleanup nil 'local) - (setq-local outline-regexp diff-outline-regexp) (setq-local imenu-generic-expression diff-imenu-generic-expression) ;; These are not perfect. They would be better done separately for @@ -1539,11 +1541,7 @@ a diff with \\[diff-reverse-direction]. #'diff--filter-substring) (unless buffer-file-name (hack-dir-local-variables-non-file-buffer)) - (save-excursion - (setq-local diff-buffer-type - (if (re-search-forward "^diff --git" nil t) - 'git - nil)))) + (diff-setup-buffer-type)) ;;;###autoload (define-minor-mode diff-minor-mode @@ -1579,6 +1577,21 @@ modified lines of the diff." "^[-+!] .*?\\([\t ]+\\)$" "^[-+!<>].*?\\([\t ]+\\)$")))) +(defun diff-setup-buffer-type () + "Try to guess the `diff-buffer-type' from content of current Diff mode buffer. +`outline-regexp' is updated accordingly." + (save-excursion + (goto-char (point-min)) + (setq-local diff-buffer-type + (if (re-search-forward "^diff --git" nil t) + 'git + nil))) + (when (eq diff-buffer-type 'git) + (setq diff-outline-regexp + (concat "\\(^diff --git.*\n\\|" diff-hunk-header-re "\\)")) + (setq-local outline-level #'diff--outline-level)) + (setq-local outline-regexp diff-outline-regexp)) + (defun diff-delete-if-empty () ;; An empty diff file means there's no more diffs to integrate, so we ;; can just remove the file altogether. Very handy for .rej files if we @@ -2599,17 +2612,17 @@ fixed, visit it in a buffer." "\\(?:index.*\n\\)?" "--- \\(?:" null-device "\\|a/\\(.*\\)\\)\n" "\\+\\+\\+ \\(?:" null-device "\\|b/\\(.*\\)\\)\n")))) - (put-text-property (match-beginning 0) - (or (match-beginning 2) (match-beginning 1)) - 'display (propertize - (cond - ((null (match-beginning 1)) "new file ") - ((null (match-beginning 2)) "deleted ") - (t "modified ")) - 'face '(diff-file-header diff-header))) - (unless (match-beginning 2) - (put-text-property (match-end 1) (1- (match-end 0)) - 'display ""))))) + (put-text-property (match-beginning 0) (1- (match-end 0)) + 'display + (propertize + (cond + ((null (match-string 1)) + (concat "new file " (match-string 2))) + ((null (match-string 2)) + (concat "deleted " (match-string 1))) + (t + (concat "modified " (match-string 1)))) + 'face '(diff-file-header diff-header)))))) nil) ;;; Syntax highlighting from font-lock diff --git a/lisp/vc/diff.el b/lisp/vc/diff.el index 352fa693ffb..4061fedd578 100644 --- a/lisp/vc/diff.el +++ b/lisp/vc/diff.el @@ -96,15 +96,15 @@ Non-interactively, OLD and NEW may each be a file or a buffer." (interactive (let* ((newf (if (and buffer-file-name (file-exists-p buffer-file-name)) (read-file-name - (concat "Diff new file (default " - (file-name-nondirectory buffer-file-name) "): ") + (format-prompt "Diff new file" + (file-name-nondirectory buffer-file-name)) nil buffer-file-name t) (read-file-name "Diff new file: " nil nil t))) (oldf (file-newest-backup newf))) (setq oldf (if (and oldf (file-exists-p oldf)) (read-file-name - (concat "Diff original file (default " - (file-name-nondirectory oldf) "): ") + (format-prompt "Diff original file" + (file-name-nondirectory oldf)) (file-name-directory oldf) oldf t) (read-file-name "Diff original file: " (file-name-directory newf) nil t))) 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 4135e8b4702..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 @@ -503,15 +505,11 @@ are two possible targets for this %spatch. However, these files do not exist." patch-file-name) (setq patch-file-name (read-file-name - (format "Patch is in file%s: " - (cond ((and buffer-file-name - (equal (expand-file-name dir) - (file-name-directory buffer-file-name))) - (concat - " (default " - (file-name-nondirectory buffer-file-name) - ")")) - (t ""))) + (format-prompt "Patch is in file" + (and buffer-file-name + (equal (expand-file-name dir) + (file-name-directory buffer-file-name)) + (file-name-nondirectory buffer-file-name))) dir buffer-file-name 'must-match)) (if (file-directory-p patch-file-name) (error "Patch file cannot be a directory: %s" patch-file-name) @@ -827,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-util.el b/lisp/vc/ediff-util.el index c12de02e49f..c2b08bd31af 100644 --- a/lisp/vc/ediff-util.el +++ b/lisp/vc/ediff-util.el @@ -3121,11 +3121,7 @@ Hit \\[ediff-recenter] to reset the windows afterward." (lambda () (when defaults (setq minibuffer-default defaults))) (read-file-name - (format "%s%s " - prompt - (cond (default-file - (concat " (default " default-file "):")) - (t (concat " (default " default-dir "):")))) + (format-prompt prompt (or default-file default-dir)) default-dir (or default-file default-dir) t ; must match, no-confirm 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-mode-map>\\[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 4d151d555cc..6e3f302263b 100644 --- a/lisp/vc/log-edit.el +++ b/lisp/vc/log-edit.el @@ -54,21 +54,19 @@ (define-obsolete-variable-alias 'vc-log-mode-map 'log-edit-mode-map "28.1") (define-obsolete-variable-alias 'vc-log-entry-mode 'log-edit-mode-map "28.1") -(easy-mmode-defmap log-edit-mode-map - '(("\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)) - "Keymap for the `log-edit-mode' (to edit version control log messages)." - :group 'log-edit) +(defvar-keymap log-edit-mode-map + "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 c2f008fc47d..d45c1696a2f 100644 --- a/lisp/vc/log-view.el +++ b/lisp/vc/log-view.el @@ -110,6 +110,7 @@ ;;; Code: (require 'pcvs-util) +(require 'easy-mmode) (autoload 'vc-find-revision "vc") (autoload 'vc-diff-internal "vc") @@ -121,39 +122,23 @@ :group 'pcl-cvs :prefix "log-view-") -(easy-mmode-defmap log-view-mode-map - '( - ("-" . negative-argument) - ("0" . digit-argument) - ("1" . digit-argument) - ("2" . digit-argument) - ("3" . digit-argument) - ("4" . digit-argument) - ("5" . digit-argument) - ("6" . digit-argument) - ("7" . digit-argument) - ("8" . digit-argument) - ("9" . digit-argument) - - ("\C-m" . log-view-toggle-entry-display) - ("m" . log-view-toggle-mark-entry) - ("e" . log-view-modify-change-comment) - ("d" . log-view-diff) - ("=" . log-view-diff) - ("D" . log-view-diff-changeset) - ("a" . log-view-annotate-version) - ("f" . log-view-find-revision) - ("n" . log-view-msg-next) - ("p" . log-view-msg-prev) - ("\t" . log-view-msg-next) - ([backtab] . log-view-msg-prev) - ("N" . log-view-file-next) - ("P" . log-view-file-prev) - ("\M-n" . log-view-file-next) - ("\M-p" . log-view-file-prev)) - "Log-View's keymap." - :inherit special-mode-map - :group 'log-view) +(defvar-keymap log-view-mode-map + "RET" #'log-view-toggle-entry-display + "m" #'log-view-toggle-mark-entry + "e" #'log-view-modify-change-comment + "d" #'log-view-diff + "=" #'log-view-diff + "D" #'log-view-diff-changeset + "a" #'log-view-annotate-version + "f" #'log-view-find-revision + "n" #'log-view-msg-next + "p" #'log-view-msg-prev + "TAB" #'log-view-msg-next + "<backtab>" #'log-view-msg-prev + "N" #'log-view-file-next + "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-defs.el b/lisp/vc/pcvs-defs.el index 54ef06960f9..c3109f7e85b 100644 --- a/lisp/vc/pcvs-defs.el +++ b/lisp/vc/pcvs-defs.el @@ -264,160 +264,6 @@ This variable is buffer local and only used in the *cvs* buffer.") (defconst cvs-vendor-branch "1.1.1" "The default branch used by CVS for vendor code.") -(easy-mmode-defmap cvs-mode-diff-map - '(("E" "imerge" . cvs-mode-imerge) - ("=" . cvs-mode-diff) - ("e" "idiff" . cvs-mode-idiff) - ("2" "other" . cvs-mode-idiff-other) - ("d" "diff" . cvs-mode-diff) - ("b" "backup" . cvs-mode-diff-backup) - ("h" "head" . cvs-mode-diff-head) - ("r" "repository" . cvs-mode-diff-repository) - ("y" "yesterday" . cvs-mode-diff-yesterday) - ("v" "vendor" . cvs-mode-diff-vendor)) - "Keymap for diff-related operations in `cvs-mode'." - :name "Diff") -;; This is necessary to allow correct handling of \\[cvs-mode-diff-map] -;; in substitute-command-keys. -(fset 'cvs-mode-diff-map cvs-mode-diff-map) - -(easy-mmode-defmap cvs-mode-map - ;;(define-prefix-command 'cvs-mode-map-diff-prefix) - ;;(define-prefix-command 'cvs-mode-map-control-c-prefix) - '(;; various - ;; (undo . cvs-mode-undo) - ("?" . cvs-help) - ("h" . cvs-help) - ("q" . cvs-bury-buffer) - ("z" . kill-this-buffer) - ("F" . cvs-mode-set-flags) - ;; ("\M-f" . cvs-mode-force-command) - ("!" . cvs-mode-force-command) - ("\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) - ("\C-?". cvs-mode-unmark-up) - ("%" . cvs-mode-mark-matching-files) - ("T" . cvs-mode-toggle-marks) - ("\M-\C-?" . cvs-mode-unmark-all-files) - ;; navigation keys - (" " . cvs-mode-next-line) - ("n" . cvs-mode-next-line) - ("p" . cvs-mode-previous-line) - ("\t" . cvs-mode-next-line) - ([backtab] . cvs-mode-previous-line) - ;; M- keys are usually those that operate on modules - ;;("\M-C". cvs-mode-rcs2log) ; i.e. "Create a ChangeLog" - ;;("\M-t". cvs-rtag) - ;;("\M-l". cvs-rlog) - ("\M-c". cvs-checkout) - ("\M-e". cvs-examine) - ("g" . cvs-mode-revert-buffer) - ("\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) - ("A" . cvs-mode-add-change-log-entry-other-window) - ;;("B" . cvs-mode-byte-compile-files) - ("C" . cvs-mode-commit-setup) - ("O" . cvs-mode-update) - ("U" . cvs-mode-undo) - ("I" . cvs-mode-insert) - ("a" . cvs-mode-add) - ("b" . cvs-set-branch-prefix) - ("B" . cvs-set-secondary-branch-prefix) - ("c" . cvs-mode-commit) - ("e" . cvs-mode-examine) - ("f" . cvs-mode-find-file) - ("\C-m" . cvs-mode-find-file) - ("i" . cvs-mode-ignore) - ("l" . cvs-mode-log) - ("o" . cvs-mode-find-file-other-window) - ("r" . cvs-mode-remove) - ("s" . cvs-mode-status) - ("t" . cvs-mode-tag) - ("v" . cvs-mode-view-file) - ("x" . cvs-mode-remove-handled) - ;; cvstree bindings - ("+" . cvs-mode-tree) - ;; mouse bindings - ([mouse-2] . cvs-mode-find-file) - ([follow-link] . (lambda (pos) - (if (eq (get-char-property pos 'face) 'cvs-filename) t))) - ([(down-mouse-3)] . cvs-menu) - ;; dired-like bindings - ("\C-o" . cvs-mode-display-file) - ;; Emacs-21 toolbar - ;;([tool-bar item1] . (menu-item "Examine" cvs-examine :image (image :file "/usr/share/icons/xpaint.xpm" :type xpm))) - ;;([tool-bar item2] . (menu-item "Update" cvs-update :image (image :file "/usr/share/icons/mail1.xpm" :type xpm))) - ) - "Keymap for `cvs-mode'." - :dense t - :suppress t) - -(fset 'cvs-mode-map cvs-mode-map) - -(easy-menu-define cvs-menu cvs-mode-map "Menu used in `cvs-mode'." - '("CVS" - ["Open file" cvs-mode-find-file t] - ["Open in other window" cvs-mode-find-file-other-window t] - ["Display in other window" cvs-mode-display-file t] - ["Interactive merge" cvs-mode-imerge t] - ("View diff" - ["Interactive diff" cvs-mode-idiff t] - ["Current diff" cvs-mode-diff t] - ["Diff with head" cvs-mode-diff-head t] - ["Diff with vendor" cvs-mode-diff-vendor t] - ["Diff against yesterday" cvs-mode-diff-yesterday t] - ["Diff with backup" cvs-mode-diff-backup t]) - ["View log" cvs-mode-log t] - ["View status" cvs-mode-status t] - ["View tag tree" cvs-mode-tree t] - "----" - ["Insert" cvs-mode-insert] - ["Update" cvs-mode-update (cvs-enabledp 'update)] - ["Re-examine" cvs-mode-examine t] - ["Commit" cvs-mode-commit-setup (cvs-enabledp 'commit)] - ["Tag" cvs-mode-tag (cvs-enabledp (when cvs-force-dir-tag 'tag))] - ["Undo changes" cvs-mode-undo (cvs-enabledp 'undo)] - ["Add" cvs-mode-add (cvs-enabledp 'add)] - ["Remove" cvs-mode-remove (cvs-enabledp 'remove)] - ["Ignore" cvs-mode-ignore (cvs-enabledp 'ignore)] - ["Add ChangeLog" cvs-mode-add-change-log-entry-other-window t] - "----" - ["Mark" cvs-mode-mark t] - ["Mark all" cvs-mode-mark-all-files t] - ["Mark by regexp..." cvs-mode-mark-matching-files t] - ["Mark by state..." cvs-mode-mark-on-state t] - ["Unmark" cvs-mode-unmark t] - ["Unmark all" cvs-mode-unmark-all-files t] - ["Hide handled" cvs-mode-remove-handled t] - "----" - ["PCL-CVS Manual" (lambda () (interactive) - (info "(pcl-cvs)Top")) t] - "----" - ["Quit" cvs-mode-quit t])) - -;;;; -;;;; CVS-Minor mode -;;;; - -(defcustom cvs-minor-mode-prefix "\C-xc" - "Prefix key for the `cvs-mode' bindings in `cvs-minor-mode'." - :type 'string) - -(easy-mmode-defmap cvs-minor-mode-map - `((,cvs-minor-mode-prefix . cvs-mode-map) - ("e" . (menu-item nil cvs-mode-edit-log - :filter (lambda (x) (if (derived-mode-p 'log-view-mode) x))))) - "Keymap for `cvs-minor-mode', used in buffers related to PCL-CVS.") - (defvar cvs-buffer nil "(Buffer local) The *cvs* buffer associated with this buffer.") (put 'cvs-buffer 'permanent-local t) diff --git a/lisp/vc/pcvs.el b/lisp/vc/pcvs.el index bbc81ef195d..2d7b8cb2ef7 100644 --- a/lisp/vc/pcvs.el +++ b/lisp/vc/pcvs.el @@ -117,11 +117,11 @@ (require 'cl-lib) (require 'ewoc) ;Ewoc was once cookie -(require 'pcvs-defs) (require 'pcvs-util) (require 'pcvs-parse) (require 'pcvs-info) (require 'vc-cvs) +(require 'easy-mmode) ;;;; @@ -138,6 +138,147 @@ (defvar cvs-from-vc nil "Bound to t inside VC advice.") +(defvar-keymap cvs-mode-diff-map + :name "Diff" + "E" (cons "imerge" #'cvs-mode-imerge) + "=" #'cvs-mode-diff + "e" (cons "idiff" #'cvs-mode-idiff) + "2" (cons "other" #'cvs-mode-idiff-other) + "d" (cons "diff" #'cvs-mode-diff) + "b" (cons "backup" #'cvs-mode-diff-backup) + "h" (cons "head" #'cvs-mode-diff-head) + "r" (cons "repository" #'cvs-mode-diff-repository) + "y" (cons "yesterday" #'cvs-mode-diff-yesterday) + "v" (cons "vendor" #'cvs-mode-diff-vendor)) +;; This is necessary to allow correct handling of \\[cvs-mode-diff-map] +;; in substitute-command-keys. +(fset 'cvs-mode-diff-map cvs-mode-diff-map) + +(defvar-keymap cvs-mode-map + :full t + :suppress t + ;; various + "?" #'cvs-help + "h" #'cvs-help + "q" #'cvs-bury-buffer + "z" #'kill-this-buffer + "F" #'cvs-mode-set-flags + "!" #'cvs-mode-force-command + "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 + "%" #'cvs-mode-mark-matching-files + "T" #'cvs-mode-toggle-marks + "M-DEL" #'cvs-mode-unmark-all-files + ;; navigation keys + "SPC" #'cvs-mode-next-line + "n" #'cvs-mode-next-line + "p" #'cvs-mode-previous-line + "TAB" #'cvs-mode-next-line + "<backtab>" #'cvs-mode-previous-line + ;; M- keys are usually those that operate on modules + "M-c" #'cvs-checkout + "M-e" #'cvs-examine + "g" #'cvs-mode-revert-buffer + "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 + "A" #'cvs-mode-add-change-log-entry-other-window + "C" #'cvs-mode-commit-setup + "O" #'cvs-mode-update + "U" #'cvs-mode-undo + "I" #'cvs-mode-insert + "a" #'cvs-mode-add + "b" #'cvs-set-branch-prefix + "B" #'cvs-set-secondary-branch-prefix + "c" #'cvs-mode-commit + "e" #'cvs-mode-examine + "f" #'cvs-mode-find-file + "RET" #'cvs-mode-find-file + "i" #'cvs-mode-ignore + "l" #'cvs-mode-log + "o" #'cvs-mode-find-file-other-window + "r" #'cvs-mode-remove + "s" #'cvs-mode-status + "t" #'cvs-mode-tag + "v" #'cvs-mode-view-file + "x" #'cvs-mode-remove-handled + ;; cvstree bindings + "+" #'cvs-mode-tree + ;; mouse bindings + "<mouse-2>" #'cvs-mode-find-file + "<follow-link>" (lambda (pos) + (eq (get-char-property pos 'face) 'cvs-filename)) + "<down-mouse-3>" #'cvs-menu + ;; dired-like bindings + "C-o" #'cvs-mode-display-file) + +(easy-menu-define cvs-menu cvs-mode-map "Menu used in `cvs-mode'." + '("CVS" + ["Open file" cvs-mode-find-file t] + ["Open in other window" cvs-mode-find-file-other-window t] + ["Display in other window" cvs-mode-display-file t] + ["Interactive merge" cvs-mode-imerge t] + ("View diff" + ["Interactive diff" cvs-mode-idiff t] + ["Current diff" cvs-mode-diff t] + ["Diff with head" cvs-mode-diff-head t] + ["Diff with vendor" cvs-mode-diff-vendor t] + ["Diff against yesterday" cvs-mode-diff-yesterday t] + ["Diff with backup" cvs-mode-diff-backup t]) + ["View log" cvs-mode-log t] + ["View status" cvs-mode-status t] + ["View tag tree" cvs-mode-tree t] + "----" + ["Insert" cvs-mode-insert] + ["Update" cvs-mode-update (cvs-enabledp 'update)] + ["Re-examine" cvs-mode-examine t] + ["Commit" cvs-mode-commit-setup (cvs-enabledp 'commit)] + ["Tag" cvs-mode-tag (cvs-enabledp (when cvs-force-dir-tag 'tag))] + ["Undo changes" cvs-mode-undo (cvs-enabledp 'undo)] + ["Add" cvs-mode-add (cvs-enabledp 'add)] + ["Remove" cvs-mode-remove (cvs-enabledp 'remove)] + ["Ignore" cvs-mode-ignore (cvs-enabledp 'ignore)] + ["Add ChangeLog" cvs-mode-add-change-log-entry-other-window t] + "----" + ["Mark" cvs-mode-mark t] + ["Mark all" cvs-mode-mark-all-files t] + ["Mark by regexp..." cvs-mode-mark-matching-files t] + ["Mark by state..." cvs-mode-mark-on-state t] + ["Unmark" cvs-mode-unmark t] + ["Unmark all" cvs-mode-unmark-all-files t] + ["Hide handled" cvs-mode-remove-handled t] + "----" + ["PCL-CVS Manual" (lambda () (interactive) + (info "(pcl-cvs)Top")) t] + "----" + ["Quit" cvs-mode-quit t])) + +;;;; +;;;; CVS-Minor mode +;;;; + +(defcustom cvs-minor-mode-prefix "\C-xc" + "Prefix key for the `cvs-mode' bindings in `cvs-minor-mode'." + :type 'string + :group 'pcl-cvs) + +(defvar-keymap cvs-minor-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)))) + +(require 'pcvs-defs) + ;;;; ;;;; flags variables ;;;; @@ -758,6 +899,7 @@ clear what alternative to use. - `DOUBLE' is the generic case." (declare (debug (&define sexp lambda-list stringp ("interactive" interactive) def-body)) + (indent defun) (doc-string 3)) (let ((style (cvs-cdr fun)) (fun (cvs-car fun))) @@ -1284,8 +1426,7 @@ marked instead. A directory can never be marked." (intern (upcase (completing-read - (concat - "Mark files in state" (if default (concat " [" default "]")) ": ") + (format-prompt "Mark files in state" default) (mapcar (lambda (x) (list (downcase (symbol-name (car x))))) cvs-states) diff --git a/lisp/vc/smerge-mode.el b/lisp/vc/smerge-mode.el index b2a875c81ff..6c1b8cc95b3 100644 --- a/lisp/vc/smerge-mode.el +++ b/lisp/vc/smerge-mode.el @@ -47,6 +47,7 @@ (require 'diff) ;For diff-check-labels. (require 'diff-mode) ;For diff-refine. (require 'newcomment) +(require 'easy-mmode) ;;; The real definition comes later. (defvar smerge-mode) @@ -142,36 +143,34 @@ Used in `smerge-diff-base-upper' and related functions." "Face used for added characters shown by `smerge-refine'." :version "24.3") -(easy-mmode-defmap smerge-basic-map - `(("n" . smerge-next) - ("p" . smerge-prev) - ("r" . smerge-resolve) - ("a" . smerge-keep-all) - ("b" . smerge-keep-base) - ("o" . smerge-keep-lower) ; for the obsolete keep-other - ("l" . smerge-keep-lower) - ("m" . smerge-keep-upper) ; for the obsolete keep-mine - ("u" . smerge-keep-upper) - ("E" . smerge-ediff) - ("C" . smerge-combine-with-next) - ("R" . smerge-refine) - ("\C-m" . smerge-keep-current) - ("=" . ,(make-sparse-keymap "Diff")) - ("=<" "base-upper" . smerge-diff-base-upper) - ("=>" "base-lower" . smerge-diff-base-lower) - ("==" "upper-lower" . smerge-diff-upper-lower)) - "The base keymap for `smerge-mode'.") +(defvar-keymap smerge-basic-map + "n" #'smerge-next + "p" #'smerge-prev + "r" #'smerge-resolve + "a" #'smerge-keep-all + "b" #'smerge-keep-base + "o" #'smerge-keep-lower ; for the obsolete keep-other + "l" #'smerge-keep-lower + "m" #'smerge-keep-upper ; for the obsolete keep-mine + "u" #'smerge-keep-upper + "E" #'smerge-ediff + "C" #'smerge-combine-with-next + "R" #'smerge-refine + "C-m" #'smerge-keep-current + "=" (define-keymap :name "Diff" + "<" (cons "base-upper" #'smerge-diff-base-upper) + ">" (cons "base-lower" #'smerge-diff-base-lower) + "=" (cons "upper-lower" #'smerge-diff-upper-lower))) (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)) -(easy-mmode-defmap smerge-mode-map - `((,smerge-command-prefix . ,smerge-basic-map)) - "Keymap for `smerge-mode'.") +(defvar-keymap smerge-mode-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-dir.el b/lisp/vc/vc-dir.el index 8165d5e09f1..32e492171d3 100644 --- a/lisp/vc/vc-dir.el +++ b/lisp/vc/vc-dir.el @@ -1427,7 +1427,12 @@ These are the commands available for use in the file status buffer: (vc-dir-refresh) ;; FIXME: find a better way to pass the backend to `vc-dir-mode'. (let ((use-vc-backend backend)) - (vc-dir-mode)))) + (vc-dir-mode) + ;; Activate the backend-specific minor mode, if any. + (when-let ((minor-mode + (intern-soft (format "vc-dir-%s-mode" + (downcase (symbol-name backend)))))) + (funcall minor-mode 1))))) (defun vc-default-dir-extra-headers (_backend _dir) ;; Be loud by default to remind people to add code to display diff --git a/lisp/vc/vc-dispatcher.el b/lisp/vc/vc-dispatcher.el index 346974bdba8..53cdb5eba84 100644 --- a/lisp/vc/vc-dispatcher.el +++ b/lisp/vc/vc-dispatcher.el @@ -127,8 +127,12 @@ preserve the setting." :group 'vc) (defcustom vc-command-messages nil - "If non-nil, display run messages from back-end commands." - :type 'boolean + "If non-nil, display and log messages about running back-end commands. +If the value is `log', messages about running VC back-end commands are +logged in the *Messages* buffer, but not displayed." + :type '(choice (const :tag "No messages" nil) + (const :tag "Display and log messages" t) + (const :tag "Log messages, but don't display" log)) :group 'vc) (defcustom vc-suppress-confirm nil @@ -311,7 +315,10 @@ case, and the process object in the asynchronous case." (substring command 0 -1) command) " " (vc-delistify flags) - " " (vc-delistify files)))) + " " (vc-delistify files))) + (vc-inhibit-message + (or (eq vc-command-messages 'log) + (eq (selected-window) (active-minibuffer-window))))) (save-current-buffer (unless (or (eq buffer t) (and (stringp buffer) @@ -335,7 +342,7 @@ case, and the process object in the asynchronous case." (apply #'start-file-process command (current-buffer) command squeezed)))) (when vc-command-messages - (let ((inhibit-message (eq (selected-window) (active-minibuffer-window)))) + (let ((inhibit-message vc-inhibit-message)) (message "Running in background: %s" full-command))) ;; Get rid of the default message insertion, in case we don't ;; set a sentinel explicitly. @@ -345,11 +352,11 @@ case, and the process object in the asynchronous case." (when vc-command-messages (vc-run-delayed (let ((message-truncate-lines t) - (inhibit-message (eq (selected-window) (active-minibuffer-window)))) + (inhibit-message vc-inhibit-message)) (message "Done in background: %s" full-command))))) ;; Run synchronously (when vc-command-messages - (let ((inhibit-message (eq (selected-window) (active-minibuffer-window)))) + (let ((inhibit-message vc-inhibit-message)) (message "Running in foreground: %s" full-command))) (let ((buffer-undo-list t)) (setq status (apply #'process-file command nil t nil squeezed))) @@ -364,7 +371,7 @@ case, and the process object in the asynchronous case." (if (integerp status) (format "status %d" status) status) full-command)) (when vc-command-messages - (let ((inhibit-message (eq (selected-window) (active-minibuffer-window)))) + (let ((inhibit-message vc-inhibit-message)) (message "Done (status=%d): %s" status full-command))))) (vc-run-delayed (run-hook-with-args 'vc-post-command-functions diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 2d35061b269..5c6a39aec96 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -298,12 +298,14 @@ included in the completions." (vc-git--run-command-string nil "version"))) (setq vc-git--program-version (if (and version-string - ;; Git for Windows appends ".windows.N" to the - ;; numerical version reported by Git. - (string-match - "git version \\([0-9.]+\\)\\(\\.windows\\.[0-9]+\\)?$" - version-string)) - (match-string 1 version-string) + ;; Some Git versions append additional strings + ;; to the numerical version string. E.g., Git + ;; for Windows appends ".windows.N", while Git + ;; for Mac appends " (Apple Git-N)". Capture + ;; numerical version and ignore the rest. + (string-match "git version \\([0-9][0-9.]+\\)" + version-string)) + (string-trim-right (match-string 1 version-string) "\\.") "0"))))) (defun vc-git--git-status-to-vc-state (code-list) @@ -1688,7 +1690,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 +1735,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 @@ -1871,6 +1872,17 @@ Returns nil if not possible." (1- (point-max))))))) (and name (not (string= name "undefined")) name)))) +(defvar-keymap vc-dir-git-mode-map + "z c" #'vc-git-stash + "z s" #'vc-git-stash-snapshot + "z p" #'vc-git-stash-pop) + +(define-minor-mode vc-dir-git-mode + "A minor mode for git-specific commands in `vc-dir-mode' buffers. +Also note that there are git stash commands available in the +\"Stash\" section at the head of the buffer." + :lighter " Git") + (provide 'vc-git) ;;; vc-git.el ends here diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el index 0ed9f7c31fe..6bec9edbf35 100644 --- a/lisp/vc/vc-hg.el +++ b/lisp/vc/vc-hg.el @@ -672,7 +672,6 @@ Return the byte's value as an integer." (let* ((result nil) (flen (length fname)) (case-fold-search nil) - (inhibit-changing-match-data t) ;; Find a conservative bound for the loop below by using ;; Boyer-Moore on the raw dirstate without parsing it; we ;; know we can't possibly find fname _after_ the last place @@ -976,10 +975,9 @@ REPO must be the directory name of an hg repository." "Test whether the ignore pattern set HGIP says to ignore FILENAME. FILENAME must be the file's true absolute name." (let ((patterns (vc-hg--ignore-patterns-ignore-patterns hgip)) - (inhibit-changing-match-data t) (ignored nil)) (while (and patterns (not ignored)) - (setf ignored (string-match (pop patterns) filename))) + (setf ignored (string-match-p (pop patterns) filename))) ignored)) (defvar vc-hg--cached-ignore-patterns nil @@ -1043,7 +1041,8 @@ Avoids the need to repeatedly scan dirstate on repeated calls to (equal size (pop cache)) (equal ascii-fname (pop cache))) (pop cache) - (let ((result (vc-hg--raw-dirstate-search dirstate ascii-fname))) + (let ((result (save-match-data + (vc-hg--raw-dirstate-search dirstate ascii-fname)))) (setf vc-hg--dirstate-scan-cache (list dirstate mtime size ascii-fname result)) result)))) diff --git a/lisp/vc/vc-hooks.el b/lisp/vc/vc-hooks.el index b7760e3bba5..cd5b11d840b 100644 --- a/lisp/vc/vc-hooks.el +++ b/lisp/vc/vc-hooks.el @@ -864,7 +864,8 @@ In the latter case, VC mode is deactivated for this buffer." (defvar vc-prefix-map (let ((map (make-sparse-keymap))) (define-key map "a" #'vc-update-change-log) - (define-key map "b" #'vc-switch-backend) + (with-suppressed-warnings ((obsolete vc-switch-backend)) + (define-key map "b" #'vc-switch-backend)) (define-key map "d" #'vc-dir) (define-key map "g" #'vc-annotate) (define-key map "G" #'vc-ignore) 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 67003c83926..ba94d908d10 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -739,6 +739,7 @@ (require 'cl-lib) (declare-function diff-setup-whitespace "diff-mode" ()) +(declare-function diff-setup-buffer-type "diff-mode" ()) (eval-when-compile (require 'dired)) @@ -937,11 +938,20 @@ repository, prompting for the directory and the VC backend to use." (catch 'found ;; First try: find a responsible backend, it must be a backend - ;; under which FILE is not yet registered. - (dolist (backend vc-handled-backends) - (and (not (vc-call-backend backend 'registered file)) - (vc-call-backend backend 'responsible-p file) - (throw 'found backend))) + ;; under which FILE is not yet registered and with the most + ;; specific path to FILE. + (let ((max 0) + bk) + (dolist (backend vc-handled-backends) + (when (not (vc-call-backend backend 'registered file)) + (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 + (throw 'found bk))) ;; no responsible backend (let* ((possible-backends (let (pos) @@ -969,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)))) @@ -1188,7 +1198,11 @@ For old-style locking-based version control systems, like RCS: *vc-log* buffer to check in the changes. Leave a read-only copy of each changed file after checking in. If every file is locked by you and unchanged, unlock them. - If every file is locked by someone else, offer to steal the lock." + If every file is locked by someone else, offer to steal the lock. + +When using this command to register a new file (or files), it +will automatically deduce which VC repository to register it +with, using the most specific one." (interactive "P") (let* ((vc-fileset (vc-deduce-fileset nil t 'state-model-only-files)) (backend (car vc-fileset)) @@ -1728,6 +1742,7 @@ to override the value of `vc-diff-switches' and `diff-switches'." (insert (cdr messages) ".\n") (message "%s" (cdr messages)))) (diff-setup-whitespace) + (diff-setup-buffer-type) (goto-char (point-min)) (when window (shrink-window-if-larger-than-buffer window))) @@ -1863,13 +1878,10 @@ Return t if the buffer had changes, nil otherwise." (vc-working-revision first)))) (when (string= rev1-default "") (setq rev1-default nil)))) ;; construct argument list - (let* ((rev1-prompt (if rev1-default - (concat "Older revision (default " - rev1-default "): ") - "Older revision: ")) - (rev2-prompt (concat "Newer revision (default " - ;; (or rev2-default - "current source): ")) + (let* ((rev1-prompt (format-prompt "Older revision" rev1-default)) + (rev2-prompt (format-prompt "Newer revision" + ;; (or rev2-default + "current source")) (rev1 (vc-read-revision rev1-prompt files backend rev1-default)) (rev2 (vc-read-revision rev2-prompt files backend nil))) ;; rev2-default (when (string= rev1 "") (setq rev1 nil)) @@ -2082,7 +2094,7 @@ If `F.~REV~' already exists, use it instead of checking it out again." (with-current-buffer (or (buffer-base-buffer) (current-buffer)) (vc-ensure-vc-buffer) (list - (vc-read-revision "Revision to visit (default is working revision): " + (vc-read-revision (format-prompt "Revision to visit" "working revision") (list buffer-file-name))))) (set-buffer (or (buffer-base-buffer) (current-buffer))) (vc-ensure-vc-buffer) @@ -2378,7 +2390,7 @@ This function runs the hook `vc-retrieve-tag-hook' when finished." (read-directory-name "Directory: " default-directory nil t)))) (list dir - (vc-read-revision "Tag name to retrieve (default latest revisions): " + (vc-read-revision (format-prompt "Tag name to retrieve" "latest revisions") (list dir) (vc-responsible-backend dir))))) (let* ((backend (vc-responsible-backend dir)) @@ -2743,7 +2755,7 @@ to the working revision (except for keyword expansion)." (unwind-protect (when (if vc-revert-show-diff (progn - (setq diff-buffer (generate-new-buffer-name "*vc-diff*")) + (setq diff-buffer (generate-new-buffer "*vc-diff*")) (vc-diff-internal vc-allow-async-revert vc-fileset nil nil nil diff-buffer)) ;; Avoid querying the user again. 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/view.el b/lisp/view.el index 3476ced3f79..321bc5f5660 100644 --- a/lisp/view.el +++ b/lisp/view.el @@ -36,8 +36,8 @@ ;;; Suggested key bindings: ;; -;; (define-key ctl-x-4-map "v" #'view-file-other-window) ; ^x4v -;; (define-key ctl-x-5-map "v" #'view-file-other-frame) ; ^x5v +;; (keymap-set ctl-x-4-map "v" #'view-file-other-window) ; C-x 4 v +;; (keymap-set ctl-x-5-map "v" #'view-file-other-frame) ; C-x 5 v ;; ;; You could also bind `view-file', `view-buffer', `view-buffer-other-window' and ;; `view-buffer-other-frame' to keys. @@ -142,68 +142,68 @@ that use View mode automatically.") (defvar-local view-overlay nil "Overlay used to display where a search operation found its match. This is local in each buffer, once it is used.") + -;; Define keymap inside defvar to make it easier to load changes. ;; Some redundant "less"-like key bindings below have been commented out. -(defvar view-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "C" #'View-kill-and-leave) - (define-key map "c" #'View-leave) - (define-key map "Q" #'View-quit-all) - (define-key map "E" #'View-exit-and-edit) - ;; (define-key map "v" #'View-exit) - (define-key map "e" #'View-exit) - (define-key map "q" #'View-quit) - ;; (define-key map "N" #'View-search-last-regexp-backward) - (define-key map "p" #'View-search-last-regexp-backward) - (define-key map "n" #'View-search-last-regexp-forward) - ;; (define-key map "?" #'View-search-regexp-backward) ; Less does this. - (define-key map "\\" #'View-search-regexp-backward) - (define-key map "/" #'View-search-regexp-forward) - (define-key map "r" #'isearch-backward) - (define-key map "s" #'isearch-forward) - (define-key map "m" #'point-to-register) - (define-key map "'" #'register-to-point) - (define-key map "x" #'exchange-point-and-mark) - (define-key map "@" #'View-back-to-mark) - (define-key map "." #'set-mark-command) - (define-key map "%" #'View-goto-percent) - ;; (define-key map "G" #'View-goto-line-last) - (define-key map "g" #'View-goto-line) - (define-key map "=" #'what-line) - (define-key map "F" #'View-revert-buffer-scroll-page-forward) - ;; (define-key map "k" #'View-scroll-line-backward) - (define-key map "y" #'View-scroll-line-backward) - ;; (define-key map "j" #'View-scroll-line-forward) - (define-key map "\n" #'View-scroll-line-forward) - (define-key map "\r" #'View-scroll-line-forward) - (define-key map "u" #'View-scroll-half-page-backward) - (define-key map "d" #'View-scroll-half-page-forward) - (define-key map "z" #'View-scroll-page-forward-set-page-size) - (define-key map "w" #'View-scroll-page-backward-set-page-size) - ;; (define-key map "b" #'View-scroll-page-backward) - (define-key map "\C-?" #'View-scroll-page-backward) - ;; (define-key map "f" #'View-scroll-page-forward) - (define-key map " " #'View-scroll-page-forward) - (define-key map [?\S-\ ] #'View-scroll-page-backward) - (define-key map "o" #'View-scroll-to-buffer-end) - (define-key map ">" #'end-of-buffer) - (define-key map "<" #'beginning-of-buffer) - (define-key map "-" #'negative-argument) - (define-key map "9" #'digit-argument) - (define-key map "8" #'digit-argument) - (define-key map "7" #'digit-argument) - (define-key map "6" #'digit-argument) - (define-key map "5" #'digit-argument) - (define-key map "4" #'digit-argument) - (define-key map "3" #'digit-argument) - (define-key map "2" #'digit-argument) - (define-key map "1" #'digit-argument) - (define-key map "0" #'digit-argument) - (define-key map "H" #'describe-mode) - (define-key map "?" #'describe-mode) ; Maybe do as less instead? See above. - (define-key map "h" #'describe-mode) - map)) +(defvar-keymap view-mode-map + :doc "Keymap for ‘view-mode’." + "C" #'View-kill-and-leave + "c" #'View-leave + "Q" #'View-quit-all + "E" #'View-exit-and-edit + ;; "v" #'View-exit + "e" #'View-exit + "q" #'View-quit + ;; "N" #'View-search-last-regexp-backward + "p" #'View-search-last-regexp-backward + "n" #'View-search-last-regexp-forward + ;; "?" #'View-search-regexp-backward ; Less does this. + "\\" #'View-search-regexp-backward + "/" #'View-search-regexp-forward + "r" #'isearch-backward + "s" #'isearch-forward + "m" #'point-to-register + "'" #'register-to-point + "x" #'exchange-point-and-mark + "@" #'View-back-to-mark + "." #'set-mark-command + "%" #'View-goto-percent + ;; "G" #'View-goto-line-last + "g" #'View-goto-line + "=" #'what-line + "F" #'View-revert-buffer-scroll-page-forward + ;; "k" #'View-scroll-line-backward + "y" #'View-scroll-line-backward + ;; "j" #'View-scroll-line-forward + "C-j" #'View-scroll-line-forward + "RET" #'View-scroll-line-forward + "u" #'View-scroll-half-page-backward + "d" #'View-scroll-half-page-forward + "z" #'View-scroll-page-forward-set-page-size + "w" #'View-scroll-page-backward-set-page-size + ;; "b" #'View-scroll-page-backward + "DEL" #'View-scroll-page-backward + ;; "f" #'View-scroll-page-forward + "SPC" #'View-scroll-page-forward + "S-SPC" #'View-scroll-page-backward + "o" #'View-scroll-to-buffer-end + ">" #'end-of-buffer + "<" #'beginning-of-buffer + "-" #'negative-argument + "9" #'digit-argument + "8" #'digit-argument + "7" #'digit-argument + "6" #'digit-argument + "5" #'digit-argument + "4" #'digit-argument + "3" #'digit-argument + "2" #'digit-argument + "1" #'digit-argument + "0" #'digit-argument + "H" #'describe-mode + "?" #'describe-mode ; Maybe do as less instead? See above. + "h" #'describe-mode) + ;;; Commands that enter or exit view mode. diff --git a/lisp/wdired.el b/lisp/wdired.el index eb5a6385563..2e09bf5d9e3 100644 --- a/lisp/wdired.el +++ b/lisp/wdired.el @@ -155,26 +155,24 @@ nonexistent directory will fail." :version "26.1" :type 'boolean) -(defvar wdired-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-x\C-s" #'wdired-finish-edit) - (define-key map "\C-c\C-c" #'wdired-finish-edit) - (define-key map "\C-c\C-k" #'wdired-abort-changes) - (define-key map "\C-c\C-[" #'wdired-abort-changes) - (define-key map "\C-x\C-q" #'wdired-exit) - (define-key map "\C-m" #'undefined) - (define-key map "\C-j" #'undefined) - (define-key map "\C-o" #'undefined) - (define-key map [up] #'wdired-previous-line) - (define-key map "\C-p" #'wdired-previous-line) - (define-key map [down] #'wdired-next-line) - (define-key map "\C-n" #'wdired-next-line) - (define-key map [remap upcase-word] #'wdired-upcase-word) - (define-key map [remap capitalize-word] #'wdired-capitalize-word) - (define-key map [remap downcase-word] #'wdired-downcase-word) - (define-key map [remap self-insert-command] #'wdired--self-insert) - map) - "Keymap used in `wdired-mode'.") +(defvar-keymap wdired-mode-map + :doc "Keymap used in `wdired-mode'." + "C-x C-s" #'wdired-finish-edit + "C-c C-c" #'wdired-finish-edit + "C-c C-k" #'wdired-abort-changes + "C-c C-[" #'wdired-abort-changes + "C-x C-q" #'wdired-exit + "RET" #'undefined + "C-j" #'undefined + "C-o" #'undefined + "<up>" #'wdired-previous-line + "C-p" #'wdired-previous-line + "<down>" #'wdired-next-line + "C-n" #'wdired-next-line + "<remap> <upcase-word>" #'wdired-upcase-word + "<remap> <capitalize-word>" #'wdired-capitalize-word + "<remap> <downcase-word>" #'wdired-downcase-word + "<remap> <self-insert-command>" #'wdired--self-insert) (easy-menu-define wdired-mode-menu wdired-mode-map "Menu for `wdired-mode'." @@ -872,21 +870,19 @@ Like original function but it skips read-only words." ;; The following code deals with changing the access bits (or ;; permissions) of the files. -(defvar wdired-perm-mode-map - (let ((map (make-sparse-keymap))) - (define-key map " " #'wdired-toggle-bit) - (define-key map "r" #'wdired-set-bit) - (define-key map "w" #'wdired-set-bit) - (define-key map "x" #'wdired-set-bit) - (define-key map "-" #'wdired-set-bit) - (define-key map "S" #'wdired-set-bit) - (define-key map "s" #'wdired-set-bit) - (define-key map "T" #'wdired-set-bit) - (define-key map "t" #'wdired-set-bit) - (define-key map "s" #'wdired-set-bit) - (define-key map "l" #'wdired-set-bit) - (define-key map [mouse-1] #'wdired-mouse-toggle-bit) - map)) +(defvar-keymap wdired-perm-mode-map + "SPC" #'wdired-toggle-bit + "r" #'wdired-set-bit + "w" #'wdired-set-bit + "x" #'wdired-set-bit + "-" #'wdired-set-bit + "S" #'wdired-set-bit + "s" #'wdired-set-bit + "T" #'wdired-set-bit + "t" #'wdired-set-bit + "s" #'wdired-set-bit + "l" #'wdired-set-bit + "<mouse-1>" #'wdired-mouse-toggle-bit) ;; Put a keymap property to the permission bits of the files, and store the ;; original name and permissions as a property diff --git a/lisp/whitespace.el b/lisp/whitespace.el index 017409d6a42..5a482c5253a 100644 --- a/lisp/whitespace.el +++ b/lisp/whitespace.el @@ -1687,32 +1687,32 @@ cleaning up these problems." (or whitespace-active-style whitespace-style))) (bogus-list (mapcar - #'(lambda (option) - (when force - (push (car option) style)) - (goto-char rstart) - (let ((regexp - (cond - ((eq (car option) 'indentation) - (whitespace-indentation-regexp)) - ((eq (car option) 'indentation::tab) - (whitespace-indentation-regexp 'tab)) - ((eq (car option) 'indentation::space) - (whitespace-indentation-regexp 'space)) - ((eq (car option) 'space-after-tab) - (whitespace-space-after-tab-regexp)) - ((eq (car option) 'space-after-tab::tab) - (whitespace-space-after-tab-regexp 'tab)) - ((eq (car option) 'space-after-tab::space) - (whitespace-space-after-tab-regexp 'space)) - ((eq (car option) 'missing-newline-at-eof) - "[^\n]\\'") - (t - (cdr option))))) - (when (re-search-forward regexp rend t) - (unless has-bogus - (setq has-bogus (memq (car option) style))) - t))) + (lambda (option) + (when force + (push (car option) style)) + (goto-char rstart) + (let ((regexp + (cond + ((eq (car option) 'indentation) + (whitespace-indentation-regexp)) + ((eq (car option) 'indentation::tab) + (whitespace-indentation-regexp 'tab)) + ((eq (car option) 'indentation::space) + (whitespace-indentation-regexp 'space)) + ((eq (car option) 'space-after-tab) + (whitespace-space-after-tab-regexp)) + ((eq (car option) 'space-after-tab::tab) + (whitespace-space-after-tab-regexp 'tab)) + ((eq (car option) 'space-after-tab::space) + (whitespace-space-after-tab-regexp 'space)) + ((eq (car option) 'missing-newline-at-eof) + "[^\n]\\'") + (t + (cdr option))))) + (when (re-search-forward regexp rend t) + (unless has-bogus + (setq has-bogus (memq (car option) style))) + t))) whitespace-report-list))) (when (pcase report-if-bogus ('nil t) ('never nil) (_ has-bogus)) (whitespace-kill-buffer whitespace-report-buffer-name) @@ -2463,5 +2463,4 @@ It should be added buffer-locally to `write-file-functions'." "use `with-eval-after-load' instead." "28.1") (run-hooks 'whitespace-load-hook) - ;;; whitespace.el ends here diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index a2e9bf41ade..22f3d299081 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -131,16 +131,21 @@ This exists as a variable so it can be set locally in certain buffers.") (((class grayscale color) (background light)) :background "gray85" + ;; We use negative thickness of the horizontal box border line to + ;; avoid making lines taller when fields become visible. + :box (:line-width (1 . -1) :color "gray80") :extend t) (((class grayscale color) (background dark)) :background "dim gray" + :box (:line-width (1 . -1) :color "gray46") :extend t) (t :slant italic :extend t)) "Face used for editable fields." - :group 'widget-faces) + :group 'widget-faces + :version "28.1") (defface widget-single-line-field '((((type tty)) :background "green3" @@ -432,8 +437,9 @@ the :notify function can't know the new value.") (follow-link (widget-get widget :follow-link)) (help-echo (widget-get widget :help-echo))) (widget-put widget :button-overlay overlay) - (if (functionp help-echo) + (when (functionp help-echo) (setq help-echo 'widget-mouse-help)) + (overlay-put overlay 'before-string #(" " 0 1 (invisible t))) (overlay-put overlay 'button widget) (overlay-put overlay 'keymap (widget-get widget :keymap)) (overlay-put overlay 'evaporate t) @@ -2963,7 +2969,8 @@ Save CHILD into the :last-deleted list, so it can be inserted later." "A widget which groups other widgets inside." :convert-widget 'widget-types-convert-widget :copy 'widget-types-copy - :format ":\n%v" + :format (concat (propertize ":" 'display "") + "\n%v") :value-create 'widget-group-value-create :value-get 'widget-editable-list-value-get :default-get 'widget-group-default-get @@ -3320,7 +3327,7 @@ It reads a file name from an editable text field." ;;; (file (file-name-nondirectory value)) ;;; (menu-tag (widget-apply widget :menu-tag-get)) ;;; (must-match (widget-get widget :must-match)) -;;; (answer (read-file-name (concat menu-tag " (default " value "): ") +;;; (answer (read-file-name (format-prompt menu-tag value) ;;; dir nil must-match file))) ;;; (widget-value-set widget (abbreviate-file-name answer)) ;;; (widget-setup) diff --git a/lisp/widget.el b/lisp/widget.el index 393fe6c21b3..0232f6cf93f 100644 --- a/lisp/widget.el +++ b/lisp/widget.el @@ -44,7 +44,7 @@ ;; (list 'or (list 'boundp (list 'car 'keywords)) ;; (list 'set (list 'car 'keywords) (list 'car 'keywords))) ;; (list 'setq 'keywords (list 'cdr 'keywords))))) - (declare (obsolete nil "27.1")) + (declare (obsolete nil "27.1") (indent defun)) nil) ;;(define-widget-keywords :documentation-indent @@ -83,7 +83,7 @@ create identical widgets: * (apply #\\='widget-create CLASS ARGS) The third argument DOC is a documentation string for the widget." - (declare (doc-string 3)) + (declare (doc-string 3) (indent defun)) ;; (unless (or (null doc) (stringp doc)) (error "Widget documentation must be nil or a 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/window.el b/lisp/window.el index ce1e6098748..eb063a36460 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -108,11 +108,14 @@ Return the buffer." ;; Return the buffer. buffer))) +;; Defined in help.el. +(defvar resize-temp-buffer-window-inhibit) + (defun temp-buffer-window-show (buffer &optional action) "Show temporary buffer BUFFER in a window. Return the window showing BUFFER. Pass ACTION as action argument to `display-buffer'." - (let (window frame) + (let (resize-temp-buffer-window-inhibit window) (with-current-buffer buffer (set-buffer-modified-p nil) (setq buffer-read-only t) @@ -130,9 +133,9 @@ to `display-buffer'." t window-combination-limit))) (setq window (display-buffer buffer action))) - (setq frame (window-frame window)) - (unless (eq frame (selected-frame)) - (raise-frame frame)) + ;; We used to raise the window's frame here. Do not do that + ;; since it would override an `inhibit-switch-frame' entry + ;; specified for the action alist used by `display-buffer'. (setq minibuffer-scroll-window window) (set-window-hscroll window 0) (with-selected-window window @@ -1514,21 +1517,11 @@ Emacs won't change the size of any window displaying that buffer, unless it has no other choice (like when deleting a neighboring window).") -(defun window--preservable-size (window &optional horizontal) - "Return height of WINDOW as `window-preserve-size' would preserve it. -Optional argument HORIZONTAL non-nil means to return the width of -WINDOW as `window-preserve-size' would preserve it." - (if horizontal - (window-body-width window t) - (+ (window-body-height window t) - (window-header-line-height window) - (window-mode-line-height window)))) - (defun window-preserve-size (&optional window horizontal preserve) - "Preserve height of window WINDOW. + "Preserve height of specified WINDOW's body. WINDOW must be a live window and defaults to the selected one. -Optional argument HORIZONTAL non-nil means preserve the width of -WINDOW. +Optional argument HORIZONTAL non-nil means to preserve the width +of WINDOW's body. PRESERVE t means to preserve the current height/width of WINDOW's body in frame and window resizing operations whenever possible. @@ -1545,21 +1538,15 @@ WINDOW as argument also removes the respective restraint. Other values of PRESERVE are reserved for future use." (setq window (window-normalize-window window t)) (let* ((parameter (window-parameter window 'window-preserved-size)) - (width (nth 1 parameter)) - (height (nth 2 parameter))) - (if horizontal - (set-window-parameter - window 'window-preserved-size - (list - (window-buffer window) - (and preserve (window--preservable-size window t)) - height)) - (set-window-parameter - window 'window-preserved-size - (list - (window-buffer window) - width - (and preserve (window--preservable-size window))))))) + (width (if horizontal + (and preserve (window-body-width window t)) + (nth 1 parameter))) + (height (if horizontal + (nth 2 parameter) + (and preserve (window-body-height window t))))) + (set-window-parameter + window 'window-preserved-size + (list (window-buffer window) width height)))) (defun window-preserved-size (&optional window horizontal) "Return preserved height of window WINDOW. @@ -1567,12 +1554,9 @@ WINDOW must be a live window and defaults to the selected one. Optional argument HORIZONTAL non-nil means to return preserved width of WINDOW." (setq window (window-normalize-window window t)) - (let* ((parameter (window-parameter window 'window-preserved-size)) - (buffer (nth 0 parameter)) - (width (nth 1 parameter)) - (height (nth 2 parameter))) - (when (eq buffer (window-buffer window)) - (if horizontal width height)))) + (let ((parameter (window-parameter window 'window-preserved-size))) + (when (eq (nth 0 parameter) (window-buffer window)) + (nth (if horizontal 1 2) parameter)))) (defun window--preserve-size (window horizontal) "Return non-nil when the height of WINDOW shall be preserved. @@ -1580,7 +1564,7 @@ Optional argument HORIZONTAL non-nil means to return non-nil when the width of WINDOW shall be preserved." (let ((size (window-preserved-size window horizontal))) (and (numberp size) - (= size (window--preservable-size window horizontal))))) + (= size (window-body-size window horizontal t))))) (defun window-safe-min-size (&optional window horizontal pixelwise) "Return safe minimum size of WINDOW. @@ -7253,11 +7237,15 @@ Return WINDOW if BUFFER and WINDOW are live." (inhibit-modification-hooks t)) (funcall (cdr (assq 'body-function alist)) window))) - (let ((quit-restore (window-parameter window 'quit-restore)) - (height (cdr (assq 'window-height alist))) - (width (cdr (assq 'window-width alist))) - (size (cdr (assq 'window-size alist))) - (preserve-size (cdr (assq 'preserve-size alist)))) + (let* ((frame (window-frame window)) + (quit-restore (window-parameter window 'quit-restore)) + (window-height (assq 'window-height alist)) + (height (cdr window-height)) + (window-width (assq 'window-width alist)) + (width (cdr window-width)) + (window-size (assq 'window-size alist)) + (size (cdr window-size)) + (preserve-size (cdr (assq 'preserve-size alist)))) (cond ((or (eq type 'frame) (and (eq (car quit-restore) 'same) @@ -7268,29 +7256,43 @@ Return WINDOW if BUFFER and WINDOW are live." ;; Adjust size of frame if asked for. We probably should do ;; that only for a single window frame. (cond - ((not size)) + ((not size) + (when window-size + (setq resize-temp-buffer-window-inhibit t))) ((consp size) - (let ((width (car size)) - (height (cdr size)) - (frame (window-frame window))) - (when (and (numberp width) (numberp height)) - (set-frame-height - frame (+ (frame-height frame) - (- height (window-total-height window)))) - (set-frame-width - frame (+ (frame-width frame) - (- width (window-total-width window))))))) - ((functionp size) - (ignore-errors (funcall size window))))) + ;; Modifying the parameters of a newly created frame might + ;; not work everywhere, but then `temp-buffer-resize-mode' + ;; will certainly fail in a similar fashion. + (if (eq (car size) 'body-chars) + (let ((width (+ (frame-text-width frame) + (* (frame-char-width frame) (cadr size)) + (- (window-body-width window t)))) + (height (+ (frame-text-height frame) + (* (frame-char-height frame) (cddr size)) + (- (window-body-height window t))))) + (modify-frame-parameters + frame `((height . (text-pixels . ,height)) + (width . (text-pixels . ,width))))) + (let ((width (- (+ (frame-width frame) (car size)) + (window-total-width window))) + (height (- (+ (frame-height frame) (cdr size)) + (window-total-height window)))) + (modify-frame-parameters + frame `((height . ,height) (width . ,width))))) + (setq resize-temp-buffer-window-inhibit t)) + ((functionp size) + (ignore-errors (funcall size window)) + (setq resize-temp-buffer-window-inhibit t)))) ((or (eq type 'window) (and (eq (car quit-restore) 'same) (eq (nth 1 quit-restore) 'window))) ;; A window that never showed another buffer but BUFFER ever - ;; since it was created on an existing frame. - ;; - ;; Adjust width and/or height of window if asked for. + ;; since it was created on an existing frame. Adjust its width + ;; and/or height if asked for. (cond - ((not height)) + ((not height) + (when window-height + (setq resize-temp-buffer-window-inhibit 'vertical))) ((numberp height) (let* ((new-height (if (integerp height) @@ -7301,12 +7303,23 @@ Return WINDOW if BUFFER and WINDOW are live." (delta (- new-height (window-total-height window)))) (when (and (window--resizable-p window delta nil 'safe) (window-combined-p window)) - (window-resize window delta nil 'safe)))) - ((functionp height) - (ignore-errors (funcall height window)))) + (window-resize window delta nil 'safe))) + (setq resize-temp-buffer-window-inhibit 'vertical)) + ((and (consp height) (eq (car height) 'body-lines)) + (let* ((delta (- (* (frame-char-height frame) (cdr height)) + (window-body-height window t)))) + (and (window--resizable-p window delta nil 'safe nil nil nil t) + (window-combined-p window) + (window-resize window delta nil 'safe t))) + (setq resize-temp-buffer-window-inhibit 'vertical)) + ((functionp height) + (ignore-errors (funcall height window)) + (setq resize-temp-buffer-window-inhibit 'vertical))) ;; Adjust width of window if asked for. (cond - ((not width)) + ((not width) + (when window-width + (setq resize-temp-buffer-window-inhibit 'horizontal))) ((numberp width) (let* ((new-width (if (integerp width) @@ -7317,13 +7330,24 @@ Return WINDOW if BUFFER and WINDOW are live." (delta (- new-width (window-total-width window)))) (when (and (window--resizable-p window delta t 'safe) (window-combined-p window t)) - (window-resize window delta t 'safe)))) + (window-resize window delta t 'safe))) + (setq resize-temp-buffer-window-inhibit 'horizontal)) + ((and (consp width) (eq (car width) 'body-columns)) + (let* ((delta (- (* (frame-char-width frame) (cdr width)) + (window-body-width window t)))) + (and (window--resizable-p window delta t 'safe nil nil nil t) + (window-combined-p window t) + (window-resize window delta t 'safe t))) + (setq resize-temp-buffer-window-inhibit 'horizontal)) ((functionp width) - (ignore-errors (funcall width window)))) + (ignore-errors (funcall width window)) + (setq resize-temp-buffer-window-inhibit 'horizontal))) + ;; Preserve window size if asked for. (when (consp preserve-size) (window-preserve-size window t (car preserve-size)) (window-preserve-size window nil (cdr preserve-size))))) + ;; Assign any window parameters specified. (let ((parameters (cdr (assq 'window-parameters alist)))) (dolist (parameter parameters) @@ -7450,6 +7474,14 @@ ALIST. See `display-buffer' for details." :version "24.1" :group 'windows) +(defcustom display-comint-buffer-action 'display-buffer-same-window + "The action to display a comint buffer." + :type display-buffer--action-function-custom-type + :risky t + :version "29.1" + :group 'windows + :group 'comint) + (defconst display-buffer-fallback-action '((display-buffer--maybe-same-window ;FIXME: why isn't this redundant? display-buffer-reuse-window @@ -7566,6 +7598,9 @@ Action alist entries are: window from being used for display. `inhibit-switch-frame' -- A non-nil value prevents any frame used for showing the buffer from being raised or selected. + Note that a window manager may still raise a new frame and + give it focus, effectively overriding the value specified + here. `reusable-frames' -- The value specifies the set of frames to search for a window that already displays the buffer. Possible values are nil (the selected frame), t (any live @@ -7575,20 +7610,33 @@ Action alist entries are: frame parameters to give a new frame, if one is created. `window-height' -- The value specifies the desired height of the window chosen and is either an integer (the total height of - the window), a floating point number (the fraction of its - total height with respect to the total height of the frame's - root window) or a function to be called with one argument - - the chosen window. The function is supposed to adjust the - height of the window; its return value is ignored. Suitable - functions are `shrink-window-if-larger-than-buffer' and - `fit-window-to-buffer'. + the window specified in frame lines), a floating point + number (the fraction of its total height with respect to the + total height of the frame's root window), a cons cell whose + car is 'body-lines' and whose cdr is an integer that + specifies the height of the window's body in frame lines, or + a function to be called with one argument - the chosen + window. That function is supposed to adjust the height of + the window. Suitable functions are `fit-window-to-buffer' + and `shrink-window-if-larger-than-buffer'. `window-width' -- The value specifies the desired width of the window chosen and is either an integer (the total width of - the window), a floating point number (the fraction of its - total width with respect to the width of the frame's root - window) or a function to be called with one argument - the - chosen window. The function is supposed to adjust the width - of the window; its return value is ignored. + the window specified in frame lines), a floating point + number (the fraction of its total width with respect to the + width of the frame's root window), a cons cell whose car is + 'body-columns' and whose cdr is an integer that specifies the + width of the window's body in frame columns, or a function to + be called with one argument - the chosen window. That + function is supposed to adjust the width of the window. + `window-size' -- This entry is only useful for windows appearing + alone on their frame and specifies the desired size of that + window either as a cons of integers (the total width and + height of the window on that frame), a cons cell whose car is + 'body-chars' and whose cdr is a cons of integers (the desired + width and height of the window's body in columns and lines of + its frame), or a function to be called with one argument - + the chosen window. That function is supposed to adjust the + size of the frame. `preserve-size' -- The value should be either (t . nil) to preserve the width of the chosen window, (nil . t) to preserve its height or (t . t) to preserve its height and @@ -7604,9 +7652,9 @@ Action alist entries are: to fill the window body with some contents that might depend on dimensions of the displayed window. -The entries `window-height', `window-width' and `preserve-size' -are applied only when the window used for displaying the buffer -never showed another buffer before. +The entries `window-height', `window-width', `window-size' and +`preserve-size' are applied only when the window used for +displaying the buffer never showed another buffer before. The ACTION argument can also have a non-nil and non-list value. This means to display the buffer in a window other than the @@ -8537,7 +8585,7 @@ from the list of completions and default values." (let ((rbts-completion-table (internal-complete-buffer-except))) (minibuffer-with-setup-hook (lambda () - (setq minibuffer-completion-table rbts-completion-table) + (setq-local minibuffer-completion-table rbts-completion-table) ;; Since rbts-completion-table is built dynamically, we ;; can't just add it to the default value of ;; icomplete-with-completion-tables, so we add it diff --git a/lisp/xdg.el b/lisp/xdg.el index ee5d292ce65..60558982146 100644 --- a/lisp/xdg.el +++ b/lisp/xdg.el @@ -41,13 +41,11 @@ ;; XDG Base Directory Specification ;; https://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html -(defmacro xdg--dir-home (environ default-path) - (declare (debug (stringp stringp))) - (let ((env (make-symbol "env"))) - `(let ((,env (getenv ,environ))) - (if (or (null ,env) (not (file-name-absolute-p ,env))) - (expand-file-name ,default-path) - ,env)))) +(defun xdg--dir-home (environ default-path) + (let ((env (getenv environ))) + (if (or (null env) (not (file-name-absolute-p env))) + (expand-file-name default-path) + env))) (defun xdg-config-home () "Return the base directory for user specific configuration files. @@ -85,6 +83,23 @@ According to the XDG Base Directory Specification version should be used.\"" (xdg--dir-home "XDG_DATA_HOME" "~/.local/share")) +(defun xdg-state-home () + "Return the base directory for user-specific state data. + +According to the XDG Base Directory Specification version +0.8 (8th May 2021): + + \"The $XDG_STATE_HOME contains state data that should persist + between (application) restarts, but that is not important or + portable enough to the user that it should be stored in + $XDG_DATA_HOME. It may contain: + + * actions history (logs, history, recently used files, …) + + * current state of the application that can be reused on a + restart (view, layout, open files, undo history, …)\"" + (xdg--dir-home "XDG_STATE_HOME" "~/.local/state")) + (defun xdg-runtime-dir () "Return the value of $XDG_RUNTIME_DIR. diff --git a/lisp/xml.el b/lisp/xml.el index 0282e3741c0..e2ba02e1952 100644 --- a/lisp/xml.el +++ b/lisp/xml.el @@ -612,8 +612,8 @@ references." (if (setq ref (match-string 2)) (progn ; Numeric char reference (setq val (save-match-data - (decode-char 'ucs (string-to-number - ref (if (match-string 1) 16))))) + (string-to-number + ref (if (match-string 1) 16)))) (and (null val) xml-validating-parser (error "XML: (Validity) Invalid character reference `%s'" @@ -898,11 +898,11 @@ references and parameter-entity references." ref val) (cond ((setq ref (match-string 1 string)) ;; Decimal character reference - (setq val (decode-char 'ucs (string-to-number ref))) + (setq val (string-to-number ref)) (if val (push (string val) children))) ;; Hexadecimal character reference ((setq ref (match-string 2 string)) - (setq val (decode-char 'ucs (string-to-number ref 16))) + (setq val (string-to-number ref 16)) (if val (push (string val) children))) ;; Parameter entity reference ((setq ref (match-string 3 string)) @@ -962,7 +962,7 @@ STRING is assumed to occur in an XML attribute value." (if ref ;; [4.6] Character references are included as ;; character data. - (let ((val (decode-char 'ucs (string-to-number ref (if is-hex 16))))) + (let ((val (string-to-number ref (if is-hex 16)))) (push (cond (val (string val)) (xml-validating-parser (error "XML: (Validity) Undefined character `x%s'" ref)) diff --git a/lisp/xwidget.el b/lisp/xwidget.el index 8c593abea88..ab40e81c4d0 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -33,10 +33,12 @@ (require 'cl-lib) (require 'bookmark) +(require 'format-spec) (declare-function make-xwidget "xwidget.c" - (type title width height arguments &optional buffer)) + (type title width height arguments &optional buffer related)) (declare-function xwidget-buffer "xwidget.c" (xwidget)) +(declare-function set-xwidget-buffer "xwidget.c" (xwidget buffer)) (declare-function xwidget-size-request "xwidget.c" (xwidget)) (declare-function xwidget-resize "xwidget.c" (xwidget new-width new-height)) (declare-function xwidget-webkit-execute-script "xwidget.c" @@ -53,31 +55,34 @@ (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)) +(declare-function xwidget-info "xwidget.c" (xwidget)) (defgroup xwidget nil "Displaying native widgets in Emacs buffers." :group 'widgets) -(defun xwidget-insert (pos type title width height &optional args) +(defun xwidget-insert (pos type title width height &optional args related) "Insert an xwidget at position POS. -Supply the xwidget's TYPE, TITLE, WIDTH, and HEIGHT. +Supply the xwidget's TYPE, TITLE, WIDTH, HEIGHT, and RELATED. See `make-xwidget' for the possible TYPE values. The usage of optional argument ARGS depends on the xwidget. This returns the result of `make-xwidget'." (goto-char pos) - (let ((id (make-xwidget type title width height args))) + (let ((id (make-xwidget type title width height args nil related))) (put-text-property (point) (+ 1 (point)) 'display (list 'xwidget ':xwidget id)) id)) (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))) @@ -88,6 +93,29 @@ This returns the result of `make-xwidget'." (require 'seq) (require 'url-handlers) +(defgroup xwidget-webkit nil + "Displaying webkit xwidgets in Emacs buffers." + :version "29.1" + :group 'web + :prefix "xwidget-webkit-") + +(defcustom xwidget-webkit-buffer-name-format "*xwidget-webkit: %T*" + "Template for naming `xwidget-webkit' buffers. +It can use the following special constructs: + + %T -- the title of the Web page loaded by the xwidget. + %U -- the URI of the Web page loaded by the xwidget." + :type 'string + :version "29.1") + +(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) "Ask xwidget-webkit to browse URL. @@ -111,7 +139,7 @@ Interactively, URL defaults to the string looking like a url around point." Get the URL of current session, then browse to the URL in `split-window-below' with a new xwidget webkit session." (interactive nil xwidget-webkit-mode) - (let ((url (xwidget-webkit-current-url))) + (let ((url (xwidget-webkit-uri (xwidget-webkit-current-session)))) (with-selected-window (split-window-below) (xwidget-webkit-new-session url)))) @@ -120,10 +148,49 @@ in `split-window-below' with a new xwidget webkit session." Get the URL of current session, then browse to the URL in `split-window-right' with a new xwidget webkit session." (interactive nil xwidget-webkit-mode) - (let ((url (xwidget-webkit-current-url))) + (let ((url (xwidget-webkit-uri (xwidget-webkit-current-session)))) (with-selected-window (split-window-right) (xwidget-webkit-new-session url)))) +(declare-function xwidget-perform-lispy-event "xwidget.c") + +(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) + (let ((key (pop unread-command-events))) + (setq xwidget-webkit--input-method-events + (funcall input-method-function key)) + (exit-minibuffer))) + +(defun xwidget-webkit-pass-command-event () + "Pass `last-command-event' to the current buffer's WebKit widget. +If `current-input-method' is non-nil, consult `input-method-function' +for the actual events that will be sent." + (interactive) + (if (and current-input-method + (characterp last-command-event)) + (let ((xwidget-webkit--input-method-events nil) + (minibuffer-local-map (make-keymap))) + (define-key minibuffer-local-map [with-input-method] + 'xwidget-webkit-pass-command-event-with-input-method) + (push last-command-event unread-command-events) + (push 'with-input-method unread-command-events) + (read-from-minibuffer "" nil nil nil nil nil t) + (dolist (event xwidget-webkit--input-method-events) + (xwidget-perform-lispy-event (xwidget-webkit-current-session) + event))) + (xwidget-perform-lispy-event (xwidget-webkit-current-session) + last-command-event))) + ;;todo. ;; - check that the webkit support is compiled in (defvar xwidget-webkit-mode-map @@ -133,11 +200,14 @@ in `split-window-right' with a new xwidget webkit session." (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) (define-key map "-" 'xwidget-webkit-zoom-out) + (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) @@ -164,6 +234,70 @@ in `split-window-right' with a new xwidget webkit session." map) "Keymap for `xwidget-webkit-mode'.") +(easy-menu-define nil xwidget-webkit-mode-map "Xwidget WebKit menu." + (list "Xwidget WebKit" + ["Browse URL" xwidget-webkit-browse-url + :active t + :help "Prompt for a URL, then instruct WebKit to browse it"] + ["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"] + ["Zoom In" xwidget-webkit-zoom-in t] + ["Zoom Out" xwidget-webkit-zoom-out t] + ["Edit Mode" xwidget-webkit-edit-mode + :active t + :style toggle + :selected xwidget-webkit-edit-mode + :help "Send self inserting characters to the WebKit widget"] + ["Save Selection" xwidget-webkit-copy-selection-as-kill + :active t + :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"] + ["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 + xwidget-webkit-mode-map) + (tool-bar-local-item-from-menu 'xwidget-webkit-forward + "right-arrow" + map + xwidget-webkit-mode-map) + (tool-bar-local-item-from-menu 'xwidget-webkit-reload + "refresh" + map + xwidget-webkit-mode-map) + (tool-bar-local-item-from-menu 'xwidget-webkit-zoom-in + "zoom-in" + map + xwidget-webkit-mode-map) + (tool-bar-local-item-from-menu 'xwidget-webkit-zoom-out + "zoom-out" + map + xwidget-webkit-mode-map) + (tool-bar-local-item-from-menu 'xwidget-webkit-browse-url + "connect-to-url" + map + xwidget-webkit-mode-map) + (tool-bar-local-item-from-menu 'xwidget-webkit-isearch-mode + "search" + map + xwidget-webkit-mode-map)))) + (defun xwidget-webkit-zoom-in () "Increase webkit view zoom factor." (interactive nil xwidget-webkit-mode) @@ -214,23 +348,36 @@ If N is omitted or nil, scroll down by one line." (defun xwidget-webkit-scroll-forward (&optional n) "Scroll webkit horizontally by N chars. -The width of char is calculated with `window-font-width'. -If N is omitted or nil, scroll forwards by one char." +If the widget is larger than the window, hscroll by N columns +instead. The width of char is calculated with +`window-font-width'. If N is omitted or nil, scroll forwards by +one char." (interactive "p" xwidget-webkit-mode) - (xwidget-webkit-execute-script - (xwidget-webkit-current-session) - (format "window.scrollBy(%d, 0);" - (* n (window-font-width))))) + (let ((session (xwidget-webkit-current-session))) + (if (> (- (aref (xwidget-info session) 2) + (window-text-width nil t)) + (window-font-width)) + (set-window-hscroll nil (+ (window-hscroll) n)) + (xwidget-webkit-execute-script session + (format "window.scrollBy(%d, 0);" + (* n (window-font-width))))))) (defun xwidget-webkit-scroll-backward (&optional n) "Scroll webkit back by N chars. -The width of char is calculated with `window-font-width'. -If N is omitted or nil, scroll backwards by one char." +If the widget is larger than the window, hscroll backwards by N +columns instead. The width of char is calculated with +`window-font-width'. If N is omitted or nil, scroll backwards by +one char." (interactive "p" xwidget-webkit-mode) - (xwidget-webkit-execute-script - (xwidget-webkit-current-session) - (format "window.scrollBy(-%d, 0);" - (* n (window-font-width))))) + (let ((session (xwidget-webkit-current-session))) + (if (and (> (- (aref (xwidget-info session) 2) + (window-text-width nil t)) + (window-font-width)) + (> (window-hscroll) 0)) + (set-window-hscroll nil (- (window-hscroll) n)) + (xwidget-webkit-execute-script session + (format "window.scrollBy(%-d, 0);" + (* n (window-font-width))))))) (defun xwidget-webkit-scroll-top () "Scroll webkit to the very top." @@ -246,10 +393,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*"))) @@ -265,7 +415,18 @@ If N is omitted or nil, scroll backwards by one char." ((xwidget-event-type (nth 1 last-input-event)) (xwidget (nth 2 last-input-event)) (xwidget-callback (xwidget-get xwidget 'callback))) - (funcall xwidget-callback xwidget xwidget-event-type))) + (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-buffer-kill () + "Clean up an xwidget-webkit buffer before it is killed." + (when (timerp xwidget-webkit--progress-update-timer) + (cancel-timer xwidget-webkit--progress-update-timer))) (defun xwidget-webkit-callback (xwidget xwidget-event-type) "Callback for xwidgets. @@ -273,30 +434,58 @@ XWIDGET instance, XWIDGET-EVENT-TYPE depends on the originating xwidget." (if (not (buffer-live-p (xwidget-buffer xwidget))) (xwidget-log "error: callback called for xwidget with dead buffer") - (with-current-buffer (xwidget-buffer xwidget) - (cond ((eq xwidget-event-type 'load-changed) - (let ((title (xwidget-webkit-title xwidget))) - (xwidget-log "webkit finished loading: %s" title) - ;; Do not adjust webkit size to window here, the selected window - ;; can be the mini-buffer window unwantedly. - (rename-buffer (format "*xwidget webkit: %s *" title) t))) - ((eq xwidget-event-type 'decide-policy) - (let ((strarg (nth 3 last-input-event))) - (if (string-match ".*#\\(.*\\)" strarg) - (xwidget-webkit-show-id-or-named-element - xwidget - (match-string 1 strarg))))) - ;; TODO: Response handling other than download. - ((eq xwidget-event-type 'download-callback) - (let ((url (nth 3 last-input-event)) - (mime-type (nth 4 last-input-event)) - (file-name (nth 5 last-input-event))) - (xwidget-webkit-save-as-file url mime-type file-name))) - ((eq xwidget-event-type 'javascript-callback) - (let ((proc (nth 3 last-input-event)) - (arg (nth 4 last-input-event))) - (funcall proc arg))) - (t (xwidget-log "unhandled event:%s" xwidget-event-type)))))) + (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. + (when (or (string-equal (nth 3 last-input-event) + "load-finished") + (> (length title) 0)) + (with-current-buffer (xwidget-buffer xwidget) + (force-mode-line-update) + (xwidget-log "webkit finished loading: %s" title) + ;; Do not adjust webkit size to window here, the + ;; selected window can be the mini-buffer window + ;; unwantedly. + (rename-buffer + (format-spec + xwidget-webkit-buffer-name-format + `((?T . ,title) + (?U . ,uri))) + t))))) + ((eq xwidget-event-type 'decide-policy) + (let ((strarg (nth 3 last-input-event))) + (if (string-match ".*#\\(.*\\)" strarg) + (xwidget-webkit-show-id-or-named-element + xwidget + (match-string 1 strarg))))) + ;; TODO: Response handling other than download. + ((eq xwidget-event-type 'download-callback) + (let ((url (nth 3 last-input-event)) + (mime-type (nth 4 last-input-event)) + (file-name (nth 5 last-input-event))) + (xwidget-webkit-save-as-file url mime-type file-name))) + ((eq xwidget-event-type 'javascript-callback) + (let ((proc (nth 3 last-input-event)) + (arg (nth 4 last-input-event))) + (funcall proc arg))) + (t (xwidget-log "unhandled event:%s" xwidget-event-type))))) (defvar bookmark-make-record-function) (when (memq window-system '(mac ns)) @@ -309,8 +498,21 @@ If non-nil, plugins are enabled. Otherwise, disabled." (define-derived-mode xwidget-webkit-mode special-mode "xwidget-webkit" "Xwidget webkit view mode." (setq buffer-read-only t) + (add-hook 'kill-buffer-hook #'xwidget-webkit-buffer-kill) + (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 + (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)) @@ -343,24 +545,31 @@ directory, URL is saved at the specified directory as FILE-NAME." ;;; Bookmarks integration (defcustom xwidget-webkit-bookmark-jump-new-session nil - "Control bookmark jump to use new session or not. -If non-nil, use a new xwidget webkit session after bookmark jump. -Otherwise, it will use `xwidget-webkit-last-session'. -When you set this variable to nil, consider further customization with -`xwidget-webkit-last-session-buffer'." + "Whether to jump to a bookmarked URL in a new xwidget webkit session. +If non-nil, create a new xwidget webkit session, otherwise use +the value of `xwidget-webkit-last-session'." :version "28.1" :type 'boolean) (defun xwidget-webkit-bookmark-make-record () - "Create bookmark record in webkit xwidget. -See `xwidget-webkit-bookmark-jump-new-session' for whether this -should create a new session or not." + "Create a bookmark record for a webkit xwidget." (nconc (bookmark-make-record-default t t) `((page . ,(xwidget-webkit-uri (xwidget-webkit-current-session))) - (handler . (lambda (bmk) - (xwidget-webkit-browse-url - (bookmark-prop-get bmk 'page) - xwidget-webkit-bookmark-jump-new-session)))))) + (handler . xwidget-webkit-bookmark-jump-handler)))) + +;;;###autoload +(defun xwidget-webkit-bookmark-jump-handler (bookmark) + "Jump to the web page bookmarked by the bookmark record BOOKMARK. +If `xwidget-webkit-bookmark-jump-new-session' is non-nil, create +a new xwidget-webkit session, otherwise use an existing session." + (let* ((url (bookmark-prop-get bookmark 'page)) + (xwbuf (if (or xwidget-webkit-bookmark-jump-new-session + (not (xwidget-webkit-current-session))) + (xwidget-webkit--create-new-session-buffer url) + (xwidget-buffer (xwidget-webkit-current-session))))) + (with-current-buffer xwbuf + (xwidget-webkit-goto-uri (xwidget-webkit-current-session) url)) + (set-buffer xwbuf))) ;;; xwidget webkit session @@ -386,6 +595,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){ @@ -604,34 +817,91 @@ For example, use this to display an anchor." (add-to-list 'window-size-change-functions 'xwidget-webkit-adjust-size-in-frame)) -(defun xwidget-webkit-new-session (url &optional callback) - "Create a new webkit session buffer with URL." - (let* - ((bufname (generate-new-buffer-name "*xwidget-webkit*")) - (callback (or callback #'xwidget-webkit-callback)) - xw) - (setq xwidget-webkit-last-session-buffer (switch-to-buffer - (get-buffer-create bufname))) +(defun xwidget-webkit--create-new-session-buffer (url &optional callback) + "Create a new webkit session buffer to display URL in an xwidget. +Optional function CALLBACK specifies the callback for webkit xwidgets; +see `xwidget-webkit-callback'." + (let* ((bufname + ;; Generate a temp-name based on current buffer name. The + ;; buffer will subsequently be renamed by + ;; `xwidget-webkit-callback'. This approach can avoid + ;; flicker of buffer-name in mode-line. + (generate-new-buffer-name (buffer-name))) + (callback (or callback #'xwidget-webkit-callback)) + (current-session (xwidget-webkit-current-session)) + xw) + (setq xwidget-webkit-last-session-buffer (get-buffer-create bufname)) ;; The xwidget id is stored in a text property, so we need to have ;; at least character in this buffer. ;; Insert invisible url, good default for next `g' to browse url. - (let ((start (point))) - (insert url) - (put-text-property start (+ start (length url)) 'invisible t) - (setq xw (xwidget-insert - start 'webkit bufname - (xwidget-window-inside-pixel-width (selected-window)) - (xwidget-window-inside-pixel-height (selected-window))))) - (xwidget-put xw 'callback callback) - (xwidget-webkit-mode) - (xwidget-webkit-goto-uri (xwidget-webkit-last-session) url))) - + (with-current-buffer xwidget-webkit-last-session-buffer + (let ((start (point))) + (insert url) + (put-text-property start (+ start (length url)) 'invisible t) + (setq xw (xwidget-insert + start 'webkit bufname + (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-last-session-buffer)) + +(defun xwidget-webkit-new-session (url) + "Display URL in a new webkit xwidget." + (switch-to-buffer (xwidget-webkit--create-new-session-buffer url)) + (xwidget-webkit-goto-uri (xwidget-webkit-last-session) url)) + +(defun xwidget-webkit-import-widget (xwidget) + "Create a new webkit session buffer from XWIDGET, an existing xwidget. +Return the buffer." + (let* ((bufname + ;; Generate a temp-name based on current buffer name. it + ;; will be renamed by `xwidget-webkit-callback' in the + ;; future. This approach can limit flicker of buffer-name in + ;; mode-line. + (generate-new-buffer-name (buffer-name))) + (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) + "Trigger display callback for EVENT." + (interactive "e") + (let ((xwidget (cadr event)) + (source (caddr event))) + (when (xwidget-get source 'display-callback) + (funcall (xwidget-get source 'display-callback) + xwidget source)))) + +(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." (if (xwidget-webkit-current-session) (progn - (xwidget-webkit-goto-uri (xwidget-webkit-current-session) url)) + (xwidget-webkit-goto-uri (xwidget-webkit-current-session) url) + (switch-to-buffer (xwidget-buffer (xwidget-webkit-current-session)))) (xwidget-webkit-new-session url))) (defun xwidget-webkit-back () @@ -655,6 +925,15 @@ For example, use this to display an anchor." (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." @@ -684,7 +963,275 @@ You can retrieve the value with `xwidget-get'." (set-xwidget-plist xwidget (plist-put (xwidget-plist xwidget) propname value))) +(defvar xwidget-webkit-edit-mode-map (make-keymap)) + +(define-key xwidget-webkit-edit-mode-map [backspace] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [tab] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [left] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [right] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [up] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [down] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [return] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [C-left] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [C-right] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [C-up] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [C-down] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [C-return] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [S-left] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [S-right] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [S-up] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [S-down] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [S-return] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [M-left] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [M-right] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [M-up] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [M-down] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [M-return] 'xwidget-webkit-pass-command-event) + +(define-minor-mode xwidget-webkit-edit-mode + "Minor mode for editing the content of WebKit buffers. + +This defines most self-inserting characters and some common +keyboard shortcuts to `xwidget-webkit-pass-command-event', which +will pass the key events corresponding to these characters to the +WebKit widget." + :keymap xwidget-webkit-edit-mode-map) + +(substitute-key-definition 'self-insert-command + 'xwidget-webkit-pass-command-event + xwidget-webkit-edit-mode-map + global-map) + +(declare-function xwidget-webkit-search "xwidget.c") +(declare-function xwidget-webkit-next-result "xwidget.c") +(declare-function xwidget-webkit-previous-result "xwidget.c") +(declare-function xwidget-webkit-finish-search "xwidget.c") + +(defvar-local xwidget-webkit-isearch--string "" + "The current search query.") +(defvar-local xwidget-webkit-isearch--is-reverse nil + "Whether or not the current isearch should be reverse.") +(defvar xwidget-webkit-isearch--read-string-buffer nil + "The buffer we are reading input method text for, if any.") + +(defun xwidget-webkit-isearch--update (&optional only-message) + "Update the current buffer's WebKit widget's search query. +If ONLY-MESSAGE is non-nil, the query will not be sent to the +WebKit widget. The query will be set to the contents of +`xwidget-webkit-isearch--string'." + (unless only-message + (xwidget-webkit-search xwidget-webkit-isearch--string + (xwidget-webkit-current-session) + t xwidget-webkit-isearch--is-reverse t)) + (let ((message-log-max nil)) + (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." + (interactive (list (prefix-numeric-value current-prefix-arg))) + (when (> (length xwidget-webkit-isearch--string) 0) + (setq xwidget-webkit-isearch--string + (substring xwidget-webkit-isearch--string 0 + (- (length xwidget-webkit-isearch--string) count)))) + (xwidget-webkit-isearch--update)) + +(defun xwidget-webkit-isearch-with-input-method () + "Handle a request to use the input method to modify the search query." + (interactive) + (let ((key (car unread-command-events)) + events) + (setq unread-command-events (cdr unread-command-events) + events (funcall input-method-function key)) + (dolist (k events) + (with-current-buffer xwidget-webkit-isearch--read-string-buffer + (setq xwidget-webkit-isearch--string + (concat xwidget-webkit-isearch--string + (char-to-string k))))) + (exit-minibuffer))) + +(defun xwidget-webkit-isearch-printing-char-with-input-method (char) + "Handle printing char CHAR with the current input method." + (let ((minibuffer-local-map (make-keymap)) + (xwidget-webkit-isearch--read-string-buffer (current-buffer))) + (define-key minibuffer-local-map [with-input-method] + 'xwidget-webkit-isearch-with-input-method) + (setq unread-command-events + (cons 'with-input-method + (cons char unread-command-events))) + (read-string "Search contents: " + xwidget-webkit-isearch--string + 'junk-hist nil t) + (xwidget-webkit-isearch--update))) + +(defun xwidget-webkit-isearch-printing-char (char &optional count) + "Add ordinary character CHAR to the search string and search. +With argument, add COUNT copies of CHAR." + (interactive (list last-command-event + (prefix-numeric-value current-prefix-arg))) + (if current-input-method + (xwidget-webkit-isearch-printing-char-with-input-method char) + (setq xwidget-webkit-isearch--string (concat xwidget-webkit-isearch--string + (make-string (or count 1) char)))) + (xwidget-webkit-isearch--update)) + +(defun xwidget-webkit-isearch-forward (count) + "Move to the next search result COUNT times." + (interactive (list (prefix-numeric-value current-prefix-arg))) + (let ((was-reverse xwidget-webkit-isearch--is-reverse)) + (setq xwidget-webkit-isearch--is-reverse nil) + (when was-reverse + (xwidget-webkit-isearch--update) + (setq count (1- count)))) + (let ((i 0)) + (while (< i count) + (xwidget-webkit-next-result (xwidget-webkit-current-session)) + (cl-incf i))) + (xwidget-webkit-isearch--update t)) + +(defun xwidget-webkit-isearch-backward (count) + "Move to the previous search result COUNT times." + (interactive (list (prefix-numeric-value current-prefix-arg))) + (let ((was-reverse xwidget-webkit-isearch--is-reverse)) + (setq xwidget-webkit-isearch--is-reverse t) + (unless was-reverse + (xwidget-webkit-isearch--update) + (setq count (1- count)))) + (let ((i 0)) + (while (< i count) + (xwidget-webkit-previous-result (xwidget-webkit-current-session)) + (cl-incf i))) + (xwidget-webkit-isearch--update t)) + +(defun xwidget-webkit-isearch-exit () + "Exit incremental search of a WebKit buffer." + (interactive) + (xwidget-webkit-isearch-mode 0)) + +(defvar xwidget-webkit-isearch-mode-map (make-keymap) + "The keymap used inside xwidget-webkit-isearch-mode.") + +(set-char-table-range (nth 1 xwidget-webkit-isearch-mode-map) + (cons 0 (max-char)) + 'xwidget-webkit-isearch-exit) + +(substitute-key-definition 'self-insert-command + 'xwidget-webkit-isearch-printing-char + xwidget-webkit-isearch-mode-map + global-map) + +(define-key xwidget-webkit-isearch-mode-map (kbd "DEL") + 'xwidget-webkit-isearch-erasing-char) +(define-key xwidget-webkit-isearch-mode-map [backspace] 'xwidget-webkit-isearch-erasing-char) +(define-key xwidget-webkit-isearch-mode-map [return] 'xwidget-webkit-isearch-exit) +(define-key xwidget-webkit-isearch-mode-map "\r" 'xwidget-webkit-isearch-exit) +(define-key xwidget-webkit-isearch-mode-map "\C-g" 'xwidget-webkit-isearch-exit) +(define-key xwidget-webkit-isearch-mode-map "\C-r" 'xwidget-webkit-isearch-backward) +(define-key xwidget-webkit-isearch-mode-map "\C-s" 'xwidget-webkit-isearch-forward) +(define-key xwidget-webkit-isearch-mode-map "\C-y" 'xwidget-webkit-isearch-yank-kill) +(define-key xwidget-webkit-isearch-mode-map "\C-\\" 'toggle-input-method) +(define-key xwidget-webkit-isearch-mode-map "\t" 'xwidget-webkit-isearch-printing-char) + +(let ((meta-map (make-keymap))) + (set-char-table-range (nth 1 meta-map) + (cons 0 (max-char)) + 'xwidget-webkit-isearch-exit) + (define-key xwidget-webkit-isearch-mode-map (char-to-string meta-prefix-char) meta-map)) + +(define-minor-mode xwidget-webkit-isearch-mode + "Minor mode for performing incremental search inside WebKit buffers. + +This resembles the regular incremental search, but it does not +support recursive edits. + +If this mode is activated with `\\<xwidget-webkit-isearch-mode-map>\\[xwidget-webkit-isearch-backward]', then the search will by default +start in the reverse direction. + +To navigate around the search results, type +\\<xwidget-webkit-isearch-mode-map>\\[xwidget-webkit-isearch-forward] to move forward, and +\\<xwidget-webkit-isearch-mode-map>\\[xwidget-webkit-isearch-backward] to move backward. + +To insert the string at the front of the kill ring into the +search query, type \\<xwidget-webkit-isearch-mode-map>\\[xwidget-webkit-isearch-yank-kill]. + +Press \\<xwidget-webkit-isearch-mode-map>\\[xwidget-webkit-isearch-exit] to exit incremental search." + :keymap xwidget-webkit-isearch-mode-map + (if xwidget-webkit-isearch-mode + (progn + (setq xwidget-webkit-isearch--string "") + (setq xwidget-webkit-isearch--is-reverse (eq last-command-event ?\C-r)) + (xwidget-webkit-isearch--update)) + (xwidget-webkit-finish-search (xwidget-webkit-current-session)))) +(defun xwidget-webkit-isearch-yank-kill () + "Append the most recent kill from `kill-ring' to the current query." + (interactive) + (unless xwidget-webkit-isearch-mode + (xwidget-webkit-isearch-mode t)) + (setq xwidget-webkit-isearch--string + (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/lisp/yank-media.el b/lisp/yank-media.el new file mode 100644 index 00000000000..decab3b3625 --- /dev/null +++ b/lisp/yank-media.el @@ -0,0 +1,194 @@ +;;; yank-media.el --- Yanking images and HTML -*- lexical-binding:t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; Author: Lars Ingebrigtsen <larsi@gnus.org> +;; Keywords: utility + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'cl-lib) +(require 'seq) + +(defvar yank-media--registered-handlers nil) + +;;;###autoload +(defun yank-media () + "Yank media (images, HTML and the like) from the clipboard. +This command depends on the current major mode having support for +accepting the media type. The mode has to register itself using +the `yank-media-handler' mechanism. + +Also see `yank-media-types' for a command that lets you explore +all the different selection types." + (interactive) + (unless yank-media--registered-handlers + (user-error "The `%s' mode hasn't registered any handlers" major-mode)) + (let ((all-types nil)) + (pcase-dolist (`(,handled-type . ,handler) + yank-media--registered-handlers) + (dolist (type (yank-media--find-matching-media handled-type)) + (push (cons type handler) all-types))) + (unless all-types + (user-error + "No handler in the current buffer for anything on the clipboard")) + ;; We have a handler in the current buffer; if there's just + ;; matching type, just call the handler. + (if (length= all-types 1) + (funcall (cdar all-types) (caar all-types) + (yank-media--get-selection (caar all-types))) + ;; More than one type the user for what type to insert. + (let ((type + (intern + (completing-read "Several types available, choose one: " + (mapcar #'car all-types) nil t)))) + (funcall (alist-get type all-types) + type (yank-media--get-selection type)))))) + +(defun yank-media--find-matching-media (handled-type) + (seq-filter + (lambda (type) + (pcase-let ((`(,major ,minor) (split-string (symbol-name type) "/"))) + (if (and (equal major "image") + (not (image-type-available-p (intern minor)))) + ;; Just filter out all the image types that Emacs doesn't + ;; support, because the clipboard is full of things like + ;; `image/x-win-bitmap'. + nil + ;; Check that the handler wants this type. + (and (if (symbolp handled-type) + (eq handled-type type) + (string-match-p handled-type (symbol-name type))) + ;; An element may be in TARGETS but be empty. + (yank-media--get-selection type))))) + (gui-get-selection 'CLIPBOARD 'TARGETS))) + +(defun yank-media--get-selection (data-type) + (when-let ((data (gui-backend-get-selection 'CLIPBOARD data-type))) + (if (string-match-p "\\`text/" (symbol-name data-type)) + (yank-media-types--format data-type data) + data))) + +;;;###autoload +(defun yank-media-handler (types handler) + "Register HANDLER for dealing with `yank-media' actions for TYPES. +TYPES should be a MIME media type symbol, a regexp, or a list +that can contain both symbols and regexps. + +HANDLER is a function that will be called with two arguments: The +MIME type (a symbol on the form `image/png') and the selection +data (a string)." + (make-local-variable 'yank-media--registered-handlers) + (dolist (type (ensure-list types)) + (setf (alist-get type yank-media--registered-handlers nil nil #'equal) + handler))) + +(defun yank-media-types (&optional all) + "Yank any element present in the primary selection or the clipboard. +This is primarily meant as a debugging tool -- many of the +elements (like images) will be inserted as raw data into the +current buffer. See `yank-media' instead for a command that +inserts images as images. + +By default, data types that aren't supported by +`gui-get-selection' (i.e., that returns nothing if you actually +try to look at the selection) are not included by this command. +If ALL (interactively, the prefix), also include these +non-supported selection data types." + (interactive "P") + (let ((elements nil)) + ;; First gather all the data. + (dolist (type '(PRIMARY CLIPBOARD)) + (when-let ((data-types (gui-get-selection type 'TARGETS))) + (when (vectorp data-types) + (seq-do (lambda (data-type) + (unless (memq data-type '( TARGETS MULTIPLE + DELETE SAVE_TARGETS)) + (let ((data (gui-get-selection type data-type))) + (when (or data all) + ;; Remove duplicates -- the data in PRIMARY and + ;; CLIPBOARD are sometimes (mostly) identical, + ;; and sometimes not. + (let ((old (assq data-type elements))) + (when (or (not old) + (not (equal (nth 2 old) data))) + (push (list data-type type data) + elements))))))) + data-types)))) + ;; Then query the user. + (unless elements + (user-error "No elements in the primary selection or the clipboard")) + (let ((spec + (completing-read + "Yank type: " + (mapcar (lambda (e) + (format "%s:%s" (downcase (symbol-name (cadr e))) + (car e))) + elements) + nil t))) + (dolist (elem elements) + (when (equal (format "%s:%s" (downcase (symbol-name (cadr elem))) + (car elem)) + spec) + (insert (yank-media-types--format (car elem) (nth 2 elem)))))))) + +(defun yank-media-types--format (data-type data) + (cond + ((not (stringp data)) + (format "%s" data)) + ((string-match-p "\\`text/" (symbol-name data-type)) + ;; We may have utf-16, which Emacs won't detect automatically. + (let ((coding-system + (and (zerop (mod (length data) 2)) + (let ((stats (vector 0 0))) + (dotimes (i (length data)) + (when (zerop (elt data i)) + (setf (aref stats (mod i 2)) + (1+ (aref stats (mod i 2)))))) + ;; If we have more than 90% every-other nul, then it's + ;; pretty likely to be utf-16. + (cond + ((> (if (zerop (elt stats 1)) + 1 + (/ (float (elt stats 0)) + (float (elt stats 1)))) + 0.9) + ;; Big endian. + 'utf-16-be) + ((> (if (zerop (elt stats 0)) + 1 + (/ (float (elt stats 1)) + (float (elt stats 0)))) + 0.9) + ;; Little endian. + 'utf-16-le)))))) + (if coding-system + (decode-coding-string data coding-system) + ;; Some programs add a nul character at the end of text/* + ;; selections. Remove that. + (if (zerop (elt data (1- (length data)))) + (substring data 0 (1- (length data))) + data)))) + (t + data))) + +(provide 'yank-media) + +;;; yank-media.el ends here diff --git a/lwlib/xlwmenu.c b/lwlib/xlwmenu.c index cc73d9aa498..68b0a2f5fe4 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; @@ -1357,27 +1390,46 @@ fit_to_screen (XlwMenuWidget mw, window_state *previous_ws, Boolean horizontal_p) { - unsigned int screen_width = WidthOfScreen (XtScreen (mw)); - unsigned int screen_height = HeightOfScreen (XtScreen (mw)); + int screen_width, screen_height; + int screen_x, screen_y; + int prev_screen_x, prev_screen_y; + +#ifdef emacs + xlw_monitor_dimensions_at_pos (XtDisplay (mw), XtScreen (mw), + previous_ws->x, previous_ws->y, + &prev_screen_x, &prev_screen_y, + &screen_width, &screen_height); + xlw_monitor_dimensions_at_pos (XtDisplay (mw), XtScreen (mw), + ws->x, ws->y, &screen_x, &screen_y, + &screen_width, &screen_height); +#else + screen_width = WidthOfScreen (XtScreen (mw)); + screen_height = HeightOfScreen (XtScreen (mw)); + prev_screen_x = screen_x = 0; + prev_screen_y = screen_y = 0; +#endif /* 1 if we are unable to avoid an overlap between this menu and the parent menu in the X dimension. */ int horizontal_overlap = 0; - if (ws->x < 0) - ws->x = 0; - else if (ws->x + ws->width > screen_width) + if (ws->x < screen_x) + ws->x = screen_x; + else if (ws->x + ws->width > screen_x + screen_width) { if (!horizontal_p) /* The addition of shadow-thickness for a sub-menu's position is to reflect a similar adjustment when the menu is displayed to the right of the invoking menu-item; it makes the sub-menu look more `attached' to the menu-item. */ - ws->x = previous_ws->x - ws->width + mw->menu.shadow_thickness; + ws->x = screen_x + (previous_ws->x + - prev_screen_x + - ws->width + + mw->menu.shadow_thickness); else - ws->x = screen_width - ws->width; - if (ws->x < 0) + ws->x = screen_x + (screen_width - ws->width); + if (ws->x < screen_x) { - ws->x = 0; + ws->x = screen_x; horizontal_overlap = 1; } } @@ -1394,16 +1446,18 @@ fit_to_screen (XlwMenuWidget mw, ws->y = previous_ws->y - ws->height; } - if (ws->y < 0) - ws->y = 0; - else if (ws->y + ws->height > screen_height) + if (ws->y < screen_y) + ws->y = screen_y; + else if (ws->y + ws->height > screen_y + screen_height) { if (horizontal_p) - ws->y = previous_ws->y - ws->height; + ws->y = screen_y + (previous_ws->y + - prev_screen_y + - ws->height); else - ws->y = screen_height - ws->height; - if (ws->y < 0) - ws->y = 0; + ws->y = screen_y + (screen_height - ws->height); + if (ws->y < screen_y) + ws->y = screen_y; } } @@ -1624,7 +1678,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 @@ -2594,7 +2647,21 @@ pop_up_menu (XlwMenuWidget mw, XButtonPressedEvent *event) int borderwidth = mw->menu.shadow_thickness; Screen* screen = XtScreen (mw); Display *display = XtDisplay (mw); + int screen_x; + int screen_y; + int screen_w; + int screen_h; +#ifdef emacs + xlw_monitor_dimensions_at_pos (display, screen, x, y, + &screen_x, &screen_y, + &screen_w, &screen_h); +#else + screen_x = 0; + screen_y = 0; + screen_w = WidthOfScreen (screen); + screen_h = HeightOfScreen (screen); +#endif next_release_must_exit = 0; mw->menu.inside_entry = NULL; @@ -2608,14 +2675,14 @@ pop_up_menu (XlwMenuWidget mw, XButtonPressedEvent *event) x -= borderwidth; y -= borderwidth; - if (x < borderwidth) - x = borderwidth; - if (x + w + 2 * borderwidth > WidthOfScreen (screen)) - x = WidthOfScreen (screen) - w - 2 * borderwidth; - if (y < borderwidth) - y = borderwidth; - if (y + h + 2 * borderwidth> HeightOfScreen (screen)) - y = HeightOfScreen (screen) - h - 2 * borderwidth; + if (x < screen_x + borderwidth) + x = screen_x + borderwidth; + if (x + w + 2 * borderwidth > screen_x + screen_w) + x = (screen_x + screen_w) - w - 2 * borderwidth; + if (y < screen_y + borderwidth) + y = screen_y + borderwidth; + if (y + h + 2 * borderwidth > screen_y + screen_h) + y = (screen_y + screen_h) - h - 2 * borderwidth; mw->menu.popped_up = True; if (XtIsShell (XtParent ((Widget)mw))) 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 <https://www.gnu.org/licenses/>. */ #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/m4/alloca.m4 b/m4/alloca.m4 index ba2f679d8e0..7e474aa681b 100644 --- a/m4/alloca.m4 +++ b/m4/alloca.m4 @@ -1,4 +1,4 @@ -# alloca.m4 serial 20 +# alloca.m4 serial 21 dnl Copyright (C) 2002-2004, 2006-2007, 2009-2021 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation @@ -26,17 +26,15 @@ AC_DEFUN([gl_FUNC_ALLOCA], AC_DEFINE([HAVE_ALLOCA], [1], [Define to 1 if you have 'alloca' after including <alloca.h>, a header that may be supplied by this distribution.]) - ALLOCA_H=alloca.h + GL_GENERATE_ALLOCA_H=true else dnl alloca exists as a library function, i.e. it is slow and probably dnl a memory leak. Don't define HAVE_ALLOCA in this case. - ALLOCA_H= + GL_GENERATE_ALLOCA_H=false fi else - ALLOCA_H=alloca.h + GL_GENERATE_ALLOCA_H=true fi - AC_SUBST([ALLOCA_H]) - AM_CONDITIONAL([GL_GENERATE_ALLOCA_H], [test -n "$ALLOCA_H"]) if test $ac_cv_working_alloca_h = yes; then HAVE_ALLOCA_H=1 diff --git a/m4/byteswap.m4 b/m4/byteswap.m4 index 1083b4c9e24..db35b527a69 100644 --- a/m4/byteswap.m4 +++ b/m4/byteswap.m4 @@ -1,4 +1,4 @@ -# byteswap.m4 serial 4 +# byteswap.m4 serial 5 dnl Copyright (C) 2005, 2007, 2009-2021 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -10,10 +10,8 @@ AC_DEFUN([gl_BYTESWAP], [ dnl Prerequisites of lib/byteswap.in.h. AC_CHECK_HEADERS([byteswap.h], [ - BYTESWAP_H='' + GL_GENERATE_BYTESWAP_H=false ], [ - BYTESWAP_H='byteswap.h' + GL_GENERATE_BYTESWAP_H=true ]) - AC_SUBST([BYTESWAP_H]) - AM_CONDITIONAL([GL_GENERATE_BYTESWAP_H], [test -n "$BYTESWAP_H"]) ]) diff --git a/m4/errno_h.m4 b/m4/errno_h.m4 index 51dfe92938d..7f5feabb2b8 100644 --- a/m4/errno_h.m4 +++ b/m4/errno_h.m4 @@ -1,4 +1,4 @@ -# errno_h.m4 serial 13 +# errno_h.m4 serial 14 dnl Copyright (C) 2004, 2006, 2008-2021 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -68,13 +68,11 @@ booboo [gl_cv_header_errno_h_complete=yes]) ]) if test $gl_cv_header_errno_h_complete = yes; then - ERRNO_H='' + GL_GENERATE_ERRNO_H=false else gl_NEXT_HEADERS([errno.h]) - ERRNO_H='errno.h' + GL_GENERATE_ERRNO_H=true fi - AC_SUBST([ERRNO_H]) - AM_CONDITIONAL([GL_GENERATE_ERRNO_H], [test -n "$ERRNO_H"]) gl_REPLACE_ERRNO_VALUE([EMULTIHOP]) gl_REPLACE_ERRNO_VALUE([ENOLINK]) gl_REPLACE_ERRNO_VALUE([EOVERFLOW]) @@ -88,7 +86,7 @@ booboo # Set the variables EOVERFLOW_HIDDEN and EOVERFLOW_VALUE. AC_DEFUN([gl_REPLACE_ERRNO_VALUE], [ - if test -n "$ERRNO_H"; then + if $GL_GENERATE_ERRNO_H; then AC_CACHE_CHECK([for ]$1[ value], [gl_cv_header_errno_h_]$1, [ AC_EGREP_CPP([yes],[ #include <errno.h> diff --git a/m4/execinfo.m4 b/m4/execinfo.m4 index 75ab44beeea..581b173a23a 100644 --- a/m4/execinfo.m4 +++ b/m4/execinfo.m4 @@ -10,7 +10,7 @@ AC_DEFUN([gl_EXECINFO_H], AC_CHECK_HEADERS_ONCE([execinfo.h]) LIB_EXECINFO='' - EXECINFO_H='execinfo.h' + GL_GENERATE_EXECINFO_H=true if test $ac_cv_header_execinfo_h = yes; then gl_saved_libs=$LIBS @@ -18,14 +18,10 @@ AC_DEFUN([gl_EXECINFO_H], [test "$ac_cv_search_backtrace_symbols_fd" = "none required" || LIB_EXECINFO=$ac_cv_search_backtrace_symbols_fd]) LIBS=$gl_saved_libs - test "$ac_cv_search_backtrace_symbols_fd" = no || EXECINFO_H='' + if test "$ac_cv_search_backtrace_symbols_fd" != no; then + GL_GENERATE_EXECINFO_H=false + fi fi - if test -n "$EXECINFO_H"; then - AC_LIBOBJ([execinfo]) - fi - - AC_SUBST([EXECINFO_H]) AC_SUBST([LIB_EXECINFO]) - AM_CONDITIONAL([GL_GENERATE_EXECINFO_H], [test -n "$EXECINFO_H"]) ]) diff --git a/m4/getopt.m4 b/m4/getopt.m4 index bb95c5ea28e..9b71159bc57 100644 --- a/m4/getopt.m4 +++ b/m4/getopt.m4 @@ -1,4 +1,4 @@ -# getopt.m4 serial 47 +# getopt.m4 serial 48 dnl Copyright (C) 2002-2006, 2008-2021 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -21,6 +21,8 @@ AC_DEFUN([gl_FUNC_GETOPT_POSIX], REPLACE_GETOPT=1 fi ]) + GL_GENERATE_GETOPT_H=false + GL_GENERATE_GETOPT_CDEFS_H=false if test $REPLACE_GETOPT = 1; then dnl Arrange for getopt.h to be created. gl_GETOPT_SUBSTITUTE_HEADER @@ -374,8 +376,6 @@ AC_DEFUN([gl_GETOPT_SUBSTITUTE_HEADER], AC_DEFINE([__GETOPT_PREFIX], [[rpl_]], [Define to rpl_ if the getopt replacement functions and variables should be used.]) - GETOPT_H=getopt.h - GETOPT_CDEFS_H=getopt-cdefs.h - AC_SUBST([GETOPT_H]) - AC_SUBST([GETOPT_CDEFS_H]) + GL_GENERATE_GETOPT_H=true + GL_GENERATE_GETOPT_CDEFS_H=true ]) diff --git a/m4/gnulib-common.m4 b/m4/gnulib-common.m4 index 12b19dbcb44..f70ef4ea968 100644 --- a/m4/gnulib-common.m4 +++ b/m4/gnulib-common.m4 @@ -1,4 +1,4 @@ -# gnulib-common.m4 serial 67 +# gnulib-common.m4 serial 69 dnl Copyright (C) 2007-2021 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -879,6 +879,36 @@ AC_DEFUN([gl_CXX_ALLOW_WARNINGS], AC_SUBST([GL_CXXFLAG_ALLOW_WARNINGS]) ]) +dnl gl_CONDITIONAL_HEADER([foo.h]) +dnl takes a shell variable GL_GENERATE_FOO_H (with value true or false) as input +dnl and produces +dnl - an AC_SUBSTed variable FOO_H that is either a file name or empty, based +dnl on whether GL_GENERATE_FOO_H is true or false, +dnl - an Automake conditional GL_GENERATE_FOO_H that evaluates to the value of +dnl the shell variable GL_GENERATE_FOO_H. +AC_DEFUN([gl_CONDITIONAL_HEADER], +[ + m4_pushdef([gl_header_name], AS_TR_SH(m4_toupper($1))) + m4_pushdef([gl_generate_var], [GL_GENERATE_]AS_TR_SH(m4_toupper($1))) + m4_pushdef([gl_generate_cond], [GL_GENERATE_]AS_TR_SH(m4_toupper($1))) + case "$gl_generate_var" in + false) gl_header_name='' ;; + true) + dnl It is OK to use a .h file in lib/ from within tests/, but not vice + dnl versa. + if test -z "$gl_header_name"; then + gl_header_name="${gl_source_base_prefix}$1" + fi + ;; + *) echo "*** gl_generate_var is not set correctly" 1>&2; exit 1 ;; + esac + AC_SUBST(gl_header_name) + AM_CONDITIONAL(gl_generate_cond, [$gl_generate_var]) + m4_popdef([gl_generate_cond]) + m4_popdef([gl_generate_var]) + m4_popdef([gl_header_name]) +]) + dnl Expands to some code for use in .c programs that, on native Windows, defines dnl the Microsoft deprecated alias function names to the underscore-prefixed dnl actual function names. With this macro, these function names are available diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index e314edcfb53..a6810523ec9 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -224,10 +224,15 @@ AC_DEFUN([gl_INIT], m4_pushdef([GL_MODULE_INDICATOR_PREFIX], [GL]) gl_COMMON gl_source_base='lib' + gl_source_base_prefix= gl_FUNC_ACL gl_FUNC_ALLOCA + gl_CONDITIONAL_HEADER([alloca.h]) + AC_PROG_MKDIR_P gl___BUILTIN_EXPECT gl_BYTESWAP + gl_CONDITIONAL_HEADER([byteswap.h]) + AC_PROG_MKDIR_P gl_CANONICALIZE_LGPL if test $HAVE_CANONICALIZE_FILE_NAME = 0 || test $REPLACE_CANONICALIZE_FILE_NAME = 1; then AC_LIBOBJ([canonicalize-lgpl]) @@ -255,6 +260,7 @@ AC_DEFUN([gl_INIT], gl_CHECK_TYPE_STRUCT_DIRENT_D_TYPE gl_DIRENT_H gl_DIRENT_H_REQUIRE_DEFAULTS + AC_PROG_MKDIR_P gl_DOUBLE_SLASH_ROOT gl_FUNC_DUP2 if test $REPLACE_DUP2 = 1; then @@ -265,7 +271,14 @@ AC_DEFUN([gl_INIT], gl_ENVIRON gl_UNISTD_MODULE_INDICATOR([environ]) gl_HEADER_ERRNO_H + gl_CONDITIONAL_HEADER([errno.h]) + AC_PROG_MKDIR_P gl_EXECINFO_H + gl_CONDITIONAL_HEADER([execinfo.h]) + AC_PROG_MKDIR_P + if $GL_GENERATE_EXECINFO_H; then + AC_LIBOBJ([execinfo]) + fi gl_FUNC_EXPLICIT_BZERO if test $HAVE_EXPLICIT_BZERO = 0; then AC_LIBOBJ([explicit_bzero]) @@ -293,6 +306,7 @@ AC_DEFUN([gl_INIT], gl_FCNTL_MODULE_INDICATOR([fcntl]) gl_FCNTL_H gl_FCNTL_H_REQUIRE_DEFAULTS + AC_PROG_MKDIR_P gl_FUNC_FDOPENDIR if test $HAVE_FDOPENDIR = 0 || test $REPLACE_FDOPENDIR = 1; then AC_LIBOBJ([fdopendir]) @@ -345,6 +359,9 @@ AC_DEFUN([gl_INIT], dnl mechanism), there is no need to do any AC_LIBOBJ or AC_SUBST here; they are dnl done in the getopt-posix module. gl_FUNC_GETOPT_POSIX + gl_CONDITIONAL_HEADER([getopt.h]) + gl_CONDITIONAL_HEADER([getopt-cdefs.h]) + AC_PROG_MKDIR_P if test $REPLACE_GETOPT = 1; then AC_LIBOBJ([getopt]) AC_LIBOBJ([getopt1]) @@ -367,15 +384,22 @@ AC_DEFUN([gl_INIT], fi gl_SYS_TIME_MODULE_INDICATOR([gettimeofday]) gl_IEEE754_H + gl_CONDITIONAL_HEADER([ieee754.h]) + AC_PROG_MKDIR_P gl_INTTYPES_INCOMPLETE gl_INTTYPES_H_REQUIRE_DEFAULTS + AC_PROG_MKDIR_P AC_REQUIRE([gl_LARGEFILE]) gl___INLINE gl_LIBGMP + gl_CONDITIONAL_HEADER([gmp.h]) + AC_PROG_MKDIR_P if test $HAVE_LIBGMP != yes; then AC_LIBOBJ([mini-gmp-gnulib]) fi gl_LIMITS_H + gl_CONDITIONAL_HEADER([limits.h]) + AC_PROG_MKDIR_P gl_FUNC_LSTAT if test $REPLACE_LSTAT = 1; then AC_LIBOBJ([lstat]) @@ -458,16 +482,26 @@ AC_DEFUN([gl_INIT], gl_STRING_MODULE_INDICATOR([sigdescr_np]) gl_SIGNAL_H gl_SIGNAL_H_REQUIRE_DEFAULTS + AC_PROG_MKDIR_P gl_TYPE_SOCKLEN_T gt_TYPE_SSIZE_T gl_STAT_TIME gl_STAT_BIRTHTIME gl_STDALIGN_H + gl_CONDITIONAL_HEADER([stdalign.h]) + AC_PROG_MKDIR_P gl_STDDEF_H gl_STDDEF_H_REQUIRE_DEFAULTS + gl_CONDITIONAL_HEADER([stddef.h]) + AC_PROG_MKDIR_P gl_STDINT_H + gl_CONDITIONAL_HEADER([stdint.h]) + dnl Because of gl_REPLACE_LIMITS_H: + gl_CONDITIONAL_HEADER([limits.h]) + AC_PROG_MKDIR_P gl_STDIO_H gl_STDIO_H_REQUIRE_DEFAULTS + AC_PROG_MKDIR_P dnl No need to create extra modules for these functions. Everyone who uses dnl <stdio.h> likely needs them. gl_STDIO_MODULE_INDICATOR([fscanf]) @@ -493,6 +527,7 @@ AC_DEFUN([gl_INIT], gl_STDIO_MODULE_INDICATOR([fwrite]) gl_STDLIB_H gl_STDLIB_H_REQUIRE_DEFAULTS + AC_PROG_MKDIR_P gl_FUNC_STPCPY if test $HAVE_STPCPY = 0; then AC_LIBOBJ([stpcpy]) @@ -501,6 +536,7 @@ AC_DEFUN([gl_INIT], gl_STRING_MODULE_INDICATOR([stpcpy]) gl_STRING_H gl_STRING_H_REQUIRE_DEFAULTS + AC_PROG_MKDIR_P gl_FUNC_STRNLEN if test $HAVE_DECL_STRNLEN = 0 || test $REPLACE_STRNLEN = 1; then AC_LIBOBJ([strnlen]) @@ -537,6 +573,7 @@ AC_DEFUN([gl_INIT], gl_MODULE_INDICATOR([tempname]) gl_TIME_H gl_TIME_H_REQUIRE_DEFAULTS + AC_PROG_MKDIR_P gl_TIME_R if test $HAVE_LOCALTIME_R = 0 || test $REPLACE_LOCALTIME_R = 1; then AC_LIBOBJ([time_r]) @@ -558,6 +595,7 @@ AC_DEFUN([gl_INIT], gl_TIMESPEC gl_UNISTD_H gl_UNISTD_H_REQUIRE_DEFAULTS + AC_PROG_MKDIR_P AC_DEFINE([GNULIB_STDIO_SINGLE_THREAD], [1], [Define to 1 if you want the FILE stream functions getc, putc, etc. to use unlocked I/O if available, throughout the package. @@ -993,6 +1031,7 @@ AC_DEFUN([gl_INIT], m4_pushdef([GL_MODULE_INDICATOR_PREFIX], [GL]) gl_COMMON gl_source_base='tests' + gl_source_base_prefix= changequote(,)dnl gltests_WITNESS=IN_`echo "${PACKAGE-$PACKAGE_TARNAME}" | LC_ALL=C tr abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ | LC_ALL=C sed -e 's/[^A-Z0-9_]/_/g'`_GNULIB_TESTS changequote([, ])dnl diff --git a/m4/gsettings.m4 b/m4/gsettings.m4 new file mode 100644 index 00000000000..882e6a83e76 --- /dev/null +++ b/m4/gsettings.m4 @@ -0,0 +1,88 @@ +# Increment this whenever this file is changed. +#serial 2 + +dnl GLIB_GSETTINGS +dnl Defines GSETTINGS_SCHEMAS_INSTALL which controls whether +dnl the schema should be compiled +dnl + +AC_DEFUN([GLIB_GSETTINGS], +[ + dnl We can't use PKG_PREREQ because that needs 0.29. + m4_ifndef([PKG_PROG_PKG_CONFIG], + [pkg.m4 version 0.28 or later is required]) + + m4_pattern_allow([AM_V_GEN]) + AC_ARG_ENABLE(schemas-compile, + AS_HELP_STRING([--disable-schemas-compile], + [Disable regeneration of gschemas.compiled on install]), + [case ${enableval} in + yes) GSETTINGS_DISABLE_SCHEMAS_COMPILE="" ;; + no) GSETTINGS_DISABLE_SCHEMAS_COMPILE="1" ;; + *) AC_MSG_ERROR([bad value ${enableval} for --enable-schemas-compile]) ;; + esac]) + AC_SUBST([GSETTINGS_DISABLE_SCHEMAS_COMPILE]) + PKG_PROG_PKG_CONFIG([0.16]) + AC_SUBST(gsettingsschemadir, [${datadir}/glib-2.0/schemas]) + AS_IF([test x$cross_compiling != xyes], + [PKG_CHECK_VAR([GLIB_COMPILE_SCHEMAS], [gio-2.0], [glib_compile_schemas])], + [AC_PATH_PROG([GLIB_COMPILE_SCHEMAS], [glib-compile-schemas])]) + AC_SUBST(GLIB_COMPILE_SCHEMAS) + if test "x$GLIB_COMPILE_SCHEMAS" = "x"; then + ifelse([$2],,[AC_MSG_ERROR([glib-compile-schemas not found.])],[$2]) + else + ifelse([$1],,[:],[$1]) + fi + + GSETTINGS_RULES=' +.PHONY : uninstall-gsettings-schemas install-gsettings-schemas clean-gsettings-schemas + +mostlyclean-am: clean-gsettings-schemas + +gsettings__enum_file = $(addsuffix .enums.xml,$(gsettings_ENUM_NAMESPACE)) + +%.gschema.valid: %.gschema.xml $(gsettings__enum_file) + $(AM_V_GEN) $(GLIB_COMPILE_SCHEMAS) --strict --dry-run $(addprefix --schema-file=,$(gsettings__enum_file)) --schema-file=$< && mkdir -p [$](@D) && touch [$]@ + +all-am: $(gsettings_SCHEMAS:.xml=.valid) +uninstall-am: uninstall-gsettings-schemas +install-data-am: install-gsettings-schemas + +.SECONDARY: $(gsettings_SCHEMAS) + +install-gsettings-schemas: $(gsettings_SCHEMAS) $(gsettings__enum_file) + @$(NORMAL_INSTALL) + if test -n "$^"; then \ + test -z "$(gsettingsschemadir)" || $(MKDIR_P) "$(DESTDIR)$(gsettingsschemadir)"; \ + $(INSTALL_DATA) $^ "$(DESTDIR)$(gsettingsschemadir)"; \ + test -n "$(GSETTINGS_DISABLE_SCHEMAS_COMPILE)$(DESTDIR)" || $(GLIB_COMPILE_SCHEMAS) $(gsettingsschemadir); \ + fi + +uninstall-gsettings-schemas: + @$(NORMAL_UNINSTALL) + @list='\''$(gsettings_SCHEMAS) $(gsettings__enum_file)'\''; test -n "$(gsettingsschemadir)" || list=; \ + files=`for p in $$list; do echo $$p; done | sed -e '\''s|^.*/||'\''`; \ + test -n "$$files" || exit 0; \ + echo " ( cd '\''$(DESTDIR)$(gsettingsschemadir)'\'' && rm -f" $$files ")"; \ + cd "$(DESTDIR)$(gsettingsschemadir)" && rm -f $$files + test -n "$(GSETTINGS_DISABLE_SCHEMAS_COMPILE)$(DESTDIR)" || $(GLIB_COMPILE_SCHEMAS) $(gsettingsschemadir) + +clean-gsettings-schemas: + rm -f $(gsettings_SCHEMAS:.xml=.valid) $(gsettings__enum_file) + +ifdef gsettings_ENUM_NAMESPACE +$(gsettings__enum_file): $(gsettings_ENUM_FILES) + $(AM_V_GEN) glib-mkenums --comments '\''<!-- @comment@ -->'\'' --fhead "<schemalist>" --vhead " <@type@ id='\''$(gsettings_ENUM_NAMESPACE).@EnumName@'\''>" --vprod " <value nick='\''@valuenick@'\'' value='\''@valuenum@'\''/>" --vtail " </@type@>" --ftail "</schemalist>" [$]^ > [$]@.tmp && mv [$]@.tmp [$]@ +endif +' + _GSETTINGS_SUBST(GSETTINGS_RULES) +]) + +dnl _GSETTINGS_SUBST(VARIABLE) +dnl Abstract macro to do either _AM_SUBST_NOTMAKE or AC_SUBST +AC_DEFUN([_GSETTINGS_SUBST], +[ +AC_SUBST([$1]) +m4_ifdef([_AM_SUBST_NOTMAKE], [_AM_SUBST_NOTMAKE([$1])]) +] +) diff --git a/m4/ieee754-h.m4 b/m4/ieee754-h.m4 index 68af3bd7ebe..0712613b6f2 100644 --- a/m4/ieee754-h.m4 +++ b/m4/ieee754-h.m4 @@ -10,12 +10,10 @@ AC_DEFUN([gl_IEEE754_H], AC_REQUIRE([AC_C_BIGENDIAN]) AC_CHECK_HEADERS_ONCE([ieee754.h]) if test $ac_cv_header_ieee754_h = yes; then - IEEE754_H= + GL_GENERATE_IEEE754_H=false else - IEEE754_H=ieee754.h + GL_GENERATE_IEEE754_H=true AC_DEFINE([_GL_REPLACE_IEEE754_H], 1, [Define to 1 if <ieee754.h> is missing.]) fi - AC_SUBST([IEEE754_H]) - AM_CONDITIONAL([GL_GENERATE_IEEE754_H], [test -n "$IEEE754_H"]) ]) diff --git a/m4/include_next.m4 b/m4/include_next.m4 index bdd542bc64d..7dcd1cef0b3 100644 --- a/m4/include_next.m4 +++ b/m4/include_next.m4 @@ -193,9 +193,9 @@ AC_DEFUN([gl_NEXT_HEADERS_INTERNAL], if test AS_VAR_GET([gl_header_exists]) = yes; then AS_VAR_POPDEF([gl_header_exists]) ]) - gl_ABSOLUTE_HEADER_ONE(gl_HEADER_NAME) - AS_VAR_COPY([gl_header], [gl_cv_absolute_]AS_TR_SH(gl_HEADER_NAME)) - AS_VAR_SET([gl_next_header], ['"'$gl_header'"']) + gl_ABSOLUTE_HEADER_ONE(gl_HEADER_NAME) + AS_VAR_COPY([gl_header], [gl_cv_absolute_]AS_TR_SH(gl_HEADER_NAME)) + AS_VAR_SET([gl_next_header], ['"'$gl_header'"']) m4_if([$2], [check], [else AS_VAR_SET([gl_next_header], ['<'gl_HEADER_NAME'>']) diff --git a/m4/inttypes.m4 b/m4/inttypes.m4 index 64b1de5c42a..c446aa82773 100644 --- a/m4/inttypes.m4 +++ b/m4/inttypes.m4 @@ -1,4 +1,4 @@ -# inttypes.m4 serial 35 +# inttypes.m4 serial 36 dnl Copyright (C) 2006-2021 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -36,7 +36,7 @@ AC_DEFUN_ONCE([gl_INTTYPES_INCOMPLETE], AC_DEFUN([gl_INTTYPES_PRI_SCN], [ PRIPTR_PREFIX= - if test -n "$STDINT_H"; then + if $GL_GENERATE_STDINT_H; then dnl Using the gnulib <stdint.h>. It defines intptr_t to 'long' or dnl 'long long', depending on _WIN64. AC_COMPILE_IFELSE( diff --git a/m4/libgmp.m4 b/m4/libgmp.m4 index c630a19e640..a2103dde88d 100644 --- a/m4/libgmp.m4 +++ b/m4/libgmp.m4 @@ -1,4 +1,4 @@ -# libgmp.m4 serial 5 +# libgmp.m4 serial 6 # Configure the GMP library or a replacement. dnl Copyright 2020-2021 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation @@ -59,11 +59,10 @@ AC_DEFUN([gl_LIBGMP], [ Try specifying --with-libgmp-prefix=DIR.])]) fi]) if test $HAVE_LIBGMP = yes && test "$ac_cv_header_gmp_h" = yes; then - GMP_H= + GL_GENERATE_GMP_H=false else - GMP_H=gmp.h + GL_GENERATE_GMP_H=true fi - AC_SUBST([GMP_H]) AM_CONDITIONAL([GL_GENERATE_MINI_GMP_H], [test $HAVE_LIBGMP != yes]) AM_CONDITIONAL([GL_GENERATE_GMP_GMP_H], diff --git a/m4/limits-h.m4 b/m4/limits-h.m4 index 00c9fe9e50a..c82f6c67813 100644 --- a/m4/limits-h.m4 +++ b/m4/limits-h.m4 @@ -27,18 +27,15 @@ AC_DEFUN_ONCE([gl_LIMITS_H], [gl_cv_header_limits_width=yes], [gl_cv_header_limits_width=no])]) if test "$gl_cv_header_limits_width" = yes; then - LIMITS_H= + GL_GENERATE_LIMITS_H=false else - LIMITS_H=limits.h + GL_GENERATE_LIMITS_H=true fi - AC_SUBST([LIMITS_H]) - AM_CONDITIONAL([GL_GENERATE_LIMITS_H], [test -n "$LIMITS_H"]) ]) dnl Unconditionally enables the replacement of <limits.h>. AC_DEFUN([gl_REPLACE_LIMITS_H], [ AC_REQUIRE([gl_LIMITS_H]) - LIMITS_H='limits.h' - AM_CONDITIONAL([GL_GENERATE_LIMITS_H], [test -n "$LIMITS_H"]) + GL_GENERATE_LIMITS_H=true ]) diff --git a/m4/stdalign.m4 b/m4/stdalign.m4 index e22d7f78c06..fd57cdd47f2 100644 --- a/m4/stdalign.m4 +++ b/m4/stdalign.m4 @@ -49,11 +49,8 @@ AC_DEFUN([gl_STDALIGN_H], [gl_cv_header_working_stdalign_h=no])]) if test $gl_cv_header_working_stdalign_h = yes; then - STDALIGN_H='' + GL_GENERATE_STDALIGN_H=false else - STDALIGN_H='stdalign.h' + GL_GENERATE_STDALIGN_H=true fi - - AC_SUBST([STDALIGN_H]) - AM_CONDITIONAL([GL_GENERATE_STDALIGN_H], [test -n "$STDALIGN_H"]) ]) diff --git a/m4/stddef_h.m4 b/m4/stddef_h.m4 index 1303d2e06c7..0b160cde08b 100644 --- a/m4/stddef_h.m4 +++ b/m4/stddef_h.m4 @@ -1,4 +1,4 @@ -# stddef_h.m4 serial 11 +# stddef_h.m4 serial 12 dnl Copyright (C) 2009-2021 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -14,7 +14,7 @@ AC_DEFUN_ONCE([gl_STDDEF_H], dnl Persuade OpenBSD <stddef.h> to declare max_align_t. AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) - STDDEF_H= + GL_GENERATE_STDDEF_H=false dnl Test whether the type max_align_t exists and whether its alignment dnl "is as great as is supported by the implementation in all contexts". @@ -41,12 +41,12 @@ AC_DEFUN_ONCE([gl_STDDEF_H], ]) if test $gl_cv_type_max_align_t = no; then HAVE_MAX_ALIGN_T=0 - STDDEF_H=stddef.h + GL_GENERATE_STDDEF_H=true fi if test $gt_cv_c_wchar_t = no; then HAVE_WCHAR_T=0 - STDDEF_H=stddef.h + GL_GENERATE_STDDEF_H=true fi AC_CACHE_CHECK([whether NULL can be used in arbitrary expressions], @@ -58,12 +58,10 @@ AC_DEFUN_ONCE([gl_STDDEF_H], [gl_cv_decl_null_works=no])]) if test $gl_cv_decl_null_works = no; then REPLACE_NULL=1 - STDDEF_H=stddef.h + GL_GENERATE_STDDEF_H=true fi - AC_SUBST([STDDEF_H]) - AM_CONDITIONAL([GL_GENERATE_STDDEF_H], [test -n "$STDDEF_H"]) - if test -n "$STDDEF_H"; then + if $GL_GENERATE_STDDEF_H; then gl_NEXT_HEADERS([stddef.h]) fi ]) diff --git a/m4/stdint.m4 b/m4/stdint.m4 index 2eb1652d8e2..61fb8ca696f 100644 --- a/m4/stdint.m4 +++ b/m4/stdint.m4 @@ -1,4 +1,4 @@ -# stdint.m4 serial 60 +# stdint.m4 serial 61 dnl Copyright (C) 2001-2021 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -296,7 +296,7 @@ static const char *macro_values[] = HAVE_C99_STDINT_H=0 HAVE_SYS_BITYPES_H=0 HAVE_SYS_INTTYPES_H=0 - STDINT_H=stdint.h + GL_GENERATE_STDINT_H=true case "$gl_cv_header_working_stdint_h" in *yes) HAVE_C99_STDINT_H=1 @@ -341,7 +341,7 @@ int32_t i32 = INT32_C (0x7fffffff); ]])], [gl_cv_header_stdint_width=yes])]) if test "$gl_cv_header_stdint_width" = yes; then - STDINT_H= + GL_GENERATE_STDINT_H=false fi ;; *) @@ -364,8 +364,6 @@ int32_t i32 = INT32_C (0x7fffffff); AC_SUBST([HAVE_C99_STDINT_H]) AC_SUBST([HAVE_SYS_BITYPES_H]) AC_SUBST([HAVE_SYS_INTTYPES_H]) - AC_SUBST([STDINT_H]) - AM_CONDITIONAL([GL_GENERATE_STDINT_H], [test -n "$STDINT_H"]) ]) dnl gl_STDINT_BITSIZEOF(TYPES, INCLUDES) diff --git a/m4/sys_socket_h.m4 b/m4/sys_socket_h.m4 index 5676a0d2170..1f9a06f09cb 100644 --- a/m4/sys_socket_h.m4 +++ b/m4/sys_socket_h.m4 @@ -1,4 +1,4 @@ -# sys_socket_h.m4 serial 28 +# sys_socket_h.m4 serial 29 dnl Copyright (C) 2005-2021 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -22,6 +22,7 @@ AC_DEFUN_ONCE([gl_SYS_SOCKET_H], ;; esac + GL_GENERATE_SYS_SOCKET_H=false AC_CACHE_CHECK([whether <sys/socket.h> is self-contained], [gl_cv_header_sys_socket_h_selfcontained], [ @@ -44,7 +45,7 @@ AC_DEFUN_ONCE([gl_SYS_SOCKET_H], [gl_cv_header_sys_socket_h_shut=no]) ]) if test $gl_cv_header_sys_socket_h_shut = no; then - SYS_SOCKET_H='sys/socket.h' + GL_GENERATE_SYS_SOCKET_H=true fi fi fi @@ -83,7 +84,7 @@ AC_DEFUN_ONCE([gl_SYS_SOCKET_H], fi if test $HAVE_STRUCT_SOCKADDR_STORAGE = 0 || test $HAVE_SA_FAMILY_T = 0 \ || test $HAVE_STRUCT_SOCKADDR_STORAGE_SS_FAMILY = 0; then - SYS_SOCKET_H='sys/socket.h' + GL_GENERATE_SYS_SOCKET_H=true fi gl_PREREQ_SYS_H_WINSOCK2 diff --git a/msdos/sed2v2.inp b/msdos/sed2v2.inp index ae5d46fe860..52fbd4e9cbc 100644 --- a/msdos/sed2v2.inp +++ b/msdos/sed2v2.inp @@ -67,7 +67,7 @@ /^#undef PACKAGE_NAME/s/^.*$/#define PACKAGE_NAME ""/ /^#undef PACKAGE_STRING/s/^.*$/#define PACKAGE_STRING ""/ /^#undef PACKAGE_TARNAME/s/^.*$/#define PACKAGE_TARNAME ""/ -/^#undef PACKAGE_VERSION/s/^.*$/#define PACKAGE_VERSION "28.0.90"/ +/^#undef PACKAGE_VERSION/s/^.*$/#define PACKAGE_VERSION "29.0.50"/ /^#undef SYSTEM_TYPE/s/^.*$/#define SYSTEM_TYPE "ms-dos"/ /^#undef HAVE_DECL_GETENV/s/^.*$/#define HAVE_DECL_GETENV 1/ /^#undef SYS_SIGLIST_DECLARED/s/^.*$/#define SYS_SIGLIST_DECLARED 1/ diff --git a/nextstep/templates/Info.plist.in b/nextstep/templates/Info.plist.in index 66cde9f4eeb..f9f0ec08571 100644 --- a/nextstep/templates/Info.plist.in +++ b/nextstep/templates/Info.plist.in @@ -555,7 +555,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. <key>UTTypeIdentifier</key> <string>org.orgmode.org</string> <key>UTTypeReferenceURL</key> - <string>http://orgmode.org</string> + <string>https://orgmode.org</string> <key>UTTypeTagSpecification</key> <dict> <key>public.filename-extension</key> diff --git a/nt/INSTALL b/nt/INSTALL index 9f543151a94..c324fb4ae7d 100644 --- a/nt/INSTALL +++ b/nt/INSTALL @@ -488,6 +488,7 @@ build will run on Windows 9X and newer systems). Does Emacs use a gif library? yes Does Emacs use a png library? yes Does Emacs use -lrsvg-2? yes + Does Emacs use -lwebp? yes Does Emacs use cairo? no Does Emacs use -llcms2? yes Does Emacs use imagemagick? no @@ -597,8 +598,8 @@ build will run on Windows 9X and newer systems). * Optional image library support In addition to its "native" image formats (pbm and xbm), Emacs can - handle other image types: xpm, tiff, gif, png, jpeg and experimental - support for svg. + handle other image types: xpm, tiff, gif, png, jpeg, webp and + experimental support for svg. To build Emacs with support for them, the corresponding headers must be in the include path and libraries should be where the linker @@ -736,6 +737,18 @@ build will run on Windows 9X and newer systems). without it by specifying the --without-rsvg switch to the configure script. + For WebP images you will need libwebp. You can find it here: + + http://sourceforge.net/projects/ezwinports/files/ + + Note: the MS-Windows binary distribution on the Google site: + + https://developers.google.com/speed/webp/ + + was compiled by MSVC, and includes only static libraries, no DLLs. + So you cannot use that to build Emacs with WebP support on + MS-Windows, as that needs libwebp as a DLL. + Binaries for the other image libraries can be found on the ezwinports site or at the GnuWin32 project (the latter are generally very old, so not recommended). Note specifically that, due to some diff --git a/nt/INSTALL.W64 b/nt/INSTALL.W64 index 8f0d0c9528f..c3845d5b177 100644 --- a/nt/INSTALL.W64 +++ b/nt/INSTALL.W64 @@ -51,6 +51,7 @@ packages (you can copy and paste it into the shell with Shift + Insert): mingw-w64-x86_64-libpng \ mingw-w64-x86_64-libjpeg-turbo \ mingw-w64-x86_64-librsvg \ + mingw-w64-x86_64-libwebp \ mingw-w64-x86_64-lcms2 \ mingw-w64-x86_64-jansson \ mingw-w64-x86_64-libxml2 \ diff --git a/nt/Makefile.in b/nt/Makefile.in index 3274ff924f9..811680da851 100644 --- a/nt/Makefile.in +++ b/nt/Makefile.in @@ -144,6 +144,7 @@ LIBS_ADDPM = -lole32 -luuid ## Compilation and linking flags BASE_CFLAGS = $(C_SWITCH_SYSTEM) $(C_SWITCH_MACHINE) \ $(WARN_CFLAGS) $(WERROR_CFLAGS) \ + -I../src -I${srcdir}/../src -I../lib -I${srcdir}/../lib \ -I. -I${srcdir} ALL_CFLAGS = ${BASE_CFLAGS} ${PROFILING_CFLAGS} ${LDFLAGS} ${CPPFLAGS} ${CFLAGS} diff --git a/nt/README.W32 b/nt/README.W32 index 7a7c1920ddc..495af0baede 100644 --- a/nt/README.W32 +++ b/nt/README.W32 @@ -1,7 +1,7 @@ Copyright (C) 2001-2021 Free Software Foundation, Inc. See the end of the file for license conditions. - Emacs version 28.0.90 for MS-Windows + Emacs version 29.0.50 for MS-Windows This README file describes how to set up and run a precompiled distribution of the latest version of GNU Emacs for MS-Windows. You diff --git a/nt/addpm.c b/nt/addpm.c index f54a6ea9f7c..4fbcf6c05ea 100644 --- a/nt/addpm.c +++ b/nt/addpm.c @@ -34,6 +34,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ installed, then the DDE fallback for creating icons the Windows 3.1 progman way will be used instead, but that is prone to lockups caused by other applications not servicing their message queues. */ + +#define DEFER_MS_W32_H +#include <config.h> + #include <stdlib.h> #include <stdio.h> #include <malloc.h> diff --git a/nt/cmdproxy.c b/nt/cmdproxy.c index 224f68b1e85..f5a0550aa9d 100644 --- a/nt/cmdproxy.c +++ b/nt/cmdproxy.c @@ -27,6 +27,9 @@ GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ +#define DEFER_MS_W32_H +#include <config.h> + #include <windows.h> #include <stdarg.h> /* va_args */ diff --git a/nt/ddeclient.c b/nt/ddeclient.c index c577bfcfa93..0a44cbfd770 100644 --- a/nt/ddeclient.c +++ b/nt/ddeclient.c @@ -16,6 +16,9 @@ GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ +#define DEFER_MS_W32_H +#include <config.h> + #include <windows.h> #include <ddeml.h> #include <stdlib.h> diff --git a/nt/preprep.c b/nt/preprep.c index 78ed1c32381..8b054b19a71 100644 --- a/nt/preprep.c +++ b/nt/preprep.c @@ -21,6 +21,9 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. based on code from addsection.c */ +#define DEFER_MS_W32_H +#include <config.h> + #include <stdlib.h> #include <stdio.h> #include <fcntl.h> diff --git a/nt/runemacs.c b/nt/runemacs.c index 308e856be2a..b4ed9fb1564 100644 --- a/nt/runemacs.c +++ b/nt/runemacs.c @@ -40,6 +40,9 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ /* #define CHOOSE_NEWEST_EXE */ +#define DEFER_MS_W32_H +#include <config.h> + #include <windows.h> #include <string.h> #include <malloc.h> diff --git a/src/.gdbinit b/src/.gdbinit index f74e295f7ea..68db1ff3ea4 100644 --- a/src/.gdbinit +++ b/src/.gdbinit @@ -41,6 +41,11 @@ handle SIGUSR2 noprint pass # debugging. handle SIGALRM ignore +# On selection send failed. +if defined_HAVE_PGTK + handle SIGPIPE nostop noprint +end + # Use $bugfix so that the value isn't a constant. # Using a constant runs into GDB bugs sometimes. define xgetptr @@ -1224,6 +1229,9 @@ set print pretty on set print sevenbit-strings show environment DISPLAY +if defined_HAVE_PGTK + show environment WAYLAND_DISPLAY +end show environment TERM # When debugging, it is handy to be able to "return" from diff --git a/src/Makefile.in b/src/Makefile.in index 954d5482162..76e4675c2a7 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@ @@ -124,7 +125,7 @@ LIB_MATH=@LIB_MATH@ ## -lpthread, or empty. LIB_PTHREAD=@LIB_PTHREAD@ -LIBIMAGE=@LIBTIFF@ @LIBJPEG@ @LIBPNG@ @LIBGIF@ @LIBXPM@ +LIBIMAGE=@LIBTIFF@ @LIBJPEG@ @LIBPNG@ @LIBGIF@ @LIBXPM@ @WEBP_LIBS@ XCB_LIBS=@XCB_LIBS@ XFT_LIBS=@XFT_LIBS@ @@ -223,6 +224,8 @@ CFLAGS_SOUND= @CFLAGS_SOUND@ RSVG_LIBS= @RSVG_LIBS@ RSVG_CFLAGS= @RSVG_CFLAGS@ +WEBP_CFLAGS= @WEBP_CFLAGS@ + WEBKIT_LIBS= @WEBKIT_LIBS@ WEBKIT_CFLAGS= @WEBKIT_CFLAGS@ @@ -235,6 +238,8 @@ IMAGEMAGICK_CFLAGS= @IMAGEMAGICK_CFLAGS@ LIBXML2_LIBS = @LIBXML2_LIBS@ LIBXML2_CFLAGS = @LIBXML2_CFLAGS@ +SQLITE3_LIBS = @SQLITE3_LIBS@ + GETADDRINFO_A_LIBS = @GETADDRINFO_A_LIBS@ LCMS2_LIBS = @LCMS2_LIBS@ @@ -256,6 +261,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@ @@ -289,6 +297,9 @@ W32_OBJ=@W32_OBJ@ ## -lkernel32 if CYGWIN but not HAVE_W32, else empty. W32_LIBS=@W32_LIBS@ +PGTK_OBJ=@PGTK_OBJ@ +PGTK_LIBS=@PGTK_LIBS@ + ## emacs.res if HAVE_W32 EMACSRES = @EMACSRES@ ## If HAVE_W32, compiler arguments for including @@ -341,10 +352,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@) @@ -362,6 +380,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., @@ -372,22 +393,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) $(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. @@ -406,11 +431,13 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \ doprnt.o intervals.o textprop.o composite.o xml.o lcms.o $(NOTIFY_OBJ) \ $(XWIDGETS_OBJ) \ profiler.o decompress.o \ - thread.o systhread.o \ + thread.o systhread.o sqlite.o \ $(if $(HYBRID_MALLOC),sheap.o) \ $(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) \ - $(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ) $(JSON_OBJ) -obj = $(base_obj) $(NS_OBJC_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. @@ -424,7 +451,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@ @@ -450,7 +478,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 @@ -493,11 +525,11 @@ endif ## but the second one seems like it could be more future-proof. shortlisp = lisp.mk: $(lispsource)/loadup.el - @rm -f $@ ${AM_V_GEN}( printf 'shortlisp = \\\n'; \ sed -n 's/^[ \t]*(load "\([^"]*\)".*/\1/p' $< | \ sed -e 's/$$/.elc \\/' -e 's/\.el\.elc/.el/'; \ - echo "" ) > $@ + echo "" ) > $@.tmp + $(AM_V_at)mv -f $@.tmp $@ -include lisp.mk shortlisp_filter = leim/leim-list.el site-load.elc site-init.elc @@ -510,7 +542,7 @@ export LISP_PRELOADED = ${shortlisp} lisp = $(addprefix ${lispsource}/,${shortlisp}) ## Construct full set of libraries to be linked. -LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE) $(LIBIMAGE) \ +LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(PGTK_LIBS) $(LIBX_BASE) $(LIBIMAGE) \ $(LIBX_OTHER) $(LIBSOUND) \ $(RSVG_LIBS) $(IMAGEMAGICK_LIBS) $(LIB_ACL) $(LIB_CLOCK_GETTIME) \ $(WEBKIT_LIBS) \ @@ -522,7 +554,8 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(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) \ + $(SQLITE3_LIBS) ## FORCE it so that admin/unidata can decide whether this file is ## up-to-date. Although since charprop depends on bootstrap-emacs, @@ -579,6 +612,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) + $(AM_V_GEN) cp -f emacs$(EXEEXT) $@ + $(AM_V_at) $(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 \ @@ -597,13 +642,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: $(libsrc)/make-docfile$(EXEEXT) $(doc_obj) $(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 - $(AM_V_at)$(libsrc)/make-docfile -a $(etc)/DOC -d $(lispsource) \ - $(shortlisp) + $(SOME_MACHINE_OBJECTS) $(doc_obj) > $(etc)/DOC $(libsrc)/make-docfile$(EXEEXT) $(libsrc)/make-fingerprint$(EXEEXT): \ $(lib)/libgnu.a @@ -619,7 +662,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 > $@ @@ -644,9 +687,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) @@ -731,6 +780,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). @@ -745,7 +795,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. @@ -796,16 +847,6 @@ elnlisp := \ international/charscript.eln \ emacs-lisp/comp.eln \ emacs-lisp/comp-cstr.eln \ - emacs-lisp/cl-macs.eln \ - emacs-lisp/rx.eln \ - emacs-lisp/cl-seq.eln \ - help-mode.eln \ - emacs-lisp/cl-extra.eln \ - emacs-lisp/gv.eln \ - emacs-lisp/seq.eln \ - emacs-lisp/cl-lib.eln \ - emacs-lisp/warnings.eln \ - emacs-lisp/subr-x.eln \ international/emoji-zwj.eln elnlisp := $(addprefix ${lispsource}/,${elnlisp}) $(lisp:.elc=.eln) @@ -860,6 +901,9 @@ ifeq ($(DUMPING),unexec) else @: In the pdumper case, make compile-first after the dump cp -f temacs$(EXEEXT) bootstrap-emacs$(EXEEXT) +ifeq ($(DO_CODESIGN),yes) + codesign -s - -f bootstrap-emacs$(EXEEXT) +endif endif ifeq ($(DUMPING),pdumper) diff --git a/src/alloc.c b/src/alloc.c index e2184d7ba86..d82af1980a3 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -125,6 +125,7 @@ union emacs_align_type struct Lisp_Overlay Lisp_Overlay; struct Lisp_Sub_Char_Table Lisp_Sub_Char_Table; struct Lisp_Subr Lisp_Subr; + struct Lisp_Sqlite Lisp_Sqlite; struct Lisp_User_Ptr Lisp_User_Ptr; struct Lisp_Vector Lisp_Vector; struct terminal terminal; @@ -765,7 +766,7 @@ xmalloc (size_t size) val = lmalloc (size, false); MALLOC_UNBLOCK_INPUT; - if (!val && size) + if (!val) memory_full (size); MALLOC_PROBE (size); return val; @@ -782,7 +783,7 @@ xzalloc (size_t size) val = lmalloc (size, true); MALLOC_UNBLOCK_INPUT; - if (!val && size) + if (!val) memory_full (size); MALLOC_PROBE (size); return val; @@ -796,15 +797,15 @@ xrealloc (void *block, size_t size) void *val; MALLOC_BLOCK_INPUT; - /* We must call malloc explicitly when BLOCK is 0, since some - reallocs don't do this. */ + /* Call lmalloc when BLOCK is null, for the benefit of long-obsolete + platforms lacking support for realloc (NULL, size). */ if (! block) val = lmalloc (size, false); else val = lrealloc (block, size); MALLOC_UNBLOCK_INPUT; - if (!val && size) + if (!val) memory_full (size); MALLOC_PROBE (size); return val; @@ -988,8 +989,7 @@ record_xmalloc (size_t size) /* Like malloc but used for allocating Lisp data. NBYTES is the number of bytes to allocate, TYPE describes the intended use of the - allocated memory block (for strings, for conses, ...). - NBYTES must be positive. */ + allocated memory block (for strings, for conses, ...). */ #if ! USE_LSB_TAG void *lisp_malloc_loser EXTERNALLY_VISIBLE; @@ -1330,16 +1330,20 @@ laligned (void *p, size_t size) || size % LISP_ALIGNMENT != 0); } -/* Like malloc and realloc except that if SIZE is Lisp-aligned, make - sure the result is too, if necessary by reallocating (typically - with larger and larger sizes) until the allocator returns a - Lisp-aligned pointer. Code that needs to allocate C heap memory +/* Like malloc and realloc except return null only on failure, + the result is Lisp-aligned if SIZE is, and lrealloc's pointer + argument must be nonnull. Code allocating C heap memory for a Lisp object should use one of these functions to obtain a pointer P; that way, if T is an enum Lisp_Type value and L == make_lisp_ptr (P, T), then XPNTR (L) == P and XTYPE (L) == T. + If CLEARIT, arrange for the allocated memory to be cleared. + This might use calloc, as calloc can be faster than malloc+memset. + On typical modern platforms these functions' loops do not iterate. - On now-rare (and perhaps nonexistent) platforms, the loops in + On now-rare (and perhaps nonexistent) platforms, the code can loop, + reallocating (typically with larger and larger sizes) until the + allocator returns a Lisp-aligned pointer. This loop in theory could repeat forever. If an infinite loop is possible on a platform, a build would surely loop and the builder can then send us a bug report. Adding a counter to try to detect any such loop @@ -1353,8 +1357,13 @@ lmalloc (size_t size, bool clearit) if (! MALLOC_IS_LISP_ALIGNED && size % LISP_ALIGNMENT == 0) { void *p = aligned_alloc (LISP_ALIGNMENT, size); - if (clearit && p) - memclear (p, size); + if (p) + { + if (clearit) + memclear (p, size); + } + else if (! (MALLOC_0_IS_NONNULL || size)) + return aligned_alloc (LISP_ALIGNMENT, LISP_ALIGNMENT); return p; } #endif @@ -1362,7 +1371,7 @@ lmalloc (size_t size, bool clearit) while (true) { void *p = clearit ? calloc (1, size) : malloc (size); - if (laligned (p, size)) + if (laligned (p, size) && (MALLOC_0_IS_NONNULL || size || p)) return p; free (p); size_t bigger = size + LISP_ALIGNMENT; @@ -1377,7 +1386,7 @@ lrealloc (void *p, size_t size) while (true) { p = realloc (p, size); - if (laligned (p, size)) + if (laligned (p, size) && (size || p)) return p; size_t bigger = size + LISP_ALIGNMENT; if (size < bigger) @@ -3879,6 +3888,7 @@ count as reachable for the purpose of deciding whether to run FUNCTION. FUNCTION will be run once per finalizer object. */) (Lisp_Object function) { + CHECK_TYPE (FUNCTIONP (function), Qfunctionp, function); struct Lisp_Finalizer *finalizer = ALLOCATE_PSEUDOVECTOR (struct Lisp_Finalizer, function, PVEC_FINALIZER); finalizer->function = function; @@ -6136,11 +6146,18 @@ garbage_collect (void) mark_terminals (); mark_kboards (); mark_threads (); +#ifdef HAVE_PGTK + mark_pgtkterm (); +#endif #ifdef USE_GTK xg_mark_data (); #endif +#ifdef HAVE_HAIKU + mark_haiku_display (); +#endif + #ifdef HAVE_WINDOW_SYSTEM mark_fringe_data (); #endif @@ -7708,6 +7725,12 @@ enum defined_HAVE_X_WINDOWS { defined_HAVE_X_WINDOWS = true }; enum defined_HAVE_X_WINDOWS { defined_HAVE_X_WINDOWS = false }; #endif +#ifdef HAVE_PGTK +enum defined_HAVE_PGTK { defined_HAVE_PGTK = true }; +#else +enum defined_HAVE_PGTK { defined_HAVE_PGTK = false }; +#endif + /* When compiled with GCC, GDB might say "No enum type named pvec_type" if we don't have at least one symbol with that type, and then xbacktrace could fail. Similarly for the other enums and @@ -7727,5 +7750,6 @@ union enum More_Lisp_Bits More_Lisp_Bits; enum pvec_type pvec_type; enum defined_HAVE_X_WINDOWS defined_HAVE_X_WINDOWS; + enum defined_HAVE_PGTK defined_HAVE_PGTK; } const EXTERNALLY_VISIBLE gdb_make_enums_visible = {0}; #endif /* __GNUC__ */ diff --git a/src/atimer.c b/src/atimer.c index 9b198675ab4..df35603f324 100644 --- a/src/atimer.c +++ b/src/atimer.c @@ -305,18 +305,34 @@ set_alarm (void) #ifdef HAVE_ITIMERSPEC if (0 <= timerfd || alarm_timer_ok) { + bool exit = false; 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); - return; + exit = true; } # endif - if (alarm_timer_ok - && timer_settime (alarm_timer, TIMER_ABSTIME, &ispec, 0) == 0) + + if (exit) return; } #endif @@ -333,9 +349,8 @@ set_alarm (void) memset (&it, 0, sizeof it); it.it_value = make_timeval (interval); setitimer (ITIMER_REAL, &it, 0); -#else /* not HAVE_SETITIMER */ - alarm (max (interval.tv_sec, 1)); #endif /* not HAVE_SETITIMER */ + alarm (max (interval.tv_sec, 1)); } } @@ -583,15 +598,17 @@ init_atimer (void) timerfd = (egetenv ("EMACS_IGNORE_TIMERFD") || have_buggy_timerfd () ? -1 : timerfd_create (CLOCK_REALTIME, TFD_NONBLOCK | TFD_CLOEXEC)); # endif - if (timerfd < 0) - { - struct sigevent sigev; - sigev.sigev_notify = SIGEV_SIGNAL; - sigev.sigev_signo = SIGALRM; - sigev.sigev_value.sival_ptr = &alarm_timer; - alarm_timer_ok - = timer_create (CLOCK_REALTIME, &sigev, &alarm_timer) == 0; - } + /* We're starting the alarms even if we have timerfd, because + timerfd events do not fire while Emacs Lisp is busy and doesn't + call thread_select. This might or might not mean that the + timerfd code doesn't really give us anything and should be + removed, see discussion in bug#19776. */ + struct sigevent sigev; + sigev.sigev_notify = SIGEV_SIGNAL; + sigev.sigev_signo = SIGALRM; + sigev.sigev_value.sival_ptr = &alarm_timer; + alarm_timer_ok + = timer_create (CLOCK_REALTIME, &sigev, &alarm_timer) == 0; #endif free_atimers = stopped_atimers = atimers = NULL; diff --git a/src/bidi.c b/src/bidi.c index 1413ba6b888..890a60acc43 100644 --- a/src/bidi.c +++ b/src/bidi.c @@ -3564,11 +3564,19 @@ bidi_move_to_visually_next (struct bidi_it *bidi_it) } /* Utility function for looking for strong directional characters - whose bidi type was overridden by a directional override. */ + whose bidi type was overridden by directional override or embedding + or isolate control characters. */ ptrdiff_t bidi_find_first_overridden (struct bidi_it *bidi_it) { ptrdiff_t found_pos = ZV; + /* Maximum bidi levels we allow for L2R and R2L characters. Note + that these are levels after resolving explicit embeddings, + overrides, and isolates, i.e. before resolving implicit levels. */ + int max_l2r = bidi_it->paragraph_dir == L2R ? 0 : 2; + int max_r2l = 1; + /* Same for WEAK and NEUTRAL_ON types. */ + int max_weak = bidi_it->paragraph_dir == L2R ? 1 : 2; do { @@ -3576,11 +3584,28 @@ bidi_find_first_overridden (struct bidi_it *bidi_it) because the directional overrides are applied by the former. */ bidi_type_t type = bidi_resolve_weak (bidi_it); + unsigned level = bidi_it->level_stack[bidi_it->stack_idx].level; + bidi_category_t category = bidi_get_category (bidi_it->orig_type); + /* Detect strong L or R types that have been overridden by + explicit overrides. */ if ((type == STRONG_R && bidi_it->orig_type == STRONG_L) || (type == STRONG_L && (bidi_it->orig_type == STRONG_R - || bidi_it->orig_type == STRONG_AL))) + || bidi_it->orig_type == STRONG_AL)) + /* Detect strong L or R types or WEAK_EN types that were + pushed into higher embedding levels (and will thus + reorder) by explicit embeddings and isolates. */ + || ((bidi_it->orig_type == STRONG_L + || bidi_it->orig_type == WEAK_EN) + && level > max_l2r) + || ((bidi_it->orig_type == STRONG_R + || bidi_it->orig_type == STRONG_AL) + && level > max_r2l) + /* Detect other weak or neutral types whose level was + tweaked by explicit embeddings and isolates. */ + || ((category == WEAK || bidi_it->orig_type == NEUTRAL_ON) + && level > max_weak)) found_pos = bidi_it->charpos; } while (found_pos == ZV && bidi_it->charpos < ZV diff --git a/src/bignum.c b/src/bignum.c index 1ac75c19e24..5c587fc6dba 100644 --- a/src/bignum.c +++ b/src/bignum.c @@ -53,6 +53,15 @@ init_bignum (void) { eassert (mp_bits_per_limb == GMP_NUMB_BITS); integer_width = 1 << 16; + + /* FIXME: The Info node `(gmp) Custom Allocation' states: "No error + return is allowed from any of these functions, if they return + then they must have performed the specified operation. [...] + There's currently no defined way for the allocation functions to + recover from an error such as out of memory, they must terminate + program execution. A 'longjmp' or throwing a C++ exception will + have undefined results." But xmalloc and xrealloc do call + 'longjmp'. */ mp_set_memory_functions (xmalloc, xrealloc_for_gmp, xfree_for_gmp); for (int i = 0; i < ARRAYELTS (mpz); i++) diff --git a/src/buffer.c b/src/buffer.c index eca2843e2bc..a2fd0a83bce 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -1552,7 +1552,7 @@ This does not change the name of the visited file (if any). */) /* Catch redisplay's attention. Unless we do this, the mode lines for any windows displaying current_buffer will stay unchanged. */ - update_mode_lines = 11; + bset_update_mode_line (current_buffer); XSETBUFFER (buf, current_buffer); Fsetcar (Frassq (buf, Vbuffer_alist), newname); @@ -1562,6 +1562,9 @@ This does not change the name of the visited file (if any). */) run_buffer_list_update_hook (current_buffer); + call2 (intern ("uniquify--rename-buffer-advice"), + BVAR (current_buffer, name), unique); + /* Refetch since that last call may have done GC. */ return BVAR (current_buffer, name); } @@ -2805,7 +2808,7 @@ current buffer is cleared. */) } DEFUN ("kill-all-local-variables", Fkill_all_local_variables, - Skill_all_local_variables, 0, 0, 0, + Skill_all_local_variables, 0, 1, 0, doc: /* Switch to Fundamental mode by killing current buffer's local variables. Most local variable bindings are eliminated so that the default values become effective once more. Also, the syntax table is set from @@ -2816,18 +2819,20 @@ This function also forces redisplay of the mode line. Every function to select a new major mode starts by calling this function. -As a special exception, local variables whose names have -a non-nil `permanent-local' property are not eliminated by this function. +As a special exception, local variables whose names have a non-nil +`permanent-local' property are not eliminated by this function. If +the optional KILL-PERMANENT argument is non-nil, clear out these local +variables, too. The first thing this function does is run the normal hook `change-major-mode-hook'. */) - (void) + (Lisp_Object kill_permanent) { run_hook (Qchange_major_mode_hook); /* Actually eliminate all local bindings of this buffer. */ - reset_buffer_local_variables (current_buffer, 0); + reset_buffer_local_variables (current_buffer, !NILP (kill_permanent)); /* Force mode-line redisplay. Useful here because all major mode commands call this function. */ diff --git a/src/callproc.c b/src/callproc.c index f7c55d04863..c89628bb0ec 100644 --- a/src/callproc.c +++ b/src/callproc.c @@ -34,8 +34,7 @@ extern char **environ; /* In order to be able to use `posix_spawn', it needs to support some variant of `chdir' as well as `setsid'. */ -#if defined DARWIN_OS \ - && defined HAVE_SPAWN_H && defined HAVE_POSIX_SPAWN \ +#if defined HAVE_SPAWN_H && defined HAVE_POSIX_SPAWN \ && defined HAVE_POSIX_SPAWNATTR_SETFLAGS \ && (defined HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR \ || defined HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDCHDIR_NP) \ diff --git a/src/casefiddle.c b/src/casefiddle.c index a7a25414909..81e9ed153fb 100644 --- a/src/casefiddle.c +++ b/src/casefiddle.c @@ -54,6 +54,9 @@ struct casing_context /* Whether the context is within a word. */ bool inword; + + /* What the last operation was. */ + bool downcase_last; }; /* Initialize CTX structure for casing characters. */ @@ -143,10 +146,14 @@ case_character_impl (struct casing_str_buf *buf, /* Handle simple, one-to-one case. */ if (flag == CASE_DOWN) - cased = downcase (ch); + { + cased = downcase (ch); + ctx->downcase_last = true; + } else { bool cased_is_set = false; + ctx->downcase_last = false; if (!NILP (ctx->titlecase_char_table)) { prop = CHAR_TABLE_REF (ctx->titlecase_char_table, ch); @@ -297,6 +304,16 @@ do_casify_multibyte_string (struct casing_context *ctx, Lisp_Object obj) return obj; } +static int +ascii_casify_character (bool downcase, int c) +{ + Lisp_Object cased = CHAR_TABLE_REF (downcase? + uniprop_table (Qlowercase) : + uniprop_table (Quppercase), + c); + return FIXNATP (cased) ? XFIXNAT (cased) : c; +} + static Lisp_Object do_casify_unibyte_string (struct casing_context *ctx, Lisp_Object obj) { @@ -310,11 +327,12 @@ do_casify_unibyte_string (struct casing_context *ctx, Lisp_Object obj) cased = case_single_character (ctx, ch); if (ch == cased) continue; - cased = make_char_unibyte (cased); - /* If the char can't be converted to a valid byte, just don't - change it. */ - if (SINGLE_BYTE_CHAR_P (cased)) - SSET (obj, i, cased); + /* If down/upcasing changed an ASCII character into a non-ASCII + character (this can happen in some locales, like the Turkish + "I"), downcase using the ASCII char table. */ + if (ASCII_CHAR_P (ch) && !SINGLE_BYTE_CHAR_P (cased)) + cased = ascii_casify_character (ctx->downcase_last, ch); + SSET (obj, i, make_char_unibyte (cased)); } return obj; } @@ -339,10 +357,13 @@ casify_object (enum case_action flag, Lisp_Object obj) DEFUN ("upcase", Fupcase, Supcase, 1, 1, 0, doc: /* Convert argument to upper case and return that. -The argument may be a character or string. The result has the same type. +The argument may be a character or string. The result has the same +type. (See `downcase' for further details about the type.) + The argument object is not altered--the value is a copy. If argument is a character, characters which map to multiple code points when cased, e.g. fi, are returned unchanged. + See also `capitalize', `downcase' and `upcase-initials'. */) (Lisp_Object obj) { @@ -351,7 +372,15 @@ See also `capitalize', `downcase' and `upcase-initials'. */) DEFUN ("downcase", Fdowncase, Sdowncase, 1, 1, 0, doc: /* Convert argument to lower case and return that. -The argument may be a character or string. The result has the same type. +The argument may be a character or string. The result has the same type, +including the multibyteness of the string. + +This means that if this function is called with a unibyte string +argument, and downcasing it would turn it into a multibyte string +(according to the current locale), the downcasing is done using ASCII +\"C\" rules instead. To accurately downcase according to the current +locale, the string must be converted into multibyte first. + The argument object is not altered--the value is a copy. */) (Lisp_Object obj) { @@ -362,7 +391,10 @@ DEFUN ("capitalize", Fcapitalize, Scapitalize, 1, 1, 0, doc: /* Convert argument to capitalized form and return that. This means that each word's first character is converted to either title case or upper case, and the rest to lower case. -The argument may be a character or string. The result has the same type. + +The argument may be a character or string. The result has the same +type. (See `downcase' for further details about the type.) + The argument object is not altered--the value is a copy. If argument is a character, characters which map to multiple code points when cased, e.g. fi, are returned unchanged. */) @@ -377,7 +409,10 @@ DEFUN ("upcase-initials", Fupcase_initials, Supcase_initials, 1, 1, 0, doc: /* Convert the initial of each word in the argument to upper case. This means that each word's first character is converted to either title case or upper case, and the rest are left unchanged. -The argument may be a character or string. The result has the same type. + +The argument may be a character or string. The result has the same +type. (See `downcase' for further details about the type.) + The argument object is not altered--the value is a copy. If argument is a character, characters which map to multiple code points when cased, e.g. fi, are returned unchanged. */) @@ -651,6 +686,8 @@ syms_of_casefiddle (void) DEFSYM (Qbounds, "bounds"); DEFSYM (Qidentity, "identity"); DEFSYM (Qtitlecase, "titlecase"); + DEFSYM (Qlowercase, "lowercase"); + DEFSYM (Quppercase, "uppercase"); DEFSYM (Qspecial_uppercase, "special-uppercase"); DEFSYM (Qspecial_lowercase, "special-lowercase"); DEFSYM (Qspecial_titlecase, "special-titlecase"); diff --git a/src/comp.c b/src/comp.c index 43feac64903..1fb384840cf 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4123,7 +4123,7 @@ one for the file name and another for its contents, followed by .eln. */) FOR_EACH_TAIL (lds_re_tail) { Lisp_Object match_idx = - Fstring_match (XCAR (lds_re_tail), filename, Qnil); + Fstring_match (XCAR (lds_re_tail), filename, Qnil, Qnil); if (EQ (match_idx, make_fixnum (0))) { filename = @@ -4786,10 +4786,6 @@ register_native_comp_unit (Lisp_Object comp_u) /* Deferred compilation mechanism. */ /***********************************/ -/* List of sources we'll compile and load after having conventionally - loaded the compiler and its dependencies. */ -static Lisp_Object delayed_sources; - /* Queue an asynchronous compilation for the source file defining FUNCTION_NAME and perform a late load. @@ -4846,30 +4842,16 @@ maybe_defer_native_compilation (Lisp_Object function_name, /* This is so deferred compilation is able to compile comp dependencies breaking circularity. */ - if (!NILP (Ffeaturep (Qcomp, Qnil))) + if (comp__loadable) { - /* Comp already loaded. */ - if (!NILP (delayed_sources)) - { - CALLN (Ffuncall, intern_c_string ("native--compile-async"), - delayed_sources, Qnil, Qlate); - delayed_sources = Qnil; - } + /* Startup is done, comp is usable. */ + Frequire (Qcomp, Qnil, Qnil); Fputhash (function_name, definition, Vcomp_deferred_pending_h); CALLN (Ffuncall, intern_c_string ("native--compile-async"), src, Qnil, Qlate); } else - { - delayed_sources = Fcons (src, delayed_sources); - /* Require comp only once. */ - static bool comp_required = false; - if (!comp_required) - { - comp_required = true; - Frequire (Qcomp, Qnil, Qnil); - } - } + Vcomp__delayed_sources = Fcons (src, Vcomp__delayed_sources); } @@ -5268,7 +5250,8 @@ file_in_eln_sys_dir (Lisp_Object filename) eln_sys_dir = XCAR (tmp); return !NILP (Fstring_match (Fregexp_quote (Fexpand_file_name (eln_sys_dir, Qnil)), - Fexpand_file_name (filename, Qnil), Qnil)); + Fexpand_file_name (filename, Qnil), + Qnil, Qnil)); } /* Load related routines. */ @@ -5295,16 +5278,16 @@ LATE_LOAD has to be non-nil when loading for deferred compilation. */) Fmake_temp_file_internal (filename, Qnil, build_string (".eln.tmp"), Qnil); if (NILP (Ffile_writable_p (tmp_filename))) - comp_u->handle = dynlib_open (SSDATA (encoded_filename)); + comp_u->handle = dynlib_open_for_eln (SSDATA (encoded_filename)); else { Frename_file (filename, tmp_filename, Qt); - comp_u->handle = dynlib_open (SSDATA (ENCODE_FILE (tmp_filename))); + comp_u->handle = dynlib_open_for_eln (SSDATA (ENCODE_FILE (tmp_filename))); Frename_file (tmp_filename, filename, Qnil); } } else - comp_u->handle = dynlib_open (SSDATA (encoded_filename)); + comp_u->handle = dynlib_open_for_eln (SSDATA (encoded_filename)); if (!comp_u->handle) xsignal2 (Qnative_lisp_load_failed, filename, @@ -5335,6 +5318,13 @@ void syms_of_comp (void) { #ifdef HAVE_NATIVE_COMP + DEFVAR_LISP ("comp--delayed-sources", Vcomp__delayed_sources, + doc: /* List of sources to be native-compiled when startup is finished. +For internal use. */); + DEFVAR_BOOL ("comp--loadable", + comp__loadable, + doc: /* Non-nil when comp.el can be loaded. +For internal use. */); /* Compiler control customizes. */ DEFVAR_BOOL ("native-comp-deferred-compilation", native_comp_deferred_compilation, @@ -5475,8 +5465,6 @@ compiled one. */); staticpro (&comp.func_blocks_h); staticpro (&comp.emitter_dispatcher); comp.emitter_dispatcher = Qnil; - staticpro (&delayed_sources); - delayed_sources = Qnil; staticpro (&loadsearch_re_list); loadsearch_re_list = Qnil; diff --git a/src/data.c b/src/data.c index b2c395831ae..f07667b0003 100644 --- a/src/data.c +++ b/src/data.c @@ -259,6 +259,8 @@ for example, (type-of 1) returns `integer'. */) return Qxwidget; case PVEC_XWIDGET_VIEW: return Qxwidget_view; + case PVEC_SQLITE: + return Qsqlite; /* "Impossible" cases. */ case PVEC_MISC_PTR: case PVEC_OTHER: diff --git a/src/dispextern.h b/src/dispextern.h index 08dac5d4557..f1d99abad32 100644 --- a/src/dispextern.h +++ b/src/dispextern.h @@ -123,15 +123,25 @@ typedef HDC Emacs_Pix_Context; #ifdef HAVE_NS #include "nsgui.h" -#define FACE_COLOR_TO_PIXEL(face_color, frame) (FRAME_NS_P (frame) \ - ? ns_color_index_to_rgba (face_color, frame) \ - : face_color) /* Following typedef needed to accommodate the MSDOS port, believe it or not. */ typedef struct ns_display_info Display_Info; typedef Emacs_Pixmap Emacs_Pix_Container; typedef Emacs_Pixmap Emacs_Pix_Context; -#else -#define FACE_COLOR_TO_PIXEL(face_color, frame) face_color +#endif + +#ifdef HAVE_PGTK +#include "pgtkgui.h" +/* Following typedef needed to accommodate the MSDOS port, believe it or not. */ +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 @@ -536,8 +546,8 @@ struct glyph int img_id; #ifdef HAVE_XWIDGETS - /* Xwidget reference (type == XWIDGET_GLYPH). */ - struct xwidget *xwidget; + /* Xwidget ID. */ + uint32_t xwidget; #endif /* Sub-structure for type == STRETCH_GLYPH. */ @@ -1393,6 +1403,9 @@ struct glyph_string Emacs_GC *gc; HDC hdc; #endif +#if defined (HAVE_PGTK) + Emacs_GC xgcv; +#endif /* A pointer to the first glyph in the string. This glyph corresponds to char2b[0]. Needed to draw rectangles if @@ -1470,21 +1483,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 @@ -1497,7 +1512,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 @@ -1811,7 +1826,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, @@ -1829,6 +1844,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 }; @@ -2538,7 +2554,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 @@ -2739,6 +2756,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; }; @@ -3011,7 +3034,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 @@ -3050,6 +3073,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; @@ -3162,7 +3193,7 @@ struct image_cache /* Size of bucket vector of image caches. Should be prime. */ -#define IMAGE_CACHE_BUCKETS_SIZE 1001 +#define IMAGE_CACHE_BUCKETS_SIZE 1009 #endif /* HAVE_WINDOW_SYSTEM */ @@ -3489,7 +3520,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 @@ -3722,10 +3754,8 @@ extern Lisp_Object gui_default_parameter (struct frame *, Lisp_Object, const char *, const char *, enum resource_types); -#ifndef HAVE_NS /* These both used on W32 and X only. */ extern bool gui_mouse_grabbed (Display_Info *); extern void gui_redo_mouse_highlight (Display_Info *); -#endif /* HAVE_NS */ #endif /* HAVE_WINDOW_SYSTEM */ diff --git a/src/dispnew.c b/src/dispnew.c index 4a9f2bae44b..4faa7a7777b 100644 --- a/src/dispnew.c +++ b/src/dispnew.c @@ -3850,6 +3850,9 @@ gui_update_window_end (struct window *w, bool cursor_on_p, w->output_cursor.hpos, w->output_cursor.vpos, w->output_cursor.x, w->output_cursor.y); + if (cursor_in_mouse_face_p (w) && cursor_on_p) + mouse_face_overwritten_p = 1; + if (draw_window_fringes (w, true)) { if (WINDOW_RIGHT_DIVIDER_WIDTH (w)) @@ -4446,16 +4449,6 @@ scrolling_window (struct window *w, int tab_line_p) break; } -#ifdef HAVE_XWIDGETS - /* Currently this seems needed to detect xwidget movement reliably. - This is most probably because an xwidget glyph is represented in - struct glyph's 'union u' by a pointer to a struct, which takes 8 - bytes in 64-bit builds, and thus the comparison of u.val values - done by GLYPH_EQUAL_P doesn't work reliably, since it assumes the - size of the union is 4 bytes. FIXME. */ - return 0; -#endif - /* Can't scroll the display of w32 GUI frames when position of point is indicated by the system caret, because scrolling the display will then "copy" the pixels used by the caret. */ @@ -6153,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 @@ -6460,6 +6453,24 @@ init_display_interactive (void) } #endif +#ifdef HAVE_PGTK + 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; + } +#endif + /* If no window system has been specified, try to use the terminal. */ if (! isatty (STDIN_FILENO)) fatal ("standard input is not a tty"); diff --git a/src/doc.c b/src/doc.c index 6be023bb934..129d3a517b7 100644 --- a/src/doc.c +++ b/src/doc.c @@ -84,16 +84,19 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool definition) char *from, *to, *name, *p, *p1; Lisp_Object file, pos; ptrdiff_t count = SPECPDL_INDEX (); + Lisp_Object dir; USE_SAFE_ALLOCA; if (FIXNUMP (filepos)) { file = Vdoc_file_name; + dir = Vdoc_directory; pos = filepos; } else if (CONSP (filepos)) { file = XCAR (filepos); + dir = Fsymbol_value (Qlisp_directory); pos = XCDR (filepos); } else @@ -101,7 +104,7 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool definition) EMACS_INT position = eabs (XFIXNUM (pos)); - if (!STRINGP (Vdoc_directory)) + if (!STRINGP (dir)) return Qnil; if (!STRINGP (file)) @@ -113,7 +116,7 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool definition) Lisp_Object tem = Ffile_name_absolute_p (file); file = ENCODE_FILE (file); Lisp_Object docdir - = NILP (tem) ? ENCODE_FILE (Vdoc_directory) : empty_unibyte_string; + = NILP (tem) ? ENCODE_FILE (dir) : empty_unibyte_string; ptrdiff_t docdir_sizemax = SBYTES (docdir) + 1; if (will_dump_p ()) docdir_sizemax = max (docdir_sizemax, sizeof sibling_etc); @@ -703,6 +706,7 @@ See variable `text-quoting-style'. */) void syms_of_doc (void) { + DEFSYM (Qlisp_directory, "lisp-directory"); DEFSYM (Qsubstitute_command_keys, "substitute-command-keys"); DEFSYM (Qfunction_documentation, "function-documentation"); DEFSYM (Qgrave, "grave"); diff --git a/src/dynlib.c b/src/dynlib.c index a8c88439615..e9a775f2d3c 100644 --- a/src/dynlib.c +++ b/src/dynlib.c @@ -104,6 +104,12 @@ dynlib_open (const char *dll_fname) return (dynlib_handle_ptr) hdll; } +dynlib_handle_ptr +dynlib_open_for_eln (const char *dll_fname) +{ + return dynlib_open (dll_fname); +} + void * dynlib_sym (dynlib_handle_ptr h, const char *sym) { @@ -270,6 +276,12 @@ dynlib_close (dynlib_handle_ptr h) dynlib_handle_ptr dynlib_open (const char *path) { + return dlopen (path, RTLD_LAZY | RTLD_GLOBAL); +} + +dynlib_handle_ptr +dynlib_open_for_eln (const char *path) +{ return dlopen (path, RTLD_LAZY); } diff --git a/src/dynlib.h b/src/dynlib.h index e20d8891a23..05ba7981226 100644 --- a/src/dynlib.h +++ b/src/dynlib.h @@ -24,6 +24,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ typedef void *dynlib_handle_ptr; dynlib_handle_ptr dynlib_open (const char *path); +dynlib_handle_ptr dynlib_open_for_eln (const char *path); int dynlib_close (dynlib_handle_ptr h); const char *dynlib_error (void); diff --git a/src/emacs-module.h.in b/src/emacs-module.h.in index fe52587c1a5..a56e4dd12ae 100644 --- a/src/emacs-module.h.in +++ b/src/emacs-module.h.in @@ -169,6 +169,19 @@ struct emacs_env_28 @module_env_snippet_28@ }; +struct emacs_env_29 +{ +@module_env_snippet_25@ + +@module_env_snippet_26@ + +@module_env_snippet_27@ + +@module_env_snippet_28@ + +@module_env_snippet_29@ +}; + /* Every module should define a function as follows. */ extern int emacs_module_init (struct emacs_runtime *runtime) EMACS_NOEXCEPT diff --git a/src/emacs.c b/src/emacs.c index c99b007ea78..6048d126781 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -109,6 +109,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "getpagesize.h" #include "gnutls.h" +#ifdef HAVE_HAIKU +#include <kernel/OS.h> +#endif + #ifdef PROFILING # include <sys/gmon.h> extern void moncontrol (int mode); @@ -133,6 +137,7 @@ extern char etext; #endif #include "pdumper.h" +#include "fingerprint.h" #include "epaths.h" static const char emacs_version[] = PACKAGE_VERSION; @@ -255,11 +260,12 @@ Initialization options:\n\ #ifdef HAVE_PDUMPER "\ --dump-file FILE read dumped state from FILE\n\ +--fingerprint output fingerprint and exit\n\ ", #endif #if SECCOMP_USABLE "\ ---sandbox=FILE read Seccomp BPF filter from FILE\n\ +--seccomp=FILE read Seccomp BPF filter from FILE\n\ " #endif "\ @@ -830,6 +836,8 @@ load_pdump (int argc, char **argv) const char *const suffix = ".pdmp"; int result; char *emacs_executable = argv[0]; + ptrdiff_t hexbuf_size; + char *hexbuf; const char *strip_suffix = #if defined DOS_NT || defined CYGWIN ".exe" @@ -924,12 +932,18 @@ load_pdump (int argc, char **argv) path_exec = ns_relocate (path_exec); #endif - /* Look for "emacs.pdmp" in PATH_EXEC. We hardcode "emacs" in - "emacs.pdmp" so that the Emacs binary still works if the user - copies and renames it. */ + /* Look for "emacs-FINGERPRINT.pdmp" in PATH_EXEC. We hardcode + "emacs" in "emacs-FINGERPRINT.pdmp" so that the Emacs binary + still works if the user copies and renames it. */ + hexbuf_size = 2 * sizeof fingerprint; + hexbuf = xmalloc (hexbuf_size + 1); + hexbuf_digest (hexbuf, (char *) fingerprint, sizeof fingerprint); + hexbuf[hexbuf_size] = '\0'; needed = (strlen (path_exec) + 1 + strlen (argv0_base) + + 1 + + strlen (hexbuf) + strlen (suffix) + 1); if (bufsize < needed) @@ -937,8 +951,8 @@ load_pdump (int argc, char **argv) xfree (dump_file); dump_file = xpalloc (NULL, &bufsize, needed - bufsize, -1, 1); } - sprintf (dump_file, "%s%c%s%s", - path_exec, DIRECTORY_SEP, argv0_base, suffix); + sprintf (dump_file, "%s%c%s-%s%s", + path_exec, DIRECTORY_SEP, argv0_base, hexbuf, suffix); #if !defined (NS_SELF_CONTAINED) /* Assume the Emacs binary lives in a sibling directory as set up by the default installation configuration. */ @@ -1420,6 +1434,24 @@ main (int argc, char **argv) exit (0); } +#ifdef HAVE_PDUMPER + if (argmatch (argv, argc, "-fingerprint", "--fingerprint", 4, + NULL, &skip_args)) + { + if (initialized) + { + dump_fingerprint (stdout, "", + (unsigned char *) fingerprint); + exit (0); + } + else + { + fputs ("Not initialized\n", stderr); + exit (1); + } + } +#endif + emacs_wd = emacs_get_current_dir_name (); #ifdef HAVE_PDUMPER if (dumped_with_pdumper_p ()) @@ -1877,7 +1909,9 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem init_bignum (); init_threads (); init_eval (); - init_atimer (); +#ifdef HAVE_PGTK + init_pgtkterm (); /* before init_atimer(). */ +#endif running_asynch_code = 0; init_random (); @@ -2039,6 +2073,9 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem if (!will_dump_p ()) set_initial_environment (); + /* Has to run after the environment is set up. */ + init_atimer (); + #ifdef WINDOWSNT globals_of_w32 (); #ifdef HAVE_W32NOTIFY @@ -2149,6 +2186,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem #endif syms_of_window (); syms_of_xdisp (); + syms_of_sqlite (); syms_of_font (); #ifdef HAVE_WINDOW_SYSTEM syms_of_fringe (); @@ -2210,6 +2248,27 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem syms_of_fontset (); #endif /* HAVE_NS */ +#ifdef HAVE_PGTK + syms_of_pgtkterm (); + syms_of_pgtkfns (); + syms_of_pgtkselect (); + syms_of_pgtkmenu (); + 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 (); #ifdef HAVE_INOTIFY @@ -2264,6 +2323,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 (); @@ -2277,7 +2340,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem #ifdef HAVE_DBUS init_dbusbind (); #endif -#ifdef USE_GTK +#if defined(USE_GTK) && !defined(HAVE_PGTK) init_xterm (); #endif @@ -2349,6 +2412,11 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem if (dump_mode) Vdump_mode = build_string (dump_mode); +#ifdef HAVE_PDUMPER + /* Allow code to be run (mostly useful after redumping). */ + safe_run_hooks (Qafter_pdump_load_hook); +#endif + /* Enter editor command loop. This never returns. */ set_initial_minibuffer_mode (); Frecursive_edit (); @@ -2371,6 +2439,9 @@ struct standard_args static const struct standard_args standard_args[] = { { "-version", "--version", 150, 0 }, +#ifdef HAVE_PDUMPER + { "-fingerprint", "--fingerprint", 140, 0 }, +#endif { "-chdir", "--chdir", 130, 1 }, { "-t", "--terminal", 120, 1 }, { "-nw", "--no-window-system", 110, 0 }, @@ -2734,6 +2805,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); @@ -2743,6 +2817,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))]; @@ -3235,6 +3313,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/emacsgtkfixed.c b/src/emacsgtkfixed.c index 996ded2acaa..bd365004ad6 100644 --- a/src/emacsgtkfixed.c +++ b/src/emacsgtkfixed.c @@ -22,8 +22,11 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "lisp.h" #include "frame.h" +#ifdef HAVE_PGTK +#include "pgtkterm.h" +#else #include "xterm.h" -#include "xwidget.h" +#endif #include "emacsgtkfixed.h" /* Silence a bogus diagnostic; see GNOME bug 683906. */ @@ -47,7 +50,9 @@ static void emacs_fixed_get_preferred_width (GtkWidget *widget, static void emacs_fixed_get_preferred_height (GtkWidget *widget, gint *minimum, gint *natural); +#ifndef HAVE_PGTK static GType emacs_fixed_get_type (void); +#endif G_DEFINE_TYPE (EmacsFixed, emacs_fixed, GTK_TYPE_FIXED) static EmacsFixed * @@ -57,92 +62,6 @@ EMACS_FIXED (GtkWidget *widget) EmacsFixed); } -#ifdef HAVE_XWIDGETS - -static EmacsFixedClass * -EMACS_FIXED_GET_CLASS (GtkWidget *widget) -{ - return G_TYPE_INSTANCE_GET_CLASS (widget, emacs_fixed_get_type (), - EmacsFixedClass); -} - -struct GtkFixedPrivateL -{ - GList *children; -}; - -static void -emacs_fixed_gtk_widget_size_allocate (GtkWidget *widget, - GtkAllocation *allocation) -{ - /* For xwidgets. - - This basically re-implements the base class method and adds an - additional case for an xwidget view. - - It would be nicer if the bse class method could be called first, - and the xview modification only would remain here. It wasn't - possible to solve it that way yet. */ - EmacsFixedClass *klass; - GtkWidgetClass *parent_class; - struct GtkFixedPrivateL *priv; - - klass = EMACS_FIXED_GET_CLASS (widget); - parent_class = g_type_class_peek_parent (klass); - parent_class->size_allocate (widget, allocation); - - priv = G_TYPE_INSTANCE_GET_PRIVATE (widget, GTK_TYPE_FIXED, - struct GtkFixedPrivateL); - - gtk_widget_set_allocation (widget, allocation); - - if (gtk_widget_get_has_window (widget)) - { - if (gtk_widget_get_realized (widget)) - gdk_window_move_resize (gtk_widget_get_window (widget), - allocation->x, - allocation->y, - allocation->width, - allocation->height); - } - - for (GList *children = priv->children; children; children = children->next) - { - GtkFixedChild *child = children->data; - - if (!gtk_widget_get_visible (child->widget)) - continue; - - GtkRequisition child_requisition; - gtk_widget_get_preferred_size (child->widget, &child_requisition, NULL); - - GtkAllocation child_allocation; - child_allocation.x = child->x; - child_allocation.y = child->y; - - if (!gtk_widget_get_has_window (widget)) - { - child_allocation.x += allocation->x; - child_allocation.y += allocation->y; - } - - child_allocation.width = child_requisition.width; - child_allocation.height = child_requisition.height; - - struct xwidget_view *xv - = g_object_get_data (G_OBJECT (child->widget), XG_XWIDGET_VIEW); - if (xv) - { - child_allocation.width = xv->clip_right; - child_allocation.height = xv->clip_bottom - xv->clip_top; - } - - gtk_widget_size_allocate (child->widget, &child_allocation); - } -} - -#endif /* HAVE_XWIDGETS */ - static void emacs_fixed_class_init (EmacsFixedClass *klass) { @@ -152,9 +71,6 @@ emacs_fixed_class_init (EmacsFixedClass *klass) widget_class->get_preferred_width = emacs_fixed_get_preferred_width; widget_class->get_preferred_height = emacs_fixed_get_preferred_height; -#ifdef HAVE_XWIDGETS - widget_class->size_allocate = emacs_fixed_gtk_widget_size_allocate; -#endif g_type_class_add_private (klass, sizeof (EmacsFixedPrivate)); } @@ -182,9 +98,15 @@ emacs_fixed_get_preferred_width (GtkWidget *widget, { EmacsFixed *fixed = EMACS_FIXED (widget); EmacsFixedPrivate *priv = fixed->priv; +#ifdef HAVE_PGTK + int w = priv->f->output_data.pgtk->size_hints.min_width; + if (minimum) *minimum = w; + if (natural) *natural = priv->f->output_data.pgtk->preferred_width; +#else int w = priv->f->output_data.x->size_hints.min_width; if (minimum) *minimum = w; if (natural) *natural = w; +#endif } static void @@ -194,12 +116,20 @@ emacs_fixed_get_preferred_height (GtkWidget *widget, { EmacsFixed *fixed = EMACS_FIXED (widget); EmacsFixedPrivate *priv = fixed->priv; +#ifdef HAVE_PGTK + int h = priv->f->output_data.pgtk->size_hints.min_height; + if (minimum) *minimum = h; + if (natural) *natural = priv->f->output_data.pgtk->preferred_height; +#else int h = priv->f->output_data.x->size_hints.min_height; if (minimum) *minimum = h; if (natural) *natural = h; +#endif } +#ifndef HAVE_PGTK + /* Override the X function so we can intercept Gtk+ 3 calls. Use our values for min_width/height so that KDE don't freak out (Bug#8919), and so users can resize our frames as they wish. */ @@ -234,8 +164,13 @@ XSetWMSizeHints (Display *d, if ((hints->flags & PMinSize) && f) { +#ifdef HAVE_PGTK + int w = f->output_data.pgtk->size_hints.min_width; + int h = f->output_data.pgtk->size_hints.min_height; +#else int w = f->output_data.x->size_hints.min_width; int h = f->output_data.x->size_hints.min_height; +#endif data[5] = w; data[6] = h; } @@ -253,3 +188,5 @@ XSetWMNormalHints (Display *d, Window w, XSizeHints *hints) { XSetWMSizeHints (d, w, hints, XA_WM_NORMAL_HINTS); } + +#endif diff --git a/src/emacsgtkfixed.h b/src/emacsgtkfixed.h index 78879764d86..4f7a4eb3f71 100644 --- a/src/emacsgtkfixed.h +++ b/src/emacsgtkfixed.h @@ -27,6 +27,11 @@ struct frame; G_BEGIN_DECLS +#ifdef HAVE_PGTK +#define EMACS_TYPE_FIXED (emacs_fixed_get_type ()) +#define EMACS_IS_FIXED(obj) (G_TYPE_CHECK_INSTANCE_TYPE ((obj), EMACS_TYPE_FIXED)) +#endif + struct frame; typedef struct _EmacsFixedPrivate EmacsFixedPrivate; @@ -44,6 +49,10 @@ struct _EmacsFixedClass GtkFixedClass parent_class; }; +#ifdef HAVE_PGTK +extern GType emacs_fixed_get_type (void); +#endif + extern GtkWidget *emacs_fixed_new (struct frame *f); G_END_DECLS diff --git a/src/eval.c b/src/eval.c index 3ac1afc17bd..83ec3eab112 100644 --- a/src/eval.c +++ b/src/eval.c @@ -29,6 +29,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "dispextern.h" #include "buffer.h" #include "pdumper.h" +#include "atimer.h" /* CACHEABLE is ordinarily nothing, except it is 'volatile' if necessary to cajole GCC into not warning incorrectly that a @@ -1075,6 +1076,47 @@ usage: (while TEST BODY...) */) return Qnil; } +static void +with_delayed_message_display (struct atimer *timer) +{ + message3 (build_string (timer->client_data)); +} + +static void +with_delayed_message_cancel (void *timer) +{ + xfree (((struct atimer *) timer)->client_data); + cancel_atimer (timer); +} + +DEFUN ("funcall-with-delayed-message", + Ffuncall_with_delayed_message, Sfuncall_with_delayed_message, + 3, 3, 0, + doc: /* Like `funcall', but display MESSAGE if FUNCTION takes longer than TIMEOUT. +TIMEOUT is a number of seconds, and can be an integer or a floating +point number. + +If FUNCTION takes less time to execute than TIMEOUT seconds, MESSAGE +is not displayed. */) + (Lisp_Object timeout, Lisp_Object message, Lisp_Object function) +{ + ptrdiff_t count = SPECPDL_INDEX (); + + CHECK_NUMBER (timeout); + CHECK_STRING (message); + + /* Set up the atimer. */ + struct timespec interval = dtotimespec (XFLOATINT (timeout)); + struct atimer *timer = start_atimer (ATIMER_RELATIVE, interval, + with_delayed_message_display, + xstrdup (SSDATA (message))); + record_unwind_protect_ptr (with_delayed_message_cancel, timer); + + Lisp_Object result = CALLN (Ffuncall, function); + + return unbind_to (count, result); +} + DEFUN ("macroexpand", Fmacroexpand, Smacroexpand, 1, 2, 0, doc: /* Return result of expanding macros at top level of FORM. If FORM is not a macro call, it is returned unchanged. @@ -2566,6 +2608,19 @@ eval_sub (Lisp_Object form) interpreted using lexical-binding or not. */ specbind (Qlexical_binding, NILP (Vinternal_interpreter_environment) ? Qnil : Qt); + + /* Make the macro aware of any defvar declarations in scope. */ + Lisp_Object dynvars = Vmacroexp__dynvars; + for (Lisp_Object p = Vinternal_interpreter_environment; + !NILP (p); p = XCDR(p)) + { + Lisp_Object e = XCAR (p); + if (SYMBOLP (e)) + dynvars = Fcons(e, dynvars); + } + if (!EQ (dynvars, Vmacroexp__dynvars)) + specbind (Qmacroexp__dynvars, dynvars); + exp = apply1 (Fcdr (fun), original_args); exp = unbind_to (count1, exp); val = eval_sub (exp); @@ -4510,6 +4565,7 @@ alist of active lexical bindings. */); defsubr (&Slet); defsubr (&SletX); defsubr (&Swhile); + defsubr (&Sfuncall_with_delayed_message); defsubr (&Smacroexpand); defsubr (&Scatch); defsubr (&Sthrow); @@ -4538,5 +4594,6 @@ alist of active lexical bindings. */); defsubr (&Sbacktrace_eval); defsubr (&Sbacktrace__locals); defsubr (&Sspecial_variable_p); + DEFSYM (Qfunctionp, "functionp"); defsubr (&Sfunctionp); } diff --git a/src/fileio.c b/src/fileio.c index b1f464cf988..f802e4e4184 100644 --- a/src/fileio.c +++ b/src/fileio.c @@ -195,7 +195,11 @@ get_file_errno_data (char const *string, Lisp_Object name, int errorno) if (errorno == EEXIST) return Fcons (Qfile_already_exists, errdata); else - return Fcons (errorno == ENOENT ? Qfile_missing : Qfile_error, + return Fcons (errorno == ENOENT + ? Qfile_missing + : (errorno == EACCES + ? Qpermission_denied + : Qfile_error), Fcons (build_string (string), errdata)); } @@ -3833,7 +3837,7 @@ restore_window_points (Lisp_Object window_markers, ptrdiff_t inserted, Lisp_Object oldpos = XCDR (car); 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; @@ -6194,7 +6198,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 @@ -6380,6 +6384,7 @@ syms_of_fileio (void) DEFSYM (Qfile_already_exists, "file-already-exists"); DEFSYM (Qfile_date_error, "file-date-error"); DEFSYM (Qfile_missing, "file-missing"); + DEFSYM (Qpermission_denied, "permission-denied"); DEFSYM (Qfile_notify_error, "file-notify-error"); DEFSYM (Qremote_file_error, "remote-file-error"); DEFSYM (Qexcl, "excl"); @@ -6438,6 +6443,11 @@ behaves as if file names were encoded in `utf-8'. */); Fput (Qfile_missing, Qerror_message, build_pure_c_string ("File is missing")); + Fput (Qpermission_denied, Qerror_conditions, + Fpurecopy (list3 (Qpermission_denied, Qfile_error, Qerror))); + Fput (Qpermission_denied, Qerror_message, + build_pure_c_string ("Cannot access file or directory")); + Fput (Qfile_notify_error, Qerror_conditions, Fpurecopy (list3 (Qfile_notify_error, Qfile_error, Qerror))); Fput (Qfile_notify_error, Qerror_message, 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 <https://www.gnu.org/licenses/>. */ #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/fns.c b/src/fns.c index 6f358dd1ba4..23721334f76 100644 --- a/src/fns.c +++ b/src/fns.c @@ -2855,12 +2855,16 @@ mapcar1 (EMACS_INT leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq) return leni; } -DEFUN ("mapconcat", Fmapconcat, Smapconcat, 3, 3, 0, +DEFUN ("mapconcat", Fmapconcat, Smapconcat, 2, 3, 0, doc: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings. In between each pair of results, stick in SEPARATOR. Thus, " " as SEPARATOR results in spaces between the values returned by FUNCTION. + SEQUENCE may be a list, a vector, a bool-vector, or a string. -SEPARATOR must be a string, a vector, or a list of characters. + +Optional argument SEPARATOR must be a string, a vector, or a list of +characters; nil stands for the empty string. + FUNCTION must be a function of one argument, and must return a value that is a sequence of characters: either a string, or a vector or list of numbers that are valid character codepoints. */) @@ -3649,7 +3653,7 @@ base64_encode_1 (const char *from, char *to, ptrdiff_t length, c = string_char_and_length ((unsigned char *) from + i, &bytes); if (CHAR_BYTE8_P (c)) c = CHAR_TO_BYTE8 (c); - else if (c >= 256) + else if (c >= 128) return -1; i += bytes; } @@ -3692,7 +3696,7 @@ base64_encode_1 (const char *from, char *to, ptrdiff_t length, c = string_char_and_length ((unsigned char *) from + i, &bytes); if (CHAR_BYTE8_P (c)) c = CHAR_TO_BYTE8 (c); - else if (c >= 256) + else if (c >= 128) return -1; i += bytes; } @@ -3717,7 +3721,7 @@ base64_encode_1 (const char *from, char *to, ptrdiff_t length, c = string_char_and_length ((unsigned char *) from + i, &bytes); if (CHAR_BYTE8_P (c)) c = CHAR_TO_BYTE8 (c); - else if (c >= 256) + else if (c >= 128) return -1; i += bytes; } diff --git a/src/font.c b/src/font.c index 6ff28397d95..f2fd64e76ee 100644 --- a/src/font.c +++ b/src/font.c @@ -57,24 +57,28 @@ struct table_entry int numeric; /* The first one is a valid name as a face attribute. The second one (if any) is a typical name in XLFD field. */ - const char *names[5]; + 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. */ + sorted by numeric values in ascending order and the numeric values + must approximately match the weights in the font files. */ static const struct table_entry weight_table[] = { { 0, { "thin" }}, - { 20, { "ultra-light", "ultralight" }}, - { 40, { "extra-light", "extralight" }}, + { 40, { "ultra-light", "ultralight", "extra-light", "extralight" }}, { 50, { "light" }}, - { 75, { "semi-light", "semilight", "demilight", "book" }}, - { 100, { "normal", "medium", "regular", "unspecified" }}, - { 180, { "semi-bold", "semibold", "demibold", "demi" }}, + { 55, { "semi-light", "semilight", "demilight" }}, + { 80, { "regular", "normal", "unspecified", "book" }}, + { 100, { "medium" }}, + { 180, { "semi-bold", "semibold", "demibold", "demi-bold", "demi" }}, { 200, { "bold" }}, - { 205, { "extra-bold", "extrabold" }}, - { 210, { "ultra-bold", "ultrabold", "black" }} + { 205, { "extra-bold", "extrabold", "ultra-bold", "ultrabold" }}, + { 210, { "black", "heavy" }}, + { 250, { "ultra-heavy", "ultraheavy" }} }; /* Table of slant numeric values and their names. This table must be @@ -1484,11 +1488,20 @@ font_parse_fcname (char *name, ptrdiff_t len, Lisp_Object font) #define PROP_MATCH(STR) (word_len == strlen (STR) \ && memcmp (p, STR, strlen (STR)) == 0) - if (PROP_MATCH ("light") + if (PROP_MATCH ("thin") + || PROP_MATCH ("ultra-light") + || PROP_MATCH ("light") + || PROP_MATCH ("semi-light") + || PROP_MATCH ("book") || PROP_MATCH ("medium") + || PROP_MATCH ("normal") + || PROP_MATCH ("semibold") || PROP_MATCH ("demibold") || PROP_MATCH ("bold") - || PROP_MATCH ("black")) + || PROP_MATCH ("ultra-bold") + || PROP_MATCH ("black") + || PROP_MATCH ("heavy") + || PROP_MATCH ("ultra-heavy")) FONT_SET_STYLE (font, FONT_WEIGHT_INDEX, val); else if (PROP_MATCH ("roman") || PROP_MATCH ("italic") @@ -2170,9 +2183,7 @@ font_score (Lisp_Object entity, Lisp_Object *spec_prop) /* Score three style numeric fields. Maximum difference is 127. */ for (i = FONT_WEIGHT_INDEX; i <= FONT_WIDTH_INDEX; i++) - if (! NILP (spec_prop[i]) - && ! EQ (AREF (entity, i), spec_prop[i]) - && FIXNUMP (AREF (entity, i))) + if (! NILP (spec_prop[i]) && ! EQ (AREF (entity, i), spec_prop[i])) { EMACS_INT diff = ((XFIXNUM (AREF (entity, i)) >> 8) - (XFIXNUM (spec_prop[i]) >> 8)); @@ -2750,11 +2761,34 @@ 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)) - && ! (FIXNUMP (AREF (entity, 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 + /* 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. + + Similar things happen on Posix platforms, when + people use font families that don't have the + regular weight, only the medium weight: these + families get rejected if we require an exact match. */ + && (prop != FONT_WEIGHT_INDEX + || eabs (candidate - required) > 100) + ) + prop = FONT_SPEC_MAX; + } + } if (prop < FONT_SPEC_MAX && size && XFIXNUM (AREF (entity, FONT_SIZE_INDEX)) > 0) @@ -4988,6 +5022,33 @@ If the font is not OpenType font, CAPABILITY is nil. */) : Qnil)); } +DEFUN ("font-has-char-p", Ffont_has_char_p, Sfont_has_char_p, 2, 3, 0, + doc: + /* Return non-nil if FONT on FRAME has a glyph for character CH. +FONT can be either a font-entity or a font-object. If it is +a font-entity and the result is nil, it means the font needs to be +opened (with `open-font') to check. +FRAME defaults to the selected frame if it is nil or omitted. */) + (Lisp_Object font, Lisp_Object ch, Lisp_Object frame) +{ + struct frame *f; + CHECK_FONT (font); + CHECK_CHARACTER (ch); + + if (NILP (frame)) + f = XFRAME (selected_frame); + else + { + CHECK_FRAME (frame); + f = XFRAME (frame); + } + + if (font_has_char (f, font, XFIXNAT (ch)) <= 0) + return Qnil; + else + return Qt; +} + DEFUN ("font-get-glyphs", Ffont_get_glyphs, Sfont_get_glyphs, 3, 4, 0, doc: /* Return a vector of FONT-OBJECT's glyphs for the specified characters. @@ -5006,8 +5067,13 @@ where CODE is the glyph-code of C in FONT-OBJECT. WIDTH thru DESCENT are the metrics (in pixels) of the glyph. ADJUSTMENT is always nil. -If FONT-OBJECT doesn't have a glyph for a character, -the corresponding element is nil. */) + +If FONT-OBJECT doesn't have a glyph for a character, the corresponding +element is nil. + +Also see `font-has-char-p', which is more efficient than this function +if you just want to check whether FONT-OBJECT has a glyph for a +character. */) (Lisp_Object font_object, Lisp_Object from, Lisp_Object to, Lisp_Object object) { @@ -5559,6 +5625,7 @@ syms_of_font (void) defsubr (&Sclose_font); defsubr (&Squery_font); defsubr (&Sfont_get_glyphs); + defsubr (&Sfont_has_char_p); defsubr (&Sfont_match_p); defsubr (&Sfont_at); #if 0 @@ -5677,7 +5744,11 @@ match. */); syms_of_xftfont (); #endif /* HAVE_XFT */ #endif /* not USE_CAIRO */ -#endif /* HAVE_X_WINDOWS */ +#else /* not HAVE_X_WINDOWS */ +#ifdef USE_CAIRO + syms_of_ftcrfont (); +#endif +#endif /* not HAVE_X_WINDOWS */ #else /* not HAVE_FREETYPE */ #ifdef HAVE_X_WINDOWS syms_of_xfont (); @@ -5689,6 +5760,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 6694164e09b..2da5ec45047 100644 --- a/src/font.h +++ b/src/font.h @@ -965,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; @@ -999,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 2b1cb452efd..2b06bc821d0 100644 --- a/src/frame.c +++ b/src/frame.c @@ -225,7 +225,9 @@ Value is: `x' for an Emacs frame that is really an X window, `w32' for an Emacs frame that is a window on MS-Windows display, `ns' for an Emacs frame on a GNUstep or Macintosh Cocoa display, - `pc' for a direct-write MS-DOS frame. + `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) { @@ -244,6 +246,10 @@ See also `frame-live-p'. */) return Qpc; case output_ns: return Qns; + case output_pgtk: + return Qpgtk; + case output_haiku: + return Qhaiku; default: emacs_abort (); } @@ -2212,7 +2218,8 @@ delete_frame (Lisp_Object frame, Lisp_Object force) /* Since a similar behavior was observed on the Lucid and Motif builds (see Bug#5802, Bug#21509, Bug#23499, Bug#27816), we now don't delete the terminal for these builds either. */ - if (terminal->reference_count == 0 && terminal->type == output_x_window) + if (terminal->reference_count == 0 && + (terminal->type == output_x_window || terminal->type == output_pgtk)) terminal->reference_count = 1; #endif /* USE_X_TOOLKIT || USE_GTK */ if (terminal->reference_count == 0) @@ -5028,8 +5035,6 @@ gui_set_no_special_glyphs (struct frame *f, Lisp_Object new_value, Lisp_Object o } -#ifndef HAVE_NS - /* Non-zero if mouse is grabbed on DPYINFO and we know the frame where it is. */ @@ -5054,8 +5059,6 @@ gui_redo_mouse_highlight (Display_Info *dpyinfo) dpyinfo->last_mouse_motion_y); } -#endif /* HAVE_NS */ - /* Subroutines of creating an X frame. */ /* Make sure that Vx_resource_name is set to a reasonable value. @@ -5897,7 +5900,7 @@ This function is for internal use only. */) #ifdef HAVE_WINDOW_SYSTEM -# if (defined USE_GTK || defined HAVE_NS || defined HAVE_XINERAMA \ +# if (defined USE_GTK || defined HAVE_PGTK || defined HAVE_NS || defined HAVE_XINERAMA \ || defined HAVE_XRANDR) void free_monitors (struct MonitorInfo *monitors, int n_monitors) @@ -5935,6 +5938,10 @@ make_monitor_attribute_list (struct MonitorInfo *monitors, attributes); attributes = Fcons (Fcons (Qframes, AREF (monitor_frames, i)), attributes); +#ifdef HAVE_PGTK + attributes = Fcons (Fcons (Qscale_factor, make_float (mi->scale_factor)), + attributes); +#endif attributes = Fcons (Fcons (Qmm_size, list2i (mi->mm_width, mi->mm_height)), attributes); @@ -6024,6 +6031,8 @@ syms_of_frame (void) DEFSYM (Qw32, "w32"); 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"); @@ -6046,6 +6055,9 @@ syms_of_frame (void) DEFSYM (Qworkarea, "workarea"); DEFSYM (Qmm_size, "mm-size"); +#ifdef HAVE_PGTK + DEFSYM (Qscale_factor, "scale-factor"); +#endif DEFSYM (Qframes, "frames"); DEFSYM (Qsource, "source"); diff --git a/src/frame.h b/src/frame.h index 3dd76805dd2..4060ee65c42 100644 --- a/src/frame.h +++ b/src/frame.h @@ -585,6 +585,8 @@ struct frame struct x_output *x; /* From xterm.h. */ 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; @@ -852,6 +854,16 @@ default_pixels_per_inch_y (void) #else #define FRAME_NS_P(f) ((f)->output_method == output_ns) #endif +#ifndef HAVE_PGTK +#define FRAME_PGTK_P(f) false +#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. */ @@ -864,6 +876,12 @@ default_pixels_per_inch_y (void) #ifdef HAVE_NS #define FRAME_WINDOW_P(f) FRAME_NS_P(f) #endif +#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 @@ -916,6 +934,8 @@ default_pixels_per_inch_y (void) /* Scale factor of frame F. */ #if defined HAVE_NS # define FRAME_SCALE_FACTOR(f) (FRAME_NS_P (f) ? ns_frame_scale_factor (f) : 1) +#elif defined HAVE_PGTK +# define FRAME_SCALE_FACTOR(f) (FRAME_PGTK_P (f) ? pgtk_frame_scale_factor (f) : 1) #else # define FRAME_SCALE_FACTOR(f) 1 #endif @@ -1673,7 +1693,7 @@ extern const char *x_get_resource_string (const char *, const char *); extern void x_sync (struct frame *); #endif /* HAVE_X_WINDOWS */ -#ifndef HAVE_NS +#if !defined (HAVE_NS) && !defined (HAVE_PGTK) /* Set F's bitmap icon, if specified among F's parameters. */ @@ -1709,6 +1729,9 @@ struct MonitorInfo { Emacs_Rectangle geom, work; int mm_width, mm_height; char *name; +#ifdef HAVE_PGTK + double scale_factor; +#endif }; extern void free_monitors (struct MonitorInfo *monitors, int n_monitors); diff --git a/src/fringe.c b/src/fringe.c index b651a4eb0d9..441146d135d 100644 --- a/src/fringe.c +++ b/src/fringe.c @@ -30,6 +30,8 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "termhooks.h" #include "pdumper.h" +#include "pgtkterm.h" + /* Fringe bitmaps are represented in three different ways: Logical bitmaps are used internally to denote things like @@ -1408,7 +1410,7 @@ If BITMAP overrides a standard fringe bitmap, the original bitmap is restored. On W32 and MAC (little endian), there's no need to do this. */ -#if defined (HAVE_X_WINDOWS) +#if defined (HAVE_X_WINDOWS) || defined (HAVE_PGTK) static const unsigned char swap_nibble[16] = { 0x0, 0x8, 0x4, 0xc, /* 0000 1000 0100 1100 */ 0x2, 0xa, 0x6, 0xe, /* 0010 1010 0110 1110 */ @@ -1471,6 +1473,25 @@ init_fringe_bitmap (int which, struct fringe_bitmap *fb, int once_p) #endif /* not USE_CAIRO */ #endif /* HAVE_X_WINDOWS */ +#if !defined(HAVE_X_WINDOWS) && defined (HAVE_PGTK) + unsigned short *bits = fb->bits; + int j; + + for (j = 0; j < fb->height; j++) + { + unsigned short b = *bits; +#ifdef WORDS_BIGENDIAN + *bits++ = (b << (16 - fb->width)); +#else + b = (unsigned short)((swap_nibble[b & 0xf] << 12) + | (swap_nibble[(b>>4) & 0xf] << 8) + | (swap_nibble[(b>>8) & 0xf] << 4) + | (swap_nibble[(b>>12) & 0xf])); + *bits++ = (b >> (16 - fb->width)); +#endif + } +#endif /* !HAVE_X_WINDOWS && HAVE_PGTK */ + #ifdef HAVE_NTGUI unsigned short *bits = fb->bits; int j; diff --git a/src/ftcrfont.c b/src/ftcrfont.c index db417b3e77d..49b179b0efc 100644 --- a/src/ftcrfont.c +++ b/src/ftcrfont.c @@ -22,7 +22,15 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <cairo-ft.h> #include "lisp.h" +#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 #include "blockinput.h" #include "charset.h" #include "composite.h" @@ -30,6 +38,12 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #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 @@ -513,11 +527,52 @@ ftcrfont_draw (struct glyph_string *s, block_input (); +#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 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); @@ -533,13 +588,33 @@ ftcrfont_draw (struct glyph_string *s, glyphs[i].index, NULL)); } - +#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 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 12d0d72d276..cf592759ab6 100644 --- a/src/ftfont.c +++ b/src/ftfont.c @@ -225,8 +225,6 @@ ftfont_pattern_entity (FcPattern *p, Lisp_Object extra) } if (FcPatternGetInteger (p, FC_WEIGHT, 0, &numeric) == FcResultMatch) { - if (numeric >= FC_WEIGHT_REGULAR && numeric < FC_WEIGHT_MEDIUM) - numeric = FC_WEIGHT_MEDIUM; FONT_SET_STYLE (entity, FONT_WEIGHT_INDEX, make_fixnum (numeric)); } if (FcPatternGetInteger (p, FC_SLANT, 0, &numeric) == FcResultMatch) @@ -3110,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 f771dc159b0..cfab8d3154f 100644 --- a/src/ftfont.h +++ b/src/ftfont.h @@ -25,10 +25,15 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <ft2build.h> #include FT_FREETYPE_H #include FT_SIZES_H +#include FT_TRUETYPE_TABLES_H #ifdef FT_BDF_H # include FT_BDF_H #endif +#ifdef USE_BE_CAIRO +#include <cairo.h> +#endif + #ifdef HAVE_HARFBUZZ #include <hb.h> #include <hb-ft.h> @@ -62,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 e87845caf70..0f1c1103649 100644 --- a/src/gtkutil.c +++ b/src/gtkutil.c @@ -17,13 +17,6 @@ GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ -/* FIXME: This code is problematic; it misuses GTK, so the GTK - developers don't think they should fix the resulting problems in GTK - itself. The right way to fix this is by rewriting the code in Emacs - to use GTK3 properly. As of 2020, there is a project to do this. - Talk with Yuuki Harano <masm+emacs@masm11.me> if you are interested - in doing substantial work on this. */ - #include <config.h> #ifdef USE_GTK @@ -37,7 +30,14 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "dispextern.h" #include "frame.h" #include "systime.h" +#ifndef HAVE_PGTK #include "xterm.h" +#define xp x +typedef struct x_output xp_output; +#else +#define xp pgtk +typedef struct pgtk_output xp_output; +#endif #include "blockinput.h" #include "window.h" #include "gtkutil.h" @@ -47,12 +47,18 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <gdk/gdkkeysyms.h> +#ifdef HAVE_XINPUT2 +#include <X11/extensions/XInput2.h> +#endif + #ifdef HAVE_XFT #include <X11/Xft/Xft.h> #endif #ifdef HAVE_GTK3 +#ifndef HAVE_PGTK #include <gtk/gtkx.h> +#endif #include "emacsgtkfixed.h" #endif @@ -127,6 +133,7 @@ static GdkDisplay *gdpy_def; static void xg_set_screen (GtkWidget *w, struct frame *f) { +#ifndef HAVE_PGTK if (FRAME_X_DISPLAY (f) != DEFAULT_GDK_DISPLAY ()) { GdkDisplay *gdpy = gdk_x11_lookup_xdisplay (FRAME_X_DISPLAY (f)); @@ -137,6 +144,17 @@ xg_set_screen (GtkWidget *w, struct frame *f) else gtk_window_set_screen (GTK_WINDOW (w), gscreen); } +#else + if (FRAME_X_DISPLAY (f) != DEFAULT_GDK_DISPLAY ()) + { + GdkScreen *gscreen = gdk_display_get_default_screen (FRAME_X_DISPLAY (f)); + + if (GTK_IS_MENU (w)) + gtk_menu_set_screen (GTK_MENU (w), gscreen); + else + gtk_window_set_screen (GTK_WINDOW (w), gscreen); + } +#endif } @@ -148,12 +166,20 @@ xg_set_screen (GtkWidget *w, struct frame *f) multiple displays. */ void +#ifndef HAVE_PGTK xg_display_open (char *display_name, Display **dpy) +#else +xg_display_open (char *display_name, GdkDisplay **dpy) +#endif { GdkDisplay *gdpy; unrequest_sigio (); /* See comment in x_display_ok, xterm.c. */ +#ifndef HAVE_PGTK gdpy = gdk_display_open (display_name); +#else + gdpy = gdk_display_open (strlen (display_name) == 0 ? NULL : display_name); +#endif request_sigio (); if (!gdpy_def && gdpy) { @@ -162,7 +188,11 @@ xg_display_open (char *display_name, Display **dpy) gdpy); } +#ifndef HAVE_PGTK *dpy = gdpy ? GDK_DISPLAY_XDISPLAY (gdpy) : NULL; +#else + *dpy = gdpy; +#endif } /* Scaling/HiDPI functions. */ @@ -184,6 +214,9 @@ xg_get_gdk_scale (void) int xg_get_scale (struct frame *f) { +#ifdef HAVE_PGTK + return 1; +#endif #ifdef HAVE_GTK3 if (FRAME_GTK_WIDGET (f)) return gtk_widget_get_scale_factor (FRAME_GTK_WIDGET (f)); @@ -194,8 +227,13 @@ xg_get_scale (struct frame *f) /* Close display DPY. */ void +#ifndef HAVE_PGTK xg_display_close (Display *dpy) +#else +xg_display_close (GdkDisplay *gdpy) +#endif { +#ifndef HAVE_PGTK GdkDisplay *gdpy = gdk_x11_lookup_xdisplay (dpy); /* If this is the default display, try to change it before closing. @@ -219,6 +257,31 @@ xg_display_close (Display *dpy) } gdk_display_close (gdpy); + +#else + + /* If this is the default display, try to change it before closing. + If there is no other display to use, gdpy_def is set to NULL, and + the next call to xg_display_open resets the default display. */ + if (gdk_display_get_default () == gdpy) + { + struct pgtk_display_info *dpyinfo; + GdkDisplay *gdpy_new = NULL; + + /* Find another display. */ + for (dpyinfo = x_display_list; dpyinfo; dpyinfo = dpyinfo->next) + if (dpyinfo->gdpy != gdpy) + { + gdpy_new = dpyinfo->gdpy; + gdk_display_manager_set_default_display (gdk_display_manager_get (), + gdpy_new); + break; + } + gdpy_def = gdpy_new; + } + + gdk_display_close (gdpy); +#endif } @@ -230,12 +293,19 @@ xg_display_close (Display *dpy) scroll bars on display DPY. */ GdkCursor * +#ifndef HAVE_PGTK xg_create_default_cursor (Display *dpy) +#else +xg_create_default_cursor (GdkDisplay *gdpy) +#endif { +#ifndef HAVE_PGTK GdkDisplay *gdpy = gdk_x11_lookup_xdisplay (dpy); +#endif return gdk_cursor_new_for_display (gdpy, GDK_LEFT_PTR); } +#ifndef HAVE_PGTK /* Apply GMASK to GPIX and return a GdkPixbuf with an alpha channel. */ static GdkPixbuf * @@ -335,6 +405,8 @@ xg_get_pixbuf_from_surface (cairo_surface_t *surface) } #endif /* USE_CAIRO && !HAVE_GTK3 */ +#endif /* !HAVE_PGTK */ + static Lisp_Object file_for_image (Lisp_Object image) { @@ -605,8 +677,13 @@ xg_check_special_colors (struct frame *f, block_input (); { #ifdef HAVE_GTK3 +#ifndef HAVE_PGTK GtkStyleContext *gsty = gtk_widget_get_style_context (FRAME_GTK_OUTER_WIDGET (f)); +#else + GtkStyleContext *gsty + = gtk_widget_get_style_context (FRAME_WIDGET (f)); +#endif GdkRGBA col; char buf[sizeof "rgb://rrrr/gggg/bbbb"]; int state = GTK_STATE_FLAG_SELECTED|GTK_STATE_FLAG_FOCUSED; @@ -630,9 +707,14 @@ xg_check_special_colors (struct frame *f, r = col.red * 65535, g = col.green * 65535, b = col.blue * 65535; +#ifndef HAVE_PGTK sprintf (buf, "rgb:%04x/%04x/%04x", r, g, b); success_p = x_parse_color (f, buf, color) != 0; #else + sprintf (buf, "#%04x%04x%04x", r, g, b); + success_p = pgtk_parse_color (f, buf, color) != 0; +#endif +#else GtkStyle *gsty = gtk_widget_get_style (FRAME_GTK_WIDGET (f)); GdkColor *grgb = get_bg ? &gsty->bg[GTK_STATE_SELECTED] @@ -655,6 +737,9 @@ xg_check_special_colors (struct frame *f, /*********************************************************************** Tooltips ***********************************************************************/ + +#ifndef HAVE_PGTK + /* Gtk+ calls this callback when the parent of our tooltip dummy changes. We use that to pop down the tooltip. This happens if Gtk+ for some reason wants to change or hide the tooltip. */ @@ -665,7 +750,7 @@ hierarchy_ch_cb (GtkWidget *widget, gpointer user_data) { struct frame *f = user_data; - struct x_output *x = f->output_data.x; + xp_output *x = f->output_data.xp; GtkWidget *top = gtk_widget_get_toplevel (x->ttip_lbl); if (! top || ! GTK_IS_WINDOW (top)) @@ -687,7 +772,7 @@ qttip_cb (GtkWidget *widget, gpointer user_data) { struct frame *f = user_data; - struct x_output *x = f->output_data.x; + xp_output *x = f->output_data.xp; if (x->ttip_widget == NULL) { GtkWidget *p; @@ -734,7 +819,7 @@ xg_prepare_tooltip (struct frame *f, int *width, int *height) { - struct x_output *x = f->output_data.x; + xp_output *x = f->output_data.xp; GtkWidget *widget; GdkWindow *gwin; GdkScreen *screen; @@ -785,13 +870,19 @@ xg_prepare_tooltip (struct frame *f, void xg_show_tooltip (struct frame *f, int root_x, int root_y) { - struct x_output *x = f->output_data.x; + xp_output *x = f->output_data.xp; if (x->ttip_window) { block_input (); +#ifndef HAVE_PGTK gtk_window_move (x->ttip_window, root_x / xg_get_scale (f), root_y / xg_get_scale (f)); gtk_widget_show (GTK_WIDGET (x->ttip_window)); +#else + gtk_widget_show (GTK_WIDGET (x->ttip_window)); + gtk_window_move (x->ttip_window, root_x / xg_get_scale (f), + root_y / xg_get_scale (f)); +#endif unblock_input (); } } @@ -803,10 +894,9 @@ xg_show_tooltip (struct frame *f, int root_x, int root_y) bool xg_hide_tooltip (struct frame *f) { - if (f->output_data.x->ttip_window) + if (f->output_data.xp->ttip_window) { - GtkWindow *win = f->output_data.x->ttip_window; - + GtkWindow *win = f->output_data.xp->ttip_window; block_input (); gtk_widget_hide (GTK_WIDGET (win)); @@ -824,6 +914,30 @@ xg_hide_tooltip (struct frame *f) return FALSE; } +#else /* HAVE_PGTK */ + +void +xg_show_tooltip (struct frame *f, + Lisp_Object string) +{ + Lisp_Object encoded_string = ENCODE_UTF_8 (string); + gtk_widget_set_tooltip_text (FRAME_GTK_OUTER_WIDGET (f) + ? FRAME_GTK_OUTER_WIDGET (f) + : FRAME_GTK_WIDGET (f), + SSDATA (encoded_string)); +} + +bool +xg_hide_tooltip (struct frame *f) +{ + if (FRAME_GTK_OUTER_WIDGET (f)) + gtk_widget_set_tooltip_text (FRAME_GTK_OUTER_WIDGET (f), NULL); + gtk_widget_set_tooltip_text (FRAME_GTK_WIDGET (f), NULL); + return TRUE; +} + +#endif /* HAVE_PGTK */ + /*********************************************************************** General functions for creating widgets, resizing, events, e.t.c. @@ -839,6 +953,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. @@ -954,8 +1089,23 @@ xg_frame_set_char_size (struct frame *f, int width, int height) bool was_visible = false; bool hide_child_frame; +#ifndef HAVE_PGTK gtk_window_get_size (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), &gwidth, &gheight); +#else + if (FRAME_GTK_OUTER_WIDGET (f)) + { + gtk_window_get_size (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), + &gwidth, &gheight); + } + else + { + GtkAllocation alloc; + gtk_widget_get_allocation (FRAME_GTK_WIDGET (f), &alloc); + gwidth = alloc.width; + gheight = alloc.height; + } +#endif /* Do this before resize, as we don't know yet if we will be resized. */ FRAME_RIF (f)->clear_under_internal_border (f); @@ -975,11 +1125,37 @@ xg_frame_set_char_size (struct frame *f, int width, int height) remain unchanged but giving the frame back its normal size will be broken ... */ if (EQ (fullscreen, Qfullwidth) && width == FRAME_PIXEL_WIDTH (f)) +#ifndef HAVE_PGTK gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), gwidth, outer_height); +#else + if (FRAME_GTK_OUTER_WIDGET (f)) + { + gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), + gwidth, outer_height); + } + else + { + gtk_widget_set_size_request (FRAME_GTK_WIDGET (f), + gwidth, outer_height); + } +#endif else if (EQ (fullscreen, Qfullheight) && height == FRAME_PIXEL_HEIGHT (f)) +#ifndef HAVE_PGTK gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), outer_width, gheight); +#else + if (FRAME_GTK_OUTER_WIDGET (f)) + { + gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), + outer_width, gheight); + } + else + { + gtk_widget_set_size_request (FRAME_GTK_WIDGET (f), + outer_width, gheight); + } +#endif else if (FRAME_PARENT_FRAME (f) && FRAME_VISIBLE_P (f)) { was_visible = true; @@ -990,17 +1166,38 @@ xg_frame_set_char_size (struct frame *f, int width, int height) if (hide_child_frame) { block_input (); +#ifndef HAVE_PGTK gtk_widget_hide (FRAME_GTK_OUTER_WIDGET (f)); +#else + gtk_widget_hide (FRAME_WIDGET (f)); +#endif unblock_input (); } +#ifndef HAVE_PGTK gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), outer_width, outer_height); +#else + if (FRAME_GTK_OUTER_WIDGET (f)) + { + gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), + outer_width, outer_height); + } + else + { + gtk_widget_set_size_request (FRAME_GTK_WIDGET (f), + outer_width, outer_height); + } +#endif if (hide_child_frame) { block_input (); +#ifndef HAVE_PGTK gtk_widget_show_all (FRAME_GTK_OUTER_WIDGET (f)); +#else + gtk_widget_show_all (FRAME_WIDGET (f)); +#endif unblock_input (); } @@ -1009,8 +1206,21 @@ xg_frame_set_char_size (struct frame *f, int width, int height) } else { +#ifndef HAVE_PGTK gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), outer_width, outer_height); +#else + if (FRAME_GTK_OUTER_WIDGET (f)) + { + gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), + outer_width, outer_height); + } + else + { + gtk_widget_set_size_request (FRAME_GTK_WIDGET (f), + outer_width, outer_height); + } +#endif fullscreen = Qnil; } @@ -1035,7 +1245,9 @@ xg_frame_set_char_size (struct frame *f, int width, int height) /* Must call this to flush out events */ (void)gtk_events_pending (); gdk_flush (); +#ifndef HAVE_PGTK x_wait_for_event (f, ConfigureNotify); +#endif if (!NILP (fullscreen)) /* Try to restore fullscreen state. */ @@ -1068,11 +1280,12 @@ xg_height_or_width_changed (struct frame *f) gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), FRAME_TOTAL_PIXEL_WIDTH (f), FRAME_TOTAL_PIXEL_HEIGHT (f)); - f->output_data.x->hint_flags = 0; + f->output_data.xp->hint_flags = 0; x_wm_set_size_hint (f, 0, 0); } #endif +#ifndef HAVE_PGTK /* Convert an X Window WSESC on display DPY to its corresponding GtkWidget. Must be done like this, because GtkWidget:s can have "hidden" X Window that aren't accessible. @@ -1100,6 +1313,7 @@ xg_win_to_widget (Display *dpy, Window wdesc) unblock_input (); return gwdesc; } +#endif /* Set the background of widget W to PIXEL. */ @@ -1107,9 +1321,18 @@ static void xg_set_widget_bg (struct frame *f, GtkWidget *w, unsigned long pixel) { #ifdef HAVE_GTK3 - XColor xbg; + Emacs_Color xbg; xbg.pixel = pixel; +#ifndef HAVE_PGTK if (XQueryColor (FRAME_X_DISPLAY (f), FRAME_X_COLORMAP (f), &xbg)) +#else + xbg.red = (pixel >> 16) & 0xff; + xbg.green = (pixel >> 8) & 0xff; + xbg.blue = (pixel >> 0) & 0xff; + xbg.red |= xbg.red << 8; + xbg.green |= xbg.green << 8; + xbg.blue |= xbg.blue << 8; +#endif { const char format[] = "* { background-color: #%02x%02x%02x; }"; /* The format is always longer than the resulting string. */ @@ -1144,7 +1367,16 @@ style_changed_cb (GObject *go, struct input_event event; GdkDisplay *gdpy = user_data; const char *display_name = gdk_display_get_name (gdpy); +#ifndef HAVE_PGTK Display *dpy = GDK_DISPLAY_XDISPLAY (gdpy); +#else + GdkDisplay *dpy = gdpy; +#endif + +#ifndef HAVE_PGTK + if (display_name == NULL) + display_name = ""; +#endif EVENT_INIT (event); event.kind = CONFIG_CHANGED_EVENT; @@ -1165,7 +1397,11 @@ style_changed_cb (GObject *go, { struct frame *f = XFRAME (frame); if (FRAME_LIVE_P (f) +#ifndef HAVE_PGTK && FRAME_X_P (f) +#else + && FRAME_PGTK_P (f) +#endif && FRAME_X_DISPLAY (f) == dpy) { FRAME_TERMINAL (f)->set_scroll_bar_default_width_hook (f); @@ -1179,6 +1415,7 @@ style_changed_cb (GObject *go, /* Called when a delete-event occurs on WIDGET. */ +#ifndef HAVE_PGTK static gboolean delete_cb (GtkWidget *widget, GdkEvent *event, @@ -1186,6 +1423,7 @@ delete_cb (GtkWidget *widget, { return TRUE; } +#endif /* Create and set up the GTK widgets for frame F. Return true if creation succeeded. */ @@ -1199,17 +1437,27 @@ xg_create_frame_widgets (struct frame *f) #ifndef HAVE_GTK3 GtkRcStyle *style; #endif + GtkWindowType type = GTK_WINDOW_TOPLEVEL; char *title = 0; block_input (); +#ifndef HAVE_PGTK /* gtk_plug not found. */ if (FRAME_X_EMBEDDED_P (f)) { GdkDisplay *gdpy = gdk_x11_lookup_xdisplay (FRAME_X_DISPLAY (f)); - wtop = gtk_plug_new_for_display (gdpy, f->output_data.x->parent_desc); + wtop = gtk_plug_new_for_display (gdpy, f->output_data.xp->parent_desc); } else - wtop = gtk_window_new (GTK_WINDOW_TOPLEVEL); + wtop = gtk_window_new (type); +#else + if (f->tooltip) + { + type = GTK_WINDOW_POPUP; + } + wtop = gtk_window_new (type); + gtk_widget_add_events (wtop, GDK_ALL_EVENTS_MASK); +#endif /* gtk_window_set_has_resize_grip is a Gtk+ 3.0 function but Ubuntu has backported it to Gtk+ 2.0 and they add the resize grip for @@ -1266,8 +1514,8 @@ xg_create_frame_widgets (struct frame *f) FRAME_GTK_OUTER_WIDGET (f) = wtop; FRAME_GTK_WIDGET (f) = wfixed; - f->output_data.x->vbox_widget = wvbox; - f->output_data.x->hbox_widget = whbox; + f->output_data.xp->vbox_widget = wvbox; + f->output_data.xp->hbox_widget = whbox; gtk_widget_set_has_window (wfixed, TRUE); @@ -1286,7 +1534,10 @@ xg_create_frame_widgets (struct frame *f) FIXME: gtk_widget_set_double_buffered is deprecated and might stop working in the future. We need to migrate away from combining X and GTK+ drawing to a pure GTK+ build. */ + +#ifndef HAVE_PGTK gtk_widget_set_double_buffered (wfixed, FALSE); +#endif #if ! GTK_CHECK_VERSION (3, 22, 0) gtk_window_set_wmclass (GTK_WINDOW (wtop), @@ -1294,10 +1545,12 @@ xg_create_frame_widgets (struct frame *f) SSDATA (Vx_resource_class)); #endif +#ifndef HAVE_PGTK /* Add callback to do nothing on WM_DELETE_WINDOW. The default in GTK is to destroy the widget. We want Emacs to do that instead. */ g_signal_connect (G_OBJECT (wtop), "delete-event", G_CALLBACK (delete_cb), f); +#endif /* Convert our geometry parameters into a geometry string and specify it. @@ -1308,7 +1561,9 @@ xg_create_frame_widgets (struct frame *f) gtk_widget_add_events (wfixed, GDK_POINTER_MOTION_MASK +#ifndef HAVE_PGTK | GDK_EXPOSURE_MASK +#endif | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK | GDK_KEY_PRESS_MASK @@ -1316,13 +1571,19 @@ xg_create_frame_widgets (struct frame *f) | GDK_LEAVE_NOTIFY_MASK | GDK_FOCUS_CHANGE_MASK | GDK_STRUCTURE_MASK +#ifdef HAVE_PGTK + | GDK_SCROLL_MASK + | GDK_SMOOTH_SCROLL_MASK +#endif | GDK_VISIBILITY_NOTIFY_MASK); +#ifndef HAVE_PGTK /* Must realize the windows so the X window gets created. It is used by callers of this function. */ gtk_widget_realize (wfixed); FRAME_X_WINDOW (f) = GTK_WIDGET_TO_X_WIN (wfixed); initial_set_up_x_back_buffer (f); +#endif /* Since GTK clears its window by filling with the background color, we must keep X and GTK background in sync. */ @@ -1339,6 +1600,9 @@ xg_create_frame_widgets (struct frame *f) gtk_widget_modify_style (wfixed, style); #else gtk_widget_set_can_focus (wfixed, TRUE); +#ifdef HAVE_PGTK + gtk_widget_grab_focus (wfixed); +#endif gtk_window_set_resizable (GTK_WINDOW (wtop), TRUE); #endif @@ -1351,11 +1615,13 @@ xg_create_frame_widgets (struct frame *f) } /* Steal a tool tip window we can move ourselves. */ - f->output_data.x->ttip_widget = 0; - f->output_data.x->ttip_lbl = 0; - f->output_data.x->ttip_window = 0; + f->output_data.xp->ttip_widget = 0; + f->output_data.xp->ttip_lbl = 0; + f->output_data.xp->ttip_window = 0; +#ifndef HAVE_PGTK gtk_widget_set_tooltip_text (wtop, "Dummy text"); g_signal_connect (wtop, "query-tooltip", G_CALLBACK (qttip_cb), f); +#endif { GdkScreen *screen = gtk_widget_get_screen (wtop); @@ -1378,12 +1644,114 @@ xg_create_frame_widgets (struct frame *f) return 1; } +#ifdef HAVE_PGTK +void +xg_create_frame_outer_widgets (struct frame *f) +{ + GtkWidget *wtop; + GtkWidget *wvbox, *whbox; + GtkWindowType type = GTK_WINDOW_TOPLEVEL; + char *title = 0; + + block_input (); + + wtop = gtk_window_new (type); + gtk_widget_add_events (wtop, GDK_ALL_EVENTS_MASK); + + xg_set_screen (wtop, f); + + wvbox = gtk_box_new (GTK_ORIENTATION_VERTICAL, 0); + whbox = gtk_box_new (GTK_ORIENTATION_HORIZONTAL, 0); + gtk_box_set_homogeneous (GTK_BOX (wvbox), FALSE); + gtk_box_set_homogeneous (GTK_BOX (whbox), FALSE); + + /* Use same names as the Xt port does. I.e. Emacs.pane.emacs by default */ + gtk_widget_set_name (wtop, EMACS_CLASS); + gtk_widget_set_name (wvbox, "pane"); + + /* If this frame has a title or name, set it in the title bar. */ + if (! NILP (f->title)) + title = SSDATA (ENCODE_UTF_8 (f->title)); + else if (! NILP (f->name)) + title = SSDATA (ENCODE_UTF_8 (f->name)); + + if (title) + gtk_window_set_title (GTK_WINDOW (wtop), title); + + if (FRAME_UNDECORATED (f)) + { + gtk_window_set_decorated (GTK_WINDOW (wtop), FALSE); + store_frame_param (f, Qundecorated, Qt); + } + + FRAME_GTK_OUTER_WIDGET (f) = wtop; + f->output_data.xp->vbox_widget = wvbox; + f->output_data.xp->hbox_widget = whbox; + + gtk_container_add (GTK_CONTAINER (wtop), wvbox); + gtk_box_pack_start (GTK_BOX (wvbox), whbox, TRUE, TRUE, 0); + + if (FRAME_EXTERNAL_TOOL_BAR (f)) + update_frame_tool_bar (f); + +#if ! GTK_CHECK_VERSION (3, 22, 0) + gtk_window_set_wmclass (GTK_WINDOW (wtop), + SSDATA (Vx_resource_name), + SSDATA (Vx_resource_class)); +#endif + + /* Convert our geometry parameters into a geometry string + and specify it. + GTK will itself handle calculating the real position this way. */ + xg_set_geometry (f); + f->win_gravity + = gtk_window_get_gravity (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f))); + + gtk_window_set_resizable (GTK_WINDOW (wtop), TRUE); + + if (FRAME_OVERRIDE_REDIRECT (f)) + { + GdkWindow *gwin = gtk_widget_get_window (wtop); + + if (gwin) + gdk_window_set_override_redirect (gwin, TRUE); + } + + /* Steal a tool tip window we can move ourselves. */ + f->output_data.xp->ttip_widget = 0; + f->output_data.xp->ttip_lbl = 0; + f->output_data.xp->ttip_window = 0; +#ifndef HAVE_PGTK + gtk_widget_set_tooltip_text (wtop, "Dummy text"); + g_signal_connect (wtop, "query-tooltip", G_CALLBACK (qttip_cb), f); +#endif + + { + GdkScreen *screen = gtk_widget_get_screen (wtop); + GtkSettings *gs = gtk_settings_get_for_screen (screen); + /* Only connect this signal once per screen. */ + if (! g_signal_handler_find (G_OBJECT (gs), + G_SIGNAL_MATCH_FUNC, + 0, 0, 0, + (gpointer) G_CALLBACK (style_changed_cb), + 0)) + { + g_signal_connect (G_OBJECT (gs), "notify::gtk-theme-name", + G_CALLBACK (style_changed_cb), + gdk_screen_get_display (screen)); + } + } + + unblock_input (); +} +#endif + void xg_free_frame_widgets (struct frame *f) { if (FRAME_GTK_OUTER_WIDGET (f)) { - struct x_output *x = f->output_data.x; + xp_output *x = f->output_data.xp; struct xg_frame_tb_info *tbinfo = g_object_get_data (G_OBJECT (FRAME_GTK_OUTER_WIDGET (f)), TB_INFO_KEY); @@ -1391,10 +1759,14 @@ xg_free_frame_widgets (struct frame *f) xfree (tbinfo); /* x_free_frame_resources should have taken care of it */ +#ifndef HAVE_PGTK eassert (!FRAME_X_DOUBLE_BUFFERED_P (f)); +#endif gtk_widget_destroy (FRAME_GTK_OUTER_WIDGET (f)); FRAME_X_WINDOW (f) = 0; /* Set to avoid XDestroyWindow in xterm.c */ +#ifndef HAVE_PGTK FRAME_X_RAW_DRAWABLE (f) = 0; +#endif FRAME_GTK_OUTER_WIDGET (f) = 0; if (x->ttip_widget) { @@ -1436,9 +1808,12 @@ x_wm_set_size_hint (struct frame *f, long int flags, bool user_position) XSETFRAME (frame, f); fs_state = Fframe_parameter (frame, Qfullscreen); - if ((EQ (fs_state, Qmaximized) || EQ (fs_state, Qfullboth)) && - (x_wm_supports (f, FRAME_DISPLAY_INFO (f)->Xatom_net_wm_state) || - x_wm_supports (f, FRAME_DISPLAY_INFO (f)->Xatom_net_wm_state_fullscreen))) + if ((EQ (fs_state, Qmaximized) || EQ (fs_state, Qfullboth)) +#ifndef HAVE_PGTK + && (x_wm_supports (f, FRAME_DISPLAY_INFO (f)->Xatom_net_wm_state) || + x_wm_supports (f, FRAME_DISPLAY_INFO (f)->Xatom_net_wm_state_fullscreen)) +#endif + ) { /* Don't set hints when maximized or fullscreen. Apparently KWin and Gtk3 don't get along and the frame shrinks (!). @@ -1449,14 +1824,14 @@ x_wm_set_size_hint (struct frame *f, long int flags, bool user_position) if (flags) { memset (&size_hints, 0, sizeof (size_hints)); - f->output_data.x->size_hints = size_hints; - f->output_data.x->hint_flags = hint_flags; + f->output_data.xp->size_hints = size_hints; + f->output_data.xp->hint_flags = hint_flags; } else flags = f->size_hint_flags; - size_hints = f->output_data.x->size_hints; - hint_flags = f->output_data.x->hint_flags; + size_hints = f->output_data.xp->size_hints; + hint_flags = f->output_data.xp->hint_flags; hint_flags |= GDK_HINT_RESIZE_INC | GDK_HINT_MIN_SIZE; size_hints.width_inc = frame_resize_pixelwise ? 1 : FRAME_COLUMN_WIDTH (f); @@ -1518,16 +1893,16 @@ x_wm_set_size_hint (struct frame *f, long int flags, bool user_position) size_hints.width_inc /= scale; size_hints.height_inc /= scale; - if (hint_flags != f->output_data.x->hint_flags + if (hint_flags != f->output_data.xp->hint_flags || memcmp (&size_hints, - &f->output_data.x->size_hints, + &f->output_data.xp->size_hints, sizeof (size_hints)) != 0) { block_input (); gtk_window_set_geometry_hints (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), NULL, &size_hints, hint_flags); - f->output_data.x->size_hints = size_hints; - f->output_data.x->hint_flags = hint_flags; + f->output_data.xp->size_hints = size_hints; + f->output_data.xp->hint_flags = hint_flags; unblock_input (); } } @@ -1567,6 +1942,10 @@ xg_set_background_color (struct frame *f, unsigned long bg) void xg_set_undecorated (struct frame *f, Lisp_Object undecorated) { +#ifdef HAVE_PGTK + if (!FRAME_GTK_OUTER_WIDGET (f)) + return; +#endif if (FRAME_GTK_WIDGET (f)) { block_input (); @@ -1593,7 +1972,11 @@ xg_frame_restack (struct frame *f1, struct frame *f2, bool above_flag) XSETFRAME (frame2, f2); gdk_window_restack (gwin1, gwin2, above_flag); +#ifndef HAVE_PGTK x_sync (f1); +#else + gdk_flush (); +#endif } unblock_input (); } @@ -1604,10 +1987,17 @@ void xg_set_skip_taskbar (struct frame *f, Lisp_Object skip_taskbar) { block_input (); +#ifndef HAVE_PGTK if (FRAME_GTK_WIDGET (f)) gdk_window_set_skip_taskbar_hint (gtk_widget_get_window (FRAME_GTK_OUTER_WIDGET (f)), NILP (skip_taskbar) ? FALSE : TRUE); +#else + if (FRAME_GTK_OUTER_WIDGET (f)) + gdk_window_set_skip_taskbar_hint + (gtk_widget_get_window (FRAME_GTK_OUTER_WIDGET (f)), + NILP (skip_taskbar) ? FALSE : TRUE); +#endif unblock_input (); } @@ -1616,6 +2006,10 @@ xg_set_skip_taskbar (struct frame *f, Lisp_Object skip_taskbar) void xg_set_no_focus_on_map (struct frame *f, Lisp_Object no_focus_on_map) { +#ifdef HAVE_PGTK + if (!FRAME_GTK_OUTER_WIDGET (f)) + return; +#endif block_input (); if (FRAME_GTK_WIDGET (f)) { @@ -1631,12 +2025,19 @@ xg_set_no_focus_on_map (struct frame *f, Lisp_Object no_focus_on_map) void xg_set_no_accept_focus (struct frame *f, Lisp_Object no_accept_focus) { + gboolean g_no_accept_focus = NILP (no_accept_focus) ? TRUE : FALSE; +#ifdef HAVE_PGTK + if (!FRAME_GTK_OUTER_WIDGET (f)) + { + if (FRAME_WIDGET (f)) + gtk_widget_set_can_focus (FRAME_WIDGET (f), g_no_accept_focus); + return; + } +#endif block_input (); if (FRAME_GTK_WIDGET (f)) { GtkWindow *gwin = GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)); - gboolean g_no_accept_focus = NILP (no_accept_focus) ? TRUE : FALSE; - gtk_window_set_accept_focus (gwin, g_no_accept_focus); } unblock_input (); @@ -1657,18 +2058,24 @@ xg_set_override_redirect (struct frame *f, Lisp_Object override_redirect) unblock_input (); } +#ifndef HAVE_PGTK /* Set the frame icon to ICON_PIXMAP/MASK. This must be done with GTK functions so GTK does not overwrite the icon. */ void xg_set_frame_icon (struct frame *f, Pixmap icon_pixmap, Pixmap icon_mask) { +#ifdef HAVE_PGTK + if (!FRAME_GTK_OUTER_WIDGET (f)) + return; +#endif GdkPixbuf *gp = xg_get_pixbuf_from_pix_and_mask (f, icon_pixmap, icon_mask); if (gp) gtk_window_set_icon (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), gp); } +#endif @@ -2205,6 +2612,11 @@ xg_get_file_name (struct frame *f, int filesel_done = 0; xg_get_file_func func; +#ifdef HAVE_PGTK + if (!FRAME_GTK_OUTER_WIDGET (f)) + error ("Can't open dialog from child frames"); +#endif + #ifdef HAVE_GTK_FILE_SELECTION_NEW if (xg_uses_old_file_dialog ()) @@ -2237,20 +2649,34 @@ xg_get_file_name (struct frame *f, #ifdef HAVE_GTK3 -#define XG_WEIGHT_TO_SYMBOL(w) \ - (w <= PANGO_WEIGHT_THIN ? Qextra_light \ - : w <= PANGO_WEIGHT_ULTRALIGHT ? Qlight \ - : w <= PANGO_WEIGHT_LIGHT ? Qsemi_light \ - : w < PANGO_WEIGHT_MEDIUM ? Qnormal \ - : w <= PANGO_WEIGHT_SEMIBOLD ? Qsemi_bold \ - : w <= PANGO_WEIGHT_BOLD ? Qbold \ - : w <= PANGO_WEIGHT_HEAVY ? Qextra_bold \ - : Qultra_bold) - -#define XG_STYLE_TO_SYMBOL(s) \ - (s == PANGO_STYLE_OBLIQUE ? Qoblique \ - : s == PANGO_STYLE_ITALIC ? Qitalic \ - : Qnormal) +static +Lisp_Object xg_weight_to_symbol (PangoWeight w) +{ + return + (w <= PANGO_WEIGHT_THIN ? Qthin /* 100 */ + : w <= PANGO_WEIGHT_ULTRALIGHT ? Qultra_light /* 200 */ + : w <= PANGO_WEIGHT_LIGHT ? Qlight /* 300 */ +#if PANGO_VERSION_CHECK(1, 36, 7) + : w <= PANGO_WEIGHT_SEMILIGHT ? Qsemi_light /* 350 */ +#endif + : w <= PANGO_WEIGHT_BOOK ? Qbook /* 380 */ + : w <= PANGO_WEIGHT_NORMAL ? Qnormal /* 400 */ + : w <= PANGO_WEIGHT_MEDIUM ? Qmedium /* 500 */ + : w <= PANGO_WEIGHT_SEMIBOLD ? Qsemi_bold /* 600 */ + : w <= PANGO_WEIGHT_BOLD ? Qbold /* 700 */ + : w <= PANGO_WEIGHT_ULTRABOLD ? Qultra_bold /* 800 */ + : w <= PANGO_WEIGHT_HEAVY ? Qblack /* 900 */ + : Qultra_heavy); /* 1000 */ +} + +static +Lisp_Object xg_style_to_symbol (PangoStyle s) +{ + return + (s == PANGO_STYLE_OBLIQUE ? Qoblique + : s == PANGO_STYLE_ITALIC ? Qitalic + : Qnormal); +} #endif /* HAVE_GTK3 */ @@ -2288,6 +2714,11 @@ xg_get_font (struct frame *f, const char *default_name) int done = 0; Lisp_Object font = Qnil; +#ifdef HAVE_PGTK + if (!FRAME_GTK_OUTER_WIDGET (f)) + error ("Can't open dialog from child frames"); +#endif + w = gtk_font_chooser_dialog_new ("Pick a font", GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f))); @@ -2341,8 +2772,8 @@ xg_get_font (struct frame *f, const char *default_name) font = CALLN (Ffont_spec, QCfamily, build_string (family), QCsize, make_float (pango_units_to_double (size)), - QCweight, XG_WEIGHT_TO_SYMBOL (weight), - QCslant, XG_STYLE_TO_SYMBOL (style)); + QCweight, xg_weight_to_symbol (weight), + QCslant, xg_style_to_symbol (style)); char *font_desc_str = pango_font_description_to_string (desc); dupstring (&x_last_font_name, font_desc_str); @@ -2485,7 +2916,7 @@ xg_mark_data (void) { struct frame *f = XFRAME (frame); - if (FRAME_X_P (f) && FRAME_GTK_OUTER_WIDGET (f)) + if ((FRAME_X_P (f) || FRAME_PGTK_P (f)) && FRAME_GTK_OUTER_WIDGET (f)) { struct xg_frame_tb_info *tbinfo = g_object_get_data (G_OBJECT (FRAME_GTK_OUTER_WIDGET (f)), @@ -2649,6 +3080,11 @@ make_menu_item (const char *utf8_label, if (wtoadd) gtk_container_add (GTK_CONTAINER (w), wtoadd); if (! item->enabled) gtk_widget_set_sensitive (w, FALSE); +#ifdef HAVE_PGTK + if (!NILP (item->help)) + gtk_widget_set_tooltip_text (w, SSDATA (item->help)); +#endif + return w; } @@ -2715,6 +3151,20 @@ xg_create_one_menuitem (widget_value *item, return w; } +#ifdef HAVE_PGTK +static gboolean +menu_bar_button_pressed_cb (GtkWidget *widget, GdkEvent *event, + gpointer user_data) +{ + struct frame *f = user_data; + + if (event->button.button < 4) + set_frame_menubar (f, true); + + return false; +} +#endif + /* Create a full menu tree specified by DATA. F is the frame the created menu belongs to. SELECT_CB is the callback to use when a menu item is selected. @@ -2772,6 +3222,10 @@ create_menus (widget_value *data, else { wmenu = gtk_menu_bar_new (); +#ifdef HAVE_PGTK + g_signal_connect (G_OBJECT (wmenu), "button-press-event", + G_CALLBACK (menu_bar_button_pressed_cb), f); +#endif /* Set width of menu bar to a small value so it doesn't enlarge a small initial frame size. The width will be set to the width of the frame later on when it is added to a container. @@ -2788,9 +3242,15 @@ create_menus (widget_value *data, if (name) gtk_widget_set_name (wmenu, name); +#ifndef HAVE_PGTK if (deactivate_cb) g_signal_connect (G_OBJECT (wmenu), "selection-done", deactivate_cb, 0); +#else + if (deactivate_cb) + g_signal_connect (G_OBJECT (wmenu), + "deactivate", deactivate_cb, 0); +#endif } for (item = data; item; item = item->next) @@ -3512,7 +3972,7 @@ menubar_map_cb (GtkWidget *w, gpointer user_data) void xg_update_frame_menubar (struct frame *f) { - struct x_output *x = f->output_data.x; + xp_output *x = f->output_data.xp; GtkRequisition req; if (!x->menubar_widget || gtk_widget_get_mapped (x->menubar_widget)) @@ -3545,7 +4005,7 @@ xg_update_frame_menubar (struct frame *f) void free_frame_menubar (struct frame *f) { - struct x_output *x = f->output_data.x; + xp_output *x = f->output_data.xp; if (x->menubar_widget) { @@ -3561,6 +4021,7 @@ free_frame_menubar (struct frame *f) } } +#ifndef HAVE_PGTK bool xg_event_is_for_menubar (struct frame *f, const XEvent *event) { @@ -3575,6 +4036,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 or a touch event. */ + { + 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 @@ -3583,7 +4056,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; @@ -3597,8 +4075,21 @@ xg_event_is_for_menubar (struct frame *f, const XEvent *event) list = gtk_container_get_children (GTK_CONTAINER (x->menubar_widget)); if (! list) return 0; int scale = xg_get_scale (f); - rec.x = event->xbutton.x / scale; - rec.y = event->xbutton.y / scale; +#ifdef HAVE_XINPUT2 + if (event->type == GenericEvent) + { + rec.x = xev->event_x / scale; + rec.y = xev->event_y / scale; + } + else + { +#else + rec.x = event->xbutton.x / scale; + rec.y = event->xbutton.y / scale; +#endif +#ifdef HAVE_XINPUT2 + } +#endif rec.width = 1; rec.height = 1; @@ -3611,6 +4102,7 @@ xg_event_is_for_menubar (struct frame *f, const XEvent *event) g_list_free (list); return iter != 0; } +#endif @@ -3766,6 +4258,7 @@ xg_get_default_scrollbar_height (struct frame *f) return scroll_bar_width_for_theme * xg_get_scale (f); } +#ifndef HAVE_PGTK /* Return the scrollbar id for X Window WID on display DPY. Return -1 if WID not in id_to_widget. */ @@ -3786,6 +4279,7 @@ xg_get_scroll_id_for_window (Display *dpy, Window wid) return -1; } +#endif /* Callback invoked when scroll bar WIDGET is destroyed. DATA is the index into id_to_widget for WIDGET. @@ -3835,7 +4329,7 @@ xg_finish_scroll_bar_creation (struct frame *f, also, which causes flicker. Put an event box between the edit widget and the scroll bar, so the scroll bar instead draws itself on the event box window. */ - gtk_fixed_put (GTK_FIXED (f->output_data.x->edit_widget), webox, -1, -1); + gtk_fixed_put (GTK_FIXED (f->output_data.xp->edit_widget), webox, -1, -1); gtk_container_add (GTK_CONTAINER (webox), wscroll); xg_set_widget_bg (f, webox, FRAME_BACKGROUND_PIXEL (f)); @@ -3845,11 +4339,28 @@ xg_finish_scroll_bar_creation (struct frame *f, real X window, it and its scroll-bar child try to draw on the Emacs main window, which we draw over using Xlib. */ gtk_widget_realize (webox); +#ifdef HAVE_PGTK + gtk_widget_show_all (webox); +#endif +#ifndef HAVE_PGTK GTK_WIDGET_TO_X_WIN (webox); +#endif /* Set the cursor to an arrow. */ xg_set_cursor (webox, FRAME_DISPLAY_INFO (f)->xg_cursor); +#ifdef HAVE_PGTK + GtkStyleContext *ctxt = gtk_widget_get_style_context (wscroll); + gtk_style_context_add_provider (ctxt, + GTK_STYLE_PROVIDER (FRAME_OUTPUT_DATA (f)-> + scrollbar_foreground_css_provider), + GTK_STYLE_PROVIDER_PRIORITY_USER); + gtk_style_context_add_provider (ctxt, + GTK_STYLE_PROVIDER (FRAME_OUTPUT_DATA (f)-> + scrollbar_background_css_provider), + GTK_STYLE_PROVIDER_PRIORITY_USER); +#endif + bar->x_window = scroll_id; } @@ -3950,7 +4461,7 @@ xg_update_scrollbar_pos (struct frame *f, GtkWidget *wscroll = xg_get_widget_from_map (scrollbar_id); if (wscroll) { - GtkWidget *wfixed = f->output_data.x->edit_widget; + GtkWidget *wfixed = f->output_data.xp->edit_widget; GtkWidget *wparent = gtk_widget_get_parent (wscroll); gint msl; int scale = xg_get_scale (f); @@ -3990,7 +4501,11 @@ xg_update_scrollbar_pos (struct frame *f, /* Clear under old scroll bar position. */ oldw += (scale - 1) * oldw; oldx -= (scale - 1) * oldw; +#ifndef HAVE_PGTK x_clear_area (f, oldx, oldy, oldw, oldh); +#else + pgtk_clear_area (f, oldx, oldy, oldw, oldh); +#endif } if (!hidden) @@ -3998,15 +4513,23 @@ xg_update_scrollbar_pos (struct frame *f, GtkWidget *scrollbar = xg_get_widget_from_map (scrollbar_id); GtkWidget *webox = gtk_widget_get_parent (scrollbar); +#ifndef HAVE_PGTK /* Don't obscure any child frames. */ XLowerWindow (FRAME_X_DISPLAY (f), GTK_WIDGET_TO_X_WIN (webox)); +#else + gdk_window_lower (gtk_widget_get_window (webox)); +#endif } /* GTK does not redraw until the main loop is entered again, but if there are no X events pending we will not enter it. So we sync here to get some events. */ +#ifndef HAVE_PGTK x_sync (f); +#else + gdk_flush (); +#endif SET_FRAME_GARBAGED (f); cancel_mouse_face (f); } @@ -4031,7 +4554,7 @@ xg_update_horizontal_scrollbar_pos (struct frame *f, if (wscroll) { - GtkWidget *wfixed = f->output_data.x->edit_widget; + GtkWidget *wfixed = f->output_data.xp->edit_widget; GtkWidget *wparent = gtk_widget_get_parent (wscroll); gint msl; int scale = xg_get_scale (f); @@ -4067,7 +4590,11 @@ xg_update_horizontal_scrollbar_pos (struct frame *f, } if (oldx != -1 && oldw > 0 && oldh > 0) /* Clear under old scroll bar position. */ +#ifndef HAVE_PGTK x_clear_area (f, oldx, oldy, oldw, oldh); +#else + pgtk_clear_area (f, oldx, oldy, oldw, oldh); +#endif /* GTK does not redraw until the main loop is entered again, but if there are no X events pending we will not enter it. So we sync @@ -4078,11 +4605,19 @@ xg_update_horizontal_scrollbar_pos (struct frame *f, xg_get_widget_from_map (scrollbar_id); GtkWidget *webox = gtk_widget_get_parent (scrollbar); +#ifndef HAVE_PGTK /* Don't obscure any child frames. */ XLowerWindow (FRAME_X_DISPLAY (f), GTK_WIDGET_TO_X_WIN (webox)); +#else + gdk_window_lower (gtk_widget_get_window (webox)); +#endif } +#ifndef HAVE_PGTK x_sync (f); +#else + gdk_flush (); +#endif SET_FRAME_GARBAGED (f); cancel_mouse_face (f); } @@ -4226,14 +4761,37 @@ xg_set_toolkit_horizontal_scroll_bar_thumb (struct scroll_bar *bar, frame. This function does additional checks. */ bool -xg_event_is_for_scrollbar (struct frame *f, const XEvent *event) +xg_event_is_for_scrollbar (struct frame *f, const EVENT *event) { bool retval = 0; - if (f && event->type == ButtonPress && event->xbutton.button < 4) +#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 +#else + && event->type == GDK_BUTTON_PRESS && event->button.button < 4 +#endif + ) +#endif /* HAVE_XINPUT2 */ { /* Check if press occurred outside the edit widget. */ +#ifndef HAVE_PGTK GdkDisplay *gdpy = gdk_x11_lookup_xdisplay (FRAME_X_DISPLAY (f)); +#else + GdkDisplay *gdpy = FRAME_X_DISPLAY (f); +#endif GdkWindow *gwin; #ifdef HAVE_GTK3 #if GTK_CHECK_VERSION (3, 20, 0) @@ -4247,11 +4805,42 @@ xg_event_is_for_scrollbar (struct frame *f, const XEvent *event) #else gwin = gdk_display_get_window_at_pointer (gdpy, NULL, NULL); #endif - retval = gwin != gtk_widget_get_window (f->output_data.x->edit_widget); +#ifndef HAVE_XINPUT2 + retval = gwin != gtk_widget_get_window (f->output_data.xp->edit_widget); +#else + retval = (gwin + && (gwin + != gtk_widget_get_window (f->output_data.xp->edit_widget))); +#endif +#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) - || event->type == MotionNotify)) + || event->type == MotionNotify) +#else + && ((event->type == GDK_BUTTON_RELEASE && event->button.button < 4) + || event->type == GDK_MOTION_NOTIFY) +#endif + ) +#endif /* HAVE_XINPUT2 */ { /* If we are releasing or moving the scroll bar, it has the grab. */ GtkWidget *w = gtk_grab_get_current (); @@ -4329,7 +4918,11 @@ draw_page (GtkPrintOperation *operation, GtkPrintContext *context, struct frame *f = XFRAME (Fnth (make_fixnum (page_nr), frames)); cairo_t *cr = gtk_print_context_get_cairo_context (context); +#ifndef HAVE_PGTK x_cr_draw_frame (cr, f); +#else + pgtk_cr_draw_frame (cr, f); +#endif } void @@ -4430,7 +5023,11 @@ xg_tool_bar_callback (GtkWidget *w, gpointer client_data) /* Convert between the modifier bits GDK uses and the modifier bits Emacs uses. This assumes GDK and X masks are the same, which they are when this is written. */ +#ifndef HAVE_PGTK event.modifiers = x_x_to_emacs_modifiers (FRAME_DISPLAY_INFO (f), mod); +#else + event.modifiers = pgtk_gtk_to_emacs_modifiers (FRAME_DISPLAY_INFO (f), mod); +#endif kbd_buffer_store_event (&event); /* Return focus to the frame after we have clicked on a detached @@ -4527,7 +5124,7 @@ xg_tool_bar_item_expose_callback (GtkWidget *w, static void xg_pack_tool_bar (struct frame *f, Lisp_Object pos) { - struct x_output *x = f->output_data.x; + xp_output *x = f->output_data.xp; bool into_hbox = EQ (pos, Qleft) || EQ (pos, Qright); GtkWidget *top_widget = x->toolbar_widget; @@ -4583,7 +5180,7 @@ tb_size_cb (GtkWidget *widget, static void xg_create_tool_bar (struct frame *f) { - struct x_output *x = f->output_data.x; + xp_output *x = f->output_data.xp; #ifdef HAVE_GTK3 GtkStyleContext *gsty; #endif @@ -4822,7 +5419,7 @@ xg_tool_item_stale_p (GtkWidget *wbutton, const char *stock_name, static bool xg_update_tool_bar_sizes (struct frame *f) { - struct x_output *x = f->output_data.x; + xp_output *x = f->output_data.xp; GtkRequisition req; int nl = 0, nr = 0, nt = 0, nb = 0; GtkWidget *top_widget = x->toolbar_widget; @@ -4908,7 +5505,7 @@ void update_frame_tool_bar (struct frame *f) { int i, j; - struct x_output *x = f->output_data.x; + xp_output *x = f->output_data.xp; int hmargin = 0, vmargin = 0; GtkToolbar *wtoolbar; GtkToolItem *ti; @@ -4923,6 +5520,11 @@ update_frame_tool_bar (struct frame *f) if (! FRAME_GTK_WIDGET (f)) return; +#ifdef HAVE_PGTK + if (! FRAME_GTK_OUTER_WIDGET (f)) + return; +#endif + block_input (); if (RANGED_FIXNUMP (1, Vtool_bar_button_margin, INT_MAX)) @@ -5218,7 +5820,7 @@ update_frame_tool_bar (struct frame *f) void free_frame_tool_bar (struct frame *f) { - struct x_output *x = f->output_data.x; + xp_output *x = f->output_data.xp; if (x->toolbar_widget) { @@ -5263,7 +5865,7 @@ free_frame_tool_bar (struct frame *f) void xg_change_toolbar_position (struct frame *f, Lisp_Object pos) { - struct x_output *x = f->output_data.x; + xp_output *x = f->output_data.xp; GtkWidget *top_widget = x->toolbar_widget; if (! x->toolbar_widget || ! top_widget) diff --git a/src/gtkutil.h b/src/gtkutil.h index 31a12cd5d3c..9c6160dd772 100644 --- a/src/gtkutil.h +++ b/src/gtkutil.h @@ -25,7 +25,13 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <gtk/gtk.h> #include "../lwlib/lwlib-widget.h" +#ifdef HAVE_PGTK +#include "pgtkterm.h" +#define EVENT GdkEvent +#else #include "xterm.h" +#define EVENT XEvent +#endif /* Minimum and maximum values used for GTK scroll bars */ @@ -105,7 +111,7 @@ extern void xg_modify_menubar_widgets (GtkWidget *menubar, extern void xg_update_frame_menubar (struct frame *f); -extern bool xg_event_is_for_menubar (struct frame *, const XEvent *); +extern bool xg_event_is_for_menubar (struct frame *, const EVENT *); extern ptrdiff_t xg_get_scroll_id_for_window (Display *dpy, Window wid); @@ -142,7 +148,7 @@ extern void xg_set_toolkit_horizontal_scroll_bar_thumb (struct scroll_bar *bar, int portion, int position, int whole); -extern bool xg_event_is_for_scrollbar (struct frame *, const XEvent *); +extern bool xg_event_is_for_scrollbar (struct frame *, const EVENT *); extern int xg_get_default_scrollbar_width (struct frame *f); extern int xg_get_default_scrollbar_height (struct frame *f); @@ -157,9 +163,15 @@ extern void xg_frame_set_char_size (struct frame *f, int width, int height); extern GtkWidget * xg_win_to_widget (Display *dpy, Window wdesc); extern int xg_get_scale (struct frame *f); +#ifndef HAVE_PGTK extern void xg_display_open (char *display_name, Display **dpy); extern void xg_display_close (Display *dpy); extern GdkCursor * xg_create_default_cursor (Display *dpy); +#else +extern void xg_display_open (char *display_name, GdkDisplay **dpy); +extern void xg_display_close (GdkDisplay *gdpy); +extern GdkCursor * xg_create_default_cursor (GdkDisplay *gdpy); +#endif extern bool xg_create_frame_widgets (struct frame *f); extern void xg_free_frame_widgets (struct frame *f); @@ -167,10 +179,15 @@ extern void xg_set_background_color (struct frame *f, unsigned long bg); extern bool xg_check_special_colors (struct frame *f, const char *color_name, Emacs_Color *color); +#ifdef HAVE_PGTK +extern void xg_create_frame_outer_widgets (struct frame *f); +#endif +#ifndef HAVE_PGTK extern void xg_set_frame_icon (struct frame *f, Pixmap icon_pixmap, Pixmap icon_mask); +#endif extern void xg_set_undecorated (struct frame *f, Lisp_Object undecorated); extern void xg_frame_restack (struct frame *f1, struct frame *f2, bool above); @@ -183,7 +200,11 @@ extern bool xg_prepare_tooltip (struct frame *f, Lisp_Object string, int *width, int *height); +#ifndef HAVE_PGTK extern void xg_show_tooltip (struct frame *f, int root_x, int root_y); +#else +extern void xg_show_tooltip (struct frame *f, Lisp_Object string); +#endif extern bool xg_hide_tooltip (struct frame *f); #ifdef USE_CAIRO @@ -192,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 <https://www.gnu.org/licenses/>. */ + +#include <config.h> + +#include "lisp.h" +#include "process.h" +#include "coding.h" + +#include <kernel/OS.h> + +#include <pwd.h> +#include <stdlib.h> + +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 <https://www.gnu.org/licenses/>. */ + +#include <config.h> + +#include <View.h> +#include <Region.h> +#include <Font.h> +#include <Window.h> +#include <Bitmap.h> + +#include <cmath> + +#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 <https://www.gnu.org/licenses/>. */ + +#include <config.h> + +#include <Font.h> +#include <Rect.h> +#include <AffineTransform.h> + +#include <cstring> +#include <cmath> + +#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 <https://www.gnu.org/licenses/>. */ + +#include <config.h> + +#include <signal.h> +#include <stdio.h> +#include <pthread.h> +#include <unistd.h> + +#include <OS.h> + +#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 <https://www.gnu.org/licenses/>. */ + +#include <config.h> + +#include <Clipboard.h> + +#include <cstdlib> +#include <cstring> + +#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..32e61d96604 --- /dev/null +++ b/src/haiku_support.cc @@ -0,0 +1,2940 @@ +/* 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 <https://www.gnu.org/licenses/>. */ + +#include <config.h> + +#include <app/Application.h> +#include <app/Cursor.h> +#include <app/Messenger.h> + +#include <interface/GraphicsDefs.h> +#include <interface/InterfaceDefs.h> +#include <interface/Bitmap.h> +#include <interface/Window.h> +#include <interface/View.h> +#include <interface/Screen.h> +#include <interface/ScrollBar.h> +#include <interface/Region.h> +#include <interface/Menu.h> +#include <interface/MenuItem.h> +#include <interface/PopUpMenu.h> +#include <interface/MenuBar.h> +#include <interface/Alert.h> +#include <interface/Button.h> + +#include <locale/UnicodeChar.h> + +#include <game/WindowScreen.h> +#include <game/DirectWindow.h> + +#include <storage/Entry.h> +#include <storage/Path.h> +#include <storage/FilePanel.h> +#include <storage/AppFileInfo.h> +#include <storage/Path.h> +#include <storage/PathFinder.h> + +#include <support/Beep.h> +#include <support/DataIO.h> +#include <support/Locker.h> + +#include <translation/TranslatorRoster.h> +#include <translation/TranslationDefs.h> +#include <translation/TranslationUtils.h> + +#include <kernel/OS.h> +#include <kernel/fs_attr.h> +#include <kernel/scheduler.h> + +#include <private/interface/ToolTip.h> + +#include <cmath> +#include <cstring> +#include <cstdint> +#include <cstdio> +#include <csignal> +#include <cfloat> + +#include <pthread.h> + +#ifdef USE_BE_CAIRO +#include <cairo.h> +#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; + +/* The locking semantics of BWindows running in multiple threads are + so complex that child frame state (which is the only state that is + shared between different BWindows at runtime) does best with a + single global lock. */ + +static BLocker child_frame_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 (); +} + +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 BWindow +{ +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; + + EmacsWindow () : BWindow (BRect (0, 0, 0, 0), "", B_TITLED_WINDOW_LOOK, + B_NORMAL_WINDOW_FEEL, B_NO_SERVER_SIDE_WINDOW_MODIFIERS) + { + + } + + ~EmacsWindow () + { + if (!child_frame_lock.Lock ()) + gui_abort ("Failed to lock child frame state lock"); + struct child_frame *next; + for (struct child_frame *f = subset_windows; f; f = next) + { + if (f->window->LockLooper ()) + gui_abort ("Failed to lock looper for unparent"); + f->window->Unparent (); + f->window->UnlockLooper (); + next = f->next; + delete f; + } + + if (this->parent) + UnparentAndUnlink (); + child_frame_lock.Unlock (); + } + + void + UpwardsSubset (EmacsWindow *w) + { + for (; w; w = w->parent) + AddToSubset (w); + } + + void + UpwardsSubsetChildren (EmacsWindow *w) + { + if (!LockLooper ()) + gui_abort ("Failed to lock looper for subset"); + if (!child_frame_lock.Lock ()) + gui_abort ("Failed to lock child frame state lock"); + UpwardsSubset (w); + for (struct child_frame *f = subset_windows; f; + f = f->next) + f->window->UpwardsSubsetChildren (w); + child_frame_lock.Unlock (); + UnlockLooper (); + } + + void + UpwardsUnSubset (EmacsWindow *w) + { + for (; w; w = w->parent) + RemoveFromSubset (w); + } + + void + UpwardsUnSubsetChildren (EmacsWindow *w) + { + if (!LockLooper ()) + gui_abort ("Failed to lock looper for unsubset"); + if (!child_frame_lock.Lock ()) + gui_abort ("Failed to lock child frame state lock"); + UpwardsUnSubset (w); + for (struct child_frame *f = subset_windows; f; + f = f->next) + f->window->UpwardsUnSubsetChildren (w); + child_frame_lock.Unlock (); + UnlockLooper (); + } + + void + Unparent (void) + { + if (!child_frame_lock.Lock ()) + gui_abort ("Failed to lock child frame state lock"); + this->SetFeel (B_NORMAL_WINDOW_FEEL); + UpwardsUnSubsetChildren (parent); + this->RemoveFromSubset (this); + this->parent = NULL; + if (fullscreen_p) + { + fullscreen_p = 0; + MakeFullscreen (1); + } + child_frame_lock.Unlock (); + } + + void + UnparentAndUnlink (void) + { + if (!child_frame_lock.Lock ()) + gui_abort ("Failed to lock child frame state lock"); + this->parent->UnlinkChild (this); + this->Unparent (); + child_frame_lock.Unlock (); + } + + 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; + else + subset_windows = tem->next; + delete tem; + return; + } + } + + gui_abort ("Failed to unlink child frame"); + } + + void + ParentTo (EmacsWindow *window) + { + if (!child_frame_lock.Lock ()) + gui_abort ("Failed to lock child frame state lock"); + + 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); + + child_frame_lock.Unlock (); + } + + 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 (); + if (!f->window->LockLooper ()) + gui_abort ("Failed to lock child frame window for move"); + f->window->MoveTo (frame.left + f->xoff, + frame.top + f->yoff); + f->window->UnlockLooper (); + } + + void + DoUpdateWorkspace (struct child_frame *f) + { + f->window->SetWorkspaces (this->Workspaces ()); + } + + void + MoveChild (EmacsWindow *window, int xoff, int yoff, + int weak_p) + { + if (!child_frame_lock.Lock ()) + gui_abort ("Failed to lock child frame state lock"); + + 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); + + child_frame_lock.Unlock (); + return; + } + } + + child_frame_lock.Unlock (); + 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 + 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 + BWindow::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 + BWindow::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); + BWindow::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); + + if (!child_frame_lock.Lock ()) + gui_abort ("Failed to lock child frame state lock"); + + for (struct child_frame *f = subset_windows; + f; f = f->next) + DoMove (f); + + child_frame_lock.Unlock (); + BWindow::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 (!child_frame_lock.Lock ()) + gui_abort ("Failed to lock child frame state lock"); + + if (!this->parent) + this->MoveTo (x, y); + else + this->parent->MoveChild (this, x, y, 0); + child_frame_lock.Unlock (); + } + + bool + QuitRequested () + { + struct haiku_quit_requested_event rq; + rq.window = this; + haiku_write (QUIT_REQUESTED, &rq); + return false; + } + + void + Minimize (bool minimized_p) + { + BWindow::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; + if (!child_frame_lock.Lock ()) + gui_abort ("Failed to lock child frame state lock"); + + Hide (); + if (this->parent) + UpwardsUnSubsetChildren (this->parent); + + child_frame_lock.Unlock (); + } + + void + EmacsShow (void) + { + if (!this->IsHidden ()) + return; + + if (!child_frame_lock.Lock ()) + gui_abort ("Failed to lock child frame state lock"); + + if (this->parent) + shown_flag = 1; + Show (); + if (this->parent) + UpwardsSubsetChildren (this->parent); + + child_frame_lock.Unlock (); + } + + 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; + } + + BWindow::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 (!child_frame_lock.Lock ()) + gui_abort ("Failed to lock child frame state lock"); + + if (parent) + { + *width = parent->Frame ().Width (); + *height = parent->Frame ().Height (); + } + else + { + BScreen s (this); + *width = s.Frame ().Width (); + *height = s.Frame ().Height (); + } + + child_frame_lock.Unlock (); + } + + void + OffsetChildRect (BRect *r, EmacsWindow *c) + { + if (!child_frame_lock.Lock ()) + gui_abort ("Failed to lock child frame state lock"); + + 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; + child_frame_lock.Unlock (); + return; + } + + child_frame_lock.Lock (); + 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 (!child_frame_lock.Lock ()) + gui_abort ("Failed to lock child frame state lock"); + + if (parent) + parent->OffsetChildRect (&pre_fullscreen_rect, this); + + child_frame_lock.Unlock (); + + 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<EmacsWindow *> (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<EmacsView *> (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<EmacsView *>(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) + { + while (!be_app->Lock ()); + be_app->Quit (); + } +} + +/* 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; + return vw->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) +{ + BWindow *w = (BWindow *) window; + BView *vw = (BView *) w->FindView ("Emacs"); + EmacsView *ev = dynamic_cast <EmacsView *> (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) +{ + BWindow *w = (BWindow *) window; + BView *vw = (BView *) w->FindView ("Emacs"); + EmacsView *ev = dynamic_cast <EmacsView *> (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 (); +} + +/* Synchronize WINDOW's connection to the App Server. */ +void +BWindow_sync (void *window) +{ + BWindow *w = (BWindow *) window; + + if (!w->LockLooper ()) + gui_abort ("Failed to lock window looper for sync"); + w->Sync (); + 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..b08a561def3 --- /dev/null +++ b/src/haiku_support.h @@ -0,0 +1,872 @@ +/* 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 <https://www.gnu.org/licenses/>. */ + +#ifndef _HAIKU_SUPPORT_H +#define _HAIKU_SUPPORT_H + +#include <stdint.h> + +#ifdef HAVE_FREETYPE +#include <ft2build.h> +#include <fontconfig/fontconfig.h> +#include FT_FREETYPE_H +#include FT_SIZES_H +#endif + +#ifdef USE_BE_CAIRO +#include <cairo.h> +#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 <pthread.h> +#include <OS.h> + +#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); + + extern void + BWindow_sync (void *window); + +#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..b9198e9d445 --- /dev/null +++ b/src/haikufns.c @@ -0,0 +1,2453 @@ +/* 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 <https://www.gnu.org/licenses/>. */ + +#include <config.h> + +#include <math.h> + +#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 <stdlib.h> + +#include <kernel/OS.h> + +#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 (); +#ifndef USE_BE_CAIRO + if (FRAME_HAIKU_WINDOW (f)) + { + if (NILP (new_value)) + { +#endif + EmacsView_set_up_double_buffering (FRAME_HAIKU_VIEW (f)); + if (!NILP (old_value)) + { + SET_FRAME_GARBAGED (f); + expose_frame (f, 0, 0, 0, 0); + } +#ifndef USE_BE_CAIRO + } + else + EmacsView_disable_double_buffering (FRAME_HAIKU_VIEW (f)); + } +#endif + 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, + 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 <https://www.gnu.org/licenses/>. */ + +#include <config.h> + +#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 <math.h> +#include <stdlib.h> + +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 <https://www.gnu.org/licenses/>. */ + +#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 <https://www.gnu.org/licenses/>. */ + +#include <config.h> + +#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..2ce0aed1468 --- /dev/null +++ b/src/haikumenu.c @@ -0,0 +1,666 @@ +/* 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 <https://www.gnu.org/licenses/>. */ + +#include <config.h> + +#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; + void *view = 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)); + view = FRAME_HAIKU_VIEW (XFRAME (Vmenu_updating_frame)); + } + + if (view) + BView_draw_lock (view); + + 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; + } + } + + if (view) + BView_draw_unlock (view); +} + +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 <https://www.gnu.org/licenses/>. */ + +#include <config.h> + +#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 <https://www.gnu.org/licenses/>. */ + +#ifndef _HAIKU_SELECT_H_ +#define _HAIKU_SELECT_H_ + +#ifdef __cplusplus +#include <cstdio> +#endif + +#ifdef __cplusplus +#include <stdio.h> +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..574bf40f7b6 --- /dev/null +++ b/src/haikuterm.c @@ -0,0 +1,3649 @@ +/* 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 <https://www.gnu.org/licenses/>. */ + +#include <config.h> + +#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 <math.h> +#include <stdlib.h> + +#ifdef USE_BE_CAIRO +#include <cairo.h> +#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)); + BWindow_sync (FRAME_HAIKU_WINDOW (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_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_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); + + haiku_draw_text_decoration (s, face, face->foreground, s->width, s->x); + 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_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); + else + haiku_draw_text_decoration (s, face, face->foreground, s->width, s->x); + + if (!s->for_overlaps) + { + 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 void +flush_dirty_back_buffers (void) +{ + block_input (); + Lisp_Object tail, frame; + FOR_EACH_FRAME (tail, frame) + { + struct frame *f = XFRAME (frame); + if (FRAME_LIVE_P (f) && + FRAME_HAIKU_P (f) && + FRAME_HAIKU_WINDOW (f) && + !FRAME_GARBAGED_P (f) && + !buffer_flipping_blocked_p () && + FRAME_DIRTY_P (f)) + haiku_flip_buffers (f); + } + unblock_input (); +} + +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; + int need_flush = 0; + + 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; + + need_flush = 1; + } + + 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); + need_flush = 1; + } + } + + 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); + need_flush = 1; + } + } + + 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) + || !mwheel_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); + } + + if (need_flush) + flush_dirty_back_buffers (); + + 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 ("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 <https://www.gnu.org/licenses/>. */ + +#ifndef _HAIKU_TERM_H_ +#define _HAIKU_TERM_H_ + +#include <pthread.h> + +#ifdef USE_BE_CAIRO +#include <cairo.h> +#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 49b26301e8b..1d83065cf71 100644 --- a/src/image.c +++ b/src/image.c @@ -20,6 +20,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <config.h> #include <fcntl.h> +#include <math.h> #include <unistd.h> /* Include this before including <setjmp.h> to work around bugs with @@ -30,6 +31,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <setjmp.h> +#include <math.h> #include <stdint.h> #include <c-ctype.h> #include <flexmember.h> @@ -78,14 +80,7 @@ typedef struct x_bitmap_record Bitmap_Record; #endif /* !USE_CAIRO */ #endif /* HAVE_X_WINDOWS */ -#ifdef USE_CAIRO -#define GET_PIXEL image_pix_context_get_pixel -#define PUT_PIXEL image_pix_container_put_pixel -#define NO_PIXMAP 0 - -#define PIX_MASK_RETAIN 0 -#define PIX_MASK_DRAW 255 - +#if defined(USE_CAIRO) || defined(HAVE_NS) #define RGB_TO_ULONG(r, g, b) (((r) << 16) | ((g) << 8) | (b)) #define ARGB_TO_ULONG(a, r, g, b) (((a) << 24) | ((r) << 16) | ((g) << 8) | (b)) #define RED_FROM_ULONG(color) (((color) >> 16) & 0xff) @@ -94,11 +89,29 @@ typedef struct x_bitmap_record Bitmap_Record; #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 + +#ifdef USE_CAIRO +#define GET_PIXEL image_pix_context_get_pixel +#define PUT_PIXEL image_pix_container_put_pixel +#define NO_PIXMAP 0 + +#define PIX_MASK_RETAIN 0 +#define PIX_MASK_DRAW 255 static unsigned long image_alloc_image_color (struct frame *, struct image *, Lisp_Object, unsigned long); #endif /* USE_CAIRO */ +#if defined HAVE_PGTK && defined HAVE_IMAGEMAGICK +/* In pgtk, we don't want to create scaled image. If we create scaled + * image on scale=2.0 environment, the created image is half size and + * Gdk scales it back, and the result is blurry. To avoid this, we + * hold original size image as far as we can, and let Gdk to scale it + * when it is shown. */ +# define DONT_CREATE_TRANSFORMED_IMAGEMAGICK_IMAGE +#endif + #ifdef HAVE_NTGUI /* We need (or want) w32.h only when we're _not_ compiling for Cygwin. */ @@ -129,12 +142,37 @@ typedef struct ns_bitmap_record Bitmap_Record; #endif /* HAVE_NS */ +#ifdef HAVE_PGTK +typedef struct pgtk_bitmap_record Bitmap_Record; +#endif /* HAVE_PGTK */ + #if (defined HAVE_X_WINDOWS \ && ! (defined HAVE_NTGUI || defined USE_CAIRO || defined HAVE_NS)) /* W32_TODO : Color tables on W32. */ # 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); @@ -396,6 +434,34 @@ image_reference_bitmap (struct frame *f, ptrdiff_t id) ++FRAME_DISPLAY_INFO (f)->bitmaps[id - 1].refcount; } +#ifdef HAVE_PGTK +static cairo_pattern_t * +image_create_pattern_from_pixbuf (struct frame *f, GdkPixbuf * pixbuf) +{ + GdkPixbuf *pb = gdk_pixbuf_add_alpha (pixbuf, TRUE, 255, 255, 255); + cairo_surface_t *surface = + cairo_surface_create_similar_image (cairo_get_target + (f->output_data.pgtk->cr_context), + CAIRO_FORMAT_A1, + gdk_pixbuf_get_width (pb), + gdk_pixbuf_get_height (pb)); + + cairo_t *cr = cairo_create (surface); + gdk_cairo_set_source_pixbuf (cr, pb, 0, 0); + cairo_set_operator (cr, CAIRO_OPERATOR_SOURCE); + cairo_paint (cr); + cairo_destroy (cr); + + cairo_pattern_t *pat = cairo_pattern_create_for_surface (surface); + cairo_pattern_set_extend (pat, CAIRO_EXTEND_REPEAT); + + cairo_surface_destroy (surface); + g_object_unref (pb); + + return pat; +} +#endif + /* Create a bitmap for frame F from a HEIGHT x WIDTH array of bits at BITS. */ ptrdiff_t @@ -430,6 +496,54 @@ image_create_bitmap_from_data (struct frame *f, char *bits, return -1; #endif +#ifdef HAVE_PGTK + GdkPixbuf *pixbuf = gdk_pixbuf_new (GDK_COLORSPACE_RGB, + FALSE, + 8, + width, + height); + { + char *sp = bits; + int mask = 0x01; + unsigned char *buf = gdk_pixbuf_get_pixels (pixbuf); + int rowstride = gdk_pixbuf_get_rowstride (pixbuf); + for (int y = 0; y < height; y++) + { + unsigned char *dp = buf + rowstride * y; + for (int x = 0; x < width; x++) + { + if (*sp & mask) + { + *dp++ = 0xff; + *dp++ = 0xff; + *dp++ = 0xff; + } + else + { + *dp++ = 0x00; + *dp++ = 0x00; + *dp++ = 0x00; + } + if ((mask <<= 1) >= 0x100) + { + mask = 0x01; + sp++; + } + } + if (mask != 0x01) + { + mask = 0x01; + sp++; + } + } + } +#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); #ifdef HAVE_NS @@ -437,6 +551,18 @@ image_create_bitmap_from_data (struct frame *f, char *bits, dpyinfo->bitmaps[id - 1].depth = 1; #endif +#ifdef HAVE_PGTK + dpyinfo->bitmaps[id - 1].img = pixbuf; + dpyinfo->bitmaps[id - 1].depth = 1; + dpyinfo->bitmaps[id - 1].pattern = + 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; @@ -465,7 +591,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); @@ -489,6 +615,30 @@ image_create_bitmap_from_file (struct frame *f, Lisp_Object file) return id; #endif +#ifdef HAVE_PGTK + GError *err = NULL; + ptrdiff_t id; + void * bitmap = gdk_pixbuf_new_from_file (SSDATA (file), &err); + + if (!bitmap) + { + g_error_free (err); + return -1; + } + + id = image_allocate_bitmap_record (f); + + dpyinfo->bitmaps[id - 1].img = bitmap; + dpyinfo->bitmaps[id - 1].refcount = 1; + dpyinfo->bitmaps[id - 1].file = xlispstrdup (file); + //dpyinfo->bitmaps[id - 1].depth = 1; + dpyinfo->bitmaps[id - 1].height = gdk_pixbuf_get_width (bitmap); + dpyinfo->bitmaps[id - 1].width = gdk_pixbuf_get_height (bitmap); + dpyinfo->bitmaps[id - 1].pattern + = image_create_pattern_from_pixbuf (f, bitmap); + return id; +#endif + #ifdef HAVE_X_WINDOWS unsigned int width, height; Pixmap bitmap; @@ -561,6 +711,15 @@ free_bitmap_record (Display_Info *dpyinfo, Bitmap_Record *bm) ns_release_object (bm->img); #endif +#ifdef HAVE_PGTK + if (bm->pattern != NULL) + cairo_pattern_destroy (bm->pattern); +#endif + +#ifdef HAVE_HAIKU + BBitmap_free (bm->img); +#endif + if (bm->file) { xfree (bm->file); @@ -1321,7 +1480,6 @@ image_ascent (struct image *img, struct face *face, struct glyph_slice *slice) return ascent; } - /* Image background colors. */ @@ -1345,6 +1503,7 @@ four_corners_best (Emacs_Pix_Context pimg, int *corners, corner_pixels[3] = GET_PIXEL (pimg, corners[LEFT_CORNER], corners[BOT_CORNER] - 1); } else + { /* Get the colors at the corner_pixels of pimg. */ corner_pixels[0] = GET_PIXEL (pimg, 0, 0); @@ -1834,6 +1993,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; @@ -1975,14 +2139,16 @@ postprocess_image (struct frame *f, struct image *img) safely rounded and clipped to int range. */ static int -scale_image_size (int size, size_t divisor, size_t multiplier) +scale_image_size (int size, double divisor, double multiplier) { if (divisor != 0) { - double s = size; - double scaled = s * multiplier / divisor + 0.5; + double scaled = size * multiplier / divisor; if (scaled < INT_MAX) - return scaled; + { + /* Use ceil, as rounding can discard fractional SVG pixels. */ + return ceil (scaled); + } } return INT_MAX; } @@ -2003,84 +2169,77 @@ image_get_dimension (struct image *img, Lisp_Object symbol) if (FIXNATP (value)) return min (XFIXNAT (value), INT_MAX); if (CONSP (value) && NUMBERP (CAR (value)) && EQ (Qem, CDR (value))) - return min (img->face_font_size * XFLOATINT (CAR (value)), INT_MAX); + return scale_image_size (img->face_font_size, 1, XFLOATINT (CAR (value))); return -1; } /* Compute the desired size of an image with native size WIDTH x HEIGHT. - Use SPEC to deduce the size. Store the desired size into + Use IMG to deduce the size. Store the desired size into *D_WIDTH x *D_HEIGHT. Store -1 x -1 if the native size is OK. */ static void -compute_image_size (size_t width, size_t height, +compute_image_size (double width, double height, struct image *img, int *d_width, int *d_height) { - Lisp_Object value; - int int_value; - int desired_width = -1, desired_height = -1, max_width = -1, max_height = -1; double scale = 1; - - value = image_spec_value (img->spec, QCscale, NULL); + Lisp_Object value = image_spec_value (img->spec, QCscale, NULL); if (NUMBERP (value)) - scale = XFLOATINT (value); - - int_value = image_get_dimension (img, QCmax_width); - if (int_value >= 0) - max_width = int_value; - - int_value = image_get_dimension (img, QCmax_height); - if (int_value >= 0) - max_height = int_value; + { + double dval = XFLOATINT (value); + if (0 <= dval) + scale = dval; + } /* If width and/or height is set in the display spec assume we want to scale to those values. If either h or w is unspecified, the unspecified should be calculated from the specified to preserve aspect ratio. */ - int_value = image_get_dimension (img, QCwidth); - if (int_value >= 0) + int desired_width = image_get_dimension (img, QCwidth), max_width; + if (desired_width < 0) + max_width = image_get_dimension (img, QCmax_width); + else { - desired_width = int_value * scale; + desired_width = scale_image_size (desired_width, 1, scale); /* :width overrides :max-width. */ max_width = -1; } - int_value = image_get_dimension (img, QCheight); - if (int_value >= 0) + int desired_height = image_get_dimension (img, QCheight), max_height; + if (desired_height < 0) + max_height = image_get_dimension (img, QCmax_height); + else { - desired_height = int_value * scale; + desired_height = scale_image_size (desired_height, 1, scale); /* :height overrides :max-height. */ max_height = -1; } /* If we have both width/height set explicitly, we skip past all the aspect ratio-preserving computations below. */ - if (desired_width != -1 && desired_height != -1) + if (0 <= desired_width && 0 <= desired_height) goto out; - width = width * scale; - height = height * scale; - - if (desired_width != -1) + if (0 <= desired_width) /* Width known, calculate height. */ desired_height = scale_image_size (desired_width, width, height); - else if (desired_height != -1) + else if (0 <= desired_height) /* Height known, calculate width. */ desired_width = scale_image_size (desired_height, height, width); else { - desired_width = width; - desired_height = height; + desired_width = scale_image_size (width, 1, scale); + desired_height = scale_image_size (height, 1, scale); } - if (max_width != -1 && desired_width > max_width) + if (0 <= max_width && max_width < desired_width) { /* The image is wider than :max-width. */ desired_width = max_width; desired_height = scale_image_size (desired_width, width, height); } - if (max_height != -1 && desired_height > max_height) + if (0 <= max_height && max_height < desired_height) { /* The image is higher than :max-height. */ desired_height = max_height; @@ -2173,6 +2332,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 @@ -2187,6 +2347,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) @@ -2211,7 +2372,8 @@ compute_image_rotation (struct image *img, double *rotation) static void image_set_transform (struct frame *f, struct image *img) { -# ifdef HAVE_IMAGEMAGICK +# if (defined HAVE_IMAGEMAGICK \ + && !defined DONT_CREATE_TRANSFORMED_IMAGEMAGICK_IMAGE) /* ImageMagick images already have the correct transform. */ if (EQ (image_spec_value (img->spec, QCtype, NULL), Qimagemagick)) return; @@ -2244,6 +2406,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 @@ -2414,6 +2577,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 */ @@ -2435,8 +2626,8 @@ lookup_image (struct frame *f, Lisp_Object spec, int face_id) face_id = DEFAULT_FACE_ID; struct face *face = FACE_FROM_ID (f, face_id); - unsigned long foreground = FACE_COLOR_TO_PIXEL (face->foreground, f); - unsigned long background = FACE_COLOR_TO_PIXEL (face->background, f); + unsigned long foreground = face->foreground; + unsigned long background = face->background; int font_size = face->font->pixel_size; char *font_family = SSDATA (face->lface[LFACE_FAMILY_INDEX]); @@ -2820,6 +3011,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; @@ -2960,7 +3175,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; @@ -2972,14 +3187,6 @@ gui_put_x_image (struct frame *f, Emacs_Pix_Container pimg, XFreeGC (FRAME_X_DISPLAY (f), gc); #endif /* HAVE_X_WINDOWS */ -#ifdef HAVE_NTGUI -#if 0 /* I don't think this is necessary looking at where it is used. */ - HDC hdc = get_frame_dc (f); - SetDIBits (hdc, pixmap, 0, height, pimg->data, &(pimg->info), DIB_RGB_COLORS); - release_frame_dc (f, hdc); -#endif -#endif /* HAVE_NTGUI */ - #ifdef HAVE_NS eassert (pimg == pixmap); ns_retain_object (pimg); @@ -3087,7 +3294,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; @@ -3547,10 +3754,8 @@ convert_mono_to_color_image (struct frame *f, struct image *img, release_frame_dc (f, hdc); old_prev = SelectObject (old_img_dc, img->pixmap); new_prev = SelectObject (new_img_dc, new_pixmap); - /* Windows convention for mono bitmaps is black = background, - white = foreground. */ - SetTextColor (new_img_dc, background); - SetBkColor (new_img_dc, foreground); + SetTextColor (new_img_dc, foreground); + SetBkColor (new_img_dc, background); BitBlt (new_img_dc, 0, 0, img->width, img->height, old_img_dc, 0, 0, SRCCOPY); @@ -4015,6 +4220,13 @@ xbm_load (struct frame *f, struct image *img) XPM images ***********************************************************************/ +#if defined (HAVE_XPM) || defined (HAVE_NS) || defined (HAVE_PGTK) + +static bool xpm_image_p (Lisp_Object object); +static bool xpm_load (struct frame *f, struct image *img); + +#endif /* HAVE_XPM || HAVE_NS */ + #ifdef HAVE_XPM #ifdef HAVE_NTGUI /* Indicate to xpm.h that we don't have Xlib. */ @@ -4038,7 +4250,7 @@ xbm_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. */ @@ -4058,7 +4270,7 @@ enum xpm_keyword_index XPM_LAST }; -#if defined HAVE_XPM || defined HAVE_NS +#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. */ @@ -4076,7 +4288,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 @@ -4116,9 +4328,9 @@ struct xpm_cached_color }; /* The hash table used for the color cache, and its bucket vector - size. */ + size (which should be prime). */ -#define XPM_COLOR_CACHE_BUCKETS 1001 +#define XPM_COLOR_CACHE_BUCKETS 1009 static struct xpm_cached_color **xpm_color_cache; /* Initialize the color cache. */ @@ -4300,7 +4512,7 @@ init_xpm_functions (void) #endif /* WINDOWSNT */ -#if defined HAVE_XPM || defined HAVE_NS +#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. */ @@ -4336,9 +4548,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 @@ -4707,9 +4919,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_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 *, @@ -4906,7 +5120,7 @@ xpm_load_image (struct frame *f, Lisp_Object (*get_color_table) (Lisp_Object, const char *, int); Lisp_Object frame, color_symbols, color_table; int best_key; -#ifndef HAVE_NS +#if !defined (HAVE_NS) bool have_mask = false; #endif Emacs_Pix_Container ximg = NULL, mask_img = NULL; @@ -5446,7 +5660,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, @@ -5519,7 +5733,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); @@ -5527,7 +5741,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); @@ -5841,6 +6055,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) @@ -5858,6 +6073,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; @@ -6415,15 +6631,16 @@ 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 } /* - * These functions are actually defined in the OS-native implementation - * file. Currently, for Windows GDI+ interface, w32image.c, but other - * operating systems can follow suit. + * These functions are actually defined in the OS-native implementation file. + * Currently, for Windows GDI+ interface, w32image.c, and nsimage.m for macOS. */ /* Indices of image specification fields in native format, below. */ @@ -6489,6 +6706,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 @@ -8233,24 +8453,30 @@ gif_image_p (Lisp_Object object) # undef DrawText # endif -/* Giflib before 5.0 didn't define these macros (used only if HAVE_NTGUI). */ -# ifndef GIFLIB_MINOR -# define GIFLIB_MINOR 0 -# endif -# ifndef GIFLIB_RELEASE -# define GIFLIB_RELEASE 0 -# endif - # else /* HAVE_NTGUI */ # include <gif_lib.h> # endif /* HAVE_NTGUI */ -/* Giflib before 5.0 didn't define these macros. */ +/* Giflib before 4.1.6 didn't define these macros. */ # ifndef GIFLIB_MAJOR # define GIFLIB_MAJOR 4 # endif +# ifndef GIFLIB_MINOR +# define GIFLIB_MINOR 0 +# endif +# ifndef GIFLIB_RELEASE +# define GIFLIB_RELEASE 0 +# endif +/* Giflib before 5.0 didn't define these macros. */ +# if GIFLIB_MAJOR < 5 +# define DISPOSAL_UNSPECIFIED 0 /* No disposal specified. */ +# define DISPOSE_DO_NOT 1 /* Leave image in place. */ +# define DISPOSE_BACKGROUND 2 /* Set area too background color. */ +# define DISPOSE_PREVIOUS 3 /* Restore to previous content. */ +# define NO_TRANSPARENT_COLOR -1 +# endif /* GifErrorString is declared to return char const * when GIFLIB_MAJOR and GIFLIB_MINOR indicate 5.1 or later. Do not bother using it in @@ -8273,6 +8499,8 @@ DEF_DLL_FN (GifFileType *, DGifOpenFileName, (const char *)); # else DEF_DLL_FN (GifFileType *, DGifOpen, (void *, InputFunc, int *)); DEF_DLL_FN (GifFileType *, DGifOpenFileName, (const char *, int *)); +DEF_DLL_FN (int, DGifSavedExtensionToGCB, + (GifFileType *, int, GraphicsControlBlock *)); # endif # if HAVE_GIFERRORSTRING DEF_DLL_FN (char const *, GifErrorString, (int)); @@ -8290,6 +8518,9 @@ init_gif_functions (void) LOAD_DLL_FN (library, DGifSlurp); LOAD_DLL_FN (library, DGifOpen); LOAD_DLL_FN (library, DGifOpenFileName); +# if GIFLIB_MAJOR >= 5 + LOAD_DLL_FN (library, DGifSavedExtensionToGCB); +# endif # if HAVE_GIFERRORSTRING LOAD_DLL_FN (library, GifErrorString); # endif @@ -8300,12 +8531,18 @@ init_gif_functions (void) # undef DGifOpen # undef DGifOpenFileName # undef DGifSlurp +# if GIFLIB_MAJOR >= 5 +# undef DGifSavedExtensionToGCB +# endif # undef GifErrorString # define DGifCloseFile fn_DGifCloseFile # define DGifOpen fn_DGifOpen # define DGifOpenFileName fn_DGifOpenFileName # define DGifSlurp fn_DGifSlurp +# if GIFLIB_MAJOR >= 5 +# define DGifSavedExtensionToGCB fn_DGifSavedExtensionToGCB +# endif # define GifErrorString fn_GifErrorString # endif /* WINDOWSNT */ @@ -8383,7 +8620,7 @@ gif_load (struct frame *f, struct image *img) if (!STRINGP (file)) { image_error ("Cannot find image file `%s'", specified_file); - return 0; + return false; } Lisp_Object encoded_file = ENCODE_FILE (file); @@ -8406,8 +8643,7 @@ gif_load (struct frame *f, struct image *img) else #endif image_error ("Cannot open `%s'", file); - - return 0; + return false; } } else @@ -8415,7 +8651,7 @@ gif_load (struct frame *f, struct image *img) if (!STRINGP (specified_data)) { image_error ("Invalid image data `%s'", specified_data); - return 0; + return false; } /* Read from memory! */ @@ -8439,7 +8675,7 @@ gif_load (struct frame *f, struct image *img) else #endif image_error ("Cannot open memory source `%s'", img->spec); - return 0; + return false; } } @@ -8447,8 +8683,7 @@ gif_load (struct frame *f, struct image *img) if (!check_image_size (f, gif->SWidth, gif->SHeight)) { image_size_error (); - gif_close (gif, NULL); - return 0; + goto gif_error; } /* Read entire contents. */ @@ -8459,8 +8694,7 @@ gif_load (struct frame *f, struct image *img) image_error ("Error reading `%s'", img->spec); else image_error ("Error reading GIF data"); - gif_close (gif, NULL); - return 0; + goto gif_error; } /* Which sub-image are we to display? */ @@ -8471,8 +8705,7 @@ gif_load (struct frame *f, struct image *img) { image_error ("Invalid image number `%s' in image `%s'", image_number, img->spec); - gif_close (gif, NULL); - return 0; + goto gif_error; } } @@ -8489,8 +8722,7 @@ gif_load (struct frame *f, struct image *img) if (!check_image_size (f, width, height)) { image_size_error (); - gif_close (gif, NULL); - return 0; + goto gif_error; } /* Check that the selected subimages fit. It's not clear whether @@ -8507,18 +8739,14 @@ gif_load (struct frame *f, struct image *img) && 0 <= subimg_left && subimg_left <= width - subimg_width)) { image_error ("Subimage does not fit in image"); - gif_close (gif, NULL); - return 0; + goto gif_error; } } /* Create the X image and pixmap. */ Emacs_Pix_Container ximg; if (!image_create_x_image_and_pixmap (f, img, width, height, 0, &ximg, 0)) - { - gif_close (gif, NULL); - return 0; - } + goto gif_error; /* Clear the part of the screen image not covered by the image. Full animated GIF support requires more here (see the gif89 spec, @@ -8577,13 +8805,17 @@ gif_load (struct frame *f, struct image *img) char *, which invites problems with bytes >= 0x80. */ struct SavedImage *subimage = gif->SavedImages + j; unsigned char *raster = (unsigned char *) subimage->RasterBits; - int transparency_color_index = -1; - int disposal = 0; int subimg_width = subimage->ImageDesc.Width; int subimg_height = subimage->ImageDesc.Height; int subimg_top = subimage->ImageDesc.Top; int subimg_left = subimage->ImageDesc.Left; + /* From gif89a spec: 1 = "keep in place", 2 = "restore + to background". Treat any other value like 2. */ + int disposal = DISPOSAL_UNSPECIFIED; + int transparency_color_index = NO_TRANSPARENT_COLOR; + +#if GIFLIB_MAJOR < 5 /* Find the Graphic Control Extension block for this sub-image. Extract the disposal method and transparency color. */ for (i = 0; i < subimage->ExtensionBlockCount; i++) @@ -8594,24 +8826,29 @@ gif_load (struct frame *f, struct image *img) && extblock->ByteCount == 4 && extblock->Bytes[0] & 1) { - /* From gif89a spec: 1 = "keep in place", 2 = "restore - to background". Treat any other value like 2. */ disposal = (extblock->Bytes[0] >> 2) & 7; transparency_color_index = (unsigned char) extblock->Bytes[3]; break; } } +#else + GraphicsControlBlock gcb; + DGifSavedExtensionToGCB (gif, j, &gcb); + disposal = gcb.DisposalMode; + transparency_color_index = gcb.TransparentColor; +#endif /* We can't "keep in place" the first subimage. */ if (j == 0) - disposal = 2; + disposal = DISPOSE_BACKGROUND; - /* For disposal == 0, the spec says "No disposal specified. The - decoder is not required to take any action." In practice, it - seems we need to treat this like "keep in place", see e.g. + /* For disposal == 0 (DISPOSAL_UNSPECIFIED), the spec says + "No disposal specified. The decoder is not required to take + any action." In practice, it seems we need to treat this + like "keep in place" (DISPOSE_DO_NOT), see e.g. https://upload.wikimedia.org/wikipedia/commons/3/37/Clock.gif */ - if (disposal == 0) - disposal = 1; + if (disposal == DISPOSAL_UNSPECIFIED) + disposal = DISPOSE_DO_NOT; gif_color_map = subimage->ImageDesc.ColorMap; if (!gif_color_map) @@ -8650,7 +8887,7 @@ gif_load (struct frame *f, struct image *img) for (x = 0; x < subimg_width; x++) { int c = raster[y * subimg_width + x]; - if (transparency_color_index != c || disposal != 1) + if (transparency_color_index != c || disposal != DISPOSE_DO_NOT) { PUT_PIXEL (ximg, x + subimg_left, row + subimg_top, pixel_colors[c]); @@ -8664,7 +8901,7 @@ gif_load (struct frame *f, struct image *img) for (x = 0; x < subimg_width; ++x) { int c = raster[y * subimg_width + x]; - if (transparency_color_index != c || disposal != 1) + if (transparency_color_index != c || disposal != DISPOSE_DO_NOT) { PUT_PIXEL (ximg, x + subimg_left, y + subimg_top, pixel_colors[c]); @@ -8734,14 +8971,302 @@ gif_load (struct frame *f, struct image *img) /* Put ximg into the image. */ image_put_x_image (f, img, ximg, 0); - return 1; + return true; + + gif_error: + gif_close (gif, NULL); + return false; } #endif /* HAVE_GIF */ +#ifdef HAVE_WEBP + + +/*********************************************************************** + WebP + ***********************************************************************/ + +#include "webp/decode.h" + +/* Indices of image specification fields in webp_format, below. */ + +enum webp_keyword_index +{ + WEBP_TYPE, + WEBP_DATA, + WEBP_FILE, + WEBP_ASCENT, + WEBP_MARGIN, + WEBP_RELIEF, + WEBP_ALGORITHM, + WEBP_HEURISTIC_MASK, + WEBP_MASK, + WEBP_BACKGROUND, + WEBP_LAST +}; + +/* Vector of image_keyword structures describing the format + of valid user-defined image specifications. */ + +static const struct image_keyword webp_format[WEBP_LAST] = +{ + {":type", IMAGE_SYMBOL_VALUE, 1}, + {":data", IMAGE_STRING_VALUE, 0}, + {":file", IMAGE_STRING_VALUE, 0}, + {":ascent", IMAGE_ASCENT_VALUE, 0}, + {":margin", IMAGE_NON_NEGATIVE_INTEGER_VALUE_OR_PAIR, 0}, + {":relief", IMAGE_INTEGER_VALUE, 0}, + {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":background", IMAGE_STRING_OR_NIL_VALUE, 0} +}; + +/* Return true if OBJECT is a valid WebP image specification. */ + +static bool +webp_image_p (Lisp_Object object) +{ + struct image_keyword fmt[WEBP_LAST]; + memcpy (fmt, webp_format, sizeof fmt); + + if (!parse_image_spec (object, fmt, WEBP_LAST, Qwebp)) + return false; + + /* Must specify either the :data or :file keyword. */ + return fmt[WEBP_FILE].count + fmt[WEBP_DATA].count == 1; +} + +#ifdef WINDOWSNT + +/* WebP library details. */ + +DEF_DLL_FN (int, WebPGetInfo, (const uint8_t *, size_t, int *, int *)); +/* WebPGetFeatures is a static inline function defined in WebP's + decode.h. Since we cannot use that with dynamically-loaded libwebp + DLL, we instead load the internal function it calls and redirect to + that through a macro. */ +DEF_DLL_FN (VP8StatusCode, WebPGetFeaturesInternal, + (const uint8_t *, size_t, WebPBitstreamFeatures *, int)); +DEF_DLL_FN (uint8_t *, WebPDecodeRGBA, (const uint8_t *, size_t, int *, int *)); +DEF_DLL_FN (uint8_t *, WebPDecodeRGB, (const uint8_t *, size_t, int *, int *)); +DEF_DLL_FN (void, WebPFree, (void *)); + +static bool +init_webp_functions (void) +{ + HMODULE library; + + if (!(library = w32_delayed_load (Qwebp))) + return false; + + LOAD_DLL_FN (library, WebPGetInfo); + LOAD_DLL_FN (library, WebPGetFeaturesInternal); + LOAD_DLL_FN (library, WebPDecodeRGBA); + LOAD_DLL_FN (library, WebPDecodeRGB); + LOAD_DLL_FN (library, WebPFree); + return true; +} + +#undef WebPGetInfo +#undef WebPGetFeatures +#undef WebPDecodeRGBA +#undef WebPDecodeRGB +#undef WebPFree + +#define WebPGetInfo fn_WebPGetInfo +#define WebPGetFeatures(d,s,f) \ + fn_WebPGetFeaturesInternal(d,s,f,WEBP_DECODER_ABI_VERSION) +#define WebPDecodeRGBA fn_WebPDecodeRGBA +#define WebPDecodeRGB fn_WebPDecodeRGB +#define WebPFree fn_WebPFree + +#endif /* WINDOWSNT */ + +/* Load WebP image IMG for use on frame F. Value is true if + successful. */ + +static bool +webp_load (struct frame *f, struct image *img) +{ + ptrdiff_t size = 0; + uint8_t *contents; + Lisp_Object file = Qnil; + + /* Open the WebP file. */ + Lisp_Object specified_file = image_spec_value (img->spec, QCfile, NULL); + Lisp_Object specified_data = image_spec_value (img->spec, QCdata, NULL); + + if (NILP (specified_data)) + { + int fd; + file = image_find_image_fd (specified_file, &fd); + if (!STRINGP (file)) + { + image_error ("Cannot find image file `%s'", specified_file); + return false; + } + + contents = (uint8_t *) slurp_file (fd, &size); + if (contents == NULL) + { + image_error ("Error loading WebP image `%s'", file); + return false; + } + } + else + { + if (!STRINGP (specified_data)) + { + image_error ("Invalid image data `%s'", specified_data); + return false; + } + contents = SDATA (specified_data); + size = SBYTES (specified_data); + } + + /* Validate the WebP image header. */ + if (!WebPGetInfo (contents, size, NULL, NULL)) + { + if (!NILP (file)) + image_error ("Not a WebP file: `%s'", file); + else + image_error ("Invalid header in WebP image data"); + goto webp_error1; + } + + /* Get WebP features. */ + WebPBitstreamFeatures features; + VP8StatusCode result = WebPGetFeatures (contents, size, &features); + switch (result) + { + case VP8_STATUS_OK: + break; + case VP8_STATUS_NOT_ENOUGH_DATA: + case VP8_STATUS_OUT_OF_MEMORY: + case VP8_STATUS_INVALID_PARAM: + case VP8_STATUS_BITSTREAM_ERROR: + case VP8_STATUS_UNSUPPORTED_FEATURE: + case VP8_STATUS_SUSPENDED: + case VP8_STATUS_USER_ABORT: + default: + /* Error out in all other cases. */ + if (!NILP (file)) + image_error ("Error when interpreting WebP image data: `%s'", file); + else + image_error ("Error when interpreting WebP image data"); + goto webp_error1; + } + + /* Decode WebP data. */ + uint8_t *decoded; + int width, height; + if (features.has_alpha) + /* Linear [r0, g0, b0, a0, r1, g1, b1, a1, ...] order. */ + decoded = WebPDecodeRGBA (contents, size, &width, &height); + else + /* Linear [r0, g0, b0, r1, g1, b1, ...] order. */ + decoded = WebPDecodeRGB (contents, size, &width, &height); + + if (!decoded) + { + image_error ("Error when interpreting WebP image data"); + goto webp_error1; + } + + if (!(width <= INT_MAX && height <= INT_MAX + && check_image_size (f, width, height))) + { + image_size_error (); + goto webp_error2; + } + + /* Create the x image and pixmap. */ + Emacs_Pix_Container ximg, mask_img = NULL; + if (!image_create_x_image_and_pixmap (f, img, width, height, 0, &ximg, false)) + goto webp_error2; + + /* Create an image and pixmap serving as mask if the WebP image + contains an alpha channel. */ + if (features.has_alpha + && !image_create_x_image_and_pixmap (f, img, width, height, 1, &mask_img, true)) + { + image_destroy_x_image (ximg); + image_clear_image_1 (f, img, CLEAR_IMAGE_PIXMAP); + goto webp_error2; + } + + /* Fill the X image and mask from WebP data. */ + init_color_table (); + + uint8_t *p = decoded; + for (int y = 0; y < height; ++y) + { + for (int x = 0; x < width; ++x) + { + int r = *p++ << 8; + int g = *p++ << 8; + int b = *p++ << 8; + PUT_PIXEL (ximg, x, y, lookup_rgb_color (f, r, g, b)); + + /* An alpha channel associates variable transparency with an + image. WebP allows up to 256 levels of partial transparency. + We handle this like with PNG (which see), using the frame's + background color to combine the image with. */ + if (features.has_alpha) + { + if (mask_img) + PUT_PIXEL (mask_img, x, y, *p > 0 ? PIX_MASK_DRAW : PIX_MASK_RETAIN); + ++p; + } + } + } + +#ifdef COLOR_TABLE_SUPPORT + /* Remember colors allocated for this image. */ + img->colors = colors_in_color_table (&img->ncolors); + free_color_table (); +#endif /* COLOR_TABLE_SUPPORT */ + + /* Put ximg into the image. */ + image_put_x_image (f, img, ximg, 0); + + /* Same for the mask. */ + if (mask_img) + { + /* Fill in the background_transparent field while we have the + mask handy. Casting avoids a GCC warning. */ + image_background_transparent (img, f, (Emacs_Pix_Context)mask_img); + + image_put_x_image (f, img, mask_img, 1); + } + + img->width = width; + img->height = height; + + /* Clean up. */ + WebPFree (decoded); + if (NILP (specified_data)) + xfree (contents); + return true; + + webp_error2: + WebPFree (decoded); + + webp_error1: + if (NILP (specified_data)) + xfree (contents); + return false; +} + +#endif /* HAVE_WEBP */ + + #ifdef HAVE_IMAGEMAGICK + /*********************************************************************** ImageMagick ***********************************************************************/ @@ -9117,11 +9642,15 @@ imagemagick_load_image (struct frame *f, struct image *img, PixelWand **pixels, *bg_wand = NULL; MagickPixelPacket pixel; Lisp_Object image; +#ifndef DONT_CREATE_TRANSFORMED_IMAGEMAGICK_IMAGE Lisp_Object value; +#endif Lisp_Object crop; EMACS_INT ino; int desired_width, desired_height; +#ifndef DONT_CREATE_TRANSFORMED_IMAGEMAGICK_IMAGE double rotation; +#endif char hint_buffer[MaxTextExtent]; char *filename_hint = NULL; imagemagick_initialize (); @@ -9238,9 +9767,13 @@ imagemagick_load_image (struct frame *f, struct image *img, PixelSetBlue (bg_wand, (double) bgcolor.blue / 65535); } +#ifndef DONT_CREATE_TRANSFORMED_IMAGEMAGICK_IMAGE compute_image_size (MagickGetImageWidth (image_wand), MagickGetImageHeight (image_wand), img, &desired_width, &desired_height); +#else + desired_width = desired_height = -1; +#endif if (desired_width != -1 && desired_height != -1) { @@ -9284,6 +9817,7 @@ imagemagick_load_image (struct frame *f, struct image *img, } } +#ifndef DONT_CREATE_TRANSFORMED_IMAGEMAGICK_IMAGE /* Furthermore :rotation. we need background color and angle for rotation. */ /* @@ -9302,6 +9836,7 @@ imagemagick_load_image (struct frame *f, struct image *img, goto imagemagick_error; } } +#endif /* Set the canvas background color to the frame or specified background, and flatten the image. Note: as of ImageMagick @@ -9339,7 +9874,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 @@ -9432,8 +9968,8 @@ imagemagick_load_image (struct frame *f, struct image *img, color_scale * pixel.red, color_scale * pixel.green, color_scale * pixel.blue)); - } - } + } + } DestroyPixelIterator (iterator); } @@ -9669,6 +10205,10 @@ DEF_DLL_FN (gboolean, rsvg_handle_close, (RsvgHandle *, GError **)); DEF_DLL_FN (void, rsvg_handle_set_dpi_x_y, (RsvgHandle * handle, double dpi_x, double dpi_y)); +# if LIBRSVG_CHECK_VERSION (2, 52, 1) +DEF_DLL_FN (gboolean, rsvg_handle_get_intrinsic_size_in_pixels, + (RsvgHandle *, gdouble *, gdouble *)); +# endif # if LIBRSVG_CHECK_VERSION (2, 46, 0) DEF_DLL_FN (void, rsvg_handle_get_intrinsic_dimensions, (RsvgHandle *, gboolean *, RsvgLength *, gboolean *, @@ -9676,14 +10216,15 @@ DEF_DLL_FN (void, rsvg_handle_get_intrinsic_dimensions, DEF_DLL_FN (gboolean, rsvg_handle_get_geometry_for_layer, (RsvgHandle *, const char *, const RsvgRectangle *, RsvgRectangle *, RsvgRectangle *, GError **)); +# else +DEF_DLL_FN (void, rsvg_handle_get_dimensions, + (RsvgHandle *, RsvgDimensionData *)); # endif # if LIBRSVG_CHECK_VERSION (2, 48, 0) DEF_DLL_FN (gboolean, rsvg_handle_set_stylesheet, (RsvgHandle *, const guint8 *, gsize, GError **)); # endif -DEF_DLL_FN (void, rsvg_handle_get_dimensions, - (RsvgHandle *, RsvgDimensionData *)); DEF_DLL_FN (GdkPixbuf *, rsvg_handle_get_pixbuf, (RsvgHandle *)); DEF_DLL_FN (int, gdk_pixbuf_get_width, (const GdkPixbuf *)); DEF_DLL_FN (int, gdk_pixbuf_get_height, (const GdkPixbuf *)); @@ -9731,14 +10272,18 @@ init_svg_functions (void) LOAD_DLL_FN (library, rsvg_handle_close); #endif LOAD_DLL_FN (library, rsvg_handle_set_dpi_x_y); +#if LIBRSVG_CHECK_VERSION (2, 52, 1) + LOAD_DLL_FN (library, rsvg_handle_get_intrinsic_size_in_pixels); +#endif #if LIBRSVG_CHECK_VERSION (2, 46, 0) LOAD_DLL_FN (library, rsvg_handle_get_intrinsic_dimensions); LOAD_DLL_FN (library, rsvg_handle_get_geometry_for_layer); +#else + LOAD_DLL_FN (library, rsvg_handle_get_dimensions); #endif #if LIBRSVG_CHECK_VERSION (2, 48, 0) LOAD_DLL_FN (library, rsvg_handle_set_stylesheet); #endif - LOAD_DLL_FN (library, rsvg_handle_get_dimensions); LOAD_DLL_FN (library, rsvg_handle_get_pixbuf); LOAD_DLL_FN (gdklib, gdk_pixbuf_get_width); @@ -9773,11 +10318,15 @@ init_svg_functions (void) # undef g_clear_error # undef g_object_unref # undef g_type_init +# if LIBRSVG_CHECK_VERSION (2, 52, 1) +# undef rsvg_handle_get_intrinsic_size_in_pixels +# endif # if LIBRSVG_CHECK_VERSION (2, 46, 0) # undef rsvg_handle_get_intrinsic_dimensions # undef rsvg_handle_get_geometry_for_layer +# else +# undef rsvg_handle_get_dimensions # endif -# undef rsvg_handle_get_dimensions # if LIBRSVG_CHECK_VERSION (2, 48, 0) # undef rsvg_handle_set_stylesheet # endif @@ -9807,13 +10356,18 @@ init_svg_functions (void) # if ! GLIB_CHECK_VERSION (2, 36, 0) # define g_type_init fn_g_type_init # endif +# if LIBRSVG_CHECK_VERSION (2, 52, 1) +# define rsvg_handle_get_intrinsic_size_in_pixels \ + fn_rsvg_handle_get_intrinsic_size_in_pixels +# endif # if LIBRSVG_CHECK_VERSION (2, 46, 0) # define rsvg_handle_get_intrinsic_dimensions \ fn_rsvg_handle_get_intrinsic_dimensions # define rsvg_handle_get_geometry_for_layer \ fn_rsvg_handle_get_geometry_for_layer +# else +# define rsvg_handle_get_dimensions fn_rsvg_handle_get_dimensions # endif -# define rsvg_handle_get_dimensions fn_rsvg_handle_get_dimensions # if LIBRSVG_CHECK_VERSION (2, 48, 0) # define rsvg_handle_set_stylesheet fn_rsvg_handle_set_stylesheet # endif @@ -10043,72 +10597,85 @@ svg_load_image (struct frame *f, struct image *img, char *contents, /* Get the image dimensions. */ #if LIBRSVG_CHECK_VERSION (2, 46, 0) - RsvgRectangle zero_rect, viewbox, out_logical_rect; - - /* Try the intrinsic dimensions first. */ - gboolean has_width, has_height, has_viewbox; - RsvgLength iwidth, iheight; - double dpi = FRAME_DISPLAY_INFO (f)->resx; - - rsvg_handle_get_intrinsic_dimensions (rsvg_handle, - &has_width, &iwidth, - &has_height, &iheight, - &has_viewbox, &viewbox); + gdouble gviewbox_width = 0, gviewbox_height = 0; + gboolean has_viewbox = FALSE; +# if LIBRSVG_CHECK_VERSION (2, 52, 1) + has_viewbox = rsvg_handle_get_intrinsic_size_in_pixels (rsvg_handle, + &gviewbox_width, + &gviewbox_height); +# endif - if (has_width && has_height) - { - /* Success! We can use these values directly. */ - viewbox_width = svg_css_length_to_pixels (iwidth, dpi, img->face_font_size); - viewbox_height = svg_css_length_to_pixels (iheight, dpi, img->face_font_size); - } - else if (has_width && has_viewbox) + if (has_viewbox) { - viewbox_width = svg_css_length_to_pixels (iwidth, dpi, img->face_font_size); - viewbox_height = svg_css_length_to_pixels (iwidth, dpi, img->face_font_size) - * viewbox.height / viewbox.width; - } - else if (has_height && has_viewbox) - { - viewbox_height = svg_css_length_to_pixels (iheight, dpi, img->face_font_size); - viewbox_width = svg_css_length_to_pixels (iheight, dpi, img->face_font_size) - * viewbox.width / viewbox.height; - } - else if (has_viewbox) - { - viewbox_width = viewbox.width; - viewbox_height = viewbox.height; + viewbox_width = gviewbox_width; + viewbox_height = gviewbox_height; } else { - /* We haven't found a usable set of sizes, so try working out - the visible area. */ - rsvg_handle_get_geometry_for_layer (rsvg_handle, NULL, - &zero_rect, &viewbox, - &out_logical_rect, NULL); - viewbox_width = viewbox.x + viewbox.width; - viewbox_height = viewbox.y + viewbox.height; - } + RsvgRectangle zero_rect, viewbox, out_logical_rect; - if (viewbox_width == 0 || viewbox_height == 0) -#endif - { - /* The functions used above to get the geometry of the visible - area of the SVG are only available in librsvg 2.46 and above, - so in certain circumstances this code path can result in some - parts of the SVG being cropped. */ - RsvgDimensionData dimension_data; + /* Try the intrinsic dimensions first. */ + gboolean has_width, has_height; + RsvgLength iwidth, iheight; + double dpi = FRAME_DISPLAY_INFO (f)->resx; - rsvg_handle_get_dimensions (rsvg_handle, &dimension_data); + rsvg_handle_get_intrinsic_dimensions (rsvg_handle, + &has_width, &iwidth, + &has_height, &iheight, + &has_viewbox, &viewbox); - viewbox_width = dimension_data.width; - viewbox_height = dimension_data.height; - } + if (has_width && has_height) + { + /* Success! We can use these values directly. */ + viewbox_width = svg_css_length_to_pixels (iwidth, dpi, + img->face_font_size); + viewbox_height = svg_css_length_to_pixels (iheight, dpi, + img->face_font_size); + } + else if (has_width && has_viewbox) + { + viewbox_width = svg_css_length_to_pixels (iwidth, dpi, + img->face_font_size); + viewbox_height = viewbox_width * viewbox.height / viewbox.width; + } + else if (has_height && has_viewbox) + { + viewbox_height = svg_css_length_to_pixels (iheight, dpi, + img->face_font_size); + viewbox_width = viewbox_height * viewbox.width / viewbox.height; + } + else if (has_viewbox) + { + viewbox_width = viewbox.width; + viewbox_height = viewbox.height; + } + else + viewbox_width = viewbox_height = 0; + + if (! (0 < viewbox_width && 0 < viewbox_height)) + { + /* We haven't found a usable set of sizes, so try working out + the visible area. */ + rsvg_handle_get_geometry_for_layer (rsvg_handle, NULL, + &zero_rect, &viewbox, + &out_logical_rect, NULL); + viewbox_width = viewbox.x + viewbox.width; + viewbox_height = viewbox.y + viewbox.height; + } + } +#else + /* In librsvg before 2.46.0, guess the viewbox from the image dimensions. */ + RsvgDimensionData dimension_data; + rsvg_handle_get_dimensions (rsvg_handle, &dimension_data); + viewbox_width = dimension_data.width; + viewbox_height = dimension_data.height; +#endif compute_image_size (viewbox_width, viewbox_height, img, &width, &height); - width *= FRAME_SCALE_FACTOR (f); - height *= FRAME_SCALE_FACTOR (f); + width = scale_image_size (width, 1, FRAME_SCALE_FACTOR (f)); + height = scale_image_size (height, 1, FRAME_SCALE_FACTOR (f)); if (! check_image_size (f, width, height)) { @@ -10555,16 +11122,6 @@ x_kill_gs_process (Pixmap pixmap, struct frame *f) free_color_table (); #endif XDestroyImage (ximg); - -#if 0 /* This doesn't seem to be the case. If we free the colors - here, we get a BadAccess later in image_clear_image when - freeing the colors. */ - /* We have allocated colors once, but Ghostscript has also - allocated colors on behalf of us. So, to get the - reference counts right, free them once. */ - if (img->ncolors) - x_free_colors (f, img->colors, img->ncolors); -#endif } else image_error ("Cannot get X image of `%s'; colors will not be freed", @@ -10633,7 +11190,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; @@ -10723,10 +11281,14 @@ 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 +#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 +#if defined HAVE_WEBP + { SYMBOL_INDEX (Qwebp), webp_image_p, webp_load, image_clear_image, + IMAGE_TYPE_INIT (init_webp_functions) }, +#endif { SYMBOL_INDEX (Qxbm), xbm_image_p, xbm_load, image_clear_image }, { SYMBOL_INDEX (Qpbm), pbm_image_p, pbm_load, image_clear_image }, }; @@ -10867,7 +11429,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) +#if defined (HAVE_XPM) || defined (HAVE_NS) \ + || defined (HAVE_HAIKU) || defined (HAVE_PGTK) DEFSYM (Qxpm, "xpm"); add_image_type (Qxpm); #endif @@ -10892,6 +11455,11 @@ non-numeric, there is no explicit limit on the size of images. */); add_image_type (Qpng); #endif +#if defined (HAVE_WEBP) + DEFSYM (Qwebp, "webp"); + add_image_type (Qwebp); +#endif + #if defined (HAVE_IMAGEMAGICK) DEFSYM (Qimagemagick, "imagemagick"); add_image_type (Qimagemagick); @@ -10913,6 +11481,11 @@ non-numeric, there is no explicit limit on the size of images. */); #endif /* HAVE_NTGUI */ #endif /* HAVE_RSVG */ +#ifdef HAVE_NS + DEFSYM (Qheic, "heic"); + add_image_type (Qheic); +#endif + #if HAVE_NATIVE_IMAGE_API DEFSYM (Qnative_image, "native-image"); # ifdef HAVE_NTGUI 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/intervals.c b/src/intervals.c index f88a41f2549..11d5b6bbb6f 100644 --- a/src/intervals.c +++ b/src/intervals.c @@ -166,10 +166,11 @@ merge_properties (register INTERVAL source, register INTERVAL target) } } -/* Return true if the two intervals have the same properties. */ +/* Return true if the two intervals have the same properties. + If use_equal is true, use Fequal for comparisons instead of EQ. */ -bool -intervals_equal (INTERVAL i0, INTERVAL i1) +static bool +intervals_equal_1 (INTERVAL i0, INTERVAL i1, bool use_equal) { Lisp_Object i0_cdr, i0_sym; Lisp_Object i1_cdr, i1_val; @@ -204,7 +205,8 @@ intervals_equal (INTERVAL i0, INTERVAL i1) /* i0 and i1 both have sym, but it has different values in each. */ if (!CONSP (i1_val) || (i1_val = XCDR (i1_val), !CONSP (i1_val)) - || !EQ (XCAR (i1_val), XCAR (i0_cdr))) + || use_equal ? NILP (Fequal (XCAR (i1_val), XCAR (i0_cdr))) + : !EQ (XCAR (i1_val), XCAR (i0_cdr))) return false; i0_cdr = XCDR (i0_cdr); @@ -218,6 +220,14 @@ intervals_equal (INTERVAL i0, INTERVAL i1) /* Lengths of the two plists were equal. */ return (NILP (i0_cdr) && NILP (i1_cdr)); } + +/* Return true if the two intervals have the same properties. */ + +bool +intervals_equal (INTERVAL i0, INTERVAL i1) +{ + return intervals_equal_1 (i0, i1, false); +} /* Traverse an interval tree TREE, performing FUNCTION on each node. @@ -2291,7 +2301,7 @@ compare_string_intervals (Lisp_Object s1, Lisp_Object s2) /* If we ever find a mismatch between the strings, they differ. */ - if (! intervals_equal (i1, i2)) + if (! intervals_equal_1 (i1, i2, true)) return 0; /* Advance POS till the end of the shorter interval, diff --git a/src/keyboard.c b/src/keyboard.c index 1d8d98c9419..8b85911cc49 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -65,6 +65,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <sys/types.h> #include <unistd.h> #include <fcntl.h> +#include <math.h> #include <ignore-value.h> @@ -375,6 +376,7 @@ static void timer_resume_idle (void); static void deliver_user_signal (int); static char *find_user_signal_name (int); static void store_user_signal_events (void); +static bool is_ignored_event (union buffered_input_event *); /* Advance or retreat a buffered input event pointer. */ @@ -2943,20 +2945,8 @@ read_char (int commandflag, Lisp_Object map, last_input_event = c; call4 (Qcommand_execute, tem, Qnil, Fvector (1, &last_input_event), Qt); - if (CONSP (c) - && (EQ (XCAR (c), Qselect_window) - || EQ (XCAR (c), Qfocus_out) -#ifdef HAVE_DBUS - || EQ (XCAR (c), Qdbus_event) -#endif -#ifdef USE_FILE_NOTIFY - || EQ (XCAR (c), Qfile_notify) -#endif -#ifdef THREADS_ENABLED - || EQ (XCAR (c), Qthread_event) -#endif - || EQ (XCAR (c), Qconfig_changed_event)) - && !end_time) + if (CONSP (c) && !NILP (Fmemq (XCAR (c), Vwhile_no_input_ignore_events)) + && !end_time) /* We stopped being idle for this event; undo that. This prevents automatic window selection (under mouse-autoselect-window) from acting as a real input event, for @@ -3458,8 +3448,13 @@ readable_events (int flags) if (flags & READABLE_EVENTS_DO_TIMERS_NOW) timer_check (); - /* If the buffer contains only FOCUS_IN/OUT_EVENT events, and - READABLE_EVENTS_FILTER_EVENTS is set, report it as empty. */ + /* READABLE_EVENTS_FILTER_EVENTS is meant to be used only by + input-pending-p and similar callers, which aren't interested in + some input events. If this flag is set, and + input-pending-p-filter-events is non-nil, ignore events in + while-no-input-ignore-events. If the flag is set and + input-pending-p-filter-events is nil, ignore only + FOCUS_IN/OUT_EVENT events. */ if (kbd_fetch_ptr != kbd_store_ptr) { /* See https://lists.gnu.org/r/emacs-devel/2005-05/msg00297.html @@ -3478,8 +3473,11 @@ readable_events (int flags) #ifdef USE_TOOLKIT_SCROLL_BARS (flags & READABLE_EVENTS_FILTER_EVENTS) && #endif - (event->kind == FOCUS_IN_EVENT - || event->kind == FOCUS_OUT_EVENT)) + ((!input_pending_p_filter_events + && (event->kind == FOCUS_IN_EVENT + || event->kind == FOCUS_OUT_EVENT)) + || (input_pending_p_filter_events + && is_ignored_event (event)))) #ifdef USE_TOOLKIT_SCROLL_BARS && !((flags & READABLE_EVENTS_IGNORE_SQUEEZABLES) && (event->kind == SCROLL_BAR_CLICK_EVENT @@ -3661,29 +3659,10 @@ kbd_buffer_store_buffered_event (union buffered_input_event *event, #endif /* subprocesses */ } - Lisp_Object ignore_event; - - switch (event->kind) - { - case FOCUS_IN_EVENT: ignore_event = Qfocus_in; break; - case FOCUS_OUT_EVENT: ignore_event = Qfocus_out; break; - case HELP_EVENT: ignore_event = Qhelp_echo; break; - case ICONIFY_EVENT: ignore_event = Qiconify_frame; break; - case DEICONIFY_EVENT: ignore_event = Qmake_frame_visible; break; - case SELECTION_REQUEST_EVENT: ignore_event = Qselection_request; break; -#ifdef USE_FILE_NOTIFY - case FILE_NOTIFY_EVENT: ignore_event = Qfile_notify; break; -#endif -#ifdef HAVE_DBUS - case DBUS_EVENT: ignore_event = Qdbus_event; break; -#endif - default: ignore_event = Qnil; break; - } - /* If we're inside while-no-input, and this event qualifies as input, set quit-flag to cause an interrupt. */ if (!NILP (Vthrow_on_input) - && NILP (Fmemq (ignore_event, Vwhile_no_input_ignore_events))) + && !is_ignored_event (event)) Vquit_flag = Vthrow_on_input; } @@ -3887,7 +3866,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) @@ -3994,6 +3973,9 @@ kbd_buffer_get_event (KBOARD **kbp, *used_mouse_menu = true; FALLTHROUGH; #endif +#ifdef HAVE_PGTK + case PGTK_PREEDIT_TEXT_EVENT: +#endif #ifdef HAVE_NTGUI case END_SESSION_EVENT: case LANGUAGE_CHANGE_EVENT: @@ -4015,6 +3997,7 @@ kbd_buffer_get_event (KBOARD **kbp, #endif #ifdef HAVE_XWIDGETS case XWIDGET_EVENT: + case XWIDGET_DISPLAY_EVENT: #endif case SAVE_SESSION_EVENT: case NO_EVENT: @@ -4055,6 +4038,61 @@ kbd_buffer_get_event (KBOARD **kbp, and build a real event from the queue entry. */ if (NILP (obj)) { + double pinch_dx, pinch_dy, pinch_angle; + + /* Pinch events are often sent in rapid succession, so + large amounts of such events have the potential to + queue up inside the keyboard buffer. In that case, + find the last pinch event in succession on the same + frame with the same modifiers, and send that instead. */ + + if (event->ie.kind == PINCH_EVENT + /* Ignore if this is the start of a pinch sequence. + These events should always be sent so that we + never miss a sequence starting, and they don't + have the potential to queue up. */ + && ((pinch_dx + = XFLOAT_DATA (XCAR (event->ie.arg))) != 0.0 + || XFLOAT_DATA (XCAR (XCDR (event->ie.arg))) != 0.0 + || XFLOAT_DATA (Fnth (make_fixnum (3), event->ie.arg)) != 0.0)) + { + union buffered_input_event *maybe_event = next_kbd_event (event); + + pinch_dy = XFLOAT_DATA (XCAR (XCDR (event->ie.arg))); + pinch_angle = XFLOAT_DATA (Fnth (make_fixnum (3), event->ie.arg)); + + while (maybe_event != kbd_store_ptr + && maybe_event->ie.kind == PINCH_EVENT + /* Make sure we never miss an event that has + different modifiers. */ + && maybe_event->ie.modifiers == event->ie.modifiers + /* Make sure that the event is for the same + frame. */ + && EQ (maybe_event->ie.frame_or_window, + event->ie.frame_or_window) + /* Make sure that the event isn't the start + of a new pinch gesture sequence. */ + && (XFLOAT_DATA (XCAR (maybe_event->ie.arg)) != 0.0 + || XFLOAT_DATA (XCAR (XCDR (maybe_event->ie.arg))) != 0.0 + || XFLOAT_DATA (Fnth (make_fixnum (3), + maybe_event->ie.arg)) != 0.0)) + { + event = maybe_event; + /* Add up relative deltas inside events we skip. */ + pinch_dx += XFLOAT_DATA (XCAR (maybe_event->ie.arg)); + pinch_dy += XFLOAT_DATA (XCAR (XCDR (maybe_event->ie.arg))); + pinch_angle += XFLOAT_DATA (Fnth (make_fixnum (3), + maybe_event->ie.arg)); + + XSETCAR (maybe_event->ie.arg, make_float (pinch_dx)); + XSETCAR (XCDR (maybe_event->ie.arg), make_float (pinch_dy)); + XSETCAR (Fnthcdr (make_fixnum (3), + maybe_event->ie.arg), + make_float (fmod (pinch_angle, 360.0))); + maybe_event = next_kbd_event (event); + } + } + obj = make_lispy_event (&event->ie); #ifdef HAVE_EXT_MENU_BAR @@ -4484,6 +4522,7 @@ static Lisp_Object func_key_syms; static Lisp_Object mouse_syms; static Lisp_Object wheel_syms; static Lisp_Object drag_n_drop_syms; +static Lisp_Object pinch_syms; /* This is a list of keysym codes for special "accent" characters. It parallels lispy_accent_keys. */ @@ -4919,7 +4958,7 @@ static const char *const lispy_kana_keys[] = /* You'll notice that this table is arranged to be conveniently indexed by X Windows keysym values. */ -static const char *const lispy_function_keys[] = +const char *const lispy_function_keys[] = { /* X Keysym value */ @@ -6002,7 +6041,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)) @@ -6011,6 +6054,77 @@ make_lispy_event (struct input_event *event) return list2 (head, position); } + case TOUCH_END_EVENT: + { + Lisp_Object position; + + /* Build the position as appropriate for this mouse click. */ + struct frame *f = XFRAME (event->frame_or_window); + + if (! FRAME_LIVE_P (f)) + return Qnil; + + position = make_lispy_position (f, event->x, event->y, + event->timestamp); + + return list2 (Qtouch_end, position); + } + + case TOUCHSCREEN_BEGIN_EVENT: + case TOUCHSCREEN_END_EVENT: + { + Lisp_Object x, y, id, position; + struct frame *f = XFRAME (event->frame_or_window); + + id = event->arg; + x = event->x; + y = event->y; + + position = make_lispy_position (f, x, y, event->timestamp); + + return list2 (((event->kind + == TOUCHSCREEN_BEGIN_EVENT) + ? Qtouchscreen_begin + : Qtouchscreen_end), + Fcons (id, position)); + } + + case PINCH_EVENT: + { + Lisp_Object x, y, position; + struct frame *f = XFRAME (event->frame_or_window); + + x = event->x; + y = event->y; + + position = make_lispy_position (f, x, y, event->timestamp); + + return Fcons (modify_event_symbol (0, event->modifiers, Qpinch, + Qnil, (const char *[]) {"pinch"}, + &pinch_syms, 1), + Fcons (position, event->arg)); + } + + case TOUCHSCREEN_UPDATE_EVENT: + { + Lisp_Object x, y, id, position, tem, it, evt; + struct frame *f = XFRAME (event->frame_or_window); + evt = Qnil; + + for (tem = event->arg; CONSP (tem); tem = XCDR (tem)) + { + it = XCAR (tem); + + x = XCAR (it); + y = XCAR (XCDR (it)); + id = XCAR (XCDR (XCDR (it))); + + position = make_lispy_position (f, x, y, event->timestamp); + evt = Fcons (Fcons (id, position), evt); + } + + return list2 (Qtouchscreen_update, evt); + } #ifdef USE_TOOLKIT_SCROLL_BARS @@ -6145,23 +6259,20 @@ make_lispy_event (struct input_event *event) #ifdef HAVE_DBUS case DBUS_EVENT: - { - return Fcons (Qdbus_event, event->arg); - } + return Fcons (Qdbus_event, event->arg); #endif /* HAVE_DBUS */ #ifdef THREADS_ENABLED case THREAD_EVENT: - { - return Fcons (Qthread_event, event->arg); - } + return Fcons (Qthread_event, event->arg); #endif /* THREADS_ENABLED */ #ifdef HAVE_XWIDGETS case XWIDGET_EVENT: - { - return Fcons (Qxwidget_event, event->arg); - } + return Fcons (Qxwidget_event, event->arg); + + case XWIDGET_DISPLAY_EVENT: + return Fcons (Qxwidget_display_event, event->arg); #endif #ifdef USE_FILE_NOTIFY @@ -6178,6 +6289,11 @@ make_lispy_event (struct input_event *event) return list3 (Qconfig_changed_event, event->arg, event->frame_or_window); +#ifdef HAVE_PGTK + case PGTK_PREEDIT_TEXT_EVENT: + return list2 (intern ("pgtk-preedit-text"), event->arg); +#endif + /* The 'kind' field of the event is something we don't recognize. */ default: emacs_abort (); @@ -7205,7 +7321,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 (); @@ -7268,7 +7384,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) @@ -7284,7 +7400,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. */ @@ -7354,7 +7470,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 @@ -7857,7 +7973,9 @@ parse_menu_item (Lisp_Object item, int inmenubar) else if (EQ (tem, QCkeys)) { tem = XCAR (item); - if (CONSP (tem) || STRINGP (tem)) + if (FUNCTIONP (tem)) + ASET (item_properties, ITEM_PROPERTY_KEYEQ, call0 (tem)); + else if (CONSP (tem) || STRINGP (tem)) ASET (item_properties, ITEM_PROPERTY_KEYEQ, tem); } else if (EQ (tem, QCbutton) && CONSP (XCAR (item))) @@ -10185,7 +10303,8 @@ read_key_sequence (Lisp_Object *keybuf, Lisp_Object prompt, use the corresponding lower-case letter instead. */ if (NILP (current_binding) && /* indec.start >= t && fkey.start >= t && */ keytran.start >= t - && FIXNUMP (key)) + && FIXNUMP (key) + && translate_upper_case_key_bindings) { Lisp_Object new_key; EMACS_INT k = XFIXNUM (key); @@ -10237,12 +10356,14 @@ read_key_sequence (Lisp_Object *keybuf, Lisp_Object prompt, int modifiers = CONSP (breakdown) ? (XFIXNUM (XCAR (XCDR (breakdown)))) : 0; - if (modifiers & shift_modifier - /* Treat uppercase keys as shifted. */ - || (FIXNUMP (key) - && (KEY_TO_CHAR (key) - < XCHAR_TABLE (BVAR (current_buffer, downcase_table))->header.size) - && uppercasep (KEY_TO_CHAR (key)))) + if (translate_upper_case_key_bindings + && (modifiers & shift_modifier + /* Treat uppercase keys as shifted. */ + || (FIXNUMP (key) + && (KEY_TO_CHAR (key) + < XCHAR_TABLE (BVAR (current_buffer, + downcase_table))->header.size) + && uppercasep (KEY_TO_CHAR (key))))) { Lisp_Object new_key = (modifiers & shift_modifier @@ -11119,7 +11240,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) { @@ -11130,9 +11251,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) { @@ -11561,12 +11682,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 @@ -11618,6 +11743,52 @@ static const struct event_head head_table[] = { {SYMBOL_INDEX (Qselect_window), SYMBOL_INDEX (Qswitch_frame)} }; +static Lisp_Object +init_while_no_input_ignore_events (void) +{ + Lisp_Object events = listn (9, Qselect_window, Qhelp_echo, Qmove_frame, + Qiconify_frame, Qmake_frame_visible, + Qfocus_in, Qfocus_out, Qconfig_changed_event, + Qselection_request); + +#ifdef HAVE_DBUS + events = Fcons (Qdbus_event, events); +#endif +#ifdef USE_FILE_NOTIFY + events = Fcons (Qfile_notify, events); +#endif +#ifdef THREADS_ENABLED + events = Fcons (Qthread_event, events); +#endif + + return events; +} + +static bool +is_ignored_event (union buffered_input_event *event) +{ + Lisp_Object ignore_event; + + switch (event->kind) + { + case FOCUS_IN_EVENT: ignore_event = Qfocus_in; break; + case FOCUS_OUT_EVENT: ignore_event = Qfocus_out; break; + case HELP_EVENT: ignore_event = Qhelp_echo; break; + case ICONIFY_EVENT: ignore_event = Qiconify_frame; break; + case DEICONIFY_EVENT: ignore_event = Qmake_frame_visible; break; + case SELECTION_REQUEST_EVENT: ignore_event = Qselection_request; break; +#ifdef USE_FILE_NOTIFY + case FILE_NOTIFY_EVENT: ignore_event = Qfile_notify; break; +#endif +#ifdef HAVE_DBUS + case DBUS_EVENT: ignore_event = Qdbus_event; break; +#endif + default: ignore_event = Qnil; break; + } + + return !NILP (Fmemq (ignore_event, Vwhile_no_input_ignore_events)); +} + static void syms_of_keyboard_for_pdumper (void); void @@ -11704,12 +11875,15 @@ syms_of_keyboard (void) #ifdef HAVE_XWIDGETS DEFSYM (Qxwidget_event, "xwidget-event"); + DEFSYM (Qxwidget_display_event, "xwidget-display-event"); #endif #ifdef USE_FILE_NOTIFY DEFSYM (Qfile_notify, "file-notify"); #endif /* USE_FILE_NOTIFY */ + DEFSYM (Qtouch_end, "touch-end"); + /* Menu and tool bar item parts. */ DEFSYM (QCenable, ":enable"); DEFSYM (QCvisible, ":visible"); @@ -11869,6 +12043,9 @@ syms_of_keyboard (void) drag_n_drop_syms = Qnil; staticpro (&drag_n_drop_syms); + pinch_syms = Qnil; + staticpro (&pinch_syms); + unread_switch_frame = Qnil; staticpro (&unread_switch_frame); @@ -12205,6 +12382,10 @@ See also `pre-command-hook'. */); doc: /* Normal hook run when clearing the echo area. */); #endif DEFSYM (Qecho_area_clear_hook, "echo-area-clear-hook"); + DEFSYM (Qtouchscreen_begin, "touchscreen-begin"); + DEFSYM (Qtouchscreen_end, "touchscreen-end"); + DEFSYM (Qtouchscreen_update, "touchscreen-update"); + DEFSYM (Qpinch, "pinch"); Fset (Qecho_area_clear_hook, Qnil); DEFVAR_LISP ("lucid-menu-bar-dirty-flag", Vlucid_menu_bar_dirty_flag, @@ -12512,7 +12693,35 @@ If nil, Emacs crashes immediately in response to fatal signals. */); DEFVAR_LISP ("while-no-input-ignore-events", Vwhile_no_input_ignore_events, - doc: /* Ignored events from while-no-input. */); + doc: /* Ignored events from `while-no-input'. +Events in this list do not count as pending input while running +`while-no-input' and do not cause any idle timers to get reset when they +occur. */); + Vwhile_no_input_ignore_events = init_while_no_input_ignore_events (); + + DEFVAR_BOOL ("translate-upper-case-key-bindings", + translate_upper_case_key_bindings, + doc: /* If non-nil, interpret upper case keys as lower case (when applicable). +Emacs allows binding both upper and lower case key sequences to +commands. However, if there is a lower case key sequence bound to a +command, and the user enters an upper case key sequence that is not +bound to a command, Emacs will use the lower case binding. Setting +this variable to nil inhibits this behaviour. */); + translate_upper_case_key_bindings = true; + + DEFVAR_BOOL ("input-pending-p-filter-events", + input_pending_p_filter_events, + doc: /* If non-nil, `input-pending-p' ignores some input events. +If this variable is non-nil (the default), `input-pending-p' and +other similar functions ignore input events in `while-no-input-ignore-events'. +This flag may eventually be removed once this behavior is deemed safe. */); + input_pending_p_filter_events = true; + + DEFVAR_BOOL ("mwheel-coalesce-scroll-events", mwheel_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. */); + mwheel_coalesce_scroll_events = true; pdumper_do_now_and_after_load (syms_of_keyboard_for_pdumper); } @@ -12562,6 +12771,8 @@ keys_of_keyboard (void) "ns-put-working-text"); initial_define_lispy_key (Vspecial_event_map, "ns-unput-working-text", "ns-unput-working-text"); + initial_define_lispy_key (Vspecial_event_map, "pgtk-preedit-text", + "pgtk-preedit-text"); /* Here we used to use `ignore-event' which would simple set prefix-arg to current-prefix-arg, as is done in `handle-switch-frame'. But `handle-switch-frame is not run from the special-map. diff --git a/src/keyboard.h b/src/keyboard.h index 8bdffaa2bff..26b910ba7e0 100644 --- a/src/keyboard.h +++ b/src/keyboard.h @@ -491,7 +491,7 @@ extern void process_pending_signals (void); extern struct timespec timer_check (void); extern void mark_kboards (void); -#ifdef HAVE_NTGUI +#if defined HAVE_NTGUI || defined HAVE_X_WINDOWS || defined HAVE_PGTK extern const char *const lispy_function_keys[]; #endif diff --git a/src/keymap.c b/src/keymap.c index 28ff71c01da..0b882958b94 100644 --- a/src/keymap.c +++ b/src/keymap.c @@ -65,12 +65,16 @@ static Lisp_Object exclude_keys; /* Pre-allocated 2-element vector for Fcommand_remapping to use. */ static Lisp_Object command_remapping_vector; +/* Char table for the backwards-compatibility part in Flookup_key. */ +static Lisp_Object unicode_case_table; + /* Hash table used to cache a reverse-map to speed up calls to where-is. */ 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, @@ -127,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, @@ -726,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; @@ -802,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; @@ -835,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) @@ -848,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; } @@ -1027,10 +1046,35 @@ is not copied. */) /* Simple Keymap mutators and accessors. */ +static Lisp_Object +possibly_translate_key_sequence (Lisp_Object key, ptrdiff_t *length) +{ + if (VECTORP (key) && ASIZE (key) == 1 && STRINGP (AREF (key, 0))) + { + /* KEY is on the ["C-c"] format, so translate to internal + format. */ + if (NILP (Ffboundp (Qkey_valid_p))) + xsignal2 (Qerror, + build_string ("`key-valid-p' is not defined, so this syntax can't be used: %s"), + key); + 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 `key-parse' syntax: %S"), key); + } + + return key; +} + /* 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 @@ -1050,15 +1094,23 @@ DEF is anything that can be a key's definition: 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), + (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'.) +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; @@ -1085,6 +1137,8 @@ binding KEY to DEF is added at the front of KEYMAP. */) def = tmp; } + key = possibly_translate_key_sequence (key, &length); + ptrdiff_t idx = 0; while (1) { @@ -1126,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); @@ -1195,6 +1249,8 @@ lookup_key_1 (Lisp_Object keymap, Lisp_Object key, Lisp_Object accept_default) if (length == 0) return keymap; + key = possibly_translate_key_sequence (key, &length); + ptrdiff_t idx = 0; while (1) { @@ -1229,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. @@ -1251,39 +1310,126 @@ recognize the default bindings, just as `read-key-sequence' does. */) return found; /* Menu definitions might use mixed case symbols (notably in old - versions of `easy-menu-define'). We accept this variation for - backwards-compatibility. (Bug#50752) */ - ptrdiff_t key_len = VECTORP (key) ? ASIZE (key) : 0; - if (key_len > 0 && EQ (AREF (key, 0), Qmenu_bar)) + versions of `easy-menu-define'), or use " " instead of "-". + The rest of this function is about accepting these variations for + backwards-compatibility. (Bug#50752) */ + + /* Just skip everything below unless this is a menu item. */ + if (!VECTORP (key) || !(ASIZE (key) > 0) + || !EQ (AREF (key, 0), Qmenu_bar)) + return found; + + /* Initialize the unicode case table, if it wasn't already. */ + if (NILP (unicode_case_table)) + { + unicode_case_table = uniprop_table (intern ("lowercase")); + /* uni-lowercase.el might be unavailable during bootstrap. */ + if (NILP (unicode_case_table)) + return found; + staticpro (&unicode_case_table); + } + + ptrdiff_t key_len = ASIZE (key); + Lisp_Object new_key = make_vector (key_len, Qnil); + + /* Try both the Unicode case table, and the buffer local one. + Otherwise, we will fail for e.g. the "Turkish" language + environment where 'I' does not downcase to 'i'. */ + Lisp_Object tables[2] = {unicode_case_table, Fcurrent_case_table ()}; + for (int tbl_num = 0; tbl_num < 2; tbl_num++) { - Lisp_Object new_key = make_vector (key_len, Qnil); - for (int i = 0; i < key_len; ++i) + /* First, let's try converting all symbols like "Foo-Bar-Baz" to + "foo-bar-baz". */ + for (int i = 0; i < key_len; i++) { Lisp_Object item = AREF (key, i); if (!SYMBOLP (item)) ASET (new_key, i, item); else { - Lisp_Object sym = Fsymbol_name (item); - USE_SAFE_ALLOCA; - unsigned char *dst = SAFE_ALLOCA (SBYTES (sym) + 1); - memcpy (dst, SSDATA (sym), SBYTES (sym)); - /* We can walk the string data byte by byte, because - UTF-8 encoding ensures that no other byte of any - multibyte sequence will ever include a 7-bit byte - equal to an ASCII single-byte character. */ - for (int j = 0; j < SBYTES (sym); ++j) - if (dst[j] >= 'A' && dst[j] <= 'Z') - dst[j] += 'a' - 'A'; /* Convert to lower case. */ - ASET (new_key, i, Fintern (make_multibyte_string ((char *) dst, - SCHARS (sym), - SBYTES (sym)), - Qnil)); - SAFE_FREE (); + Lisp_Object key_item = Fsymbol_name (item); + Lisp_Object new_item; + if (!STRING_MULTIBYTE (key_item)) + new_item = Fdowncase (key_item); + else + { + USE_SAFE_ALLOCA; + ptrdiff_t size = SCHARS (key_item), n; + if (INT_MULTIPLY_WRAPV (size, MAX_MULTIBYTE_LENGTH, &n)) + n = PTRDIFF_MAX; + unsigned char *dst = SAFE_ALLOCA (n); + unsigned char *p = dst; + ptrdiff_t j_char = 0, j_byte = 0; + + while (j_char < size) + { + int ch = fetch_string_char_advance (key_item, + &j_char, &j_byte); + Lisp_Object ch_conv = CHAR_TABLE_REF (tables[tbl_num], + ch); + if (!NILP (ch_conv)) + CHAR_STRING (XFIXNUM (ch_conv), p); + else + CHAR_STRING (ch, p); + p = dst + j_byte; + } + new_item = make_multibyte_string ((char *) dst, + SCHARS (key_item), + SBYTES (key_item)); + SAFE_FREE (); + } + ASET (new_key, i, Fintern (new_item, Qnil)); + } + } + + /* Check for match. */ + found = lookup_key_1 (keymap, new_key, accept_default); + if (!NILP (found) && !NUMBERP (found)) + break; + + /* If we still don't have a match, let's convert any spaces in + our lowercased string into dashes, e.g. "foo bar baz" to + "foo-bar-baz". */ + for (int i = 0; i < key_len; i++) + { + if (!SYMBOLP (AREF (new_key, i))) + continue; + + Lisp_Object lc_key = Fsymbol_name (AREF (new_key, i)); + + /* If there are no spaces in this symbol, just skip it. */ + if (!strstr (SSDATA (lc_key), " ")) + continue; + + USE_SAFE_ALLOCA; + ptrdiff_t size = SCHARS (lc_key), n; + if (INT_MULTIPLY_WRAPV (size, MAX_MULTIBYTE_LENGTH, &n)) + n = PTRDIFF_MAX; + unsigned char *dst = SAFE_ALLOCA (n); + + /* We can walk the string data byte by byte, because UTF-8 + encoding ensures that no other byte of any multibyte + sequence will ever include a 7-bit byte equal to an ASCII + single-byte character. */ + memcpy (dst, SSDATA (lc_key), SBYTES (lc_key)); + for (int i = 0; i < SBYTES (lc_key); ++i) + { + if (dst[i] == ' ') + dst[i] = '-'; } + Lisp_Object new_it = + make_multibyte_string ((char *) dst, + SCHARS (lc_key), SBYTES (lc_key)); + ASET (new_key, i, Fintern (new_it, Qnil)); + SAFE_FREE (); } + + /* Check for match. */ found = lookup_key_1 (keymap, new_key, accept_default); + if (!NILP (found) && !NUMBERP (found)) + break; } + return found; } @@ -1295,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; } @@ -2815,7 +2961,10 @@ You type Translation\n\ { if (EQ (start1, BVAR (XBUFFER (buffer), keymap))) { - Lisp_Object msg = build_unibyte_string ("\f\nMajor Mode Bindings"); + Lisp_Object msg = + CALLN (Fformat, + build_unibyte_string ("\f\n`%s' Major Mode Bindings"), + XBUFFER (buffer)->major_mode_); CALLN (Ffuncall, Qdescribe_map_tree, start1, Qt, shadow, prefix, @@ -3308,4 +3457,7 @@ that describe key bindings. That is why the default is nil. */); defsubr (&Stext_char_description); defsubr (&Swhere_is_internal); defsubr (&Sdescribe_buffer_bindings); + + DEFSYM (Qkey_parse, "key-parse"); + DEFSYM (Qkey_valid_p, "key-valid-p"); } diff --git a/src/lisp.h b/src/lisp.h index af8a8451933..1518d4a8690 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 @@ -251,6 +259,11 @@ DEFINE_GDB_SYMBOL_BEGIN (EMACS_INT, VALMASK) # define VALMASK (USE_LSB_TAG ? - (1 << GCTYPEBITS) : VAL_MAX) DEFINE_GDB_SYMBOL_END (VALMASK) +/* Ignore 'alignas' on compilers lacking it. */ +#if !defined alignas && !defined __alignas_is_defined +# define alignas(a) +#endif + /* Minimum alignment requirement for Lisp objects, imposed by the internal representation of tagged pointers. It is 2**GCTYPEBITS if USE_LSB_TAG, 1 otherwise. It must be a literal integer constant, @@ -941,7 +954,7 @@ typedef EMACS_UINT Lisp_Word_tag; ? ((y) - 1 + (x)) & ~ ((y) - 1) \ : ((y) - 1 + (x)) - ((y) - 1 + (x)) % (y)) -#include "globals.h" +#include <globals.h> /* Header of vector-like objects. This documents the layout constraints on vectors and pseudovectors (objects of PVEC_xxx subtype). It also prevents @@ -1070,6 +1083,7 @@ enum pvec_type PVEC_CONDVAR, PVEC_MODULE_FUNCTION, PVEC_NATIVE_COMP_UNIT, + PVEC_SQLITE, /* These should be last, for internal_equal and sxhash_obj. */ PVEC_COMPILED, @@ -2557,6 +2571,17 @@ xmint_pointer (Lisp_Object a) return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Misc_Ptr)->pointer; } +struct Lisp_Sqlite +{ + union vectorlike_header header; + void *db; + void *stmt; + char *name; + void (*finalizer) (void *); + bool eof; + bool is_statement; +} GCALIGNED_STRUCT; + struct Lisp_User_Ptr { union vectorlike_header header; @@ -2635,6 +2660,31 @@ XUSER_PTR (Lisp_Object a) } INLINE bool +SQLITEP (Lisp_Object x) +{ + return PSEUDOVECTORP (x, PVEC_SQLITE); +} + +INLINE bool +SQLITE (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_SQLITE); +} + +INLINE void +CHECK_SQLITE (Lisp_Object x) +{ + CHECK_TYPE (SQLITE (x), Qsqlitep, x); +} + +INLINE struct Lisp_Sqlite * +XSQLITE (Lisp_Object a) +{ + eassert (SQLITEP (a)); + return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Sqlite); +} + +INLINE bool BIGNUMP (Lisp_Object x) { return PSEUDOVECTORP (x, PVEC_BIGNUM); @@ -3332,7 +3382,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 @@ -3780,6 +3830,9 @@ extern Lisp_Object safe_eval (Lisp_Object); extern bool pos_visible_p (struct window *, ptrdiff_t, int *, int *, int *, int *, int *, int *); +/* Defined in sqlite.c. */ +extern void syms_of_sqlite (void); + /* Defined in xsettings.c. */ extern void syms_of_xsettings (void); @@ -3949,7 +4002,8 @@ build_string (const char *str) extern Lisp_Object pure_cons (Lisp_Object, Lisp_Object); extern Lisp_Object make_vector (ptrdiff_t, Lisp_Object); -extern struct Lisp_Vector *allocate_nil_vector (ptrdiff_t); +extern struct Lisp_Vector *allocate_nil_vector (ptrdiff_t) + ATTRIBUTE_RETURNS_NONNULL; /* Make an uninitialized vector for SIZE objects. NOTE: you must be sure that GC cannot happen until the vector is completely @@ -3962,7 +4016,8 @@ extern struct Lisp_Vector *allocate_nil_vector (ptrdiff_t); allocate_vector has a similar problem. */ -extern struct Lisp_Vector *allocate_vector (ptrdiff_t); +extern struct Lisp_Vector *allocate_vector (ptrdiff_t) + ATTRIBUTE_RETURNS_NONNULL; INLINE Lisp_Object make_uninit_vector (ptrdiff_t size) @@ -3994,7 +4049,8 @@ make_nil_vector (ptrdiff_t size) } extern struct Lisp_Vector *allocate_pseudovector (int, int, int, - enum pvec_type); + enum pvec_type) + ATTRIBUTE_RETURNS_NONNULL; /* Allocate uninitialized pseudovector with no Lisp_Object slots. */ @@ -4026,7 +4082,7 @@ extern void free_cons (struct Lisp_Cons *); extern void init_alloc_once (void); extern void init_alloc (void); extern void syms_of_alloc (void); -extern struct buffer * allocate_buffer (void); +extern struct buffer *allocate_buffer (void) ATTRIBUTE_RETURNS_NONNULL; extern int valid_lisp_object_p (Lisp_Object); /* Defined in gmalloc.c. */ @@ -4184,7 +4240,8 @@ extern Lisp_Object internal_condition_case_n (Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *, Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *)); extern Lisp_Object internal_catch_all (Lisp_Object (*) (void *), void *, Lisp_Object (*) (enum nonlocal_exit, Lisp_Object)); -extern struct handler *push_handler (Lisp_Object, enum handlertype); +extern struct handler *push_handler (Lisp_Object, enum handlertype) + ATTRIBUTE_RETURNS_NONNULL; extern struct handler *push_handler_nosignal (Lisp_Object, enum handlertype); extern void specbind (Lisp_Object, Lisp_Object); extern void record_unwind_protect (void (*) (Lisp_Object), Lisp_Object); @@ -4325,9 +4382,10 @@ extern void syms_of_marker (void); /* Defined in fileio.c. */ -extern char *splice_dir_file (char *, char const *, char const *); +extern char *splice_dir_file (char *, char const *, char const *) + ATTRIBUTE_RETURNS_NONNULL; extern bool file_name_absolute_p (const char *); -extern char const *get_homedir (void); +extern char const *get_homedir (void) ATTRIBUTE_RETURNS_NONNULL; extern Lisp_Object expand_and_dir_to_file (Lisp_Object); extern Lisp_Object write_region (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, @@ -4426,7 +4484,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; @@ -4481,7 +4539,7 @@ INLINE void fixup_locale (void) {} INLINE void synchronize_system_messages_locale (void) {} INLINE void synchronize_system_time_locale (void) {} #endif -extern char *emacs_strerror (int); +extern char *emacs_strerror (int) ATTRIBUTE_RETURNS_NONNULL; extern void shut_down_emacs (int, Lisp_Object); /* True means don't do interactive redisplay and don't change tty modes. */ @@ -4547,7 +4605,7 @@ extern void setup_process_coding_systems (Lisp_Object); extern int emacs_spawn (pid_t *, int, int, int, char **, char **, const char *, const char *, const sigset_t *); -extern char **make_environment_block (Lisp_Object); +extern char **make_environment_block (Lisp_Object) ATTRIBUTE_RETURNS_NONNULL; extern void init_callproc_1 (void); extern void init_callproc (void); extern void set_initial_environment (void); @@ -4816,17 +4874,24 @@ extern char my_edata[]; extern char my_endbss[]; extern char *my_endbss_static; -extern void *xmalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1)); -extern void *xzalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1)); -extern void *xrealloc (void *, size_t) ATTRIBUTE_ALLOC_SIZE ((2)); +extern void *xmalloc (size_t) + ATTRIBUTE_MALLOC_SIZE ((1)) ATTRIBUTE_RETURNS_NONNULL; +extern void *xzalloc (size_t) + ATTRIBUTE_MALLOC_SIZE ((1)) ATTRIBUTE_RETURNS_NONNULL; +extern void *xrealloc (void *, size_t) + ATTRIBUTE_ALLOC_SIZE ((2)) ATTRIBUTE_RETURNS_NONNULL; extern void xfree (void *); -extern void *xnmalloc (ptrdiff_t, ptrdiff_t) ATTRIBUTE_MALLOC_SIZE ((1,2)); +extern void *xnmalloc (ptrdiff_t, ptrdiff_t) + ATTRIBUTE_MALLOC_SIZE ((1,2)) ATTRIBUTE_RETURNS_NONNULL; extern void *xnrealloc (void *, ptrdiff_t, ptrdiff_t) - ATTRIBUTE_ALLOC_SIZE ((2,3)); -extern void *xpalloc (void *, ptrdiff_t *, ptrdiff_t, ptrdiff_t, ptrdiff_t); - -extern char *xstrdup (const char *) ATTRIBUTE_MALLOC; -extern char *xlispstrdup (Lisp_Object) ATTRIBUTE_MALLOC; + ATTRIBUTE_ALLOC_SIZE ((2,3)) ATTRIBUTE_RETURNS_NONNULL; +extern void *xpalloc (void *, ptrdiff_t *, ptrdiff_t, ptrdiff_t, ptrdiff_t) + ATTRIBUTE_RETURNS_NONNULL; + +extern char *xstrdup (char const *) + ATTRIBUTE_MALLOC ATTRIBUTE_RETURNS_NONNULL; +extern char *xlispstrdup (Lisp_Object) + ATTRIBUTE_MALLOC ATTRIBUTE_RETURNS_NONNULL; extern void dupstring (char **, char const *); /* Make DEST a copy of STRING's data. Return a pointer to DEST's terminating @@ -4876,7 +4941,8 @@ extern void init_system_name (void); enum MAX_ALLOCA { MAX_ALLOCA = 16 * 1024 }; -extern void *record_xmalloc (size_t) ATTRIBUTE_ALLOC_SIZE ((1)); +extern void *record_xmalloc (size_t) + ATTRIBUTE_ALLOC_SIZE ((1)) ATTRIBUTE_RETURNS_NONNULL; #define USE_SAFE_ALLOCA \ ptrdiff_t sa_avail = MAX_ALLOCA; \ diff --git a/src/lread.c b/src/lread.c index 9bb5f66adf3..55b3d473dce 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1045,12 +1045,18 @@ lisp_file_lexically_bound_p (Lisp_Object readcharfun) safe to load. Only files compiled with Emacs can be loaded. */ static int -safe_to_load_version (int fd) +safe_to_load_version (Lisp_Object file, int fd) { + struct stat st; char buf[512]; int nbytes, i; int version = 1; + /* If the file is not regular, then we cannot safely seek it. + Assume that it is not safe to load as a compiled file. */ + if (fstat (fd, &st) == 0 && !S_ISREG (st.st_mode)) + return 0; + /* Read the first few bytes from the file, and look for a line specifying the byte compiler version used. */ nbytes = emacs_read_quit (fd, buf, sizeof buf); @@ -1068,7 +1074,9 @@ safe_to_load_version (int fd) version = 0; } - lseek (fd, 0, SEEK_SET); + if (lseek (fd, 0, SEEK_SET) < 0) + report_file_error ("Seeking to start of file", file); + return version; } @@ -1407,7 +1415,7 @@ Return t if the file exists and loads successfully. */) if (is_elc /* version = 1 means the file is empty, in which case we can treat it as not byte-compiled. */ - || (fd >= 0 && (version = safe_to_load_version (fd)) > 1)) + || (fd >= 0 && (version = safe_to_load_version (file, fd)) > 1)) /* Load .elc files directly, but not when they are remote and have no handler! */ { @@ -1416,11 +1424,8 @@ Return t if the file exists and loads successfully. */) struct stat s1, s2; int result; - if (version < 0 - && ! (version = safe_to_load_version (fd))) - { - error ("File `%s' was not compiled in Emacs", SDATA (found)); - } + if (version < 0 && !(version = safe_to_load_version (file, fd))) + error ("File `%s' was not compiled in Emacs", SDATA (found)); compiled = 1; @@ -1540,7 +1545,7 @@ Return t if the file exists and loads successfully. */) message_with_string ("Loading %s...", file, 1); } - specbind (Qload_file_name, found_eff); + specbind (Qload_file_name, hist_file_name); specbind (Qload_true_file_name, found); specbind (Qinhibit_file_name_operation, Qnil); specbind (Qload_in_progress, Qt); @@ -2204,6 +2209,7 @@ readevalloop (Lisp_Object readcharfun, specbind (Qinternal_interpreter_environment, (NILP (lex_bound) || EQ (lex_bound, Qunbound) ? Qnil : list1 (Qt))); + specbind (Qmacroexp__dynvars, Vmacroexp__dynvars); /* Ensure sourcename is absolute, except whilst preloading. */ if (!will_dump_p () @@ -2710,7 +2716,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. */ @@ -3218,23 +3224,6 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) Fstring_as_unibyte (AREF (tmp, COMPILED_BYTECODE))); } - if (COMPILED_DOC_STRING < ASIZE (tmp) - && EQ (AREF (tmp, COMPILED_DOC_STRING), make_fixnum (0))) - { - /* read_list found a docstring like '(#$ . 5521)' and treated it - as 0. This placeholder 0 would lead to accidental sharing in - purecopy's hash-consing, so replace it with a (hopefully) - unique integer placeholder, which is negative so that it is - not confused with a DOC file offset (the USE_LSB_TAG shift - relies on the fact that VALMASK is one bit narrower than - INTMASK). Eventually Snarf-documentation should replace the - placeholder with the actual docstring. */ - verify (INTMASK & ~VALMASK); - EMACS_UINT hash = ((XHASH (tmp) >> USE_LSB_TAG) - | (INTMASK - INTMASK / 2)); - ASET (tmp, COMPILED_DOC_STRING, make_ufixnum (hash)); - } - XSETPVECTYPE (vec, PVEC_COMPILED); return tmp; } @@ -4202,31 +4191,13 @@ read_list (bool flag, Lisp_Object readcharfun) /* While building, if the list starts with #$, treat it specially. */ if (EQ (elt, Vload_file_name) - && ! NILP (elt) - && !NILP (Vpurify_flag)) + && ! NILP (elt)) { - if (NILP (Vdoc_file_name)) - /* We have not yet called Snarf-documentation, so assume - this file is described in the DOC file - and Snarf-documentation will fill in the right value later. - For now, replace the whole list with 0. */ - doc_reference = 1; - else - /* We have already called Snarf-documentation, so make a relative - file name for this file, so it can be found properly - in the installed Lisp directory. - We don't use Fexpand_file_name because that would make - the directory absolute now. */ - { - AUTO_STRING (dot_dot_lisp, "../lisp/"); - elt = concat2 (dot_dot_lisp, Ffile_name_nondirectory (elt)); - } + if (!NILP (Vpurify_flag)) + doc_reference = 0; + else if (load_force_doc_strings) + doc_reference = 2; } - else if (EQ (elt, Vload_file_name) - && ! NILP (elt) - && load_force_doc_strings) - doc_reference = 2; - if (ch) { if (flag > 0) @@ -4247,8 +4218,6 @@ read_list (bool flag, Lisp_Object readcharfun) if (ch == ')') { - if (doc_reference == 1) - return make_fixnum (0); if (doc_reference == 2 && FIXNUMP (XCDR (val))) { char *saved = NULL; @@ -5464,4 +5433,10 @@ This variable's value can only be set via file-local variables. See Info node `(elisp)Shorthands' for more details. */); Vread_symbol_shorthands = Qnil; DEFSYM (Qobarray_cache, "obarray-cache"); + + DEFSYM (Qmacroexp__dynvars, "macroexp--dynvars"); + DEFVAR_LISP ("macroexp--dynvars", Vmacroexp__dynvars, + doc: /* List of variables declared dynamic in the current scope. +Only valid during macro-expansion. Internal use only. */); + Vmacroexp__dynvars = Qnil; } diff --git a/src/macfont.m b/src/macfont.m index 78ed5d53f39..3f87c1be76d 100644 --- a/src/macfont.m +++ b/src/macfont.m @@ -598,9 +598,9 @@ mac_screen_font_shape (ScreenFontRef font, CFStringRef string, } static CGColorRef -get_cgcolor(unsigned long idx, struct frame *f) +get_cgcolor(unsigned long color) { - NSColor *nsColor = ns_lookup_indexed_color (idx, f); + NSColor *nsColor = [NSColor colorWithUnsignedLong:color]; [nsColor set]; CGColorSpaceRef colorSpace = [[nsColor colorSpace] CGColorSpace]; NSInteger noc = [nsColor numberOfComponents]; @@ -613,21 +613,36 @@ get_cgcolor(unsigned long idx, struct frame *f) return cgColor; } -#define CG_SET_FILL_COLOR_WITH_FACE_FOREGROUND(context, face, f) \ +static CGColorRef +get_cgcolor_from_nscolor (NSColor *nsColor, struct frame *f) +{ + [nsColor set]; + CGColorSpaceRef colorSpace = [[nsColor colorSpace] CGColorSpace]; + NSInteger noc = [nsColor numberOfComponents]; + CGFloat *components = xmalloc (sizeof(CGFloat)*(1+noc)); + CGColorRef cgColor; + + [nsColor getComponents: components]; + cgColor = CGColorCreate (colorSpace, components); + xfree (components); + return cgColor; +} + +#define CG_SET_FILL_COLOR_WITH_FACE_FOREGROUND(context, face) \ do { \ - CGColorRef refcol_ = get_cgcolor (NS_FACE_FOREGROUND (face), f); \ + CGColorRef refcol_ = get_cgcolor (NS_FACE_FOREGROUND (face)); \ CGContextSetFillColorWithColor (context, refcol_) ; \ CGColorRelease (refcol_); \ } while (0) -#define CG_SET_FILL_COLOR_WITH_FACE_BACKGROUND(context, face, f) \ +#define CG_SET_FILL_COLOR_WITH_FACE_BACKGROUND(context, face) \ do { \ - CGColorRef refcol_ = get_cgcolor (NS_FACE_BACKGROUND (face), f); \ + CGColorRef refcol_ = get_cgcolor (NS_FACE_BACKGROUND (face)); \ CGContextSetFillColorWithColor (context, refcol_); \ CGColorRelease (refcol_); \ } while (0) -#define CG_SET_STROKE_COLOR_WITH_FACE_FOREGROUND(context, face, f) \ +#define CG_SET_STROKE_COLOR_WITH_FACE_FOREGROUND(context, face) \ do { \ - CGColorRef refcol_ = get_cgcolor (NS_FACE_FOREGROUND (face), f); \ + CGColorRef refcol_ = get_cgcolor (NS_FACE_FOREGROUND (face)); \ CGContextSetStrokeColorWithColor (context, refcol_); \ CGColorRelease (refcol_); \ } while (0) @@ -2911,14 +2926,14 @@ macfont_draw (struct glyph_string *s, int from, int to, int x, int y, if (!CGRectIsNull (background_rect)) { - if (s->hl == DRAW_MOUSE_FACE) + if (s->hl == DRAW_CURSOR) { - face = FACE_FROM_ID_OR_NULL (s->f, - MOUSE_HL_INFO (s->f)->mouse_face_face_id); - if (!face) - face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); + CGColorRef colorref = get_cgcolor_from_nscolor (FRAME_CURSOR_COLOR (f), f); + CGContextSetFillColorWithColor (context, colorref); + CGColorRelease (colorref); } - CG_SET_FILL_COLOR_WITH_FACE_BACKGROUND (context, face, f); + else + CG_SET_FILL_COLOR_WITH_FACE_BACKGROUND (context, face); CGContextFillRects (context, &background_rect, 1); } @@ -2927,7 +2942,14 @@ macfont_draw (struct glyph_string *s, int from, int to, int x, int y, CGAffineTransform atfm; CGContextScaleCTM (context, 1, -1); - CG_SET_FILL_COLOR_WITH_FACE_FOREGROUND (context, face, s->f); + if (s->hl == DRAW_CURSOR) + { + CGColorRef colorref = get_cgcolor_from_nscolor (FRAME_BACKGROUND_COLOR (f), f); + CGContextSetFillColorWithColor (context, colorref); + CGColorRelease (colorref); + } + else + CG_SET_FILL_COLOR_WITH_FACE_FOREGROUND (context, face); if (macfont_info->synthetic_italic_p) atfm = synthetic_italic_atfm; else @@ -2956,7 +2978,7 @@ macfont_draw (struct glyph_string *s, int from, int to, int x, int y, #if MAC_OS_X_VERSION_MIN_REQUIRED < 1070 CGContextSetLineWidth (context, synthetic_bold_factor * font_size); #endif - CG_SET_STROKE_COLOR_WITH_FACE_FOREGROUND (context, face, f); + CG_SET_STROKE_COLOR_WITH_FACE_FOREGROUND (context, face); } if (no_antialias_p) CGContextSetShouldAntialias (context, false); diff --git a/src/menu.c b/src/menu.c index 1aafa78c3ce..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)); -#if defined (USE_X_TOOLKIT) || defined (USE_GTK) || defined (HAVE_NS) || defined (HAVE_NTGUI) +#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/menu.h b/src/menu.h index 6c67ab20bb0..30b946c0ea4 100644 --- a/src/menu.h +++ b/src/menu.h @@ -59,6 +59,12 @@ extern Lisp_Object ns_menu_show (struct frame *, int, int, int, Lisp_Object, const char **); extern void ns_activate_menubar (struct frame *); #endif +#ifdef HAVE_PGTK +extern Lisp_Object pgtk_menu_show (struct frame *, int, int, int, + Lisp_Object, const char **); +extern void pgtk_activate_menubar (struct frame *); +#endif + extern Lisp_Object tty_menu_show (struct frame *, int, int, int, Lisp_Object, const char **); extern ptrdiff_t menu_item_width (const unsigned char *); diff --git a/src/minibuf.c b/src/minibuf.c index 4b72d3e896b..6c0cd358c50 100644 --- a/src/minibuf.c +++ b/src/minibuf.c @@ -1005,7 +1005,7 @@ set_minibuffer_mode (Lisp_Object buf, EMACS_INT depth) if (!NILP (Ffboundp (Qminibuffer_inactive_mode))) call0 (Qminibuffer_inactive_mode); else - Fkill_all_local_variables (); + Fkill_all_local_variables (Qnil); } buf = unbind_to (count, buf); } @@ -1545,6 +1545,27 @@ minibuf_conform_representation (Lisp_Object string, Lisp_Object basis) return Fstring_make_multibyte (string); } +static bool +match_regexps (Lisp_Object string, Lisp_Object regexps, + bool ignore_case) +{ + ptrdiff_t val; + for (; CONSP (regexps); regexps = XCDR (regexps)) + { + CHECK_STRING (XCAR (regexps)); + + val = fast_string_match_internal + (XCAR (regexps), string, + (ignore_case ? BVAR (current_buffer, case_canon_table) : Qnil)); + + if (val == -2) + error ("Stack overflow in regexp matcher"); + if (val < 0) + return false; + } + return true; +} + DEFUN ("try-completion", Ftry_completion, Stry_completion, 2, 3, 0, doc: /* Return common substring of all completions of STRING in COLLECTION. Test each possible completion specified by COLLECTION @@ -1578,6 +1599,7 @@ Additionally to this predicate, `completion-regexp-list' is used to further constrain the set of candidates. */) (Lisp_Object string, Lisp_Object collection, Lisp_Object predicate) { + Lisp_Object bestmatch, tail, elt, eltstring; /* Size in bytes of BESTMATCH. */ ptrdiff_t bestmatchsize = 0; @@ -1591,7 +1613,6 @@ is used to further constrain the set of candidates. */) ? list_table : function_table)); ptrdiff_t idx = 0, obsize = 0; int matchcount = 0; - ptrdiff_t bindcount = -1; Lisp_Object bucket, zero, end, tem; CHECK_STRING (string); @@ -1670,27 +1691,10 @@ is used to further constrain the set of candidates. */) completion_ignore_case ? Qt : Qnil), EQ (Qt, tem))) { - /* Yes. */ - Lisp_Object regexps; - /* Ignore this element if it fails to match all the regexps. */ - { - for (regexps = Vcompletion_regexp_list; CONSP (regexps); - regexps = XCDR (regexps)) - { - if (bindcount < 0) - { - bindcount = SPECPDL_INDEX (); - specbind (Qcase_fold_search, - completion_ignore_case ? Qt : Qnil); - } - tem = Fstring_match (XCAR (regexps), eltstring, zero); - if (NILP (tem)) - break; - } - if (CONSP (regexps)) - continue; - } + if (!match_regexps (eltstring, Vcompletion_regexp_list, + completion_ignore_case)) + continue; /* Ignore this element if there is a predicate and the predicate doesn't like it. */ @@ -1701,11 +1705,6 @@ is used to further constrain the set of candidates. */) tem = Fcommandp (elt, Qnil); else { - if (bindcount >= 0) - { - unbind_to (bindcount, Qnil); - bindcount = -1; - } tem = (type == hash_table ? call2 (predicate, elt, HASH_VALUE (XHASH_TABLE (collection), @@ -1787,9 +1786,6 @@ is used to further constrain the set of candidates. */) } } - if (bindcount >= 0) - unbind_to (bindcount, Qnil); - if (NILP (bestmatch)) return Qnil; /* No completions found. */ /* If we are ignoring case, and there is no exact match, @@ -1849,7 +1845,6 @@ with a space are ignored unless STRING itself starts with a space. */) : VECTORP (collection) ? 2 : NILP (collection) || (CONSP (collection) && !FUNCTIONP (collection)); ptrdiff_t idx = 0, obsize = 0; - ptrdiff_t bindcount = -1; Lisp_Object bucket, tem, zero; CHECK_STRING (string); @@ -1934,27 +1929,10 @@ with a space are ignored unless STRING itself starts with a space. */) completion_ignore_case ? Qt : Qnil), EQ (Qt, tem))) { - /* Yes. */ - Lisp_Object regexps; - /* Ignore this element if it fails to match all the regexps. */ - { - for (regexps = Vcompletion_regexp_list; CONSP (regexps); - regexps = XCDR (regexps)) - { - if (bindcount < 0) - { - bindcount = SPECPDL_INDEX (); - specbind (Qcase_fold_search, - completion_ignore_case ? Qt : Qnil); - } - tem = Fstring_match (XCAR (regexps), eltstring, zero); - if (NILP (tem)) - break; - } - if (CONSP (regexps)) - continue; - } + if (!match_regexps (eltstring, Vcompletion_regexp_list, + completion_ignore_case)) + continue; /* Ignore this element if there is a predicate and the predicate doesn't like it. */ @@ -1965,11 +1943,6 @@ with a space are ignored unless STRING itself starts with a space. */) tem = Fcommandp (elt, Qnil); else { - if (bindcount >= 0) - { - unbind_to (bindcount, Qnil); - bindcount = -1; - } tem = type == 3 ? call2 (predicate, elt, HASH_VALUE (XHASH_TABLE (collection), idx - 1)) @@ -1982,9 +1955,6 @@ with a space are ignored unless STRING itself starts with a space. */) } } - if (bindcount >= 0) - unbind_to (bindcount, Qnil); - return Fnreverse (allmatches); } @@ -2068,7 +2038,7 @@ If COLLECTION is a function, it is called with three arguments: the values STRING, PREDICATE and `lambda'. */) (Lisp_Object string, Lisp_Object collection, Lisp_Object predicate) { - Lisp_Object regexps, tail, tem = Qnil; + Lisp_Object tail, tem = Qnil; ptrdiff_t i = 0; CHECK_STRING (string); @@ -2154,20 +2124,9 @@ the values STRING, PREDICATE and `lambda'. */) return call3 (collection, string, predicate, Qlambda); /* Reject this element if it fails to match all the regexps. */ - if (CONSP (Vcompletion_regexp_list)) - { - ptrdiff_t count = SPECPDL_INDEX (); - specbind (Qcase_fold_search, completion_ignore_case ? Qt : Qnil); - for (regexps = Vcompletion_regexp_list; CONSP (regexps); - regexps = XCDR (regexps)) - { - /* We can test against STRING, because if we got here, then - the element is equivalent to it. */ - if (NILP (Fstring_match (XCAR (regexps), string, Qnil))) - return unbind_to (count, Qnil); - } - unbind_to (count, Qnil); - } + if (!match_regexps (string, Vcompletion_regexp_list, + completion_ignore_case)) + return Qnil; /* Finally, check the predicate. */ if (!NILP (predicate)) diff --git a/src/module-env-29.h b/src/module-env-29.h new file mode 100644 index 00000000000..6ca03773181 --- /dev/null +++ b/src/module-env-29.h @@ -0,0 +1,3 @@ + /* Add module environment functions newly added in Emacs 29 here. + Before Emacs 29 is released, remove this comment and start + module-env-30.h on the master branch. */ diff --git a/src/msdos.c b/src/msdos.c index a6deea710f4..2272aba6fde 100644 --- a/src/msdos.c +++ b/src/msdos.c @@ -1794,7 +1794,7 @@ internal_terminal_init (void) } Vinitial_window_system = Qpc; - Vwindow_system_version = make_fixnum (28); /* RE Emacs version */ + Vwindow_system_version = make_fixnum (29); /* RE Emacs version */ tty->terminal->type = output_msdos_raw; /* If Emacs was dumped on DOS/V machine, forget the stale VRAM diff --git a/src/nsfns.m b/src/nsfns.m index 797d0ce7820..643da01989f 100644 --- a/src/nsfns.m +++ b/src/nsfns.m @@ -236,7 +236,6 @@ static void ns_set_foreground_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { NSColor *col; - EmacsCGFloat r, g, b, alpha; /* Must block_input, because ns_lisp_to_color does block/unblock_input which means that col may be deallocated in its unblock_input if there @@ -253,12 +252,7 @@ ns_set_foreground_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) [f->output_data.ns->foreground_color release]; f->output_data.ns->foreground_color = col; - [col getRed: &r green: &g blue: &b alpha: &alpha]; - FRAME_FOREGROUND_PIXEL (f) = - ARGB_TO_ULONG ((unsigned long) (alpha * 0xff), - (unsigned long) (r * 0xff), - (unsigned long) (g * 0xff), - (unsigned long) (b * 0xff)); + FRAME_FOREGROUND_PIXEL (f) = [col unsignedLong]; if (FRAME_NS_VIEW (f)) { @@ -277,7 +271,7 @@ ns_set_background_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) struct face *face; NSColor *col; NSView *view = FRAME_NS_VIEW (f); - EmacsCGFloat r, g, b, alpha; + EmacsCGFloat alpha; block_input (); if (ns_lisp_to_color (arg, &col)) @@ -291,12 +285,8 @@ ns_set_background_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) [f->output_data.ns->background_color release]; f->output_data.ns->background_color = col; - [col getRed: &r green: &g blue: &b alpha: &alpha]; - FRAME_BACKGROUND_PIXEL (f) = - ARGB_TO_ULONG ((unsigned long) (alpha * 0xff), - (unsigned long) (r * 0xff), - (unsigned long) (g * 0xff), - (unsigned long) (b * 0xff)); + FRAME_BACKGROUND_PIXEL (f) = [col unsignedLong]; + alpha = [col alphaComponent]; if (view != nil) { @@ -310,9 +300,9 @@ ns_set_background_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) face = FRAME_DEFAULT_FACE (f); if (face) { - col = ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), f); - face->background = ns_index_color - ([col colorWithAlphaComponent: alpha], f); + col = [NSColor colorWithUnsignedLong:NS_FACE_BACKGROUND (face)]; + face->background = [[col colorWithAlphaComponent: alpha] + unsignedLong]; update_face_from_frame_parameter (f, Qbackground_color, arg); } @@ -1236,6 +1226,7 @@ DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame, "fontBackend", "FontBackend", RES_TYPE_STRING); { +#ifdef NS_IMPL_COCOA /* use for default font name */ id font = [NSFont userFixedPitchFontOfSize: -1.0]; /* default */ gui_default_parameter (f, parms, Qfontsize, @@ -1250,6 +1241,11 @@ DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame, build_string (fontname), "font", "Font", RES_TYPE_STRING); xfree (fontname); +#else + gui_default_parameter (f, parms, Qfont, + build_string ("fixed"), + "font", "Font", RES_TYPE_STRING); +#endif } unblock_input (); @@ -1359,6 +1355,10 @@ DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame, 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), @@ -2352,6 +2352,47 @@ ns_get_string_resource (void *_rdb, const char *name, const char *class) ========================================================================== */ +#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 1080 +/* Moving files to the system recycle bin. + Used by `move-file-to-trash' instead of the default moving to ~/.Trash */ +DEFUN ("system-move-file-to-trash", Fsystem_move_file_to_trash, + Ssystem_move_file_to_trash, 1, 1, 0, + doc: /* Move file or directory named FILENAME to the recycle bin. */) + (Lisp_Object filename) +{ + Lisp_Object handler; + Lisp_Object operation; + + operation = Qdelete_file; + if (!NILP (Ffile_directory_p (filename)) + && NILP (Ffile_symlink_p (filename))) + { + operation = intern ("delete-directory"); + filename = Fdirectory_file_name (filename); + } + + /* Must have fully qualified file names for moving files to Trash. */ + filename = Fexpand_file_name (filename, Qnil); + + handler = Ffind_file_name_handler (filename, operation); + if (!NILP (handler)) + return call2 (handler, operation, filename); + else + { + NSFileManager *fm = [NSFileManager defaultManager]; + BOOL result = NO; + NSURL *fileURL = [NSURL fileURLWithPath:[NSString stringWithLispString:filename] + isDirectory:!NILP (Ffile_directory_p (filename))]; + if ([fm respondsToSelector:@selector(trashItemAtURL:resultingItemURL:error:)]) + result = [fm trashItemAtURL:fileURL resultingItemURL:nil error:nil]; + + if (!result) + report_file_error ("Removing old name", list1 (filename)); + } + return Qnil; +} +#endif + 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) @@ -3099,6 +3140,9 @@ all_nonzero_ascii (unsigned char *str, ptrdiff_t n) encoded form (e.g. UTF-8). */ + (NSString *)stringWithLispString:(Lisp_Object)string { + if (!STRINGP (string)) + return nil; + /* Shortcut for the common case. */ if (all_nonzero_ascii (SDATA (string), SBYTES (string))) return [NSString stringWithCString: SSDATA (string) @@ -3233,6 +3277,10 @@ Default is t. */); defsubr (&Sx_show_tip); defsubr (&Sx_hide_tip); +#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 1080 + defsubr (&Ssystem_move_file_to_trash); +#endif + as_status = 0; as_script = Qnil; staticpro (&as_script); diff --git a/src/nsfont.m b/src/nsfont.m index 5a9cdfebc01..7ff852b843f 100644 --- a/src/nsfont.m +++ b/src/nsfont.m @@ -1,4 +1,4 @@ -/* Font back-end driver for the NeXT/Open/GNUstep and macOS window system. +/* Font back-end driver for the GNUstep window system. See font.h Copyright (C) 2006-2021 Free Software Foundation, Inc. @@ -38,47 +38,269 @@ Author: Adrian Robert (arobert@cogsci.ucsd.edu) #include "termchar.h" #include "pdumper.h" -/* TODO: Drop once we can assume gnustep-gui 0.17.1. */ +#import <Foundation/NSException.h> #import <AppKit/NSFontDescriptor.h> +#import <AppKit/NSLayoutManager.h> +#import <GNUstepGUI/GSLayoutManager.h> +#import <GNUstepGUI/GSFontInfo.h> #define NSFONT_TRACE 0 -#define LCD_SMOOTHING_MARGIN 2 -/* Font glyph and metrics caching functions, implemented at end. */ -static void ns_uni_to_glyphs (struct nsfont_info *font_info, - unsigned char block); -static void ns_glyph_metrics (struct nsfont_info *font_info, - unsigned char block); +/* Structure used by GS `shape' functions for storing layout + information for each glyph. Borrowed from macfont.h. */ +struct ns_glyph_layout +{ + /* Range of indices of the characters composed into the group of + glyphs that share the cursor position with this glyph. The + members `location' and `length' are in UTF-16 indices. */ + NSRange comp_range; -#define INVALID_GLYPH 0xFFFF + /* UTF-16 index in the source string for the first character + associated with this glyph. */ + NSUInteger string_index; -/* ========================================================================== + /* Horizontal and vertical adjustments of glyph position. The + coordinate space is that of Core Text. So, the `baseline_delta' + value is negative if the glyph should be placed below the + baseline. */ + CGFloat advance_delta, baseline_delta; - Utilities + /* Typographical width of the glyph. */ + CGFloat advance; - ========================================================================== */ + /* Glyph ID of the glyph. */ + NSGlyph glyph_id; +}; + + +enum lgstring_direction + { + DIR_R2L = -1, DIR_UNKNOWN = 0, DIR_L2R = 1 + }; + +enum gs_font_slant + { + GS_FONT_SLANT_ITALIC, + GS_FONT_SLANT_REVERSE_ITALIC, + GS_FONT_SLANT_NORMAL + }; + +enum gs_font_weight + { + GS_FONT_WEIGHT_LIGHT, + GS_FONT_WEIGHT_BOLD, + GS_FONT_WEIGHT_NORMAL + }; + +enum gs_font_width + { + GS_FONT_WIDTH_CONDENSED, + GS_FONT_WIDTH_EXPANDED, + GS_FONT_WIDTH_NORMAL + }; + +enum gs_specified + { + GS_SPECIFIED_SLANT = 1, + GS_SPECIFIED_WEIGHT = 1 << 1, + GS_SPECIFIED_WIDTH = 1 << 2, + GS_SPECIFIED_FAMILY = 1 << 3, + GS_SPECIFIED_SPACING = 1 << 4 + }; +struct gs_font_data +{ + int specified; + enum gs_font_slant slant; + enum gs_font_weight weight; + enum gs_font_width width; + bool monospace_p; + char *family_name; +}; -/* Replace spaces w/another character so emacs core font parsing routines - aren't thrown off. */ static void -ns_escape_name (char *name) +ns_done_font_data (struct gs_font_data *data) { - for (; *name; name++) - if (*name == ' ') - *name = '_'; + if (data->specified & GS_SPECIFIED_FAMILY) + xfree (data->family_name); } - -/* Reconstruct spaces in a font family name passed through emacs. */ static void -ns_unescape_name (char *name) +ns_get_font_data (NSFontDescriptor *desc, struct gs_font_data *dat) { - for (; *name; name++) - if (*name == '_') - *name = ' '; + NSNumber *tem; + NSFontSymbolicTraits traits = [desc symbolicTraits]; + NSDictionary *dict = [desc objectForKey: NSFontTraitsAttribute]; + NSString *family = [desc objectForKey: NSFontFamilyAttribute]; + + dat->specified = 0; + + if (family != nil) + { + dat->specified |= GS_SPECIFIED_FAMILY; + dat->family_name = xstrdup ([family cStringUsingEncoding: NSUTF8StringEncoding]); + } + + tem = [desc objectForKey: NSFontFixedAdvanceAttribute]; + + if ((tem != nil && [tem boolValue] != NO) + || (traits & NSFontMonoSpaceTrait)) + { + dat->specified |= GS_SPECIFIED_SPACING; + dat->monospace_p = true; + } + else if (tem != nil && [tem boolValue] == NO) + { + dat->specified |= GS_SPECIFIED_SPACING; + dat->monospace_p = false; + } + + if (traits & NSFontBoldTrait) + { + dat->specified |= GS_SPECIFIED_WEIGHT; + dat->weight = GS_FONT_WEIGHT_BOLD; + } + + if (traits & NSFontItalicTrait) + { + dat->specified |= GS_SPECIFIED_SLANT; + dat->slant = GS_FONT_SLANT_ITALIC; + } + + if (traits & NSFontCondensedTrait) + { + dat->specified |= GS_SPECIFIED_WIDTH; + dat->width = GS_FONT_WIDTH_CONDENSED; + } + else if (traits & NSFontExpandedTrait) + { + dat->specified |= GS_SPECIFIED_WIDTH; + dat->width = GS_FONT_WIDTH_EXPANDED; + } + + if (dict != nil) + { + tem = [dict objectForKey: NSFontSlantTrait]; + + if (tem != nil) + { + dat->specified |= GS_SPECIFIED_SLANT; + + dat->slant = [tem floatValue] > 0 + ? GS_FONT_SLANT_ITALIC + : ([tem floatValue] < 0 + ? GS_FONT_SLANT_REVERSE_ITALIC + : GS_FONT_SLANT_NORMAL); + } + + tem = [dict objectForKey: NSFontWeightTrait]; + + if (tem != nil) + { + dat->specified |= GS_SPECIFIED_WEIGHT; + + dat->weight = [tem floatValue] > 0 + ? GS_FONT_WEIGHT_BOLD + : ([tem floatValue] < -0.4f + ? GS_FONT_WEIGHT_LIGHT + : GS_FONT_WEIGHT_NORMAL); + } + + tem = [dict objectForKey: NSFontWidthTrait]; + + if (tem != nil) + { + dat->specified |= GS_SPECIFIED_WIDTH; + + dat->width = [tem floatValue] > 0 + ? GS_FONT_WIDTH_EXPANDED + : ([tem floatValue] < 0 + ? GS_FONT_WIDTH_NORMAL + : GS_FONT_WIDTH_CONDENSED); + } + } +} + +static bool +ns_font_descs_match_p (NSFontDescriptor *desc, NSFontDescriptor *target) +{ + struct gs_font_data dat; + struct gs_font_data t; + + ns_get_font_data (desc, &dat); + ns_get_font_data (target, &t); + + if (!(t.specified & GS_SPECIFIED_WIDTH)) + t.width = GS_FONT_WIDTH_NORMAL; + if (!(t.specified & GS_SPECIFIED_WEIGHT)) + t.weight = GS_FONT_WEIGHT_NORMAL; + if (!(t.specified & GS_SPECIFIED_SPACING)) + t.monospace_p = false; + if (!(t.specified & GS_SPECIFIED_SLANT)) + t.slant = GS_FONT_SLANT_NORMAL; + + if (!(t.specified & GS_SPECIFIED_FAMILY)) + emacs_abort (); + + bool match_p = true; + + if (dat.specified & GS_SPECIFIED_WIDTH + && dat.width != t.width) + { + match_p = false; + goto gout; + } + + if (dat.specified & GS_SPECIFIED_WEIGHT + && dat.weight != t.weight) + { + match_p = false; + goto gout; + } + + if (dat.specified & GS_SPECIFIED_SPACING + && dat.monospace_p != t.monospace_p) + { + match_p = false; + goto gout; + } + + if (dat.specified & GS_SPECIFIED_SLANT + && dat.monospace_p != t.monospace_p) + { + if (NSFONT_TRACE) + printf ("Matching monospace for %s: %d %d\n", + t.family_name, dat.monospace_p, + t.monospace_p); + match_p = false; + goto gout; + } + + if (dat.specified & GS_SPECIFIED_FAMILY + && strcmp (dat.family_name, t.family_name)) + match_p = false; + + gout: + ns_done_font_data (&dat); + ns_done_font_data (&t); + + return match_p; } +/* Font glyph and metrics caching functions, implemented at end. */ +static void ns_uni_to_glyphs (struct nsfont_info *font_info, + unsigned char block); +static void ns_glyph_metrics (struct nsfont_info *font_info, + unsigned int block); + +#define INVALID_GLYPH 0xFFFF + +/* ========================================================================== + + Utilities + + ========================================================================== */ + /* Extract family name from a font spec. */ static NSString * @@ -91,66 +313,116 @@ ns_get_family (Lisp_Object font_spec) { char *tmp = xlispstrdup (SYMBOL_NAME (tem)); NSString *family; - ns_unescape_name (tmp); family = [NSString stringWithUTF8String: tmp]; xfree (tmp); return family; } } - -/* Return 0 if attr not set, else value (which might also be 0). - On Leopard 0 gets returned even on descriptors where the attribute - was never set, so there's no way to distinguish between unspecified - and set to not have. Callers should assume 0 means unspecified. */ -static float -ns_attribute_fvalue (NSFontDescriptor *fdesc, NSString *trait) -{ - NSDictionary *tdict = [fdesc objectForKey: NSFontTraitsAttribute]; - NSNumber *val = [tdict objectForKey: trait]; - return val == nil ? 0.0F : [val floatValue]; -} - - /* Converts FONT_WEIGHT, FONT_SLANT, FONT_WIDTH, plus family and script/lang to NSFont descriptor. Information under extra only needed for matching. */ -#define STYLE_REF 100 static NSFontDescriptor * ns_spec_to_descriptor (Lisp_Object font_spec) { NSFontDescriptor *fdesc; NSMutableDictionary *fdAttrs = [NSMutableDictionary new]; - NSMutableDictionary *tdict = [NSMutableDictionary new]; NSString *family = ns_get_family (font_spec); - float n; - - /* Add each attr in font_spec to fdAttrs. */ - n = min (FONT_WEIGHT_NUMERIC (font_spec), 200); - if (n != -1 && n != STYLE_REF) - [tdict setObject: [NSNumber numberWithFloat: (n - 100.0F) / 100.0F] - forKey: NSFontWeightTrait]; - n = min (FONT_SLANT_NUMERIC (font_spec), 200); - if (n != -1 && n != STYLE_REF) - [tdict setObject: [NSNumber numberWithFloat: (n - 100.0F) / 100.0F] - forKey: NSFontSlantTrait]; - n = min (FONT_WIDTH_NUMERIC (font_spec), 200); - if (n > -1 && (n > STYLE_REF + 10 || n < STYLE_REF - 10)) - [tdict setObject: [NSNumber numberWithFloat: (n - 100.0F) / 100.0F] - forKey: NSFontWidthTrait]; - if ([tdict count] > 0) - [fdAttrs setObject: tdict forKey: NSFontTraitsAttribute]; + NSMutableDictionary *tdict = [NSMutableDictionary new]; - fdesc = [[[NSFontDescriptor fontDescriptorWithFontAttributes: fdAttrs] - retain] autorelease]; + Lisp_Object tem; + + tem = FONT_SLANT_SYMBOLIC (font_spec); + if (!NILP (tem)) + { + if (EQ (tem, Qitalic) || EQ (tem, Qoblique)) + [tdict setObject: [NSNumber numberWithFloat: 1.0] + forKey: NSFontSlantTrait]; + else if (EQ (tem, intern ("reverse-italic")) || + EQ (tem, intern ("reverse-oblique"))) + [tdict setObject: [NSNumber numberWithFloat: -1.0] + forKey: NSFontSlantTrait]; + else + [tdict setObject: [NSNumber numberWithFloat: 0.0] + forKey: NSFontSlantTrait]; + } + + tem = FONT_WIDTH_SYMBOLIC (font_spec); + if (!NILP (tem)) + { + if (EQ (tem, Qcondensed)) + [tdict setObject: [NSNumber numberWithFloat: -1.0] + forKey: NSFontWidthTrait]; + else if (EQ (tem, Qexpanded)) + [tdict setObject: [NSNumber numberWithFloat: 1.0] + forKey: NSFontWidthTrait]; + else + [tdict setObject: [NSNumber numberWithFloat: 0.0] + forKey: NSFontWidthTrait]; + } + + tem = FONT_WEIGHT_SYMBOLIC (font_spec); + + if (!NILP (tem)) + { + if (EQ (tem, Qbold)) + { + [tdict setObject: [NSNumber numberWithFloat: 1.0] + forKey: NSFontWeightTrait]; + } + else if (EQ (tem, Qlight)) + { + [tdict setObject: [NSNumber numberWithFloat: -1.0] + forKey: NSFontWeightTrait]; + } + else + { + [tdict setObject: [NSNumber numberWithFloat: 0.0] + forKey: NSFontWeightTrait]; + } + } + + tem = AREF (font_spec, FONT_SPACING_INDEX); if (family != nil) { - NSFontDescriptor *fdesc2 = [fdesc fontDescriptorWithFamily: family]; - fdesc = [[fdesc2 retain] autorelease]; + [fdAttrs setObject: family + forKey: NSFontFamilyAttribute]; } - [fdAttrs release]; + if (FIXNUMP (tem)) + { + if (XFIXNUM (tem) != FONT_SPACING_PROPORTIONAL) + { + [fdAttrs setObject: [NSNumber numberWithBool:YES] + forKey: NSFontFixedAdvanceAttribute]; + } + else + { + [fdAttrs setObject: [NSNumber numberWithBool:NO] + forKey: NSFontFixedAdvanceAttribute]; + } + } + + /* Handle special families such as ``fixed'' or ``Sans Serif''. */ + + if ([family isEqualToString: @"fixed"]) + { + [fdAttrs setObject: [[NSFont userFixedPitchFontOfSize: 0] familyName] + forKey: NSFontFamilyAttribute]; + } + else if ([family isEqualToString: @"Sans Serif"]) + { + [fdAttrs setObject: [[NSFont userFontOfSize: 0] familyName] + forKey: NSFontFamilyAttribute]; + } + + [fdAttrs setObject: tdict forKey: NSFontTraitsAttribute]; + + fdesc = [[[NSFontDescriptor fontDescriptorWithFontAttributes: fdAttrs] + retain] autorelease]; + [tdict release]; + [fdAttrs release]; return fdesc; } @@ -161,61 +433,64 @@ ns_descriptor_to_entity (NSFontDescriptor *desc, Lisp_Object extra, const char *style) { - Lisp_Object font_entity = font_make_entity (); - /* NSString *psName = [desc postscriptName]; */ - NSString *family = [desc objectForKey: NSFontFamilyAttribute]; - unsigned int traits = [desc symbolicTraits]; - char *escapedFamily; - - /* Shouldn't happen, but on Tiger fallback desc gets name but no family. */ - if (family == nil) - family = [desc objectForKey: NSFontNameAttribute]; - if (family == nil) - family = [[NSFont userFixedPitchFontOfSize: 0] familyName]; - - escapedFamily = xstrdup ([family UTF8String]); - ns_escape_name (escapedFamily); - - ASET (font_entity, FONT_TYPE_INDEX, Qns); - ASET (font_entity, FONT_FOUNDRY_INDEX, Qapple); - ASET (font_entity, FONT_FAMILY_INDEX, intern (escapedFamily)); - ASET (font_entity, FONT_ADSTYLE_INDEX, style ? intern (style) : Qnil); - ASET (font_entity, FONT_REGISTRY_INDEX, Qiso10646_1); - - FONT_SET_STYLE (font_entity, FONT_WEIGHT_INDEX, - traits & NSFontBoldTrait ? Qbold : Qmedium); -/* FONT_SET_STYLE (font_entity, FONT_WEIGHT_INDEX, - make_fixnum (100 + 100 - * ns_attribute_fvalue (desc, NSFontWeightTrait)));*/ - FONT_SET_STYLE (font_entity, FONT_SLANT_INDEX, - traits & NSFontItalicTrait ? Qitalic : Qnormal); -/* FONT_SET_STYLE (font_entity, FONT_SLANT_INDEX, - make_fixnum (100 + 100 - * ns_attribute_fvalue (desc, NSFontSlantTrait)));*/ - FONT_SET_STYLE (font_entity, FONT_WIDTH_INDEX, - traits & NSFontCondensedTrait ? Qcondensed : - traits & NSFontExpandedTrait ? Qexpanded : Qnormal); -/* FONT_SET_STYLE (font_entity, FONT_WIDTH_INDEX, - make_fixnum (100 + 100 - * ns_attribute_fvalue (desc, NSFontWidthTrait)));*/ - - ASET (font_entity, FONT_SIZE_INDEX, make_fixnum (0)); - ASET (font_entity, FONT_AVGWIDTH_INDEX, make_fixnum (0)); - ASET (font_entity, FONT_SPACING_INDEX, - make_fixnum([desc symbolicTraits] & NSFontMonoSpaceTrait - ? FONT_SPACING_MONO : FONT_SPACING_PROPORTIONAL)); - - ASET (font_entity, FONT_EXTRA_INDEX, extra); - ASET (font_entity, FONT_OBJLIST_INDEX, Qnil); + Lisp_Object font_entity = font_make_entity (); + struct gs_font_data data; + ns_get_font_data (desc, &data); + + ASET (font_entity, FONT_TYPE_INDEX, Qns); + ASET (font_entity, FONT_FOUNDRY_INDEX, Qns); + if (data.specified & GS_SPECIFIED_FAMILY) + ASET (font_entity, FONT_FAMILY_INDEX, intern (data.family_name)); + ASET (font_entity, FONT_ADSTYLE_INDEX, style ? intern (style) : Qnil); + ASET (font_entity, FONT_REGISTRY_INDEX, Qiso10646_1); + + if (data.specified & GS_SPECIFIED_WEIGHT) + { + FONT_SET_STYLE (font_entity, FONT_WEIGHT_INDEX, + data.weight == GS_FONT_WEIGHT_BOLD + ? Qbold : (data.weight == GS_FONT_WEIGHT_LIGHT + ? Qlight : Qnormal)); + } + else + FONT_SET_STYLE (font_entity, FONT_WEIGHT_INDEX, Qnormal); - if (NSFONT_TRACE) - { - fputs ("created font_entity:\n ", stderr); - debug_print (font_entity); - } + if (data.specified & GS_SPECIFIED_SLANT) + { + FONT_SET_STYLE (font_entity, FONT_SLANT_INDEX, + data.slant == GS_FONT_SLANT_ITALIC + ? Qitalic : (data.slant == GS_FONT_SLANT_REVERSE_ITALIC + ? intern ("reverse-italic") : Qnormal)); + } + else + FONT_SET_STYLE (font_entity, FONT_SLANT_INDEX, Qnormal); + + if (data.specified & GS_SPECIFIED_WIDTH) + { + FONT_SET_STYLE (font_entity, FONT_WIDTH_INDEX, + data.width == GS_FONT_WIDTH_CONDENSED + ? Qcondensed : (data.width == GS_FONT_WIDTH_EXPANDED + ? intern ("expanded") : Qnormal)); + } + else + FONT_SET_STYLE (font_entity, FONT_WIDTH_INDEX, Qnormal); - xfree (escapedFamily); - return font_entity; + ASET (font_entity, FONT_SIZE_INDEX, make_fixnum (0)); + ASET (font_entity, FONT_AVGWIDTH_INDEX, make_fixnum (0)); + ASET (font_entity, FONT_SPACING_INDEX, + make_fixnum ((data.specified & GS_SPECIFIED_WIDTH && data.monospace_p) + ? FONT_SPACING_MONO : FONT_SPACING_PROPORTIONAL)); + + ASET (font_entity, FONT_EXTRA_INDEX, extra); + ASET (font_entity, FONT_OBJLIST_INDEX, Qnil); + + if (NSFONT_TRACE) + { + fputs ("created font_entity:\n ", stderr); + debug_print (font_entity); + } + + ns_done_font_data (&data); + return font_entity; } @@ -223,8 +498,7 @@ ns_descriptor_to_entity (NSFontDescriptor *desc, static Lisp_Object ns_fallback_entity (void) { - return ns_descriptor_to_entity ([[NSFont userFixedPitchFontOfSize: 0] - fontDescriptor], Qnil, NULL); + return ns_descriptor_to_entity ([[NSFont userFixedPitchFontOfSize: 1] fontDescriptor], Qnil, NULL); } @@ -510,21 +784,20 @@ static NSSet return families; } +/* GNUstep font matching is very mediocre (it can't even compare + symbolic styles correctly), which is why our own font matching + mechanism must be implemented. */ -/* Implementation for list() and match(). List() can return nil, match() -must return something. Strategy is to drop family name from attribute -matching set for match. */ +/* Implementation for list and match. */ static Lisp_Object ns_findfonts (Lisp_Object font_spec, BOOL isMatch) { Lisp_Object tem, list = Qnil; - NSFontDescriptor *fdesc, *desc; - NSMutableSet *fkeys; - NSArray *matchingDescs; - NSEnumerator *dEnum; - NSString *family; + NSFontDescriptor *fdesc; + NSArray *all_descs; + GSFontEnumerator *enumerator = [GSFontEnumerator sharedEnumerator]; + NSSet *cFamilies; - BOOL foundItal = NO; block_input (); if (NSFONT_TRACE) @@ -537,43 +810,22 @@ ns_findfonts (Lisp_Object font_spec, BOOL isMatch) cFamilies = ns_get_covering_families (ns_get_req_script (font_spec), 0.90); fdesc = ns_spec_to_descriptor (font_spec); - fkeys = [NSMutableSet setWithArray: [[fdesc fontAttributes] allKeys]]; - if (isMatch) - [fkeys removeObject: NSFontFamilyAttribute]; - - matchingDescs = [fdesc matchingFontDescriptorsWithMandatoryKeys: fkeys]; + all_descs = [enumerator availableFontDescriptors]; - if (NSFONT_TRACE) - NSLog(@"Got desc %@ and found %lu matching fonts from it: ", fdesc, - (unsigned long)[matchingDescs count]); - - for (dEnum = [matchingDescs objectEnumerator]; (desc = [dEnum nextObject]);) + for (NSFontDescriptor *desc in all_descs) { if (![cFamilies containsObject: [desc objectForKey: NSFontFamilyAttribute]]) continue; + if (!ns_font_descs_match_p (fdesc, desc)) + continue; + tem = ns_descriptor_to_entity (desc, - AREF (font_spec, FONT_EXTRA_INDEX), + AREF (font_spec, FONT_EXTRA_INDEX), NULL); if (isMatch) return tem; list = Fcons (tem, list); - if (fabs (ns_attribute_fvalue (desc, NSFontSlantTrait)) > 0.05) - foundItal = YES; - } - - /* Add synthItal member if needed. */ - family = [fdesc objectForKey: NSFontFamilyAttribute]; - if (family != nil && !foundItal && !NILP (list)) - { - NSFontDescriptor *s1 = [NSFontDescriptor new]; - NSFontDescriptor *sDesc - = [[s1 fontDescriptorWithSymbolicTraits: NSFontItalicTrait] - fontDescriptorWithFamily: family]; - list = Fcons (ns_descriptor_to_entity (sDesc, - AREF (font_spec, FONT_EXTRA_INDEX), - "synthItal"), list); - [s1 release]; } unblock_input (); @@ -652,7 +904,6 @@ nsfont_list_family (struct frame *f) objectEnumerator]; while ((family = [families nextObject])) list = Fcons (intern ([family UTF8String]), list); - /* FIXME: escape the name? */ if (NSFONT_TRACE) fprintf (stderr, "nsfont: list families returning %"pD"d entries\n", @@ -668,18 +919,15 @@ nsfont_list_family (struct frame *f) static Lisp_Object nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size) { - BOOL synthItal; - unsigned int traits = 0; struct nsfont_info *font_info; struct font *font; NSFontDescriptor *fontDesc = ns_spec_to_descriptor (font_entity); NSFontManager *fontMgr = [NSFontManager sharedFontManager]; NSString *family; NSFont *nsfont, *sfont; - Lisp_Object tem; NSRect brect; Lisp_Object font_object; - int fixLeopardBug; + Lisp_Object tem; block_input (); @@ -692,42 +940,20 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size) if (pixel_size <= 0) { /* try to get it out of frame params */ - Lisp_Object tem = get_frame_param (f, Qfontsize); - pixel_size = NILP (tem) ? 0 : XFIXNAT (tem); + tem = get_frame_param (f, Qfontsize); + pixel_size = NILP (tem) ? 0 : XFIXNAT (tem); } tem = AREF (font_entity, FONT_ADSTYLE_INDEX); - synthItal = !NILP (tem) && !strncmp ("synthItal", SSDATA (SYMBOL_NAME (tem)), - 9); family = ns_get_family (font_entity); if (family == nil) family = [[NSFont userFixedPitchFontOfSize: 0] familyName]; - /* Should be > 0.23 as some font descriptors (e.g. Terminus) set to that - when setting family in ns_spec_to_descriptor(). */ - if (ns_attribute_fvalue (fontDesc, NSFontWeightTrait) > 0.50F) - traits |= NSBoldFontMask; - if (ns_attribute_fvalue (fontDesc, NSFontSlantTrait) > 0.05F) - traits |= NSItalicFontMask; - - /* see https://web.archive.org/web/20100201175731/http://cocoadev.com/forums/comments.php?DiscussionID=74 */ - fixLeopardBug = traits & NSBoldFontMask ? 10 : 5; - nsfont = [fontMgr fontWithFamily: family - traits: traits weight: fixLeopardBug - size: pixel_size]; - /* if didn't find, try synthetic italic */ - if (nsfont == nil && synthItal) - { - nsfont = [fontMgr fontWithFamily: family - traits: traits & ~NSItalicFontMask - weight: fixLeopardBug size: pixel_size]; - } + + nsfont = [NSFont fontWithDescriptor: fontDesc + size: pixel_size]; if (nsfont == nil) - { - message_with_string ("*** Warning: font in family `%s' not found", - build_string ([family UTF8String]), 1); - nsfont = [NSFont userFixedPitchFontOfSize: pixel_size]; - } + nsfont = [NSFont userFixedPitchFontOfSize: pixel_size]; if (NSFONT_TRACE) NSLog (@"%@\n", nsfont); @@ -740,7 +966,7 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size) if (!font) { unblock_input (); - return Qnil; /* FIXME: other terms do, but returning Qnil causes segfault. */ + return Qnil; } font_info->glyphs = xzalloc (0x100 * sizeof *font_info->glyphs); @@ -781,7 +1007,7 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size) font_info->name = xstrdup (fontName); font_info->bold = [fontMgr traitsOfFont: nsfont] & NSBoldFontMask; font_info->ital = - synthItal || ([fontMgr traitsOfFont: nsfont] & NSItalicFontMask); + ([fontMgr traitsOfFont: nsfont] & NSItalicFontMask); /* Metrics etc.; some fonts return an unusually large max advance, so we only use it for fonts that have wide characters. */ @@ -808,8 +1034,6 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size) lrint (brect.size.width - (CGFloat) font_info->width); /* set up metrics portion of font struct */ - font->ascent = lrint([sfont ascender]); - font->descent = -lrint(floor(adjusted_descender)); font->space_width = lrint (ns_char_width (sfont, ' ')); font->max_width = lrint (font_info->max_bounds.width); font->min_width = font->space_width; /* Approximate. */ @@ -871,7 +1095,7 @@ nsfont_encode_char (struct font *font, int c) { struct nsfont_info *font_info = (struct nsfont_info *)font; unsigned char high = (c & 0xff00) >> 8, low = c & 0x00ff; - unsigned short g; + unsigned int g; if (c > 0xFFFF) return FONT_INVALID_CODE; @@ -934,51 +1158,23 @@ nsfont_text_extents (struct font *font, const unsigned int *code, static int nsfont_draw (struct glyph_string *s, int from, int to, int x, int y, bool with_background) -/* NOTE: focus and clip must be set. */ { - static unsigned char cbuf[1024]; - unsigned char *c = cbuf; -#if GNUSTEP_GUI_MAJOR_VERSION > 0 || GNUSTEP_GUI_MINOR_VERSION > 22 - static CGFloat advances[1024]; - CGFloat *adv = advances; -#else - static float advances[1024]; - float *adv = advances; -#endif + NSGlyph *c = alloca ((to - from) * sizeof *c); + struct face *face; NSRect r; struct nsfont_info *font; - NSColor *col, *bgCol; - unsigned *t = s->char2b; - int i, len, flags; + NSColor *col; + int len = to - from; char isComposite = s->first_glyph->type == COMPOSITE_GLYPH; block_input (); - font = (struct nsfont_info *)s->face->font; + font = (struct nsfont_info *) s->font; if (font == NULL) font = (struct nsfont_info *)FRAME_FONT (s->f); - /* Select face based on input flags. */ - flags = s->hl == DRAW_CURSOR ? NS_DUMPGLYPH_CURSOR : - (s->hl == DRAW_MOUSE_FACE ? NS_DUMPGLYPH_MOUSEFACE : - (s->for_overlaps ? NS_DUMPGLYPH_FOREGROUND : - NS_DUMPGLYPH_NORMAL)); - - switch (flags) - { - case NS_DUMPGLYPH_CURSOR: - face = s->face; - break; - case NS_DUMPGLYPH_MOUSEFACE: - face = FACE_FROM_ID_OR_NULL (s->f, - MOUSE_HL_INFO (s->f)->mouse_face_face_id); - if (!face) - face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); - break; - default: - face = s->face; - } + face = s->face; r.origin.x = s->x; if (s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p) @@ -987,91 +1183,24 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y, r.origin.y = s->y; r.size.height = FONT_HEIGHT (font); - /* Convert UTF-16 (?) to UTF-8 and determine advances. Note if we just ask - NS to render the string, it will come out differently from the individual - character widths added up because of layout processing. */ - { - int cwidth, twidth = 0; - int hi, lo; - /* FIXME: composition: no vertical displacement is considered. */ - t += from; /* advance into composition */ - for (i = from; i < to; i++, t++) - { - hi = (*t & 0xFF00) >> 8; - lo = *t & 0x00FF; - if (isComposite) - { - if (!s->first_glyph->u.cmp.automatic) - cwidth = s->cmp->offsets[i * 2] /* (H offset) */ - twidth; - else - { - Lisp_Object gstring = composition_gstring_from_id (s->cmp_id); - Lisp_Object glyph = LGSTRING_GLYPH (gstring, i); - if (NILP (LGLYPH_ADJUSTMENT (glyph))) - cwidth = LGLYPH_WIDTH (glyph); - else - { - cwidth = LGLYPH_WADJUST (glyph); - *(adv-1) += LGLYPH_XOFF (glyph); - } - } - } - else - { - if (!font->metrics[hi]) /* FIXME: why/how can we need this now? */ - ns_glyph_metrics (font, hi); - cwidth = font->metrics[hi][lo].width; - } - twidth += cwidth; - *adv++ = cwidth; - c += CHAR_STRING (*t, c); /* This converts the char to UTF-8. */ - } - len = adv - advances; - r.size.width = twidth; - *c = 0; - } + for (int i = from; i < to; ++i) + c[i] = s->char2b[i]; /* Fill background if requested. */ if (with_background && !isComposite) { - NSRect br = r; - int fibw = FRAME_INTERNAL_BORDER_WIDTH (s->f); - int mbox_line_width = max (s->face->box_vertical_line_width, 0); - - if (s->row->full_width_p) - { - if (br.origin.x <= fibw + 1 + mbox_line_width) - { - br.size.width += br.origin.x - mbox_line_width; - br.origin.x = mbox_line_width; - } - if (FRAME_PIXEL_WIDTH (s->f) - (br.origin.x + br.size.width) - <= fibw+1) - br.size.width += fibw; - } - if (s->face->box == FACE_NO_BOX) - { - /* Expand unboxed top row over internal border. */ - if (br.origin.y <= fibw + 1 + mbox_line_width) - { - br.size.height += br.origin.y; - br.origin.y = 0; - } - } - else - { - int correction = abs (s->face->box_horizontal_line_width)+1; - br.origin.y += correction; - br.size.height -= 2*correction; - correction = abs (s->face->box_vertical_line_width)+1; - br.origin.x += correction; - br.size.width -= 2*correction; - } + NSRect br = NSMakeRect (x, y - FONT_BASE (s->font), + s->width, FONT_HEIGHT (s->font)); if (!s->face->stipple) - [(NS_FACE_BACKGROUND (face) != 0 - ? ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), s->f) - : FRAME_BACKGROUND_COLOR (s->f)) set]; + { + if (s->hl != DRAW_CURSOR) + [(NS_FACE_BACKGROUND (face) != 0 + ? [NSColor colorWithUnsignedLong:NS_FACE_BACKGROUND (face)] + : FRAME_BACKGROUND_COLOR (s->f)) set]; + else + [FRAME_CURSOR_COLOR (s->f) set]; + } else { struct ns_display_info *dpyinfo = FRAME_DISPLAY_INFO (s->f); @@ -1080,43 +1209,32 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y, NSRectFill (br); } - /* set up for character rendering */ r.origin.y = y; - col = (NS_FACE_FOREGROUND (face) != 0 - ? ns_lookup_indexed_color (NS_FACE_FOREGROUND (face), s->f) - : FRAME_FOREGROUND_COLOR (s->f)); - - bgCol = (flags != NS_DUMPGLYPH_FOREGROUND ? nil - : (NS_FACE_BACKGROUND (face) != 0 - ? ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), s->f) - : FRAME_BACKGROUND_COLOR (s->f))); + if (s->hl == DRAW_CURSOR) + col = FRAME_BACKGROUND_COLOR (s->f); + else + col = (NS_FACE_FOREGROUND (face) != 0 + ? [NSColor colorWithUnsignedLong:NS_FACE_FOREGROUND (face)] + : FRAME_FOREGROUND_COLOR (s->f)); /* render under GNUstep using DPS */ { - NSGraphicsContext *context = GSCurrentContext (); - + NSGraphicsContext *context = [NSGraphicsContext currentContext]; DPSgsave (context); - [font->nsfont set]; - - /* do erase if "foreground" mode */ - if (bgCol != nil) + if (s->clip_head) { - [bgCol set]; - DPSmoveto (context, r.origin.x, r.origin.y); -/*[context GSSetTextDrawingMode: GSTextFillStroke]; /// not implemented yet */ - DPSxshow (context, (const char *) cbuf, advances, len); - DPSstroke (context); - [col set]; -/*[context GSSetTextDrawingMode: GSTextFill]; /// not implemented yet */ + DPSrectclip (context, s->clip_head->x, 0, + FRAME_PIXEL_WIDTH (s->f), + FRAME_PIXEL_HEIGHT (s->f)); } + [font->nsfont set]; [col set]; - /* draw with DPSxshow () */ DPSmoveto (context, r.origin.x, r.origin.y); - DPSxshow (context, (const char *) cbuf, advances, len); + GSShowGlyphs (context, c, len); DPSstroke (context); DPSgrestore (context); @@ -1126,6 +1244,360 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y, return to-from; } +static NSUInteger +ns_font_shape (NSFont *font, NSString *string, + struct ns_glyph_layout *glyph_layouts, NSUInteger glyph_len, + enum lgstring_direction dir) +{ + NSUInteger i; + NSUInteger result = 0; + NSTextStorage *textStorage; + NSLayoutManager *layoutManager; + NSTextContainer *textContainer; + NSUInteger stringLength; + NSPoint spaceLocation; + /* numberOfGlyphs can't actually be 0, but this pacifies GCC */ + NSUInteger used, numberOfGlyphs = 0; + + textStorage = [[NSTextStorage alloc] initWithString:string]; + layoutManager = [[NSLayoutManager alloc] init]; + textContainer = [[NSTextContainer alloc] init]; + + /* Append a trailing space to measure baseline position. */ + [textStorage appendAttributedString:([[[NSAttributedString alloc] + initWithString:@" "] autorelease])]; + [textStorage setFont:font]; + [textContainer setLineFragmentPadding:0]; + + [layoutManager addTextContainer:textContainer]; + [textContainer release]; + [textStorage addLayoutManager:layoutManager]; + [layoutManager release]; + + if (!(textStorage && layoutManager && textContainer)) + emacs_abort (); + + stringLength = [string length]; + + /* Force layout. */ + (void) [layoutManager glyphRangeForTextContainer:textContainer]; + + spaceLocation = [layoutManager locationForGlyphAtIndex:stringLength]; + + /* Remove the appended trailing space because otherwise it may + generate a wrong result for a right-to-left text. */ + [textStorage beginEditing]; + [textStorage deleteCharactersInRange:(NSMakeRange (stringLength, 1))]; + [textStorage endEditing]; + (void) [layoutManager glyphRangeForTextContainer:textContainer]; + + i = 0; + while (i < stringLength) + { + NSRange range; + NSFont *fontInTextStorage = + [textStorage attribute: NSFontAttributeName + atIndex:i + longestEffectiveRange: &range + inRange: NSMakeRange (0, stringLength)]; + + if (!(fontInTextStorage == font + || [[fontInTextStorage fontName] isEqualToString:[font fontName]])) + break; + i = NSMaxRange (range); + } + if (i < stringLength) + /* Make the test `used <= glyph_len' below fail if textStorage + contained some fonts other than the specified one. */ + used = glyph_len + 1; + else + { + NSRange range = NSMakeRange (0, stringLength); + + range = [layoutManager glyphRangeForCharacterRange:range + actualCharacterRange:NULL]; + numberOfGlyphs = NSMaxRange (range); + used = numberOfGlyphs; + for (i = 0; i < numberOfGlyphs; i++) + if ([layoutManager notShownAttributeForGlyphAtIndex:i]) + used--; + } + + if (0 < used && used <= glyph_len) + { + NSUInteger glyphIndex, prevGlyphIndex; + NSUInteger *permutation; + NSRange compRange, range; + CGFloat totalAdvance; + + glyphIndex = 0; + while ([layoutManager notShownAttributeForGlyphAtIndex:glyphIndex]) + glyphIndex++; + + permutation = NULL; +#define RIGHT_TO_LEFT_P permutation + + /* Fill the `comp_range' member of struct mac_glyph_layout, and + setup a permutation for right-to-left text. */ + compRange = NSMakeRange (0, 0); + for (range = NSMakeRange (0, 0); NSMaxRange (range) < used; + range.length++) + { + struct ns_glyph_layout *gl = glyph_layouts + NSMaxRange (range); + NSUInteger characterIndex = + [layoutManager characterIndexForGlyphAtIndex:glyphIndex]; + + gl->string_index = characterIndex; + + if (characterIndex >= NSMaxRange (compRange)) + { + compRange.location = NSMaxRange (compRange); + do + { + NSRange characterRange = + [string + rangeOfComposedCharacterSequenceAtIndex:characterIndex]; + + compRange.length = + NSMaxRange (characterRange) - compRange.location; + [layoutManager glyphRangeForCharacterRange:compRange + actualCharacterRange:&characterRange]; + characterIndex = NSMaxRange (characterRange) - 1; + } + while (characterIndex >= NSMaxRange (compRange)); + + if (RIGHT_TO_LEFT_P) + for (i = 0; i < range.length; i++) + permutation[range.location + i] = NSMaxRange (range) - i - 1; + + range = NSMakeRange (NSMaxRange (range), 0); + } + + gl->comp_range.location = compRange.location; + gl->comp_range.length = compRange.length; + + while (++glyphIndex < numberOfGlyphs) + if (![layoutManager notShownAttributeForGlyphAtIndex:glyphIndex]) + break; + } + if (RIGHT_TO_LEFT_P) + for (i = 0; i < range.length; i++) + permutation[range.location + i] = NSMaxRange (range) - i - 1; + + /* Then fill the remaining members. */ + glyphIndex = prevGlyphIndex = 0; + while ([layoutManager notShownAttributeForGlyphAtIndex:glyphIndex]) + glyphIndex++; + + if (!RIGHT_TO_LEFT_P) + totalAdvance = 0; + else + { + NSUInteger nrects; + NSRect *glyphRects = + [layoutManager + rectArrayForGlyphRange:(NSMakeRange (0, numberOfGlyphs)) + withinSelectedGlyphRange:(NSMakeRange (NSNotFound, 0)) + inTextContainer:textContainer rectCount:&nrects]; + + totalAdvance = NSMaxX (glyphRects[0]); + } + + for (i = 0; i < used; i++) + { + struct ns_glyph_layout *gl; + NSPoint location; + NSUInteger nextGlyphIndex; + NSRange glyphRange; + NSRect *glyphRects; + NSUInteger nrects; + + if (!RIGHT_TO_LEFT_P) + gl = glyph_layouts + i; + else + { + NSUInteger dest = permutation[i]; + + gl = glyph_layouts + dest; + if (i < dest) + { + NSUInteger tmp = gl->string_index; + + gl->string_index = glyph_layouts[i].string_index; + glyph_layouts[i].string_index = tmp; + } + } + gl->glyph_id = [layoutManager glyphAtIndex: glyphIndex]; + + location = [layoutManager locationForGlyphAtIndex:glyphIndex]; + gl->baseline_delta = spaceLocation.y - location.y; + + for (nextGlyphIndex = glyphIndex + 1; nextGlyphIndex < numberOfGlyphs; + nextGlyphIndex++) + if (![layoutManager + notShownAttributeForGlyphAtIndex:nextGlyphIndex]) + break; + + if (!RIGHT_TO_LEFT_P) + { + CGFloat maxX; + + if (prevGlyphIndex == 0) + glyphRange = NSMakeRange (0, nextGlyphIndex); + else + glyphRange = NSMakeRange (glyphIndex, + nextGlyphIndex - glyphIndex); + glyphRects = + [layoutManager + rectArrayForGlyphRange:glyphRange + withinSelectedGlyphRange:(NSMakeRange (NSNotFound, 0)) + inTextContainer:textContainer rectCount:&nrects]; + maxX = max (NSMaxX (glyphRects[0]), totalAdvance); + gl->advance_delta = location.x - totalAdvance; + gl->advance = maxX - totalAdvance; + totalAdvance = maxX; + } + else + { + CGFloat minX; + + if (nextGlyphIndex == numberOfGlyphs) + glyphRange = NSMakeRange (prevGlyphIndex, + numberOfGlyphs - prevGlyphIndex); + else + glyphRange = NSMakeRange (prevGlyphIndex, + glyphIndex + 1 - prevGlyphIndex); + glyphRects = + [layoutManager + rectArrayForGlyphRange:glyphRange + withinSelectedGlyphRange:(NSMakeRange (NSNotFound, 0)) + inTextContainer:textContainer rectCount:&nrects]; + minX = min (NSMinX (glyphRects[0]), totalAdvance); + gl->advance = totalAdvance - minX; + totalAdvance = minX; + gl->advance_delta = location.x - totalAdvance; + } + + prevGlyphIndex = glyphIndex + 1; + glyphIndex = nextGlyphIndex; + } + + if (RIGHT_TO_LEFT_P) + xfree (permutation); + +#undef RIGHT_TO_LEFT_P + + result = used; + } + [textStorage release]; + + return result; +} + +static Lisp_Object +nsfont_shape (Lisp_Object lgstring, Lisp_Object direction) +{ + struct font *font = CHECK_FONT_GET_OBJECT (LGSTRING_FONT (lgstring)); + struct nsfont_info *font_info = (struct nsfont_info *) font; + struct ns_glyph_layout *glyph_layouts; + NSFont *nsfont = font_info->nsfont; + ptrdiff_t glyph_len, len, i; + Lisp_Object tem; + unichar *mb_buf; + NSUInteger used; + + 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 (); + + mb_buf = alloca (len * sizeof *mb_buf); + + for (i = 0; i < len; ++i) + { + uint32_t c = LGLYPH_CHAR (LGSTRING_GLYPH (lgstring, i)); + mb_buf[i] = (unichar) c; + } + + NSString *string = [NSString stringWithCharacters: mb_buf + length: len]; + unblock_input (); + + if (!string) + return Qnil; + + block_input (); + + enum lgstring_direction dir = DIR_UNKNOWN; + + if (EQ (direction, QL2R)) + dir = DIR_L2R; + else if (EQ (direction, QR2L)) + dir = DIR_R2L; + glyph_layouts = alloca (sizeof (struct ns_glyph_layout) * glyph_len); + used = ns_font_shape (nsfont, string, glyph_layouts, glyph_len, dir); + + for (i = 0; i < used; i++) + { + Lisp_Object lglyph = LGSTRING_GLYPH (lgstring, i); + struct ns_glyph_layout *gl = glyph_layouts + i; + EMACS_INT from, to; + struct font_metrics metrics; + + if (NILP (lglyph)) + { + lglyph = LGLYPH_NEW (); + LGSTRING_SET_GLYPH (lgstring, i, lglyph); + } + + from = gl->comp_range.location; + LGLYPH_SET_FROM (lglyph, from); + + to = gl->comp_range.location + gl->comp_range.length; + LGLYPH_SET_TO (lglyph, to - 1); + + /* LGLYPH_CHAR is used in `describe-char' for checking whether + the composition is trivial. */ + { + UTF32Char c; + + if (mb_buf[gl->string_index] >= 0xD800 + && mb_buf[gl->string_index] < 0xDC00) + c = (((mb_buf[gl->string_index] - 0xD800) << 10) + + (mb_buf[gl->string_index + 1] - 0xDC00) + 0x10000); + else + c = mb_buf[gl->string_index]; + + LGLYPH_SET_CHAR (lglyph, c); + } + + { + unsigned long cc = gl->glyph_id; + LGLYPH_SET_CODE (lglyph, cc); + } + + nsfont_text_extents (font, &gl->glyph_id, 1, &metrics); + LGLYPH_SET_WIDTH (lglyph, metrics.width); + LGLYPH_SET_LBEARING (lglyph, metrics.lbearing); + LGLYPH_SET_RBEARING (lglyph, metrics.rbearing); + LGLYPH_SET_ASCENT (lglyph, metrics.ascent); + LGLYPH_SET_DESCENT (lglyph, metrics.descent); + } + unblock_input (); + + return make_fixnum (used); +} /* ========================================================================== @@ -1134,6 +1606,50 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y, ========================================================================== */ +static NSGlyph +ns_uni_to_glyphs_1 (struct nsfont_info *info, unsigned int c) +{ + unichar characters[] = { c }; + NSString *string = + [NSString stringWithCharacters: characters + length: 1]; + NSDictionary *attributes = + [NSDictionary dictionaryWithObjectsAndKeys: + info->nsfont, NSFontAttributeName, nil]; + NSTextStorage *storage = [[NSTextStorage alloc] initWithString: string + attributes: attributes]; + NSTextContainer *text_container = [[NSTextContainer alloc] init]; + NSLayoutManager *manager = [[NSLayoutManager alloc] init]; + + [manager addTextContainer: text_container]; + [text_container release]; /* Retained by manager */ + [storage addLayoutManager: manager]; + [manager release]; /* Retained by storage */ + + NSFont *font_in_storage = [storage attribute: NSFontAttributeName + atIndex:0 + effectiveRange: NULL]; + NSGlyph glyph = FONT_INVALID_CODE; + + if ((font_in_storage == info->nsfont + || [[font_in_storage fontName] isEqualToString: [info->nsfont fontName]])) + { + @try + { + glyph = [manager glyphAtIndex: 0]; + } + @catch (NSException *e) + { + /* GNUstep bug? */ + glyph = 'X'; + } + } + + [storage release]; + + return glyph; +} + /* Find and cache corresponding glyph codes for unicode values in given hi-byte block of 256. */ static void @@ -1141,7 +1657,7 @@ ns_uni_to_glyphs (struct nsfont_info *font_info, unsigned char block) { unichar *unichars = xmalloc (0x101 * sizeof (unichar)); unsigned int i, g, idx; - unsigned short *glyphs; + unsigned int *glyphs; if (NSFONT_TRACE) fprintf (stderr, "%p\tFinding glyphs for glyphs in block %d\n", @@ -1149,7 +1665,7 @@ ns_uni_to_glyphs (struct nsfont_info *font_info, unsigned char block) block_input (); - font_info->glyphs[block] = xmalloc (0x100 * sizeof (unsigned short)); + font_info->glyphs[block] = xmalloc (0x100 * sizeof (unsigned int)); if (!unichars || !(font_info->glyphs[block])) emacs_abort (); @@ -1166,7 +1682,8 @@ ns_uni_to_glyphs (struct nsfont_info *font_info, unsigned char block) for (i = 0; i < 0x100; i++, glyphs++) { g = unichars[i]; - *glyphs = g; + NSGlyph glyph = ns_uni_to_glyphs_1 (font_info, g); + *glyphs = glyph; } } @@ -1175,18 +1692,19 @@ ns_uni_to_glyphs (struct nsfont_info *font_info, unsigned char block) } -/* Determine and cache metrics for corresponding glyph codes in given - hi-byte block of 256. */ +/* Determine and cache metrics for glyphs in given hi-byte block of + 256. */ static void -ns_glyph_metrics (struct nsfont_info *font_info, unsigned char block) +ns_glyph_metrics (struct nsfont_info *font_info, unsigned int block) { - unsigned int i, g; + unsigned int i; + NSGlyph g; unsigned int numGlyphs = [font_info->nsfont numberOfGlyphs]; NSFont *sfont; struct font_metrics *metrics; if (NSFONT_TRACE) - fprintf (stderr, "%p\tComputing metrics for glyphs in block %d\n", + fprintf (stderr, "%p\tComputing metrics for glyphs in block %u\n", font_info, block); /* not implemented yet (as of startup 0.18), so punt */ @@ -1209,19 +1727,14 @@ ns_glyph_metrics (struct nsfont_info *font_info, unsigned char block) w = max ([sfont advancementForGlyph: g].width, 2.0); metrics->width = lrint (w); - lb = r.origin.x; - rb = r.size.width - w; - // Add to bearing for LCD smoothing. We don't know if it is there. - if (lb < 0) - metrics->lbearing = round (lb - LCD_SMOOTHING_MARGIN); - if (font_info->ital) - rb += (CGFloat) (0.22F * font_info->height); - metrics->rbearing = lrint (w + rb + LCD_SMOOTHING_MARGIN); - - metrics->descent = r.origin.y < 0 ? -r.origin.y : 0; - /* lrint (hshrink * [sfont ascender] + expand * hd/2); */ - metrics->ascent = r.size.height - metrics->descent; - /* -lrint (hshrink* [sfont descender] - expand * hd/2); */ + lb = NSMinX (r); + rb = NSMaxX (r); + + metrics->rbearing = lrint (rb); + metrics->lbearing = lrint (lb); + + metrics->descent = NSMinY (r); + metrics->ascent = NSMaxY (r); } unblock_input (); } @@ -1257,6 +1770,7 @@ struct font_driver const nsfont_driver = .has_char = nsfont_has_char, .encode_char = nsfont_encode_char, .text_extents = nsfont_text_extents, + .shape = nsfont_shape, .draw = nsfont_draw, }; @@ -1265,7 +1779,6 @@ syms_of_nsfont (void) { DEFSYM (Qcondensed, "condensed"); DEFSYM (Qexpanded, "expanded"); - DEFSYM (Qapple, "apple"); DEFSYM (Qmedium, "medium"); DEFVAR_LISP ("ns-reg-to-script", Vns_reg_to_script, doc: /* Internal use: maps font registry to Unicode script. */); diff --git a/src/nsgui.h b/src/nsgui.h index e4038d32267..e79fcab3364 100644 --- a/src/nsgui.h +++ b/src/nsgui.h @@ -58,9 +58,6 @@ typedef struct _XCharStruct int descent; } XCharStruct; -/* Used in xdisp.c when comparing faces and frame colors. */ -extern unsigned long ns_color_index_to_rgba(int idx, struct frame *f); - #ifdef __OBJC__ typedef id Emacs_Pixmap; #else diff --git a/src/nsimage.m b/src/nsimage.m index dd2bb3b0d7b..98efc9c6c08 100644 --- a/src/nsimage.m +++ b/src/nsimage.m @@ -76,6 +76,8 @@ ns_can_use_native_image_api (Lisp_Object type) imageType = @"public.tiff"; else if (EQ (type, Qsvg)) imageType = @"public.svg-image"; + else if (EQ (type, Qheic)) + imageType = @"public.heic"; /* NSImage also supports a host of other types such as PDF and BMP, but we don't yet support these in image.c. */ diff --git a/src/nsmenu.m b/src/nsmenu.m index 9b78643d56a..d15386641f8 100644 --- a/src/nsmenu.m +++ b/src/nsmenu.m @@ -101,6 +101,15 @@ popup_activated (void) static void ns_update_menubar (struct frame *f, bool deep_p) { +#ifdef NS_IMPL_GNUSTEP + static int inside = 0; + + if (inside) + return; + + inside++; +#endif + BOOL needsSet = NO; id menu = [NSApp mainMenu]; bool owfi; @@ -120,7 +129,12 @@ ns_update_menubar (struct frame *f, bool deep_p) NSTRACE ("ns_update_menubar"); if (f != SELECTED_FRAME () || FRAME_EXTERNAL_MENU_BAR (f) == 0) + { +#ifdef NS_IMPL_GNUSTEP + inside--; +#endif return; + } XSETFRAME (Vmenu_updating_frame, f); /*fprintf (stderr, "ns_update_menubar: frame: %p\tdeep: %d\tsub: %p\n", f, deep_p, submenu); */ @@ -144,10 +158,6 @@ ns_update_menubar (struct frame *f, bool deep_p) t = -(1000*tb.time+tb.millitm); #endif -#ifdef NS_IMPL_GNUSTEP - deep_p = 1; /* See comment in menuNeedsUpdate. */ -#endif - if (deep_p) { /* Make a widget-value tree representing the entire menu trees. */ @@ -275,6 +285,9 @@ ns_update_menubar (struct frame *f, bool deep_p) free_menubar_widget_value_tree (first_wv); discard_menu_items (); unbind_to (specpdl_count, Qnil); +#ifdef NS_IMPL_GNUSTEP + inside--; +#endif return; } @@ -408,6 +421,10 @@ ns_update_menubar (struct frame *f, bool deep_p) if (needsSet) [NSApp setMainMenu: menu]; +#ifdef NS_IMPL_GNUSTEP + inside--; +#endif + unblock_input (); } @@ -452,17 +469,34 @@ set_frame_menubar (struct frame *f, bool deep_p) call to ns_update_menubar. */ - (void)menuNeedsUpdate: (NSMenu *)menu { +#ifdef NS_IMPL_GNUSTEP + static int inside = 0; +#endif + if (!FRAME_LIVE_P (SELECTED_FRAME ())) return; -#ifdef NS_IMPL_COCOA -/* TODO: GNUstep calls this method when the menu is still being built - which results in a recursive stack overflow. One possible solution - is to use menuWillOpen instead, but the Apple docs explicitly warn - against changing the contents of the menu in it. I don't know what - the right thing to do for GNUstep is. */ +#ifdef NS_IMPL_GNUSTEP + /* GNUstep calls this method when the menu is still being built + which results in a recursive stack overflow, which this variable + prevents. */ + + if (!inside) + ++inside; + else + return; +#endif + if (needsUpdate) - ns_update_menubar (SELECTED_FRAME (), true); + { +#ifdef NS_IMPL_GNUSTEP + needsUpdate = NO; +#endif + ns_update_menubar (SELECTED_FRAME (), true); + } + +#ifdef NS_IMPL_GNUSTEP + --inside; #endif } @@ -789,6 +823,9 @@ ns_menu_show (struct frame *f, int x, int y, int menuflags, p.x = x; p.y = y; + /* Don't GC due to a mysterious bug. */ + inhibit_garbage_collection (); + /* now parse stage 2 as in ns_update_menubar */ wv = make_widget_value ("contextmenu", NULL, true, Qnil); wv->button_type = BUTTON_TYPE_NONE; @@ -960,15 +997,17 @@ ns_menu_show (struct frame *f, int x, int y, int menuflags, pmenu = [[EmacsMenu alloc] initWithTitle: NILP (title) ? @"" : [NSString stringWithLispString: title]]; + /* On GNUstep, this call makes menu_items nil for whatever reason + when displaying a context menu from `context-menu-mode'. */ + Lisp_Object items = menu_items; [pmenu fillWithWidgetValue: first_wv->contents]; + menu_items = items; free_menubar_widget_value_tree (first_wv); - unbind_to (specpdl_count, Qnil); - popup_activated_flag = 1; tem = [pmenu runMenuAt: p forFrame: f keymaps: keymaps]; popup_activated_flag = 0; [[FRAME_NS_VIEW (SELECTED_FRAME ()) window] makeKeyWindow]; - + unbind_to (specpdl_count, Qnil); unblock_input (); return tem; } @@ -1019,6 +1058,15 @@ update_frame_tool_bar_1 (struct frame *f, EmacsToolbar *toolbar) [toolbar clearActive]; #else [toolbar clearAll]; + /* It takes at least 3 such adjustments to fix an issue where the + tool bar is 2x too tall when a frame's tool bar is first shown. + This is ugly, but I have no other solution for this problem. */ + if (FRAME_OUTPUT_DATA (f)->tool_bar_adjusted < 3) + { + [toolbar setVisible: NO]; + FRAME_OUTPUT_DATA (f)->tool_bar_adjusted++; + [toolbar setVisible: YES]; + } #endif /* Update EmacsToolbar as in GtkUtils, build items list. */ @@ -1033,9 +1081,7 @@ update_frame_tool_bar_1 (struct frame *f, EmacsToolbar *toolbar) struct image *img; Lisp_Object image; Lisp_Object labelObj; - const char *labelText; Lisp_Object helpObj; - const char *helpText; /* Check if this is a separator. */ if (EQ (TOOLPROP (TOOL_BAR_ITEM_TYPE), Qt)) @@ -1061,11 +1107,9 @@ update_frame_tool_bar_1 (struct frame *f, EmacsToolbar *toolbar) idx = -1; } labelObj = TOOLPROP (TOOL_BAR_ITEM_LABEL); - labelText = NILP (labelObj) ? "" : SSDATA (labelObj); helpObj = TOOLPROP (TOOL_BAR_ITEM_HELP); if (NILP (helpObj)) helpObj = TOOLPROP (TOOL_BAR_ITEM_CAPTION); - helpText = NILP (helpObj) ? "" : SSDATA (helpObj); /* Ignore invalid image specifications. */ if (!valid_image_p (image)) @@ -1087,8 +1131,8 @@ update_frame_tool_bar_1 (struct frame *f, EmacsToolbar *toolbar) [toolbar addDisplayItemWithImage: img->pixmap idx: k++ tag: i - labelText: labelText - helpText: helpText + labelText: [NSString stringWithLispString:labelObj] + helpText: [NSString stringWithLispString:helpObj] enabled: enabled_p]; #undef TOOLPROP } @@ -1204,15 +1248,15 @@ update_frame_tool_bar (struct frame *f) - (void) addDisplayItemWithImage: (EmacsImage *)img idx: (int)idx tag: (int)tag - labelText: (const char *)label - helpText: (const char *)help + labelText: (NSString *)label + helpText: (NSString *)help enabled: (BOOL)enabled { NSTRACE ("[EmacsToolbar addDisplayItemWithImage: ...]"); /* 1) come up w/identifier */ - NSString *identifier - = [NSString stringWithFormat: @"%lu", (unsigned long)[img hash]]; + NSString *identifier = [NSString stringWithFormat: @"%lu%@", + (unsigned long)[img hash], label]; [activeIdentifiers addObject: identifier]; /* 2) create / reuse item */ @@ -1222,8 +1266,8 @@ update_frame_tool_bar (struct frame *f) item = [[[NSToolbarItem alloc] initWithItemIdentifier: identifier] autorelease]; [item setImage: img]; - [item setLabel: [NSString stringWithUTF8String: label]]; - [item setToolTip: [NSString stringWithUTF8String: help]]; + [item setLabel: label]; + [item setToolTip: help]; [item setTarget: emacsView]; [item setAction: @selector (toolbarClicked:)]; [identifierToItem setObject: item forKey: identifier]; 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 @@ ns_get_local_selection (Lisp_Object selection_name, 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 @@ Lisp_Object 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 @@ ns_string_from_pasteboard (id pb) } } + /* 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 @@ ns_string_from_pasteboard (id pb) NS_ENDHANDLER return make_string (utfStr, length); +#endif } @@ -491,6 +567,8 @@ syms_of_nsselect (void) 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 4bbcf43973a..75b31c68f1d 100644 --- a/src/nsterm.h +++ b/src/nsterm.h @@ -357,8 +357,9 @@ typedef id instancetype; @interface NSColor (EmacsColor) + (NSColor *)colorForEmacsRed:(CGFloat)red green:(CGFloat)green blue:(CGFloat)blue alpha:(CGFloat)alpha; ++ (NSColor *)colorWithUnsignedLong:(unsigned long)c; - (NSColor *)colorUsingDefaultColorSpace; - +- (unsigned long)unsignedLong; @end @@ -550,8 +551,8 @@ typedef id instancetype; - (void) addDisplayItemWithImage: (EmacsImage *)img idx: (int)idx tag: (int)tag - labelText: (const char *)label - helpText: (const char *)help + labelText: (NSString *)label + helpText: (NSString *)help enabled: (BOOL)enabled; /* delegate methods */ @@ -766,35 +767,6 @@ struct ns_bitmap_record int height, width, depth; }; -/* This maps between emacs color indices and NSColor objects. */ -struct ns_color_table -{ - ptrdiff_t size; - ptrdiff_t avail; -#ifdef __OBJC__ - NSColor **colors; - NSMutableSet *empty_indices; -#else - void **items; - void *availIndices; -#endif -}; -#define NS_COLOR_CAPACITY 256 - -#define RGB_TO_ULONG(r, g, b) (((r) << 16) | ((g) << 8) | (b)) -#define ARGB_TO_ULONG(a, r, g, b) (((a) << 24) | ((r) << 16) | ((g) << 8) | (b)) - -#define ALPHA_FROM_ULONG(color) ((color) >> 24) -#define RED_FROM_ULONG(color) (((color) >> 16) & 0xff) -#define GREEN_FROM_ULONG(color) (((color) >> 8) & 0xff) -#define BLUE_FROM_ULONG(color) ((color) & 0xff) - -/* Do not change `* 0x101' in the following lines to `<< 8'. If - changed, image masks in 1-bit depth will not work. */ -#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) - #ifdef NS_IMPL_GNUSTEP /* this extends font backend font */ struct nsfont_info @@ -820,7 +792,7 @@ struct nsfont_info XCharStruct max_bounds; /* We compute glyph codes and metrics on-demand in blocks of 256 indexed by hibyte, lobyte. */ - unsigned short **glyphs; /* map Unicode index to glyph */ + unsigned int **glyphs; /* map Unicode index to glyph */ struct font_metrics **metrics; }; #endif @@ -850,8 +822,6 @@ struct ns_display_info ptrdiff_t bitmaps_size; ptrdiff_t bitmaps_last; - struct ns_color_table *color_table; - /* DPI resolution of this screen */ double resx, resy; @@ -978,6 +948,12 @@ struct ns_output /* Non-zero if we are doing an animation, e.g. toggling the tool bar. */ int in_animation; + +#ifdef NS_IMPL_GNUSTEP + /* Zero if this is the first time a toolbar has been updated on this + frame. */ + int tool_bar_adjusted; +#endif }; /* This dummy declaration needed to support TTYs. */ @@ -1121,13 +1097,9 @@ ns_defined_color (struct frame *f, const char *name, Emacs_Color *color_def, bool alloc, bool makeIndex); -extern void -ns_query_color (void *col, Emacs_Color *color_def, bool setPixel); #ifdef __OBJC__ extern int ns_lisp_to_color (Lisp_Object color, NSColor **col); -extern NSColor *ns_lookup_indexed_color (unsigned long idx, struct frame *f); -extern unsigned long ns_index_color (NSColor *color, struct frame *f); extern const char *ns_get_pending_menu_title (void); #endif @@ -1340,9 +1312,16 @@ 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 NSPasteboardTypePDF NSPDFPboardType +#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 aa29c13eb22..f79e271a989 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -65,6 +65,7 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu) #ifdef NS_IMPL_GNUSTEP #include "process.h" +#import <GNUstepGUI/GSDisplayServer.h> #endif #ifdef NS_IMPL_COCOA @@ -165,6 +166,27 @@ char const * nstrace_fullscreen_type_name (int fs_type) return [self colorUsingColorSpace: [NSColorSpace deviceRGBColorSpace]]; } ++ (NSColor *)colorWithUnsignedLong:(unsigned long)c +{ + EmacsCGFloat a = (double)((c >> 24) & 0xff) / 255.0; + EmacsCGFloat r = (double)((c >> 16) & 0xff) / 255.0; + EmacsCGFloat g = (double)((c >> 8) & 0xff) / 255.0; + EmacsCGFloat b = (double)(c & 0xff) / 255.0; + + return [NSColor colorForEmacsRed:r green:g blue:b alpha:a]; +} + +- (unsigned long)unsignedLong +{ + EmacsCGFloat r, g, b, a; + [self getRed:&r green:&g blue:&b alpha:&a]; + + return (((unsigned long) (a * 255)) << 24) + | (((unsigned long) (r * 255)) << 16) + | (((unsigned long) (g * 255)) << 8) + | ((unsigned long) (b * 255)); +} + @end /* ========================================================================== @@ -431,14 +453,6 @@ ev_modifiers_helper (unsigned int flags, unsigned int left_mask, } -/* These flags will be OR'd or XOR'd with the NSWindow's styleMask - property depending on what we're doing. */ -#define FRAME_DECORATED_FLAGS (NSWindowStyleMaskTitled \ - | NSWindowStyleMaskResizable \ - | NSWindowStyleMaskMiniaturizable \ - | NSWindowStyleMaskClosable) -#define FRAME_UNDECORATED_FLAGS NSWindowStyleMaskBorderless - /* TODO: Get rid of need for these forward declarations. */ static void ns_condemn_scroll_bars (struct frame *f); static void ns_judge_scroll_bars (struct frame *f); @@ -534,8 +548,11 @@ ns_init_locale (void) 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, @@ -543,12 +560,12 @@ ns_init_locale (void) 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); } } @@ -1077,11 +1094,16 @@ ns_focus (struct frame *f, NSRect *r, int n) /* clipping */ if (r) { - [[NSGraphicsContext currentContext] saveGraphicsState]; + NSGraphicsContext *ctx = [NSGraphicsContext currentContext]; + [ctx saveGraphicsState]; +#ifdef NS_IMPL_COCOA if (n == 2) NSRectClipList (r, 2); else NSRectClip (*r); +#else + GSRectClipList (ctx, r, n); +#endif gsaved = YES; } } @@ -1940,59 +1962,6 @@ ns_fullscreen_hook (struct frame *f) ========================================================================== */ -NSColor * -ns_lookup_indexed_color (unsigned long idx, struct frame *f) -{ - struct ns_color_table *color_table = FRAME_DISPLAY_INFO (f)->color_table; - if (idx < 1 || idx >= color_table->avail) - return nil; - return color_table->colors[idx]; -} - - -unsigned long -ns_index_color (NSColor *color, struct frame *f) -{ - struct ns_color_table *color_table = FRAME_DISPLAY_INFO (f)->color_table; - ptrdiff_t idx; - ptrdiff_t i; - - if (!color_table->colors) - { - color_table->size = NS_COLOR_CAPACITY; - color_table->avail = 1; /* skip idx=0 as marker */ - color_table->colors = xmalloc (color_table->size * sizeof (NSColor *)); - color_table->colors[0] = nil; - color_table->empty_indices = [[NSMutableSet alloc] init]; - } - - /* Do we already have this color? */ - for (i = 1; i < color_table->avail; i++) - if (color_table->colors[i] && [color_table->colors[i] isEqual: color]) - return i; - - if ([color_table->empty_indices count] > 0) - { - NSNumber *index = [color_table->empty_indices anyObject]; - [color_table->empty_indices removeObject: index]; - idx = [index unsignedLongValue]; - } - else - { - if (color_table->avail == color_table->size) - color_table->colors = - xpalloc (color_table->colors, &color_table->size, 1, - min (ULONG_MAX, PTRDIFF_MAX), sizeof *color_table->colors); - idx = color_table->avail++; - } - - color_table->colors[idx] = color; - [color retain]; - /* fprintf(stderr, "color_table: allocated %d\n",idx); */ - return idx; -} - - static int ns_get_color (const char *name, NSColor **col) /* -------------------------------------------------------------------------- @@ -2117,31 +2086,11 @@ ns_lisp_to_color (Lisp_Object color, NSColor **col) return 1; } -/* Convert an index into the color table into an RGBA value. Used in - xdisp.c:extend_face_to_end_of_line when comparing faces and frame - color values. */ - -unsigned long -ns_color_index_to_rgba(int idx, struct frame *f) -{ - NSColor *col; - col = ns_lookup_indexed_color (idx, f); - - EmacsCGFloat r, g, b, a; - [col getRed: &r green: &g blue: &b alpha: &a]; - - return ARGB_TO_ULONG((unsigned long) (a * 255), - (unsigned long) (r * 255), - (unsigned long) (g * 255), - (unsigned long) (b * 255)); -} - void -ns_query_color(void *col, Emacs_Color *color_def, bool setPixel) +ns_query_color(void *col, Emacs_Color *color_def) /* -------------------------------------------------------------------------- - Get ARGB values out of NSColor col and put them into color_def. - If setPixel, set the pixel to a concatenated version. - and set color_def pixel to the resulting index. + Get ARGB values out of NSColor col and put them into color_def + and set color_def pixel to the ARGB color. -------------------------------------------------------------------------- */ { EmacsCGFloat r, g, b, a; @@ -2151,12 +2100,7 @@ ns_query_color(void *col, Emacs_Color *color_def, bool setPixel) color_def->green = g * 65535; color_def->blue = b * 65535; - if (setPixel == YES) - color_def->pixel - = ARGB_TO_ULONG((unsigned long) (a * 255), - (unsigned long) (r * 255), - (unsigned long) (g * 255), - (unsigned long) (b * 255)); + color_def->pixel = [(NSColor *)col unsignedLong]; } bool @@ -2164,12 +2108,9 @@ ns_defined_color (struct frame *f, const char *name, Emacs_Color *color_def, bool alloc, - bool makeIndex) + bool _makeIndex) /* -------------------------------------------------------------------------- Return true if named color found, and set color_def rgb accordingly. - If makeIndex and alloc are nonzero put the color in the color_table, - and set color_def pixel to the resulting index. - If makeIndex is zero, set color_def pixel to ARGB. Return false if not found. -------------------------------------------------------------------------- */ { @@ -2182,9 +2123,7 @@ ns_defined_color (struct frame *f, unblock_input (); return 0; } - if (makeIndex && alloc) - color_def->pixel = ns_index_color (col, f); - ns_query_color (col, color_def, !makeIndex); + ns_query_color (col, color_def); unblock_input (); return 1; } @@ -2195,7 +2134,7 @@ ns_query_frame_background_color (struct frame *f, Emacs_Color *bgcolor) External (hook): Store F's background color into *BGCOLOR -------------------------------------------------------------------------- */ { - ns_query_color (FRAME_BACKGROUND_COLOR (f), bgcolor, true); + ns_query_color (FRAME_BACKGROUND_COLOR (f), bgcolor); } static void @@ -2249,13 +2188,19 @@ frame_set_mouse_pixel_position (struct frame *f, int pix_x, int pix_y) { NSTRACE ("frame_set_mouse_pixel_position"); - /* FIXME: what about GNUstep? */ #ifdef NS_IMPL_COCOA CGPoint mouse_pos = CGPointMake(f->left_pos + pix_x, f->top_pos + pix_y + FRAME_NS_TITLEBAR_HEIGHT(f) + FRAME_TOOLBAR_HEIGHT(f)); CGWarpMouseCursorPosition (mouse_pos); +#else + GSDisplayServer *server = GSServerForWindow ([FRAME_NS_VIEW (f) window]); + [server setMouseLocation: NSMakePoint (f->left_pos + pix_x, + f->top_pos + pix_y + + FRAME_NS_TITLEBAR_HEIGHT(f) + + FRAME_TOOLBAR_HEIGHT(f)) + onScreen: [[[FRAME_NS_VIEW (f) window] screen] screenNumber]]; #endif } @@ -2433,9 +2378,6 @@ ns_define_frame_cursor (struct frame *f, Emacs_Cursor cursor) EmacsView *view = FRAME_NS_VIEW (f); FRAME_POINTER_TYPE (f) = cursor; [[view window] invalidateCursorRectsForView: view]; - /* Redisplay assumes this function also draws the changed frame - cursor, but this function doesn't, so do it explicitly. */ - gui_update_cursor (f, 1); } } @@ -2571,8 +2513,7 @@ ns_get_shifted_character (NSEvent *event) ========================================================================== */ -#if 0 -/* FIXME: Remove this function. */ +#ifdef NS_IMPL_GNUSTEP static void ns_redraw_scroll_bars (struct frame *f) { @@ -2612,15 +2553,14 @@ ns_clear_frame (struct frame *f) block_input (); ns_focus (f, &r, 1); - [ns_lookup_indexed_color (NS_FACE_BACKGROUND - (FACE_FROM_ID (f, DEFAULT_FACE_ID)), f) set]; + [[NSColor colorWithUnsignedLong:NS_FACE_BACKGROUND + (FACE_FROM_ID (f, DEFAULT_FACE_ID))] set]; NSRectFill (r); ns_unfocus (f); - /* as of 2006/11 or so this is now needed */ - /* FIXME: I don't see any reason for this and removing it makes no - difference here. Do we need it for GNUstep? */ - //ns_redraw_scroll_bars (f); +#ifdef NS_IMPL_GNUSTEP + ns_redraw_scroll_bars (f); +#endif unblock_input (); } @@ -2642,7 +2582,7 @@ ns_clear_frame_area (struct frame *f, int x, int y, int width, int height) r = NSIntersectionRect (r, [view frame]); ns_focus (f, &r, 1); - [ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), f) set]; + [[NSColor colorWithUnsignedLong:NS_FACE_BACKGROUND (face)] set]; NSRectFill (r); @@ -2745,8 +2685,7 @@ ns_clear_under_internal_border (struct frame *f) return; ns_focus (f, NULL, 1); - [ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), f) set]; - + [[NSColor colorWithUnsignedLong:NS_FACE_BACKGROUND (face)] set]; NSRectFill (NSMakeRect (0, margin, width, border)); NSRectFill (NSMakeRect (0, 0, border, height)); NSRectFill (NSMakeRect (0, margin, width, border)); @@ -2797,7 +2736,7 @@ ns_after_update_window_line (struct window *w, struct glyph_row *desired_row) NSRect r = NSMakeRect (0, y, FRAME_PIXEL_WIDTH (f), height); ns_focus (f, &r, 1); - [ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), f) set]; + [[NSColor colorWithUnsignedLong:NS_FACE_BACKGROUND (face)] set]; NSRectFill (NSMakeRect (0, y, width, height)); NSRectFill (NSMakeRect (FRAME_PIXEL_WIDTH (f) - width, y, width, height)); @@ -2847,31 +2786,31 @@ ns_compute_glyph_string_overhangs (struct glyph_string *s) External (RIF); compute left/right overhang of whole string and set in s -------------------------------------------------------------------------- */ { - struct font *font = s->font; - - if (s->char2b) + if (s->cmp == NULL + && (s->first_glyph->type == CHAR_GLYPH + || s->first_glyph->type == COMPOSITE_GLYPH)) { struct font_metrics metrics; - unsigned int codes[2]; - codes[0] = *(s->char2b); - codes[1] = *(s->char2b + s->nchars - 1); - font->driver->text_extents (font, codes, 2, &metrics); - s->left_overhang = -metrics.lbearing; - s->right_overhang - = metrics.rbearing > metrics.width - ? metrics.rbearing - metrics.width : 0; + 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 + else if (s->cmp) { - s->left_overhang = 0; -#ifdef NS_IMPL_GNUSTEP - if (EQ (font->driver->type, Qns)) - s->right_overhang = ((struct nsfont_info *)font)->ital ? - FONT_HEIGHT (font) * 0.2 : 0; - else -#endif - s->right_overhang = 0; + s->right_overhang = s->cmp->rbearing - s->cmp->pixel_width; + s->left_overhang = - s->cmp->lbearing; } } @@ -2965,7 +2904,7 @@ ns_draw_fringe_bitmap (struct window *w, struct glyph_row *row, { NSTRACE_RECT ("clearRect", clearRect); - [ns_lookup_indexed_color(face->background, f) set]; + [[NSColor colorWithUnsignedLong:face->background] set]; NSRectFill (clearRect); } @@ -2982,9 +2921,9 @@ ns_draw_fringe_bitmap (struct window *w, struct glyph_row *row, [bmp transformUsingAffineTransform:transform]; if (!p->cursor_p) - bm_color = ns_lookup_indexed_color(face->foreground, f); + bm_color = [NSColor colorWithUnsignedLong:face->foreground]; else if (p->overlay_p) - bm_color = ns_lookup_indexed_color(face->background, f); + bm_color = [NSColor colorWithUnsignedLong:face->background]; else bm_color = f->output_data.ns->cursor_color; @@ -3011,14 +2950,13 @@ ns_draw_window_cursor (struct window *w, struct glyph_row *glyph_row, struct frame *f = WINDOW_XFRAME (w); struct glyph *phys_cursor_glyph; struct glyph *cursor_glyph; - struct face *face; - NSColor *hollow_color = FRAME_BACKGROUND_COLOR (f); /* If cursor is out of bounds, don't draw garbage. This can happen in mini-buffer windows when switching between echo area glyphs and mini-buffer. */ - NSTRACE ("ns_draw_window_cursor"); + NSTRACE ("ns_draw_window_cursor (on = %d, cursor_type = %d)", + on_p, cursor_type); if (!on_p) return; @@ -3034,6 +2972,8 @@ ns_draw_window_cursor (struct window *w, struct glyph_row *glyph_row, if ((phys_cursor_glyph = get_phys_cursor_glyph (w)) == NULL) { + NSTRACE_MSG ("No phys cursor glyph was found!"); + if (glyph_row->exact_window_width_line_p && w->phys_cursor.hpos >= glyph_row->used[TEXT_AREA]) { @@ -3043,10 +2983,6 @@ ns_draw_window_cursor (struct window *w, struct glyph_row *glyph_row, return; } - /* We draw the cursor (with NSRectFill), then draw the glyph on top - (other terminals do it the other way round). We must set - w->phys_cursor_width to the cursor width. For bar cursors, that - is CURSOR_WIDTH; for box cursors, it is the glyph width. */ get_phys_cursor_geometry (w, glyph_row, phys_cursor_glyph, &fx, &fy, &h); /* The above get_phys_cursor_geometry call set w->phys_cursor_width @@ -3078,17 +3014,17 @@ ns_draw_window_cursor (struct window *w, struct glyph_row *glyph_row, /* Prevent the cursor from being drawn outside the text area. */ r = NSIntersectionRect (r, ns_row_rect (w, glyph_row, TEXT_AREA)); - ns_focus (f, &r, 1); + ns_focus (f, NULL, 0); - face = FACE_FROM_ID_OR_NULL (f, phys_cursor_glyph->face_id); - if (face && NS_FACE_BACKGROUND (face) - == ns_index_color (FRAME_CURSOR_COLOR (f), f)) - { - [ns_lookup_indexed_color (NS_FACE_FOREGROUND (face), f) set]; - hollow_color = FRAME_CURSOR_COLOR (f); - } - else - [FRAME_CURSOR_COLOR (f) set]; + NSGraphicsContext *ctx = [NSGraphicsContext currentContext]; + [ctx saveGraphicsState]; +#ifdef NS_IMPL_GNUSTEP + GSRectClipList (ctx, &r, 1); +#else + NSRectClip (r); +#endif + + [FRAME_CURSOR_COLOR (f) set]; switch (cursor_type) { @@ -3096,13 +3032,11 @@ ns_draw_window_cursor (struct window *w, struct glyph_row *glyph_row, case NO_CURSOR: break; case FILLED_BOX_CURSOR: - NSRectFill (r); + draw_phys_cursor_glyph (w, glyph_row, DRAW_CURSOR); break; case HOLLOW_BOX_CURSOR: - NSRectFill (r); - [hollow_color set]; - NSRectFill (NSInsetRect (r, 1, 1)); - [FRAME_CURSOR_COLOR (f) set]; + draw_phys_cursor_glyph (w, glyph_row, DRAW_NORMAL_TEXT); + [NSBezierPath strokeRect: r]; break; case HBAR_CURSOR: NSRectFill (r); @@ -3118,12 +3052,9 @@ ns_draw_window_cursor (struct window *w, struct glyph_row *glyph_row, NSRectFill (s); break; } - ns_unfocus (f); - /* Draw the character under the cursor. Other terms only draw - the character on top of box cursors, so do the same here. */ - if (cursor_type == FILLED_BOX_CURSOR || cursor_type == HOLLOW_BOX_CURSOR) - draw_phys_cursor_glyph (w, glyph_row, DRAW_CURSOR); + [ctx restoreGraphicsState]; + ns_unfocus (f); } @@ -3143,7 +3074,7 @@ ns_draw_vertical_window_border (struct window *w, int x, int y0, int y1) ns_focus (f, &r, 1); if (face) - [ns_lookup_indexed_color(face->foreground, f) set]; + [[NSColor colorWithUnsignedLong:face->foreground] set]; NSRectFill(r); ns_unfocus (f); @@ -3179,29 +3110,29 @@ ns_draw_window_divider (struct window *w, int x0, int x1, int y0, int y1) /* A vertical divider, at least three pixels wide: Draw first and last pixels differently. */ { - [ns_lookup_indexed_color(color_first, f) set]; + [[NSColor colorWithUnsignedLong:color_first] set]; NSRectFill(NSMakeRect (x0, y0, 1, y1 - y0)); - [ns_lookup_indexed_color(color, f) set]; + [[NSColor colorWithUnsignedLong:color] set]; NSRectFill(NSMakeRect (x0 + 1, y0, x1 - x0 - 2, y1 - y0)); - [ns_lookup_indexed_color(color_last, f) set]; + [[NSColor colorWithUnsignedLong:color_last] set]; NSRectFill(NSMakeRect (x1 - 1, y0, 1, y1 - y0)); } else if ((x1 - x0 > y1 - y0) && (y1 - y0 >= 3)) /* A horizontal divider, at least three pixels high: Draw first and last pixels differently. */ { - [ns_lookup_indexed_color(color_first, f) set]; + [[NSColor colorWithUnsignedLong:color_first] set]; NSRectFill(NSMakeRect (x0, y0, x1 - x0, 1)); - [ns_lookup_indexed_color(color, f) set]; + [[NSColor colorWithUnsignedLong:color] set]; NSRectFill(NSMakeRect (x0, y0 + 1, x1 - x0, y1 - y0 - 2)); - [ns_lookup_indexed_color(color_last, f) set]; + [[NSColor colorWithUnsignedLong:color_last] set]; NSRectFill(NSMakeRect (x0, y1 - 1, x1 - x0, 1)); } else { /* In any other case do not draw the first and last pixels differently. */ - [ns_lookup_indexed_color(color, f) set]; + [[NSColor colorWithUnsignedLong:color] set]; NSRectFill(divider); } @@ -3303,15 +3234,18 @@ ns_draw_text_decoration (struct glyph_string *s, struct face *face, if (s->for_overlaps) return; + if (s->hl == DRAW_CURSOR) + [FRAME_BACKGROUND_COLOR (s->f) set]; + else + [defaultCol set]; + /* Do underline. */ if (face->underline) { if (s->face->underline == FACE_UNDER_WAVE) { - if (face->underline_defaulted_p) - [defaultCol set]; - else - [ns_lookup_indexed_color (face->underline_color, s->f) set]; + if (!face->underline_defaulted_p) + [[NSColor colorWithUnsignedLong:face->underline_color] set]; ns_draw_underwave (s, width, x); } @@ -3384,10 +3318,9 @@ ns_draw_text_decoration (struct glyph_string *s, struct face *face, r = NSMakeRect (x, s->ybase + position, width, thickness); - if (face->underline_defaulted_p) - [defaultCol set]; - else - [ns_lookup_indexed_color (face->underline_color, s->f) set]; + if (!face->underline_defaulted_p) + [[NSColor colorWithUnsignedLong:face->underline_color] set]; + NSRectFill (r); } } @@ -3398,10 +3331,9 @@ ns_draw_text_decoration (struct glyph_string *s, struct face *face, NSRect r; r = NSMakeRect (x, s->y, width, 1); - if (face->overline_color_defaulted_p) - [defaultCol set]; - else - [ns_lookup_indexed_color (face->overline_color, s->f) set]; + if (!face->overline_color_defaulted_p) + [[NSColor colorWithUnsignedLong:face->overline_color] set]; + NSRectFill (r); } @@ -3424,10 +3356,9 @@ ns_draw_text_decoration (struct glyph_string *s, struct face *face, dy = lrint ((glyph_height - h) / 2); r = NSMakeRect (x, glyph_y + dy, width, 1); - if (face->strike_through_color_defaulted_p) - [defaultCol set]; - else - [ns_lookup_indexed_color (face->strike_through_color, s->f) set]; + if (!face->strike_through_color_defaulted_p) + [[NSColor colorWithUnsignedLong:face->strike_through_color] set]; + NSRectFill (r); } } @@ -3485,7 +3416,7 @@ ns_draw_relief (NSRect outer, int hthickness, int vthickness, char raised_p, if (s->face->use_box_color_for_shadows_p) { - newBaseCol = ns_lookup_indexed_color (s->face->box_color, s->f); + newBaseCol = [NSColor colorWithUnsignedLong:s->face->box_color]; } /* else if (s->first_glyph->type == IMAGE_GLYPH && s->img->pixmap @@ -3495,7 +3426,7 @@ ns_draw_relief (NSRect outer, int hthickness, int vthickness, char raised_p, } */ else { - newBaseCol = ns_lookup_indexed_color (s->face->background, s->f); + newBaseCol = [NSColor colorWithUnsignedLong:s->face->background]; } if (newBaseCol == nil) @@ -3575,17 +3506,7 @@ ns_dumpglyphs_box_or_relief (struct glyph_string *s) struct glyph *last_glyph; NSRect r; int hthickness, vthickness; - struct face *face; - - if (s->hl == DRAW_MOUSE_FACE) - { - face = FACE_FROM_ID_OR_NULL (s->f, - MOUSE_HL_INFO (s->f)->mouse_face_face_id); - if (!face) - face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); - } - else - face = s->face; + struct face *face = s->face; vthickness = face->box_vertical_line_width; hthickness = face->box_horizontal_line_width; @@ -3627,7 +3548,7 @@ ns_dumpglyphs_box_or_relief (struct glyph_string *s) if (s->face->box == FACE_SIMPLE_BOX && s->face->box_color) { ns_draw_box (r, abs (hthickness), abs (vthickness), - ns_lookup_indexed_color (face->box_color, s->f), + [NSColor colorWithUnsignedLong:face->box_color], left_p, right_p); } else @@ -3659,34 +3580,26 @@ ns_maybe_dumpglyphs_background (struct glyph_string *s, char force_p) || FONT_TOO_HIGH (s->font) || s->font_not_found_p || s->extends_to_end_of_line_p || force_p) { - struct face *face; - if (s->hl == DRAW_MOUSE_FACE) - { - face - = FACE_FROM_ID_OR_NULL (s->f, - MOUSE_HL_INFO (s->f)->mouse_face_face_id); - if (!face) - face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); - } - else - face = FACE_FROM_ID (s->f, s->first_glyph->face_id); + struct face *face = s->face; if (!face->stipple) - [(NS_FACE_BACKGROUND (face) != 0 - ? ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), s->f) - : FRAME_BACKGROUND_COLOR (s->f)) set]; + { + if (s->hl != DRAW_CURSOR) + [(NS_FACE_BACKGROUND (face) != 0 + ? [NSColor colorWithUnsignedLong:NS_FACE_BACKGROUND (face)] + : FRAME_BACKGROUND_COLOR (s->f)) set]; + else + [FRAME_CURSOR_COLOR (s->f) set]; + } else { struct ns_display_info *dpyinfo = FRAME_DISPLAY_INFO (s->f); [[dpyinfo->bitmaps[face->stipple-1].img stippleMask] set]; } - if (s->hl != DRAW_CURSOR) - { - NSRect r = NSMakeRect (s->x, s->y + box_line_width, - s->background_width, - s->height-2*box_line_width); - NSRectFill (r); - } + NSRect r = NSMakeRect (s->x, s->y + box_line_width, + s->background_width, + s->height-2*box_line_width); + NSRectFill (r); s->background_filled_p = 1; } @@ -3707,7 +3620,7 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r) int th; char raised_p; NSRect br; - struct face *face; + struct face *face = s->face; NSColor *tdCol; NSTRACE ("ns_dumpglyphs_image"); @@ -3728,17 +3641,8 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r) /* Draw BG: if we need larger area than image itself cleared, do that, otherwise, since we composite the image under NS (instead of mucking with its background color), we must clear just the image area. */ - if (s->hl == DRAW_MOUSE_FACE) - { - face = FACE_FROM_ID_OR_NULL (s->f, - MOUSE_HL_INFO (s->f)->mouse_face_face_id); - if (!face) - face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); - } - else - face = FACE_FROM_ID (s->f, s->first_glyph->face_id); - [ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), s->f) set]; + [[NSColor colorWithUnsignedLong:NS_FACE_BACKGROUND (face)] set]; if (bg_height > s->slice.height || s->img->hmargin || s->img->vmargin || s->img->mask || s->img->pixmap == 0 || s->width != s->background_width) @@ -3807,20 +3711,12 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r) if (s->hl == DRAW_CURSOR) { - [FRAME_CURSOR_COLOR (s->f) set]; - if (s->w->phys_cursor_type == FILLED_BOX_CURSOR) - tdCol = ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), s->f); - else - /* Currently on NS img->mask is always 0. Since - get_window_cursor_type specifies a hollow box cursor when on - a non-masked image we never reach this clause. But we put it - in, in anticipation of better support for image masks on - NS. */ - tdCol = ns_lookup_indexed_color (NS_FACE_FOREGROUND (face), s->f); + [FRAME_CURSOR_COLOR (s->f) set]; + tdCol = [NSColor colorWithUnsignedLong:NS_FACE_BACKGROUND (face)]; } else { - tdCol = ns_lookup_indexed_color (NS_FACE_FOREGROUND (face), s->f); + tdCol = [NSColor colorWithUnsignedLong:NS_FACE_FOREGROUND (face)]; } /* Draw underline, overline, strike-through. */ @@ -3868,66 +3764,39 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r) static void ns_dumpglyphs_stretch (struct glyph_string *s) { - NSRect r[2]; NSRect glyphRect; - int n; - struct face *face; + struct face *face = s->face; NSColor *fgCol, *bgCol; if (!s->background_filled_p) { - n = ns_get_glyph_string_clip_rect (s, r); - ns_focus (s->f, r, n); - if (s->hl == DRAW_MOUSE_FACE) - { - face = FACE_FROM_ID_OR_NULL (s->f, - MOUSE_HL_INFO (s->f)->mouse_face_face_id); - if (!face) - face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); - } - else - face = FACE_FROM_ID (s->f, s->first_glyph->face_id); - - bgCol = ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), s->f); - fgCol = ns_lookup_indexed_color (NS_FACE_FOREGROUND (face), s->f); - - glyphRect = NSMakeRect (s->x, s->y, s->background_width, s->height); + face = s->face; - [bgCol set]; + bgCol = [NSColor colorWithUnsignedLong:NS_FACE_BACKGROUND (face)]; + fgCol = [NSColor colorWithUnsignedLong:NS_FACE_FOREGROUND (face)]; - /* NOTE: under NS this is NOT used to draw cursors, but we must avoid - overwriting cursor (usually when cursor on a tab) */ if (s->hl == DRAW_CURSOR) - { - CGFloat x, width; + { + fgCol = bgCol; + bgCol = FRAME_CURSOR_COLOR (s->f); + } - /* FIXME: This looks like it will only work for left to - right languages. */ - x = NSMinX (glyphRect); - width = s->w->phys_cursor_width; - glyphRect.size.width -= width; - glyphRect.origin.x += width; + glyphRect = NSMakeRect (s->x, s->y, s->background_width, s->height); - NSRectFill (glyphRect); + [bgCol set]; - /* Draw overlining, etc. on the cursor. */ - if (s->w->phys_cursor_type == FILLED_BOX_CURSOR) - ns_draw_text_decoration (s, face, bgCol, width, x); - else - ns_draw_text_decoration (s, face, fgCol, width, x); - } - else - { - NSRectFill (glyphRect); - } + NSRectFill (glyphRect); - /* Draw overlining, etc. on the stretch glyph (or the part - of the stretch glyph after the cursor). */ - ns_draw_text_decoration (s, face, fgCol, NSWidth (glyphRect), - NSMinX (glyphRect)); + /* Draw overlining, etc. on the stretch glyph (or the part of + the stretch glyph after the cursor). If the glyph has a box, + then decorations will be drawn after drawing the box in + ns_draw_glyph_string, in order to prevent them from being + overwritten by the box. */ + if (s->face->box == FACE_NO_BOX) + ns_draw_text_decoration (s, face, fgCol, NSWidth (glyphRect), + NSMinX (glyphRect)); - ns_unfocus (s->f); s->background_filled_p = 1; } } @@ -3936,7 +3805,7 @@ ns_dumpglyphs_stretch (struct glyph_string *s) static void ns_draw_glyph_string_foreground (struct glyph_string *s) { - int x, flags; + int x; struct font *font = s->font; /* If first glyph of S has a left box line, start drawing the text @@ -3947,15 +3816,9 @@ ns_draw_glyph_string_foreground (struct glyph_string *s) else x = s->x; - flags = s->hl == DRAW_CURSOR ? NS_DUMPGLYPH_CURSOR : - (s->hl == DRAW_MOUSE_FACE ? NS_DUMPGLYPH_MOUSEFACE : - (s->for_overlaps ? NS_DUMPGLYPH_FOREGROUND : - NS_DUMPGLYPH_NORMAL)); - font->driver->draw (s, s->cmp_from, s->nchars, x, s->ybase, - (flags == NS_DUMPGLYPH_NORMAL && !s->background_filled_p) - || flags == NS_DUMPGLYPH_MOUSEFACE); + !s->for_overlaps && !s->background_filled_p); } @@ -4062,9 +3925,9 @@ ns_draw_glyph_string (struct glyph_string *s) struct font *font = s->face->font; if (! font) font = FRAME_FONT (s->f); - NSTRACE_WHEN (NSTRACE_GROUP_GLYPHS, "ns_draw_glyph_string"); + NSTRACE ("ns_draw_glyph_string (hl = %u)", s->hl); - if (s->next && s->right_overhang && !s->for_overlaps/*&&s->hl!=DRAW_CURSOR*/) + if (s->next && s->right_overhang && !s->for_overlaps) { int width; struct glyph_string *next; @@ -4074,17 +3937,17 @@ ns_draw_glyph_string (struct glyph_string *s) width += next->width, next = next->next) if (next->first_glyph->type != IMAGE_GLYPH) { + n = ns_get_glyph_string_clip_rect (s->next, r); + ns_focus (s->f, r, n); if (next->first_glyph->type != STRETCH_GLYPH) { - n = ns_get_glyph_string_clip_rect (s->next, r); - ns_focus (s->f, r, n); ns_maybe_dumpglyphs_background (s->next, 1); - ns_unfocus (s->f); } else { ns_dumpglyphs_stretch (s->next); } + ns_unfocus (s->f); next->num_clips = 0; } } @@ -4101,14 +3964,21 @@ ns_draw_glyph_string (struct glyph_string *s) box_drawn_p = 1; } + n = ns_get_glyph_string_clip_rect (s, r); + + if (!s->clip_head /* draw_glyphs didn't specify a clip mask. */ + && !s->clip_tail + && ((s->prev && s->prev->hl != s->hl && s->left_overhang) + || (s->next && s->next->hl != s->hl && s->right_overhang))) + r[0] = NSIntersectionRect (r[0], NSMakeRect (s->x, s->y, s->width, s->height)); + + ns_focus (s->f, r, n); + switch (s->first_glyph->type) { case IMAGE_GLYPH: - n = ns_get_glyph_string_clip_rect (s, r); - ns_focus (s->f, r, n); ns_dumpglyphs_image (s, r[0]); - ns_unfocus (s->f); break; case XWIDGET_GLYPH: @@ -4121,57 +3991,34 @@ ns_draw_glyph_string (struct glyph_string *s) case CHAR_GLYPH: case COMPOSITE_GLYPH: - n = ns_get_glyph_string_clip_rect (s, r); - ns_focus (s->f, r, n); - - if (s->for_overlaps || (s->cmp_from > 0 - && ! s->first_glyph->u.cmp.automatic)) - s->background_filled_p = 1; - else - ns_maybe_dumpglyphs_background - (s, s->first_glyph->type == COMPOSITE_GLYPH); - - if (s->hl == DRAW_CURSOR && s->w->phys_cursor_type == FILLED_BOX_CURSOR) - { - unsigned long tmp = NS_FACE_BACKGROUND (s->face); - NS_FACE_BACKGROUND (s->face) = NS_FACE_FOREGROUND (s->face); - NS_FACE_FOREGROUND (s->face) = tmp; - } - { - BOOL isComposite = s->first_glyph->type == COMPOSITE_GLYPH; + BOOL isComposite = s->first_glyph->type == COMPOSITE_GLYPH; + if (s->for_overlaps || (isComposite + && (s->cmp_from > 0 + && ! s->first_glyph->u.cmp.automatic))) + s->background_filled_p = 1; + else + ns_maybe_dumpglyphs_background + (s, s->first_glyph->type == COMPOSITE_GLYPH); - if (isComposite) - ns_draw_composite_glyph_string_foreground (s); - else - ns_draw_glyph_string_foreground (s); - } + if (isComposite) + ns_draw_composite_glyph_string_foreground (s); + else + ns_draw_glyph_string_foreground (s); - { - NSColor *col = (NS_FACE_FOREGROUND (s->face) != 0 - ? ns_lookup_indexed_color (NS_FACE_FOREGROUND (s->face), - s->f) - : FRAME_FOREGROUND_COLOR (s->f)); - [col set]; - - /* Draw underline, overline, strike-through. */ - ns_draw_text_decoration (s, s->face, col, s->width, s->x); - } + { + NSColor *col = (NS_FACE_FOREGROUND (s->face) != 0 + ? [NSColor colorWithUnsignedLong:NS_FACE_FOREGROUND (s->face)] + : FRAME_FOREGROUND_COLOR (s->f)); - if (s->hl == DRAW_CURSOR && s->w->phys_cursor_type == FILLED_BOX_CURSOR) - { - unsigned long tmp = NS_FACE_BACKGROUND (s->face); - NS_FACE_BACKGROUND (s->face) = NS_FACE_FOREGROUND (s->face); - NS_FACE_FOREGROUND (s->face) = tmp; - } + /* Draw underline, overline, strike-through. */ + ns_draw_text_decoration (s, s->face, col, s->width, s->x); + } + } - ns_unfocus (s->f); break; case GLYPHLESS_GLYPH: - n = ns_get_glyph_string_clip_rect (s, r); - ns_focus (s->f, r, n); - if (s->for_overlaps || (s->cmp_from > 0 && ! s->first_glyph->u.cmp.automatic)) s->background_filled_p = 1; @@ -4181,7 +4028,6 @@ ns_draw_glyph_string (struct glyph_string *s) /* ... */ /* Not yet implemented. */ /* ... */ - ns_unfocus (s->f); break; default: @@ -4190,13 +4036,102 @@ ns_draw_glyph_string (struct glyph_string *s) /* Draw box if not done already. */ if (!s->for_overlaps && !box_drawn_p && s->face->box != FACE_NO_BOX) + ns_dumpglyphs_box_or_relief (s); + + if (s->face->box != FACE_NO_BOX + && s->first_glyph->type == STRETCH_GLYPH) { - n = ns_get_glyph_string_clip_rect (s, r); - ns_focus (s->f, r, n); - ns_dumpglyphs_box_or_relief (s); + NSColor *fg_color; + + fg_color = [NSColor colorWithUnsignedLong:NS_FACE_FOREGROUND (s->face)]; + ns_draw_text_decoration (s, s->face, fg_color, + s->background_width, s->x); + } + + ns_unfocus (s->f); + + /* Draw surrounding overhangs. */ + if (s->prev) + { + ns_focus (s->f, NULL, 0); + 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->face = s->face; + NSRect r = NSMakeRect (s->x, s->y, s->width, s->height); + [[NSGraphicsContext currentContext] saveGraphicsState]; + NSRectClip (r); +#ifdef NS_IMPL_GNUSTEP + DPSgsave ([NSGraphicsContext currentContext]); + DPSrectclip ([NSGraphicsContext currentContext], s->x, s->y, + s->width, s->height); +#endif + prev->num_clips = 1; + prev->hl = s->hl; + if (prev->first_glyph->type == CHAR_GLYPH) + ns_draw_glyph_string_foreground (prev); + else + ns_draw_composite_glyph_string_foreground (prev); +#ifdef NS_IMPL_GNUSTEP + DPSgrestore ([NSGraphicsContext currentContext]); +#endif + [[NSGraphicsContext currentContext] restoreGraphicsState]; + prev->hl = save; + prev->face = save_face; + prev->num_clips = 0; + } ns_unfocus (s->f); } + if (s->next) + { + ns_focus (s->f, NULL, 0); + 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; + NSRect r = NSMakeRect (s->x, s->y, s->width, s->height); + [[NSGraphicsContext currentContext] saveGraphicsState]; + NSRectClip (r); +#ifdef NS_IMPL_GNUSTEP + DPSgsave ([NSGraphicsContext currentContext]); + DPSrectclip ([NSGraphicsContext currentContext], s->x, s->y, + s->width, s->height); +#endif + next->num_clips = 1; + if (next->first_glyph->type == CHAR_GLYPH) + ns_draw_glyph_string_foreground (next); + else + ns_draw_composite_glyph_string_foreground (next); +#ifdef NS_IMPL_GNUSTEP + DPSgrestore ([NSGraphicsContext currentContext]); +#endif + [[NSGraphicsContext currentContext] restoreGraphicsState]; + next->hl = save; + next->num_clips = 0; + next->face = save_face; + next->clip_head = next; + next->background_filled_p = 0; + } + ns_unfocus (s->f); + } s->num_clips = 0; } @@ -4927,8 +4862,6 @@ ns_initialize_display_info (struct ns_display_info *dpyinfo) && ![NSCalibratedWhiteColorSpace isEqualToString: NSColorSpaceFromDepth (depth)]; dpyinfo->n_planes = NSBitsPerPixelFromDepth (depth); - dpyinfo->color_table = xmalloc (sizeof *dpyinfo->color_table); - dpyinfo->color_table->colors = NULL; dpyinfo->root_window = 42; /* A placeholder. */ dpyinfo->highlight_frame = dpyinfo->ns_focus_frame = NULL; dpyinfo->n_fonts = 0; @@ -4946,6 +4879,17 @@ ns_default_font_parameter (struct frame *f, Lisp_Object parms) { } +#ifdef NS_IMPL_GNUSTEP +static void +ns_update_window_end (struct window *w, bool cursor_on_p, + bool mouse_face_overwritten_p) +{ + NSTRACE ("ns_update_window_end (cursor_on_p = %d)", cursor_on_p); + + ns_redraw_scroll_bars (WINDOW_XFRAME (w)); +} +#endif + /* This and next define (many of the) public functions in this file. */ /* gui_* are generic versions in xdisp.c that we, and other terms, get away with using despite presence in the "system dependent" redisplay @@ -4962,7 +4906,11 @@ static struct redisplay_interface ns_redisplay_interface = ns_scroll_run, ns_after_update_window_line, NULL, /* update_window_begin */ +#ifndef NS_IMPL_GNUSTEP NULL, /* update_window_end */ +#else + ns_update_window_end, +#endif 0, /* flush_display */ gui_clear_window_mouse_face, gui_get_glyph_overhangs, @@ -5201,11 +5149,9 @@ ns_term_init (Lisp_Object display_name) color = XCAR (color_map); name = XCAR (color); c = XFIXNUM (XCDR (color)); + c |= 0xFF000000; [cl setColor: - [NSColor colorForEmacsRed: RED_FROM_ULONG (c) / 255.0 - green: GREEN_FROM_ULONG (c) / 255.0 - blue: BLUE_FROM_ULONG (c) / 255.0 - alpha: 1.0] + [NSColor colorWithUnsignedLong:c] forKey: [NSString stringWithLispString: name]]; } @@ -6189,9 +6135,11 @@ not_in_argv (NSString *arg) Lisp_Object kind = fnKeysym ? QCfunction : QCordinary; emacs_event->modifiers = EV_MODIFIERS2 (flags, kind); +#ifndef NS_IMPL_GNUSTEP if (NS_KEYLOG) fprintf (stderr, "keyDown: code =%x\tfnKey =%x\tflags = %x\tmods = %x\n", code, fnKeysym, flags, emacs_event->modifiers); +#endif /* If it was a function key or had control-like modifiers, pass it directly to Emacs. */ @@ -6561,6 +6509,7 @@ not_in_argv (NSString *arg) */ bool horizontal; int lines = 0; + int x = 0, y = 0; int scrollUp = NO; /* FIXME: At the top or bottom of the buffer we should @@ -6596,23 +6545,33 @@ not_in_argv (NSString *arg) * 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) + && (!mwheel_coalesce_scroll_events + || abs (totalDeltaX) > lineHeight)) { horizontal = YES; scrollUp = totalDeltaX > 0; lines = abs (totalDeltaX / lineHeight); - totalDeltaX = totalDeltaX % lineHeight; + x = totalDeltaX; + if (!mwheel_coalesce_scroll_events) + totalDeltaX = 0; + else + totalDeltaX = totalDeltaX % lineHeight; totalDeltaY = 0; } else if (abs (totalDeltaY) >= abs (totalDeltaX) - && abs (totalDeltaY) > lineHeight) + && (!mwheel_coalesce_scroll_events + || abs (totalDeltaY) > lineHeight)) { horizontal = NO; scrollUp = totalDeltaY > 0; lines = abs (totalDeltaY / lineHeight); - totalDeltaY = totalDeltaY % lineHeight; + y = totalDeltaY; + if (!mwheel_coalesce_scroll_events) + totalDeltaY = 0; + else + totalDeltaY = totalDeltaY % lineHeight; totalDeltaX = 0; } @@ -6638,13 +6597,25 @@ not_in_argv (NSString *arg) ? ceil (fabs (delta)) : 1; scrollUp = delta > 0; + x = ([theEvent scrollingDeltaX] + * FRAME_COLUMN_WIDTH (emacsframe)); + y = ([theEvent scrollingDeltaY] + * FRAME_LINE_HEIGHT (emacsframe)); } - if (lines == 0) + if (lines == 0 && mwheel_coalesce_scroll_events) return; + if (NUMBERP (Vns_scroll_event_delta_factor)) + { + x *= XFLOATINT (Vns_scroll_event_delta_factor); + y *= XFLOATINT (Vns_scroll_event_delta_factor); + } + 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) | @@ -6704,6 +6675,11 @@ not_in_argv (NSString *arg) emacs_event->code = EV_BUTTON (theEvent); emacs_event->modifiers = EV_MODIFIERS (theEvent) | EV_UDMODIFIERS (theEvent); + + if (emacs_event->modifiers & down_modifier) + FRAME_DISPLAY_INFO (emacsframe)->grabbed |= 1 << EV_BUTTON (theEvent); + else + FRAME_DISPLAY_INFO (emacsframe)->grabbed &= ~(1 << EV_BUTTON (theEvent)); } XSETINT (emacs_event->x, lrint (p.x)); @@ -6845,6 +6821,42 @@ not_in_argv (NSString *arg) [self mouseMoved: e]; } +#ifdef NS_IMPL_COCOA +- (void) magnifyWithEvent: (NSEvent *) event +{ + NSPoint pt = [self convertPoint: [event locationInWindow] fromView: nil]; + static CGFloat last_scale; + + NSTRACE ("[EmacsView magnifyWithEvent]"); + if (emacs_event) + { + emacs_event->kind = PINCH_EVENT; + emacs_event->modifiers = EV_MODIFIERS (event); + XSETINT (emacs_event->x, lrint (pt.x)); + XSETINT (emacs_event->y, lrint (pt.y)); + XSETFRAME (emacs_event->frame_or_window, emacsframe); + + if ([event phase] == NSEventPhaseBegan) + { + last_scale = 1.0 + [event magnification]; + emacs_event->arg = list4 (make_float (0.0), + make_float (0.0), + make_float (last_scale), + make_float (0.0)); + } + else + /* Report a tiny change so that Lisp code doesn't think this + is the beginning of an event sequence. This is the best we + can do because NS doesn't report pinch events in as much + detail as XInput 2 or GTK+ do. */ + emacs_event->arg = list4 (make_float (0.01), + make_float (0.0), + make_float (last_scale += [event magnification]), + make_float (0.0)); + EV_TRAILER (event); + } +} +#endif - (BOOL)windowShouldClose: (id)sender { @@ -7004,7 +7016,6 @@ not_in_argv (NSString *arg) height = (int)NSHeight (frame); NSTRACE_SIZE ("New size", NSMakeSize (width, height)); - NSTRACE_SIZE ("Original size", size); /* Reset the frame size to match the bounds of the superview (the NSWindow's contentView). We need to do this as sometimes the @@ -7073,6 +7084,7 @@ not_in_argv (NSString *arg) XSETFRAME (frame, emacsframe); help_echo_string = Qnil; gen_help_event (Qnil, frame, Qnil, Qnil, 0); + any_help_event_p = NO; } if (emacs_event && is_focus_frame) @@ -7573,9 +7585,8 @@ not_in_argv (NSString *arg) onFirstScreen = [[w screen] isEqual:[[NSScreen screens] objectAtIndex:0]]; f = emacsframe; wr = [w frame]; - col = ns_lookup_indexed_color (NS_FACE_BACKGROUND - (FACE_FROM_ID (f, DEFAULT_FACE_ID)), - f); + col = [NSColor colorWithUnsignedLong:NS_FACE_BACKGROUND + (FACE_FROM_ID (f, DEFAULT_FACE_ID))]; if (fs_state != FULLSCREEN_BOTH) { @@ -8255,10 +8266,17 @@ not_in_argv (NSString *arg) if (fullscreen) styleMask = NSWindowStyleMaskBorderless; else if (FRAME_UNDECORATED (f)) - styleMask = FRAME_UNDECORATED_FLAGS; + { + styleMask = NSWindowStyleMaskBorderless; +#ifdef NS_IMPL_COCOA + styleMask |= NSWindowStyleMaskResizable; +#endif + } else - styleMask = FRAME_DECORATED_FLAGS; - + styleMask = NSWindowStyleMaskTitled + | NSWindowStyleMaskResizable + | NSWindowStyleMaskMiniaturizable + | NSWindowStyleMaskClosable; self = [super initWithContentRect: NSMakeRect (0, 0, @@ -8323,9 +8341,8 @@ not_in_argv (NSString *arg) f->border_width = [self borderWidth]; - col = ns_lookup_indexed_color (NS_FACE_BACKGROUND - (FACE_FROM_ID (f, DEFAULT_FACE_ID)), - f); + col = [NSColor colorWithUnsignedLong:NS_FACE_BACKGROUND + (FACE_FROM_ID (f, DEFAULT_FACE_ID))]; [self setBackgroundColor:col]; if ([col alphaComponent] != (EmacsCGFloat) 1.0) [self setOpaque:NO]; @@ -10001,8 +10018,15 @@ This variable is ignored on macOS < 10.7 and GNUstep. Default is t. */); x_underline_at_descent_line, doc: /* SKIP: real doc in xterm.c. */); x_underline_at_descent_line = 0; + DEFSYM (Qx_underline_at_descent_line, "x-underline-at-descent-line"); + DEFVAR_LISP ("ns-scroll-event-delta-factor", Vns_scroll_event_delta_factor, + doc: /* A factor to apply to pixel deltas reported in scroll events. + This is only effective for pixel deltas generated from touch pads or + mice with smooth scrolling capability. */); + Vns_scroll_event_delta_factor = make_float (1.0); + /* Tell Emacs about this window system. */ Fprovide (Qns, Qnil); diff --git a/src/pdumper.c b/src/pdumper.c index 2782648e7ab..554b53020e0 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -312,14 +312,15 @@ dump_reloc_set_offset (struct dump_reloc *reloc, dump_off offset) error ("dump relocation out of range"); } -static void -dump_fingerprint (char const *label, +void +dump_fingerprint (FILE *output, char const *label, unsigned char const xfingerprint[sizeof fingerprint]) { enum { hexbuf_size = 2 * sizeof fingerprint }; char hexbuf[hexbuf_size]; hexbuf_digest (hexbuf, xfingerprint, sizeof fingerprint); - fprintf (stderr, "%s: %.*s\n", label, hexbuf_size, hexbuf); + fprintf (output, "%s%s%.*s\n", label, *label ? ": " : "", + hexbuf_size, hexbuf); } /* To be used if some order in the relocation process has to be enforced. */ @@ -2947,7 +2948,7 @@ dump_vectorlike (struct dump_context *ctx, Lisp_Object lv, dump_off offset) { -#if CHECK_STRUCTS && !defined HASH_pvec_type_F5BA506141 +#if CHECK_STRUCTS && !defined HASH_pvec_type_19F6CF5169 # error "pvec_type changed. See CHECK_STRUCTS comment in config.h." #endif const struct Lisp_Vector *v = XVECTOR (lv); @@ -3027,6 +3028,8 @@ dump_vectorlike (struct dump_context *ctx, error_unsupported_dump_object (ctx, lv, "mutex"); case PVEC_CONDVAR: error_unsupported_dump_object (ctx, lv, "condvar"); + case PVEC_SQLITE: + error_unsupported_dump_object (ctx, lv, "sqlite"); case PVEC_MODULE_FUNCTION: error_unsupported_dump_object (ctx, lv, "module function"); default: @@ -4129,7 +4132,7 @@ types. */) ctx->header.fingerprint[i] = fingerprint[i]; const dump_off header_start = ctx->offset; - dump_fingerprint ("Dumping fingerprint", ctx->header.fingerprint); + dump_fingerprint (stderr, "Dumping fingerprint", ctx->header.fingerprint); dump_write (ctx, &ctx->header, sizeof (ctx->header)); const dump_off header_end = ctx->offset; @@ -5350,7 +5353,7 @@ dump_do_dump_relocation (const uintptr_t dump_base, their file names through expand-file-name and decode-coding-string. */ comp_u->file = eln_fname; - comp_u->handle = dynlib_open (SSDATA (eln_fname)); + comp_u->handle = dynlib_open_for_eln (SSDATA (eln_fname)); if (!comp_u->handle) { fprintf (stderr, "Error using execdir %s:\n", @@ -5597,8 +5600,8 @@ pdumper_load (const char *dump_filename, char *argv0) desired[i] = fingerprint[i]; if (memcmp (header->fingerprint, desired, sizeof desired) != 0) { - dump_fingerprint ("desired fingerprint", desired); - dump_fingerprint ("found fingerprint", header->fingerprint); + dump_fingerprint (stderr, "desired fingerprint", desired); + dump_fingerprint (stderr, "found fingerprint", header->fingerprint); goto out; } @@ -5706,6 +5709,7 @@ pdumper_load (const char *dump_filename, char *argv0) dump_mmap_release (§ions[i]); if (dump_fd >= 0) emacs_close (dump_fd); + return err; } @@ -5790,6 +5794,7 @@ syms_of_pdumper (void) DEFSYM (Qdumped_with_pdumper, "dumped-with-pdumper"); DEFSYM (Qload_time, "load-time"); DEFSYM (Qdump_file_name, "dump-file-name"); + DEFSYM (Qafter_pdump_load_hook, "after-pdump-load-hook"); defsubr (&Spdumper_stats); #endif /* HAVE_PDUMPER */ } diff --git a/src/pdumper.h b/src/pdumper.h index deec9af046d..7f1f5e46ad9 100644 --- a/src/pdumper.h +++ b/src/pdumper.h @@ -20,6 +20,8 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #ifndef EMACS_PDUMPER_H #define EMACS_PDUMPER_H +#include <stdio.h> +#include "fingerprint.h" #include "lisp.h" INLINE_HEADER_BEGIN @@ -50,6 +52,9 @@ enum { PDUMPER_NO_OBJECT = -1 }; #define PDUMPER_REMEMBER_SCALAR(thing) \ pdumper_remember_scalar (&(thing), sizeof (thing)) +extern void dump_fingerprint (FILE *output, const char *label, + unsigned char const fingerp[sizeof fingerprint]); + extern void pdumper_remember_scalar_impl (void *data, ptrdiff_t nbytes); INLINE void diff --git a/src/pgtkfns.c b/src/pgtkfns.c new file mode 100644 index 00000000000..c782efe395f --- /dev/null +++ b/src/pgtkfns.c @@ -0,0 +1,4108 @@ +/* Functions for the pure Gtk+-3. + +Copyright (C) 1989, 1992-1994, 2005-2006, 2008-2020 Free Software +Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ + +/* This should be the first include, as it may set up #defines affecting + interpretation of even the system includes. */ +#include <config.h> + +#include <math.h> +#include <c-strcase.h> + +#include "lisp.h" +#include "blockinput.h" +#include "gtkutil.h" +#include "window.h" +#include "character.h" +#include "buffer.h" +#include "keyboard.h" +#include "termhooks.h" +#include "fontset.h" +#include "font.h" +#include "xsettings.h" +#include "atimer.h" + + +#ifdef HAVE_PGTK + +/* Static variables to handle applescript execution. */ +static Lisp_Object as_script, *as_result; +static int as_status; + +static ptrdiff_t image_cache_refcount; + +static int x_decode_color (struct frame *f, Lisp_Object color_name, + int mono_color); +static struct pgtk_display_info *pgtk_display_info_for_name (Lisp_Object); + +static const char *pgtk_app_name = "Emacs"; + +/* Scale factor manually set per monitor. */ +static Lisp_Object monitor_scale_factor_alist; + +/* ========================================================================== + + Internal utility functions + + ========================================================================== */ + +static double +pgtk_get_monitor_scale_factor (const char *model) +{ + if (model == NULL) + return 0.0; + + Lisp_Object mdl = build_string (model); + Lisp_Object tem = Fassoc (mdl, monitor_scale_factor_alist, Qnil); + if (NILP (tem)) + return 0; + Lisp_Object cdr = Fcdr (tem); + if (NILP (cdr)) + return 0; + if (FIXNUMP (cdr)) + return XFIXNUM (cdr); + else if (FLOATP (cdr)) + return XFLOAT_DATA (cdr); + else + error ("unknown type of scale-factor"); +} + +struct pgtk_display_info * +check_pgtk_display_info (Lisp_Object object) +{ + struct pgtk_display_info *dpyinfo = NULL; + + if (NILP (object)) + { + struct frame *sf = XFRAME (selected_frame); + + if (FRAME_PGTK_P (sf) && FRAME_LIVE_P (sf)) + dpyinfo = FRAME_DISPLAY_INFO (sf); + else if (x_display_list != 0) + dpyinfo = x_display_list; + else + error ("Frames are not in use or not initialized"); + } + else if (TERMINALP (object)) + { + struct terminal *t = decode_live_terminal (object); + + if (t->type != output_pgtk) + error ("Terminal %d is not a display", t->id); + + dpyinfo = t->display_info.pgtk; + } + else if (STRINGP (object)) + dpyinfo = pgtk_display_info_for_name (object); + else + { + struct frame *f = decode_window_system_frame (object); + dpyinfo = FRAME_DISPLAY_INFO (f); + } + + return dpyinfo; +} + +/* On Wayland, even if without WAYLAND_DISPLAY, --display DISPLAY + works, but gdk_display_get_name always return "wayland-0", which + may be different from DISPLAY. If with WAYLAND_DISPLAY, then it + always returns WAYLAND_DISPLAY. So pgtk Emacs is confused and + enters multi display environment. To workaround this situation, + treat all the wayland-* as the same display. */ +static Lisp_Object +is_wayland_display (Lisp_Object dpyname) +{ + const char *p = SSDATA (dpyname); + if (strncmp (p, "wayland-", 8) != 0) + return Qnil; + p += 8; + do { + if (*p < '0' || *p > '9') + return Qnil; + } while (*++p != '\0'); + return Qt; +} + +/* Return the X display structure for the display named NAME. + Open a new connection if necessary. */ +static struct pgtk_display_info * +pgtk_display_info_for_name (Lisp_Object name) +{ + struct pgtk_display_info *dpyinfo; + + CHECK_STRING (name); + + if (!NILP (is_wayland_display (name))) + { + for (dpyinfo = x_display_list; dpyinfo; dpyinfo = dpyinfo->next) + if (!NILP (is_wayland_display (XCAR (dpyinfo->name_list_element)))) + return dpyinfo; + } + else + { + for (dpyinfo = x_display_list; dpyinfo; dpyinfo = dpyinfo->next) + if (!NILP (Fstring_equal (XCAR (dpyinfo->name_list_element), name))) + return dpyinfo; + } + + /* Use this general default value to start with. */ + Vx_resource_name = Vinvocation_name; + + validate_x_resource_name (); + + dpyinfo = pgtk_term_init (name, SSDATA (Vx_resource_name)); + + if (dpyinfo == 0) + error ("Cannot connect to display server %s", SDATA (name)); + + XSETFASTINT (Vwindow_system_version, 11); + + return dpyinfo; +} + +/* ========================================================================== + + Frame parameter setters + + ========================================================================== */ + + +static void +x_set_foreground_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +{ + unsigned long fg; + + fg = x_decode_color (f, arg, BLACK_PIX_DEFAULT (f)); + FRAME_FOREGROUND_PIXEL (f) = fg; + FRAME_X_OUTPUT (f)->foreground_color = fg; + + if (FRAME_GTK_WIDGET (f)) + { + update_face_from_frame_parameter (f, Qforeground_color, arg); + if (FRAME_VISIBLE_P (f)) + SET_FRAME_GARBAGED (f); + } +} + + +static void +x_set_background_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +{ + unsigned long bg; + + bg = x_decode_color (f, arg, WHITE_PIX_DEFAULT (f)); + FRAME_BACKGROUND_PIXEL (f) = bg; + + /* Clear the frame. */ + if (FRAME_VISIBLE_P (f)) + pgtk_clear_frame (f); + + FRAME_X_OUTPUT (f)->background_color = bg; + + xg_set_background_color (f, bg); + update_face_from_frame_parameter (f, Qbackground_color, arg); + + if (FRAME_VISIBLE_P (f)) + SET_FRAME_GARBAGED (f); +} + +static void +x_set_border_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +{ + int pix; + + CHECK_STRING (arg); + pix = x_decode_color (f, arg, BLACK_PIX_DEFAULT (f)); + FRAME_X_OUTPUT (f)->border_pixel = pix; + pgtk_frame_rehighlight (FRAME_DISPLAY_INFO (f)); +} + +static void +x_set_cursor_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +{ + unsigned long fore_pixel, pixel; + struct pgtk_output *x = f->output_data.pgtk; + + if (!NILP (Vx_cursor_fore_pixel)) + { + fore_pixel = x_decode_color (f, Vx_cursor_fore_pixel, + WHITE_PIX_DEFAULT (f)); + } + else + fore_pixel = FRAME_BACKGROUND_PIXEL (f); + + pixel = x_decode_color (f, arg, BLACK_PIX_DEFAULT (f)); + + /* Make sure that the cursor color differs from the background color. */ + if (pixel == FRAME_BACKGROUND_PIXEL (f)) + { + pixel = x->mouse_color; + if (pixel == fore_pixel) + { + fore_pixel = FRAME_BACKGROUND_PIXEL (f); + } + } + + x->cursor_foreground_color = fore_pixel; + x->cursor_color = pixel; + + if (FRAME_X_WINDOW (f) != 0) + { + x->cursor_xgcv.background = x->cursor_color; + x->cursor_xgcv.foreground = fore_pixel; + + if (FRAME_VISIBLE_P (f)) + { + gui_update_cursor (f, false); + gui_update_cursor (f, true); + } + } + + update_face_from_frame_parameter (f, Qcursor_color, arg); +} + +static void +pgtk_set_name_internal (struct frame *f, Lisp_Object name) +{ + if (FRAME_GTK_OUTER_WIDGET (f)) + { + block_input (); + { + Lisp_Object encoded_name; + + /* As ENCODE_UTF_8 may cause GC and relocation of string data, + we use it before x_encode_text that may return string data. */ + encoded_name = ENCODE_UTF_8 (name); + + gtk_window_set_title (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), + SSDATA (encoded_name)); + } + unblock_input (); + } +} + +static void +pgtk_set_name (struct frame *f, Lisp_Object name, int explicit) +{ + /* Make sure that requests from lisp code override requests from + Emacs redisplay code. */ + if (explicit) + { + /* If we're switching from explicit to implicit, we had better + update the mode lines and thereby update the title. */ + if (f->explicit_name && NILP (name)) + update_mode_lines = 12; + + f->explicit_name = !NILP (name); + } + else if (f->explicit_name) + return; + + if (NILP (name)) + name = build_string (pgtk_app_name); + else + CHECK_STRING (name); + + /* Don't change the name if it's already NAME. */ + if (!NILP (Fstring_equal (name, f->name))) + return; + + fset_name (f, name); + + /* Title overrides explicit name. */ + if (!NILP (f->title)) + name = f->title; + + pgtk_set_name_internal (f, name); +} + + +/* This function should be called when the user's lisp code has + specified a name for the frame; the name will override any set by the + redisplay code. */ +static void +x_explicitly_set_name (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +{ + pgtk_set_name (f, arg, true); +} + + +/* This function should be called by Emacs redisplay code to set the + name; names set this way will never override names set by the user's + lisp code. */ +void +pgtk_implicitly_set_name (struct frame *f, Lisp_Object arg, + Lisp_Object oldval) +{ + pgtk_set_name (f, arg, false); +} + + +/* Change the title of frame F to NAME. + If NAME is nil, use the frame name as the title. */ + +static void +x_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 = 22; + + fset_title (f, name); + + if (NILP (name)) + name = f->name; + else + CHECK_STRING (name); + + pgtk_set_name_internal (f, name); +} + + +void +pgtk_set_doc_edited (void) +{ +} + + +static void +x_set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) +{ + int nlines; + /* Right now, menu bars don't work properly in minibuf-only frames; + most of the commands try to apply themselves to the minibuffer + frame itself, and get an error because you can't switch buffers + in or split the minibuffer window. */ + if (FRAME_MINIBUF_ONLY_P (f) || FRAME_PARENT_FRAME (f)) + return; + + if (TYPE_RANGED_FIXNUMP (int, value)) + nlines = XFIXNUM (value); + else + nlines = 0; + + /* Make sure we redisplay all windows in this frame. */ + 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_PGTK_P (f) && f->output_data.pgtk->menubar_widget == 0) + /* Make sure next redisplay shows the menu bar. */ + XWINDOW (FRAME_SELECTED_WINDOW (f))->update_mode_line = true; + } + else + { + if (FRAME_EXTERNAL_MENU_BAR (f) == 1) + free_frame_menubar (f); + FRAME_EXTERNAL_MENU_BAR (f) = 0; + if (FRAME_X_P (f)) + f->output_data.pgtk->menubar_widget = 0; + } + + adjust_frame_glyphs (f); +} + +/* Set the number of lines used for the tab bar of frame F to VALUE. + VALUE not an integer, or < 0 means set the lines to zero. OLDVAL + is the old number of tab bar lines. This function changes the + height of all windows on frame F to match the new tab bar height. + The frame's height doesn't change. */ + +static void +x_set_tab_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) +{ + 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; + + x_change_tab_bar_height (f, nlines * FRAME_LINE_HEIGHT (f)); +} + + +/* Set the pixel height of the tab bar of frame F to HEIGHT. */ +void +x_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_X_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_X_WINDOW (f)) + pgtk_clear_under_internal_border (f); +} + +/* Set the pixel height of the tool bar of frame F to HEIGHT. */ +static void +x_change_tool_bar_height (struct frame *f, int height) +{ + FRAME_TOOL_BAR_LINES (f) = 0; + FRAME_TOOL_BAR_HEIGHT (f) = 0; + if (height) + { + FRAME_EXTERNAL_TOOL_BAR (f) = true; + if (FRAME_X_P (f) && f->output_data.pgtk->toolbar_widget == 0) + /* Make sure next redisplay shows the tool bar. */ + XWINDOW (FRAME_SELECTED_WINDOW (f))->update_mode_line = true; + update_frame_tool_bar (f); + } + else + { + if (FRAME_EXTERNAL_TOOL_BAR (f)) + free_frame_tool_bar (f); + FRAME_EXTERNAL_TOOL_BAR (f) = false; + } +} + +/* Toolbar support. */ +static void +x_set_tool_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) +{ + 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; + + x_change_tool_bar_height (f, nlines * FRAME_LINE_HEIGHT (f)); + +} + +static void +x_set_child_frame_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +{ + int border = check_int_nonnegative (arg); + + if (border != FRAME_CHILD_FRAME_BORDER_WIDTH (f)) + { + f->child_frame_border_width = border; + + if (FRAME_X_WINDOW (f)) + { + adjust_frame_size (f, -1, -1, 3, false, Qchild_frame_border_width); + pgtk_clear_under_internal_border (f); + } + } + +} + +static void +x_set_internal_border_width (struct frame *f, Lisp_Object arg, + Lisp_Object oldval) +{ + int border = check_int_nonnegative (arg); + + if (border != FRAME_INTERNAL_BORDER_WIDTH (f)) + { + f->internal_border_width = border; + + if (FRAME_X_WINDOW (f)) + { + adjust_frame_size (f, -1, -1, 3, false, Qinternal_border_width); + pgtk_clear_under_internal_border (f); + } + } +} + +static void +x_set_icon_type (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +{ + bool result; + + if (STRINGP (arg)) + { + if (STRINGP (oldval) && EQ (Fstring_equal (oldval, arg), Qt)) + return; + } + else if (!STRINGP (oldval) && NILP (oldval) == NILP (arg)) + return; + + block_input (); + if (NILP (arg)) + result = pgtk_text_icon (f, + SSDATA ((!NILP (f->icon_name) + ? f->icon_name : f->name))); + else + result = FRAME_TERMINAL (f)->set_bitmap_icon_hook (f, arg); + + if (result) + { + unblock_input (); + error ("No icon window available"); + } + + unblock_input (); +} + +static void +x_set_icon_name (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +{ + bool result; + + if (STRINGP (arg)) + { + if (STRINGP (oldval) && EQ (Fstring_equal (oldval, arg), Qt)) + return; + } + else if (!NILP (arg) || NILP (oldval)) + return; + + fset_icon_name (f, arg); + + block_input (); + + result = pgtk_text_icon (f, + SSDATA ((!NILP (f->icon_name) + ? f->icon_name + : !NILP (f->title) + ? f->title : f->name))); + + if (result) + { + unblock_input (); + error ("No icon window available"); + } + + unblock_input (); +} + +/* This is the same as the xfns.c definition. */ +static void +x_set_cursor_type (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +{ + set_frame_cursor_types (f, arg); +} + +/* called to set mouse pointer color, but all other terms use it to + initialize pointer types (and don't set the color ;) */ +static void +x_set_mouse_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +{ +} + + +static void +x_icon (struct frame *f, Lisp_Object parms) +/* -------------------------------------------------------------------------- + Strangely-named function to set icon position parameters in frame. + This is irrelevant under macOS, but might be needed under GNUstep, + depending on the window manager used. Note, this is not a standard + frame parameter-setter; it is called directly from x-create-frame. + -------------------------------------------------------------------------- */ +{ +#if 0 + Lisp_Object icon_x, icon_y; + struct pgtk_display_info *dpyinfo = check_pgtk_display_info (Qnil); + + FRAME_X_OUTPUT (f)->icon_top = -1; + FRAME_X_OUTPUT (f)->icon_left = -1; + + /* Set the position of the icon. */ + icon_x = + gui_display_get_arg (dpyinfo, parms, Qicon_left, 0, 0, RES_TYPE_NUMBER); + icon_y = + gui_display_get_arg (dpyinfo, parms, Qicon_top, 0, 0, RES_TYPE_NUMBER); + if (!EQ (icon_x, Qunbound) && !EQ (icon_y, Qunbound)) + { + CHECK_NUMBER (icon_x); + CHECK_NUMBER (icon_y); + FRAME_X_OUTPUT (f)->icon_top = XFIXNUM (icon_y); + FRAME_X_OUTPUT (f)->icon_left = XFIXNUM (icon_x); + } + else if (!EQ (icon_x, Qunbound) || !EQ (icon_y, Qunbound)) + error ("Both left and top icon corners of icon must be specified"); +#endif +} + +/** + * x_set_undecorated: + * + * Set frame F's `undecorated' parameter. If non-nil, F's window-system + * window is drawn without decorations, title, minimize/maximize boxes + * and external borders. This usually means that the window cannot be + * dragged, resized, iconified, maximized or deleted with the mouse. If + * nil, draw the frame with all the elements listed above unless these + * have been suspended via window manager settings. + * + * Some window managers may not honor this parameter. + */ +static void +x_set_undecorated (struct frame *f, Lisp_Object new_value, + Lisp_Object old_value) +{ + if (!EQ (new_value, old_value)) + { + FRAME_UNDECORATED (f) = NILP (new_value) ? false : true; + xg_set_undecorated (f, new_value); + } +} + +/** + * x_set_skip_taskbar: + * + * Set frame F's `skip-taskbar' parameter. If non-nil, this should + * remove F's icon from the taskbar associated with the display of F's + * window-system window and inhibit switching to F's window via + * <Alt>-<TAB>. If nil, lift these restrictions. + * + * Some window managers may not honor this parameter. + */ +static void +x_set_skip_taskbar (struct frame *f, Lisp_Object new_value, + Lisp_Object old_value) +{ + if (!EQ (new_value, old_value)) + { + xg_set_skip_taskbar (f, new_value); + FRAME_SKIP_TASKBAR (f) = !NILP (new_value); + } +} + +/** + * x_set_override_redirect: + * + * Set frame F's `override_redirect' parameter which, if non-nil, hints + * that the window manager doesn't want to deal with F. Usually, such + * frames have no decorations and always appear on top of all frames. + * + * Some window managers may not honor this parameter. + */ +static void +x_set_override_redirect (struct frame *f, Lisp_Object new_value, + Lisp_Object old_value) +{ + if (!EQ (new_value, old_value)) + { + /* Here (xfwm) override_redirect can be changed for invisible + frames only. */ + pgtk_make_frame_invisible (f); + + xg_set_override_redirect (f, new_value); + + pgtk_make_frame_visible (f); + FRAME_OVERRIDE_REDIRECT (f) = !NILP (new_value); + } +} + +/* Set icon from FILE for frame F. By using GTK functions the icon + may be any format that GdkPixbuf knows about, i.e. not just bitmaps. */ + +bool +xg_set_icon (struct frame *f, Lisp_Object file) +{ + bool result = false; + Lisp_Object found; + + if (!FRAME_GTK_OUTER_WIDGET (f)) + return false; + + found = image_find_image_file (file); + + if (!NILP (found)) + { + GdkPixbuf *pixbuf; + GError *err = NULL; + char *filename = SSDATA (ENCODE_FILE (found)); + block_input (); + + pixbuf = gdk_pixbuf_new_from_file (filename, &err); + + if (pixbuf) + { + gtk_window_set_icon (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), + pixbuf); + g_object_unref (pixbuf); + + result = true; + } + else + g_error_free (err); + + unblock_input (); + } + + return result; +} + +bool +xg_set_icon_from_xpm_data (struct frame *f, const char **data) +{ + GdkPixbuf *pixbuf = gdk_pixbuf_new_from_xpm_data (data); + + if (!pixbuf) + return false; + + if (!FRAME_GTK_OUTER_WIDGET (f)) + return false; + + gtk_window_set_icon (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), pixbuf); + g_object_unref (pixbuf); + return true; +} + +static void +pgtk_set_sticky (struct frame *f, Lisp_Object new_value, + Lisp_Object old_value) +{ + if (!FRAME_GTK_OUTER_WIDGET (f)) + return; + + if (!NILP (new_value)) + gtk_window_stick (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f))); + else + gtk_window_unstick (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f))); +} + +static void +pgtk_set_tool_bar_position (struct frame *f, + Lisp_Object new_value, Lisp_Object old_value) +{ + Lisp_Object choice = list4 (Qleft, Qright, Qtop, Qbottom); + + if (!NILP (Fmemq (new_value, choice))) + { + if (!EQ (new_value, old_value)) + { + xg_change_toolbar_position (f, new_value); + fset_tool_bar_position (f, new_value); + } + } + else + wrong_choice (choice, new_value); +} + +static void +pgtk_set_scroll_bar_foreground (struct frame *f, Lisp_Object new_value, + Lisp_Object old_value) +{ + GtkCssProvider *css_provider = + FRAME_X_OUTPUT (f)->scrollbar_foreground_css_provider; + + if (NILP (new_value)) + { + gtk_css_provider_load_from_data (css_provider, "", -1, NULL); + update_face_from_frame_parameter (f, Qscroll_bar_foreground, new_value); + } + else if (STRINGP (new_value)) + { + Emacs_Color rgb; + + if (!pgtk_parse_color (f, SSDATA (new_value), &rgb)) + error ("Unknown color."); + + /* On pgtk, this frame parameter should be ignored, and honor gtk theme. */ +#if 0 + char css[64]; + sprintf (css, "scrollbar slider { background-color: #%06x; }", + (unsigned int) rgb.pixel & 0xffffff); + gtk_css_provider_load_from_data (css_provider, css, -1, NULL); +#endif + update_face_from_frame_parameter (f, Qscroll_bar_foreground, new_value); + + } + else + error ("Invalid scroll-bar-foreground."); +} + +static void +pgtk_set_scroll_bar_background (struct frame *f, Lisp_Object new_value, + Lisp_Object old_value) +{ + GtkCssProvider *css_provider = + FRAME_X_OUTPUT (f)->scrollbar_background_css_provider; + + if (NILP (new_value)) + { + gtk_css_provider_load_from_data (css_provider, "", -1, NULL); + update_face_from_frame_parameter (f, Qscroll_bar_background, new_value); + } + else if (STRINGP (new_value)) + { + Emacs_Color rgb; + + if (!pgtk_parse_color (f, SSDATA (new_value), &rgb)) + error ("Unknown color."); + + /* On pgtk, this frame parameter should be ignored, and honor gtk theme. */ +#if 0 + char css[64]; + sprintf (css, "scrollbar trough { background-color: #%06x; }", + (unsigned int) rgb.pixel & 0xffffff); + gtk_css_provider_load_from_data (css_provider, css, -1, NULL); +#endif + update_face_from_frame_parameter (f, Qscroll_bar_background, new_value); + + } + else + error ("Invalid scroll-bar-background."); +} + + +/*********************************************************************** + Printing + ***********************************************************************/ + + +DEFUN ("x-export-frames", Fx_export_frames, Sx_export_frames, 0, 2, 0, + doc: /* Return image data of FRAMES in TYPE format. +FRAMES should be nil (the selected frame), a frame, or a list of +frames (each of which corresponds to one page). Each frame should be +visible. Optional arg TYPE should be either `pdf' (default), `png', +`postscript', or `svg'. Supported types are determined by the +compile-time configuration of cairo. + +Note: Text drawn with the `x' font backend is shown with hollow boxes +unless TYPE is `png'. */) + (Lisp_Object frames, Lisp_Object type) +{ + Lisp_Object rest, tmp; + cairo_surface_type_t surface_type; + + if (!CONSP (frames)) + frames = list1 (frames); + + tmp = Qnil; + for (rest = frames; CONSP (rest); rest = XCDR (rest)) + { + struct frame *f = decode_window_system_frame (XCAR (rest)); + Lisp_Object frame; + + XSETFRAME (frame, f); + if (!FRAME_VISIBLE_P (f)) + error ("Frames to be exported must be visible."); + tmp = Fcons (frame, tmp); + } + frames = Fnreverse (tmp); + +#ifdef CAIRO_HAS_PDF_SURFACE + if (NILP (type) || EQ (type, Qpdf)) + surface_type = CAIRO_SURFACE_TYPE_PDF; + else +#endif +#ifdef CAIRO_HAS_PNG_FUNCTIONS + if (EQ (type, Qpng)) + { + if (!NILP (XCDR (frames))) + error ("PNG export cannot handle multiple frames."); + surface_type = CAIRO_SURFACE_TYPE_IMAGE; + } + else +#endif +#ifdef CAIRO_HAS_PS_SURFACE + if (EQ (type, Qpostscript)) + surface_type = CAIRO_SURFACE_TYPE_PS; + else +#endif +#ifdef CAIRO_HAS_SVG_SURFACE + if (EQ (type, Qsvg)) + { + /* For now, we stick to SVG 1.1. */ + if (!NILP (XCDR (frames))) + error ("SVG export cannot handle multiple frames."); + surface_type = CAIRO_SURFACE_TYPE_SVG; + } + else +#endif + error ("Unsupported export type"); + + return pgtk_cr_export_frames (frames, surface_type); +} + + +/* Note: see frame.c for template, also where generic functions are impl */ +frame_parm_handler pgtk_frame_parm_handlers[] = { + gui_set_autoraise, /* generic OK */ + gui_set_autolower, /* generic OK */ + x_set_background_color, + x_set_border_color, + gui_set_border_width, + x_set_cursor_color, + x_set_cursor_type, + gui_set_font, /* generic OK */ + x_set_foreground_color, + x_set_icon_name, + x_set_icon_type, + x_set_child_frame_border_width, + x_set_internal_border_width, /* generic OK */ + gui_set_right_divider_width, + gui_set_bottom_divider_width, + x_set_menu_bar_lines, + x_set_mouse_color, + x_explicitly_set_name, + gui_set_scroll_bar_width, /* generic OK */ + gui_set_scroll_bar_height, /* generic OK */ + x_set_title, + gui_set_unsplittable, /* generic OK */ + gui_set_vertical_scroll_bars, /* generic OK */ + gui_set_horizontal_scroll_bars, /* generic OK */ + gui_set_visibility, /* generic OK */ + x_set_tab_bar_lines, + x_set_tool_bar_lines, + pgtk_set_scroll_bar_foreground, + pgtk_set_scroll_bar_background, + gui_set_screen_gamma, /* generic OK */ + gui_set_line_spacing, /* generic OK, sets f->extra_line_spacing to int */ + gui_set_left_fringe, /* generic OK */ + gui_set_right_fringe, /* generic OK */ + 0, /* x_set_wait_for_wm */ + gui_set_fullscreen, /* generic OK */ + gui_set_font_backend, /* generic OK */ + gui_set_alpha, + pgtk_set_sticky, + pgtk_set_tool_bar_position, + 0, /* x_set_inhibit_double_buffering */ + x_set_undecorated, + x_set_parent_frame, + x_set_skip_taskbar, + x_set_no_focus_on_map, + x_set_no_accept_focus, + x_set_z_group, + x_set_override_redirect, + gui_set_no_special_glyphs, +}; + + +/* Handler for signals raised during x_create_frame and + x_create_tip_frame. FRAME is the frame which is partially + constructed. */ + +static Lisp_Object +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 Qnil; + + /* If frame is ``official'', nothing to do. */ + if (NILP (Fmemq (frame, Vframe_list))) + { + /* 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 x_free_frame_resources + below, 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++; + + x_free_frame_resources (f); + free_glyphs (f); + return Qt; + } + + return Qnil; +} + +static void +do_unwind_create_frame (Lisp_Object frame) +{ + unwind_create_frame (frame); +} + +/* Return the pixel color value for color COLOR_NAME on frame F. If F + is a monochrome frame, return MONO_COLOR regardless of what ARG says. + Signal an error if color can't be allocated. */ + +static int +x_decode_color (struct frame *f, Lisp_Object color_name, int mono_color) +{ + Emacs_Color cdef; + + CHECK_STRING (color_name); + + /* Return MONO_COLOR for monochrome frames. */ + if (FRAME_DISPLAY_INFO (f)->n_planes == 1) + return mono_color; + + /* x_defined_color is responsible for coping with failures + by looking for a near-miss. */ + if (pgtk_defined_color (f, SSDATA (color_name), &cdef, true, 0)) + return cdef.pixel; + + signal_error ("Undefined color", color_name); +} + +void +pgtk_default_font_parameter (struct frame *f, Lisp_Object parms) +{ + struct pgtk_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. */ + const char *system_font = xsettings_get_system_font (); + if (system_font) + font = font_open_by_name (f, build_unibyte_string (system_font)); + } + + 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[] = { + "monospace-10", + "-adobe-courier-medium-r-*-*-*-120-*-*-*-*-iso8859-1", + "-misc-fixed-medium-r-normal-*-*-140-*-*-c-*-iso8859-1", + "-*-*-medium-r-normal-*-*-140-*-*-c-*-iso8859-1", + /* This was formerly the first thing tried, but it finds + too many fonts and takes too long. */ + "-*-*-medium-r-*-*-*-*-*-*-c-*-iso8859-1", + /* If those didn't work, look for something which will + at least work. */ + "-*-fixed-*-*-*-*-*-140-*-*-c-*-iso8859-1", + "fixed", + 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); + } + + /* This call will make X resources override any system font setting. */ + gui_default_parameter (f, parms, Qfont, font, "font", "Font", + RES_TYPE_STRING); +} + +static void +update_watched_scale_factor (struct atimer *timer) +{ + struct frame *f = timer->client_data; + double scale_factor = FRAME_SCALE_FACTOR (f); + + if (scale_factor != FRAME_X_OUTPUT (f)->watched_scale_factor) + { + FRAME_X_OUTPUT (f)->watched_scale_factor = scale_factor; + pgtk_cr_update_surface_desired_size (f, + FRAME_CR_SURFACE_DESIRED_WIDTH (f), + FRAME_CR_SURFACE_DESIRED_HEIGHT (f), + true); + } +} + +/* ========================================================================== + + Lisp definitions + + ========================================================================== */ + +DEFUN ("pgtk-set-monitor-scale-factor", Fpgtk_set_monitor_scale_factor, + Spgtk_set_monitor_scale_factor, 2, 2, 0, + doc: /* Set monitor MONITOR-MODEL's scale factor to SCALE-FACTOR. +Since Gdk's scale factor is integer, physical pixel width/height is +incorrect when you specify fractional scale factor in compositor. +If you set scale factor by this function, it is used instead of Gdk's one. + +Pass nil as SCALE-FACTOR if you want to reset the specified monitor's +scale factor. */ ) + (Lisp_Object monitor_model, Lisp_Object scale_factor) +{ + CHECK_STRING (monitor_model); + if (!NILP (scale_factor)) + { + CHECK_NUMBER (scale_factor); + if (FIXNUMP (scale_factor)) + { + if (XFIXNUM (scale_factor) <= 0) + error ("scale factor must be > 0."); + } + else if (FLOATP (scale_factor)) + { + if (XFLOAT_DATA (scale_factor) <= 0.0) + error ("scale factor must be > 0."); + } + else + error ("unknown type of scale-factor"); + } + + Lisp_Object tem = Fassoc (monitor_model, monitor_scale_factor_alist, Qnil); + if (NILP (tem)) + { + if (!NILP (scale_factor)) + monitor_scale_factor_alist = Fcons (Fcons (monitor_model, scale_factor), + monitor_scale_factor_alist); + } + else + Fsetcdr (tem, scale_factor); + + return scale_factor; +} + +DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame, 1, 1, 0, + doc: /* Make a new X window, which is called a "frame" in Emacs terms. +Return an Emacs frame object. PARMS is an alist of frame parameters. +If the parameters specify that the frame should not have a minibuffer, +and do not specify a specific minibuffer window to use, then +`default-minibuffer-frame' must be a frame whose minibuffer can be +shared by the new frame. + +This function is an internal primitive--use `make-frame' instead. */ ) + (Lisp_Object parms) +{ + struct frame *f; + Lisp_Object frame, tem; + Lisp_Object name; + bool minibuffer_only = false; + bool undecorated = false, override_redirect = false; + long window_prompting = 0; + ptrdiff_t count = SPECPDL_INDEX (); + Lisp_Object display; + struct pgtk_display_info *dpyinfo = NULL; + Lisp_Object parent, parent_frame; + struct kboard *kb; + + parms = Fcopy_alist (parms); + + /* Use this general default value to start with + until we know if this frame has a specified name. */ + Vx_resource_name = Vinvocation_name; + + display = + gui_display_get_arg (dpyinfo, parms, Qterminal, 0, 0, RES_TYPE_NUMBER); + if (EQ (display, Qunbound)) + display = + gui_display_get_arg (dpyinfo, parms, Qdisplay, 0, 0, RES_TYPE_STRING); + if (EQ (display, Qunbound)) + display = Qnil; + dpyinfo = check_pgtk_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, "name", "Name", + 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; + + /* See if parent window is specified. */ + parent = + gui_display_get_arg (dpyinfo, parms, Qparent_id, NULL, NULL, + RES_TYPE_NUMBER); + if (EQ (parent, Qunbound)) + parent = Qnil; + if (!NILP (parent)) + CHECK_NUMBER (parent); + + frame = Qnil; + tem = + gui_display_get_arg (dpyinfo, parms, Qminibuffer, "minibuffer", + "Minibuffer", RES_TYPE_SYMBOL); + 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 = true; + } + else if (WINDOWP (tem)) + f = make_frame_without_minibuffer (tem, kb, display); + else + f = make_frame (true); + + parent_frame = + gui_display_get_arg (dpyinfo, parms, Qparent_frame, NULL, NULL, + RES_TYPE_SYMBOL); + /* Accept parent-frame iff parent-id was not specified. */ + if (!NILP (parent) + || EQ (parent_frame, Qunbound) + || NILP (parent_frame) + || !FRAMEP (parent_frame) + || !FRAME_LIVE_P (XFRAME (parent_frame)) + || !FRAME_PGTK_P (XFRAME (parent_frame))) + parent_frame = Qnil; + + fset_parent_frame (f, parent_frame); + store_frame_param (f, Qparent_frame, parent_frame); + + if (!NILP + (tem = + (gui_display_get_arg + (dpyinfo, parms, Qundecorated, NULL, NULL, RES_TYPE_BOOLEAN))) + && !(EQ (tem, Qunbound))) + undecorated = true; + + FRAME_UNDECORATED (f) = undecorated; + store_frame_param (f, Qundecorated, undecorated ? Qt : Qnil); + + if (!NILP + (tem = + (gui_display_get_arg + (dpyinfo, parms, Qoverride_redirect, NULL, NULL, RES_TYPE_BOOLEAN))) + && !(EQ (tem, Qunbound))) + override_redirect = true; + + FRAME_OVERRIDE_REDIRECT (f) = override_redirect; + store_frame_param (f, Qoverride_redirect, override_redirect ? Qt : Qnil); + + XSETFRAME (frame, f); + + f->terminal = dpyinfo->terminal; + + f->output_method = output_pgtk; + FRAME_X_OUTPUT (f) = xzalloc (sizeof *FRAME_X_OUTPUT (f)); +#if 0 + FRAME_X_OUTPUT (f)->icon_bitmap = -1; +#endif + FRAME_FONTSET (f) = -1; + FRAME_X_OUTPUT (f)->white_relief.pixel = -1; + FRAME_X_OUTPUT (f)->black_relief.pixel = -1; + + FRAME_X_OUTPUT (f)->scrollbar_foreground_css_provider = + gtk_css_provider_new (); + FRAME_X_OUTPUT (f)->scrollbar_background_css_provider = + gtk_css_provider_new (); + + fset_icon_name (f, + gui_display_get_arg (dpyinfo, parms, Qicon_name, "iconName", + "Title", RES_TYPE_STRING)); + if (!STRINGP (f->icon_name)) + fset_icon_name (f, Qnil); + + FRAME_DISPLAY_INFO (f) = dpyinfo; + + /* With FRAME_DISPLAY_INFO set up, this unwind-protect is safe. */ + record_unwind_protect (do_unwind_create_frame, frame); + + /* These colors will be set anyway later, but it's important + to get the color reference counts right, so initialize them! */ + { + Lisp_Object black; + + /* Function x_decode_color can signal an error. Make + sure to initialize color slots so that we won't try + to free colors we haven't allocated. */ + FRAME_FOREGROUND_PIXEL (f) = -1; + FRAME_BACKGROUND_PIXEL (f) = -1; + FRAME_X_OUTPUT (f)->cursor_color = -1; + FRAME_X_OUTPUT (f)->cursor_foreground_color = -1; + FRAME_X_OUTPUT (f)->border_pixel = -1; + FRAME_X_OUTPUT (f)->mouse_color = -1; + + black = build_string ("black"); + FRAME_FOREGROUND_PIXEL (f) + = x_decode_color (f, black, BLACK_PIX_DEFAULT (f)); + FRAME_BACKGROUND_PIXEL (f) + = x_decode_color (f, black, BLACK_PIX_DEFAULT (f)); + FRAME_X_OUTPUT (f)->cursor_color + = x_decode_color (f, black, BLACK_PIX_DEFAULT (f)); + FRAME_X_OUTPUT (f)->cursor_foreground_color + = x_decode_color (f, black, BLACK_PIX_DEFAULT (f)); + FRAME_X_OUTPUT (f)->border_pixel + = x_decode_color (f, black, BLACK_PIX_DEFAULT (f)); + FRAME_X_OUTPUT (f)->mouse_color + = x_decode_color (f, black, BLACK_PIX_DEFAULT (f)); + } + + /* Specify the parent under which to make this X window. */ + if (!NILP (parent)) + { + FRAME_X_OUTPUT (f)->parent_desc = (Window) XFIXNAT (parent); + FRAME_X_OUTPUT (f)->explicit_parent = true; + } + else + { + FRAME_X_OUTPUT (f)->parent_desc = FRAME_DISPLAY_INFO (f)->root_window; + FRAME_X_OUTPUT (f)->explicit_parent = false; + } + + /* Set the name; the functions to which we pass f expect the name to + be set. */ + if (EQ (name, Qunbound) || NILP (name)) + { + fset_name (f, build_string (dpyinfo->x_id_name)); + f->explicit_name = false; + } + else + { + fset_name (f, name); + f->explicit_name = true; + /* Use the frame's title when getting resources for this frame. */ + specbind (Qx_resource_name, name); + } + + register_font_driver (&ftcrfont_driver, f); +#ifdef HAVE_HARFBUZZ + register_font_driver (&ftcrhbfont_driver, f); +#endif /* HAVE_HARFBUZZ */ + + 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); + + /* Extract the window parameters from the supplied values + that are needed to determine window geometry. */ + pgtk_default_font_parameter (f, parms); + if (!FRAME_FONT (f)) + { + delete_frame (frame, Qnoelisp); + error ("Invalid frame font"); + } + + /* Frame contents get displaced if an embedded X window has a border. */ +#if 0 + if (!FRAME_X_EMBEDDED_P (f)) +#endif + gui_default_parameter (f, parms, Qborder_width, make_fixnum (0), + "borderWidth", "BorderWidth", RES_TYPE_NUMBER); + + /* This defaults to 1 in order to match xterm. We recognize either + internalBorderWidth or internalBorder (which is what xterm calls + it). */ + if (NILP (Fassq (Qinternal_border_width, parms))) + { + Lisp_Object value; + + value = gui_display_get_arg (dpyinfo, parms, Qinternal_border_width, + "internalBorder", "internalBorder", + RES_TYPE_NUMBER); + if (!EQ (value, Qunbound)) + parms = Fcons (Fcons (Qinternal_border_width, value), parms); + } + + /* Same for child frames. */ + if (NILP (Fassq (Qchild_frame_border_width, parms))) + { + Lisp_Object value; + + value = gui_display_get_arg (dpyinfo, parms, Qchild_frame_border_width, + "childFrameBorderWidth", "childFrameBorderWidth", + RES_TYPE_NUMBER); + if (! EQ (value, Qunbound)) + parms = Fcons (Fcons (Qchild_frame_border_width, value), + parms); + + } + + gui_default_parameter (f, parms, Qchild_frame_border_width, + make_fixnum (0), + "childFrameBorderWidth", "childFrameBorderWidth", + RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qinternal_border_width, + make_fixnum (0), + "internalBorderWidth", "internalBorderWidth", + 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, + Qright, + "verticalScrollBars", "ScrollBars", RES_TYPE_SYMBOL); + gui_default_parameter (f, parms, Qhorizontal_scroll_bars, Qnil, + "horizontalScrollBars", "ScrollBars", + RES_TYPE_SYMBOL); + /* Also do the stuff which must be set before the window exists. */ + 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, Qmouse_color, build_string ("black"), + "pointerColor", "Foreground", RES_TYPE_STRING); + gui_default_parameter (f, parms, Qborder_color, build_string ("black"), + "borderColor", "BorderColor", RES_TYPE_STRING); + gui_default_parameter (f, parms, Qscreen_gamma, Qnil, + "screenGamma", "ScreenGamma", RES_TYPE_FLOAT); + 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, Qnil, + NULL, NULL, RES_TYPE_BOOLEAN); + + gui_default_parameter (f, parms, Qscroll_bar_foreground, Qnil, + "scrollBarForeground", "ScrollBarForeground", + RES_TYPE_STRING); + gui_default_parameter (f, parms, Qscroll_bar_background, Qnil, + "scrollBarBackground", "ScrollBarBackground", + RES_TYPE_STRING); + + /* Init faces before gui_default_parameter is called for the + scroll-bar-width parameter because otherwise we end up in + init_iterator with a null face cache, which should not happen. */ + init_frame_faces (f); + + /* We have to call adjust_frame_size here since otherwise + x_set_tool_bar_lines will already work with the character sizes + installed by init_frame_faces while the frame's pixel size is still + calculated from a character size of 1 and we subsequently hit the + (height >= 0) assertion in window_box_height. + + The non-pixelwise code apparently worked around this because it + had one frame line vs one toolbar line which left us with a zero + root window height which was obviously wrong as well ... + + Also process `min-width' and `min-height' parameters right here + because `frame-windows-min-size' needs them. */ + tem = + gui_display_get_arg (dpyinfo, parms, Qmin_width, NULL, NULL, + RES_TYPE_NUMBER); + if (NUMBERP (tem)) + store_frame_param (f, Qmin_width, tem); + tem = + gui_display_get_arg (dpyinfo, parms, Qmin_height, NULL, NULL, + RES_TYPE_NUMBER); + if (NUMBERP (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, true, + Qx_create_frame_1); + + /* Set the menu-bar-lines and tool-bar-lines parameters. We don't + look up the X resources controlling the menu-bar and tool-bar + here; they are processed specially at startup, and reflected in + the values of the mode variables. */ + + 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); + gui_default_parameter (f, parms, Qwait_for_wm, Qt, + "waitForWM", "WaitForWM", RES_TYPE_BOOLEAN); + gui_default_parameter (f, parms, Qtool_bar_position, + FRAME_TOOL_BAR_POSITION (f), 0, 0, RES_TYPE_SYMBOL); + gui_default_parameter (f, parms, Qinhibit_double_buffering, Qnil, + "inhibitDoubleBuffering", "InhibitDoubleBuffering", + RES_TYPE_BOOLEAN); + + /* Compute the size of the X window. */ + window_prompting = + gui_figure_window_size (f, parms, true, true); + + tem = + gui_display_get_arg (dpyinfo, parms, Qunsplittable, 0, 0, + RES_TYPE_BOOLEAN); + f->no_split = minibuffer_only || EQ (tem, Qt); + +#if 0 + x_icon_verify (f, parms); +#endif + + /* Create the X widget or window. */ + /* x_window (f); */ + xg_create_frame_widgets (f); + pgtk_set_event_handler (f); + + +#define INSTALL_CURSOR(FIELD, NAME) \ + FRAME_X_OUTPUT (f)->FIELD = gdk_cursor_new_for_display (FRAME_X_DISPLAY (f), GDK_ ## NAME) + + INSTALL_CURSOR (text_cursor, XTERM); + INSTALL_CURSOR (nontext_cursor, LEFT_PTR); + INSTALL_CURSOR (modeline_cursor, XTERM); + INSTALL_CURSOR (hand_cursor, HAND2); + INSTALL_CURSOR (hourglass_cursor, WATCH); + INSTALL_CURSOR (horizontal_drag_cursor, SB_H_DOUBLE_ARROW); + INSTALL_CURSOR (vertical_drag_cursor, SB_V_DOUBLE_ARROW); + INSTALL_CURSOR (left_edge_cursor, LEFT_SIDE); + INSTALL_CURSOR (right_edge_cursor, RIGHT_SIDE); + INSTALL_CURSOR (top_edge_cursor, TOP_SIDE); + INSTALL_CURSOR (bottom_edge_cursor, BOTTOM_SIDE); + INSTALL_CURSOR (top_left_corner_cursor, TOP_LEFT_CORNER); + INSTALL_CURSOR (top_right_corner_cursor, TOP_RIGHT_CORNER); + INSTALL_CURSOR (bottom_right_corner_cursor, BOTTOM_RIGHT_CORNER); + INSTALL_CURSOR (bottom_left_corner_cursor, BOTTOM_LEFT_CORNER); + +#undef INSTALL_CURSOR + + x_icon (f, parms); +#if 0 + x_make_gc (f); +#endif + + /* Now consider the frame official. */ + f->terminal->reference_count++; + FRAME_DISPLAY_INFO (f)->reference_count++; + Vframe_list = Fcons (frame, Vframe_list); + + /* We need to do this after creating the X window, so that the + icon-creation functions can say whose icon they're describing. */ + gui_default_parameter (f, parms, Qicon_type, Qt, + "bitmapIcon", "BitmapIcon", RES_TYPE_BOOLEAN); + + gui_default_parameter (f, parms, Qauto_raise, Qnil, + "autoRaise", "AutoRaiseLower", RES_TYPE_BOOLEAN); + gui_default_parameter (f, parms, Qauto_lower, Qnil, + "autoLower", "AutoRaiseLower", 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); + + if (!NILP (parent_frame)) + { + struct frame *p = XFRAME (parent_frame); + + block_input (); + + GtkWidget *fixed = FRAME_GTK_WIDGET (f); + GtkWidget *fixed_of_p = FRAME_GTK_WIDGET (p); + GtkWidget *whbox_of_f = gtk_widget_get_parent (fixed); + g_object_ref (fixed); + gtk_container_remove (GTK_CONTAINER (whbox_of_f), fixed); + gtk_fixed_put (GTK_FIXED (fixed_of_p), fixed, f->left_pos, f->top_pos); + gtk_widget_show_all (fixed); + g_object_unref (fixed); + + gtk_widget_destroy (FRAME_GTK_OUTER_WIDGET (f)); + FRAME_GTK_OUTER_WIDGET (f) = NULL; + FRAME_OUTPUT_DATA (f)->vbox_widget = NULL; + FRAME_OUTPUT_DATA (f)->hbox_widget = NULL; + FRAME_OUTPUT_DATA (f)->menubar_widget = NULL; + FRAME_OUTPUT_DATA (f)->toolbar_widget = NULL; + FRAME_OUTPUT_DATA (f)->ttip_widget = NULL; + FRAME_OUTPUT_DATA (f)->ttip_lbl = NULL; + FRAME_OUTPUT_DATA (f)->ttip_window = NULL; + + unblock_input (); + } + + if (FRAME_GTK_OUTER_WIDGET (f)) + { + GList *w = gtk_container_get_children (GTK_CONTAINER (FRAME_GTK_OUTER_WIDGET (f))); + for (; w != NULL; w = w->next) + gtk_widget_show_all (GTK_WIDGET (w->data)); + } + + 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); + + /* Create the menu bar. */ + if (!minibuffer_only && FRAME_EXTERNAL_MENU_BAR (f)) + { + /* If this signals an error, we haven't set size hints for the + frame and we didn't make it visible. */ + initialize_frame_menubar (f); + + } + + /* Consider frame official, now. */ + f->can_set_window_size = true; + + /* Tell the server what size and position, etc, we want, and how + badly we want them. This should be done after we have the menu + bar so that its size can be taken into account. */ + block_input (); + x_wm_set_size_hint (f, window_prompting, false); + unblock_input (); + + adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f), + 0, true, Qx_create_frame_2); + + /* Process fullscreen parameter here in the hope that normalizing a + fullheight/fullwidth frame will produce the size set by the last + adjust_frame_size call. */ + gui_default_parameter (f, parms, Qfullscreen, Qnil, + "fullscreen", "Fullscreen", RES_TYPE_SYMBOL); + + /* Make the window appear on the frame and enable display, unless + the caller says not to. However, with explicit parent, Emacs + cannot control visibility, so don't try. */ + if (!FRAME_X_OUTPUT (f)->explicit_parent) + { + Lisp_Object visibility + = + gui_display_get_arg (dpyinfo, parms, Qvisibility, 0, 0, + RES_TYPE_SYMBOL); + + if (EQ (visibility, Qicon)) + pgtk_iconify_frame (f); + else + { + if (EQ (visibility, Qunbound)) + visibility = Qt; + + if (!NILP (visibility)) + pgtk_make_frame_visible (f); + } + + store_frame_param (f, Qvisibility, visibility); + } + + /* Works iff frame has been already mapped. */ + gui_default_parameter (f, parms, Qskip_taskbar, Qnil, + NULL, NULL, RES_TYPE_BOOLEAN); + /* The `z-group' parameter works only for visible frames. */ + gui_default_parameter (f, parms, Qz_group, Qnil, + NULL, NULL, RES_TYPE_SYMBOL); + + /* Initialize `default-minibuffer-frame' in case this is the first + frame on this terminal. */ + 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); + + /* All remaining specified parameters, which have not been "used" + by gui_display_get_arg and friends, now go in the misc. alist of the 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)); + + FRAME_X_OUTPUT (f)->border_color_css_provider = NULL; + + FRAME_X_OUTPUT (f)->cr_surface_visible_bell = NULL; + FRAME_X_OUTPUT (f)->atimer_visible_bell = NULL; + FRAME_X_OUTPUT (f)->watched_scale_factor = 1.0; + struct timespec ts = make_timespec (1, 0); + FRAME_X_OUTPUT (f)->scale_factor_atimer = start_atimer(ATIMER_CONTINUOUS, + ts, + update_watched_scale_factor, + f); + + /* Make sure windows on this frame appear in calls to next-window + and similar functions. */ + Vwindow_list = Qnil; + + return unbind_to (count, frame); +} + + +#if 0 +static int +pgtk_window_is_ancestor (PGTKWindow * win, PGTKWindow * candidate) +/* Test whether CANDIDATE is an ancestor window of WIN. */ +{ + if (candidate == NULL) + return 0; + else if (win == candidate) + return 1; + else + return pgtk_window_is_ancestor (win,[candidate parentWindow]); +} +#endif + +/** + * x_frame_restack: + * + * Restack frame F1 below frame F2, above if ABOVE_FLAG is non-nil. In + * practice this is a two-step action: The first step removes F1's + * window-system window from the display. The second step reinserts + * F1's window below (above if ABOVE_FLAG is true) that of F2. + */ +static void +pgtk_frame_restack (struct frame *f1, struct frame *f2, bool above_flag) +{ + block_input (); + xg_frame_restack (f1, f2, above_flag); + unblock_input (); +} + + +DEFUN ("pgtk-frame-restack", Fpgtk_frame_restack, Spgtk_frame_restack, 2, 3, 0, + doc: /* Restack FRAME1 below FRAME2. +This means that if both frames are visible and the display areas of +these frames overlap, FRAME2 (partially) obscures FRAME1. If optional +third argument ABOVE is non-nil, restack FRAME1 above FRAME2. This +means that if both frames are visible and the display areas of these +frames overlap, FRAME1 (partially) obscures FRAME2. + +This may be thought of as an atomic action performed in two steps: The +first step removes FRAME1's window-step window from the display. The +second step reinserts FRAME1's window below (above if ABOVE is true) +that of FRAME2. Hence the position of FRAME2 in its display's Z +\(stacking) order relative to all other frames excluding FRAME1 remains +unaltered. + +Some window managers may refuse to restack windows. */) + (Lisp_Object frame1, Lisp_Object frame2, Lisp_Object above) +{ + struct frame *f1 = decode_live_frame (frame1); + struct frame *f2 = decode_live_frame (frame2); + + if (!(FRAME_GTK_OUTER_WIDGET (f1) && FRAME_GTK_OUTER_WIDGET (f2))) + error ("Cannot restack frames"); + pgtk_frame_restack (f1, f2, !NILP (above)); + return Qt; +} + +#ifdef HAVE_GSETTINGS + +#define RESOURCE_KEY_MAX_LEN 128 +#define SCHEMA_ID "org.gnu.emacs.defaults" +#define PATH_FOR_CLASS_TYPE "/org/gnu/emacs/defaults-by-class/" +#define PATH_PREFIX_FOR_NAME_TYPE "/org/gnu/emacs/defaults-by-name/" + +static inline int +pgtk_is_lower_char (int c) +{ + return c >= 'a' && c <= 'z'; +} + +static inline int +pgtk_is_upper_char (int c) +{ + return c >= 'A' && c <= 'Z'; +} + +static inline int +pgtk_is_numeric_char (int c) +{ + return c >= '0' && c <= '9'; +} + +static GSettings * +parse_resource_key (const char *res_key, char *setting_key) +{ + char path[32 + RESOURCE_KEY_MAX_LEN]; + const char *sp = res_key; + char *dp; + + /* + * res_key="emacs.cursorBlink" + * -> path="/org/gnu/emacs/defaults-by-name/emacs/" + * setting_key="cursor-blink" + * + * res_key="Emacs.CursorBlink" + * -> path="/org/gnu/emacs/defaults-by-class/" + * setting_key="cursor-blink" + * + * Returns GSettings* if setting_key exists in schema, otherwise NULL. + */ + + /* generate path */ + if (pgtk_is_upper_char (*sp)) + { + /* First letter is upper case. It should be "Emacs", + * but don't care. + */ + strcpy (path, PATH_FOR_CLASS_TYPE); + while (*sp != '\0') + { + if (*sp == '.') + break; + sp++; + } + } + else + { + strcpy (path, PATH_PREFIX_FOR_NAME_TYPE); + dp = path + strlen (path); + while (*sp != '\0') + { + int c = *sp; + if (c == '.') + break; + if (pgtk_is_lower_char (c)) + (void) 0; /* lower -> NOP */ + else if (pgtk_is_upper_char (c)) + c = c - 'A' + 'a'; /* upper -> lower */ + else if (pgtk_is_numeric_char (c)) + (void) 0; /* numeric -> NOP */ + else + return NULL; /* invalid */ + *dp++ = c; + sp++; + } + *dp++ = '/'; /* must ends with '/' */ + *dp = '\0'; + } + + if (*sp++ != '.') + return NULL; + + /* generate setting_key */ + dp = setting_key; + while (*sp != '\0') + { + int c = *sp; + if (pgtk_is_lower_char (c)) + (void) 0; /* lower -> NOP */ + else if (pgtk_is_upper_char (c)) + { + c = c - 'A' + 'a'; /* upper -> lower */ + if (dp != setting_key) + *dp++ = '-'; /* store '-' unless first char */ + } + else if (pgtk_is_numeric_char (c)) + (void) 0; /* numeric -> NOP */ + else + return NULL; /* invalid */ + + *dp++ = c; + sp++; + } + *dp = '\0'; + + /* check existence of setting_key */ + GSettingsSchemaSource *ssrc = g_settings_schema_source_get_default (); + GSettingsSchema *scm = g_settings_schema_source_lookup (ssrc, SCHEMA_ID, FALSE); + if (!scm) + return NULL; /* *.schema.xml is not installed. */ + if (!g_settings_schema_has_key (scm, setting_key)) + { + g_settings_schema_unref (scm); + return NULL; + } + + /* create GSettings, and return it */ + GSettings *gs = g_settings_new_full (scm, NULL, path); + + g_settings_schema_unref (scm); + return gs; +} + +const char * +pgtk_get_defaults_value (const char *key) +{ + char skey[(RESOURCE_KEY_MAX_LEN + 1) * 2]; + + if (strlen (key) >= RESOURCE_KEY_MAX_LEN) + error ("resource key too long."); + + GSettings *gs = parse_resource_key (key, skey); + if (gs == NULL) + { + return NULL; + } + + gchar *str = g_settings_get_string (gs, skey); + + /* There is no timing to free str. + * So, copy it here and free it. + * + * MEMO: Resource values for emacs shouldn't need such a long string value. + */ + static char holder[128]; + strncpy (holder, str, 128); + holder[127] = '\0'; + + g_object_unref (gs); + g_free (str); + return holder[0] != '\0' ? holder : NULL; +} + +static void +pgtk_set_defaults_value (const char *key, const char *value) +{ + char skey[(RESOURCE_KEY_MAX_LEN + 1) * 2]; + + if (strlen (key) >= RESOURCE_KEY_MAX_LEN) + error ("resource key too long."); + + GSettings *gs = parse_resource_key (key, skey); + if (gs == NULL) + error ("unknown resource key."); + + if (value != NULL) + { + g_settings_set_string (gs, skey, value); + } + else + { + g_settings_reset (gs, skey); + } + + g_object_unref (gs); +} + +#undef RESOURCE_KEY_MAX_LEN +#undef SCHEMA_ID +#undef PATH_FOR_CLASS_TYPE +#undef PATH_PREFIX_FOR_NAME_TYPE + +#else /* not HAVE_GSETTINGS */ + +const char * +pgtk_get_defaults_value (const char *key) +{ + return NULL; +} + +static void +pgtk_set_defaults_value (const char *key, const char *value) +{ + error ("gsettings not supported."); +} + +#endif + + +DEFUN ("pgtk-set-resource", Fpgtk_set_resource, Spgtk_set_resource, 2, 2, 0, + doc: /* Set the value of ATTRIBUTE, of class CLASS, as VALUE, into defaults database. */ ) + (Lisp_Object attribute, Lisp_Object value) +{ + check_window_system (NULL); + + CHECK_STRING (attribute); + if (!NILP (value)) + CHECK_STRING (value); + + char *res = SSDATA (Vx_resource_name); + char *attr = SSDATA (attribute); + if (attr[0] >= 'A' && attr[0] <= 'Z') + res = SSDATA (Vx_resource_class); + + char *key = g_strdup_printf ("%s.%s", res, attr); + + pgtk_set_defaults_value (key, NILP (value) ? NULL : SSDATA (value)); + + return Qnil; +} + + +DEFUN ("x-server-max-request-size", Fx_server_max_request_size, Sx_server_max_request_size, 0, 1, 0, + doc: /* This function is a no-op. It is only present for completeness. */ ) + (Lisp_Object terminal) +{ + check_pgtk_display_info (terminal); + /* This function has no real equivalent under PGTK. Return nil to + indicate this. */ + return Qnil; +} + + +DEFUN ("x-display-screens", Fx_display_screens, Sx_display_screens, 0, 1, 0, + doc: /* Return the number of screens on the display server TERMINAL. +The optional argument TERMINAL specifies which display to ask about. +TERMINAL should be a terminal object, a frame or a display name (a string). +If omitted or nil, that stands for the selected frame's display. + +Note: "screen" here is not in X11's. For the number of physical monitors, +use `(length \(display-monitor-attributes-list TERMINAL))' instead. */) + (Lisp_Object terminal) +{ + check_pgtk_display_info (terminal); + return make_fixnum (1); +} + + +DEFUN ("x-display-mm-height", Fx_display_mm_height, Sx_display_mm_height, 0, 1, 0, + doc: /* Return the height in millimeters of the the display TERMINAL. +The optional argument TERMINAL specifies which display to ask about. +TERMINAL should be a terminal object, a frame or a display name (a string). +If omitted or nil, that stands for the selected frame's display. + +On \"multi-monitor\" setups this refers to the height in millimeters for +all physical monitors associated with TERMINAL. To get information +for each physical monitor, use `display-monitor-attributes-list'. */) + (Lisp_Object terminal) +{ + struct pgtk_display_info *dpyinfo = check_pgtk_display_info (terminal); + GdkDisplay *gdpy; + gint n_monitors, i; + int height_mm_at_0 = 0, height_mm_at_other = 0; + + block_input (); + gdpy = dpyinfo->gdpy; + n_monitors = gdk_display_get_n_monitors (gdpy); + + for (i = 0; i < n_monitors; ++i) + { + GdkRectangle rec; + + GdkMonitor *monitor = gdk_display_get_monitor (gdpy, i); + gdk_monitor_get_geometry (monitor, &rec); + + int mm = gdk_monitor_get_height_mm (monitor); + + if (rec.y == 0) + height_mm_at_0 = max (height_mm_at_0, mm); + else + height_mm_at_other += mm; + } + + unblock_input (); + + return make_fixnum (height_mm_at_0 + height_mm_at_other); +} + + +DEFUN ("x-display-mm-width", Fx_display_mm_width, Sx_display_mm_width, 0, 1, 0, + doc: /* Return the width in millimeters of the the display TERMINAL. +The optional argument TERMINAL specifies which display to ask about. +TERMINAL should be a terminal object, a frame or a display name (a string). +If omitted or nil, that stands for the selected frame's display. + +On \"multi-monitor\" setups this refers to the width in millimeters for +all physical monitors associated with TERMINAL. To get information +for each physical monitor, use `display-monitor-attributes-list'. */) + (Lisp_Object terminal) +{ + struct pgtk_display_info *dpyinfo = check_pgtk_display_info (terminal); + GdkDisplay *gdpy; + gint n_monitors, i; + int width_mm_at_0 = 0, width_mm_at_other = 0; + + block_input (); + gdpy = dpyinfo->gdpy; + n_monitors = gdk_display_get_n_monitors (gdpy); + + for (i = 0; i < n_monitors; ++i) + { + GdkRectangle rec; + + GdkMonitor *monitor = gdk_display_get_monitor (gdpy, i); + gdk_monitor_get_geometry (monitor, &rec); + + int mm = gdk_monitor_get_width_mm (monitor); + + if (rec.x == 0) + width_mm_at_0 = max (width_mm_at_0, mm); + else + width_mm_at_other += mm; + } + + unblock_input (); + + return make_fixnum (width_mm_at_0 + width_mm_at_other); +} + + +DEFUN ("x-display-backing-store", Fx_display_backing_store, Sx_display_backing_store, 0, 1, 0, + doc: /* Return an indication of whether the the display TERMINAL does backing store. +The value may be `buffered', `retained', or `non-retained'. +The optional argument TERMINAL specifies which display to ask about. +TERMINAL should be a terminal object, a frame or a display name (a string). +If omitted or nil, that stands for the selected frame's display. */) + (Lisp_Object terminal) +{ + check_pgtk_display_info (terminal); + return Qnil; +} + + +DEFUN ("x-display-visual-class", Fx_display_visual_class, Sx_display_visual_class, 0, 1, 0, + doc: /* Return the visual class of the the display TERMINAL. +The value is one of the symbols `static-gray', `gray-scale', +`static-color', `pseudo-color', `true-color', or `direct-color'. + +The optional argument TERMINAL specifies which display to ask about. +TERMINAL should a terminal object, a frame or a display name (a string). +If omitted or nil, that stands for the selected frame's display. + +On PGTK, always return true-color. */) + (Lisp_Object terminal) +{ + return intern ("true-color"); +} + + +DEFUN ("x-display-save-under", Fx_display_save_under, Sx_display_save_under, 0, 1, 0, + doc: /* Return t if TERMINAL supports the save-under feature. +The optional argument TERMINAL specifies which display to ask about. +TERMINAL should be a terminal object, a frame or a display name (a string). +If omitted or nil, that stands for the selected frame's display. */) + (Lisp_Object terminal) +{ + check_pgtk_display_info (terminal); + return Qnil; +} + + +DEFUN ("x-open-connection", Fx_open_connection, Sx_open_connection, 1, 3, 0, + doc: /* Open a connection to a display server. +DISPLAY is the name of the display to connect to. +Optional second arg XRM-STRING is a string of resources in xrdb format. +If the optional third arg MUST-SUCCEED is non-nil, +terminate Emacs if we can't open the connection. */) + (Lisp_Object display, Lisp_Object resource_string, Lisp_Object must_succeed) +{ + struct pgtk_display_info *dpyinfo; + + if (NILP (display)) + display = build_string (""); + + CHECK_STRING (display); + + nxatoms_of_pgtkselect (); + dpyinfo = pgtk_term_init (display, SSDATA (Vx_resource_name)); + if (dpyinfo == 0) + { + if (!NILP (must_succeed)) + fatal ("Display on %s not responding.\n", SSDATA (display)); + else + error ("Display on %s not responding.\n", SSDATA (display)); + } + + return Qnil; +} + + +DEFUN ("x-close-connection", Fx_close_connection, Sx_close_connection, 1, 1, 0, + doc: /* Close the connection to TERMINAL's display server. +For TERMINAL, specify a terminal object, a frame or a display name (a +string). If TERMINAL is nil, that stands for the selected frame's +terminal. */) + (Lisp_Object terminal) +{ + struct pgtk_display_info *dpyinfo = check_pgtk_display_info (terminal); + + if (dpyinfo->reference_count > 0) + error ("Display still has frames on it"); + + pgtk_delete_terminal (dpyinfo->terminal); + + return Qnil; +} + + +DEFUN ("x-display-list", Fx_display_list, Sx_display_list, 0, 0, 0, + doc: /* Return the list of display names that Emacs has connections to. */) + (void) +{ + Lisp_Object result = Qnil; + struct pgtk_display_info *ndi; + + for (ndi = x_display_list; ndi; ndi = ndi->next) + result = Fcons (XCAR (ndi->name_list_element), result); + + return result; +} + + +DEFUN ("pgtk-hide-others", Fpgtk_hide_others, Spgtk_hide_others, 0, 0, 0, + doc: /* Hides all applications other than Emacs. */) + (void) +{ + check_window_system (NULL); + return Qnil; +} + +DEFUN ("pgtk-hide-emacs", Fpgtk_hide_emacs, Spgtk_hide_emacs, 1, 1, 0, + doc: /* If ON is non-nil, the entire Emacs application is hidden. +Otherwise if Emacs is hidden, it is unhidden. +If ON is equal to `activate', Emacs is unhidden and becomes +the active application. */) + (Lisp_Object on) +{ + check_window_system (NULL); + return Qnil; +} + + +DEFUN ("pgtk-font-name", Fpgtk_font_name, Spgtk_font_name, 1, 1, 0, + doc: /* Determine font PostScript or family name for font NAME. +NAME should be a string containing either the font name or an XLFD +font descriptor. If string contains `fontset' and not +`fontset-startup', it is left alone. */) + (Lisp_Object name) +{ + char *nm; + CHECK_STRING (name); + nm = SSDATA (name); + + if (nm[0] != '-') + return name; + if (strstr (nm, "fontset") && !strstr (nm, "fontset-startup")) + return name; + + char *str = pgtk_xlfd_to_fontname (SSDATA (name)); + name = build_string (str); + xfree (str); + return name; +} + +/* ========================================================================== + + Miscellaneous functions not called through hooks + + ========================================================================== */ + +/* Called from frame.c. */ +struct pgtk_display_info * +check_x_display_info (Lisp_Object frame) +{ + return check_pgtk_display_info (frame); +} + + +void +pgtk_set_scroll_bar_default_width (struct frame *f) +{ + int unit = FRAME_COLUMN_WIDTH (f); + int minw = xg_get_default_scrollbar_width (f); + /* A minimum width of 14 doesn't look good for toolkit scroll bars. */ + FRAME_CONFIG_SCROLL_BAR_COLS (f) = (minw + unit - 1) / unit; + FRAME_CONFIG_SCROLL_BAR_WIDTH (f) = minw; +} + +void +pgtk_set_scroll_bar_default_height (struct frame *f) +{ + int height = FRAME_LINE_HEIGHT (f); + int min_height = xg_get_default_scrollbar_height (f); + /* A minimum height of 14 doesn't look good for toolkit scroll bars. */ + FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) = min_height; + FRAME_CONFIG_SCROLL_BAR_LINES (f) = (min_height + height - 1) / height; +} + +/* Terminals implement this instead of x-get-resource directly. */ +const char * +pgtk_get_string_resource (XrmDatabase rdb, const char *name, + const char *class) +{ + check_window_system (NULL); + + if (inhibit_x_resources) + /* --quick was passed, so this is a no-op. */ + return NULL; + + const char *res = pgtk_get_defaults_value (name); + if (res == NULL) + res = pgtk_get_defaults_value (class); + + if (res == NULL) + return NULL; + + if (c_strncasecmp (res, "YES", 3) == 0) + return "true"; + + if (c_strncasecmp (res, "NO", 2) == 0) + return "false"; + + return res; +} + + +Lisp_Object +x_get_focus_frame (struct frame *frame) +{ + struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (frame); + Lisp_Object focus; + + if (!dpyinfo->x_focus_frame) + return Qnil; + + XSETFRAME (focus, dpyinfo->x_focus_frame); + return focus; +} + +/* ========================================================================== + + Lisp definitions that, for whatever reason, we can't alias as 'ns-XXX'. + + ========================================================================== */ + + +DEFUN ("xw-color-defined-p", Fxw_color_defined_p, Sxw_color_defined_p, 1, 2, 0, + doc: /* Internal function called by `color-defined-p', which see. */) + (Lisp_Object color, Lisp_Object frame) +{ + Emacs_Color col; + struct frame *f = decode_window_system_frame (frame); + + CHECK_STRING (color); + + if (pgtk_defined_color (f, SSDATA (color), &col, false, false)) + return Qt; + else + return Qnil; +} + + +DEFUN ("xw-color-values", Fxw_color_values, Sxw_color_values, 1, 2, 0, + doc: /* Internal function called by `color-values', which see. */) + (Lisp_Object color, Lisp_Object frame) +{ + Emacs_Color col; + struct frame *f = decode_window_system_frame (frame); + + CHECK_STRING (color); + + if (pgtk_defined_color (f, SSDATA (color), &col, false, false)) + return list3i (col.red, col.green, col.blue); + else + return Qnil; +} + + +DEFUN ("xw-display-color-p", Fxw_display_color_p, Sxw_display_color_p, 0, 1, 0, + doc: /* Internal function called by `display-color-p', which see. */) + (Lisp_Object terminal) +{ + check_pgtk_display_info (terminal); + return Qt; +} + + +DEFUN ("x-display-grayscale-p", Fx_display_grayscale_p, Sx_display_grayscale_p, 0, 1, 0, + doc: /* Return t if the display supports shades of gray. +Note that color displays do support shades of gray. +The optional argument TERMINAL specifies which display to ask about. +TERMINAL should be a terminal object, a frame or a display name (a string). +If omitted or nil, that stands for the selected frame's display. */) + (Lisp_Object terminal) +{ + return Qnil; +} + + +DEFUN ("x-display-pixel-width", Fx_display_pixel_width, Sx_display_pixel_width, 0, 1, 0, + doc: /* Return the width in pixels of the display TERMINAL. +The optional argument TERMINAL specifies which display to ask about. +TERMINAL should be a terminal object, a frame or a display name (a string). +If omitted or nil, that stands for the selected frame's display. + +On \"multi-monitor\" setups this refers to the pixel width for all +physical monitors associated with TERMINAL. To get information for +each physical monitor, use `display-monitor-attributes-list'. */) + (Lisp_Object terminal) +{ + struct pgtk_display_info *dpyinfo = check_pgtk_display_info (terminal); + GdkDisplay *gdpy; + gint n_monitors, i; + int width = 0; + + block_input (); + gdpy = dpyinfo->gdpy; + n_monitors = gdk_display_get_n_monitors (gdpy); + + for (i = 0; i < n_monitors; ++i) + { + GdkRectangle rec; + double scale = 1; + + GdkMonitor *monitor = gdk_display_get_monitor (gdpy, i); + gdk_monitor_get_geometry (monitor, &rec); + + /* GTK returns scaled sizes for the workareas. */ + scale = pgtk_get_monitor_scale_factor (gdk_monitor_get_model (monitor)); + if (scale == 0.0) + scale = gdk_monitor_get_scale_factor (monitor); + rec.x = rec.x * scale + 0.5; + rec.y = rec.y * scale + 0.5; + rec.width = rec.width * scale + 0.5; + rec.height = rec.height * scale + 0.5; + + width = max (width, rec.x + rec.width); + } + + unblock_input (); + + return make_fixnum (width); +} + + +DEFUN ("x-display-pixel-height", Fx_display_pixel_height, Sx_display_pixel_height, 0, 1, 0, + doc: /* Return the height in pixels of the display TERMINAL. +The optional argument TERMINAL specifies which display to ask about. +TERMINAL should be a terminal object, a frame or a display name (a string). +If omitted or nil, that stands for the selected frame's display. + +On \"multi-monitor\" setups this refers to the pixel height for all +physical monitors associated with TERMINAL. To get information for +each physical monitor, use `display-monitor-attributes-list'. */) + (Lisp_Object terminal) +{ + struct pgtk_display_info *dpyinfo = check_pgtk_display_info (terminal); + GdkDisplay *gdpy; + gint n_monitors, i; + int height = 0; + + block_input (); + gdpy = dpyinfo->gdpy; + n_monitors = gdk_display_get_n_monitors (gdpy); + + for (i = 0; i < n_monitors; ++i) + { + GdkRectangle rec; + double scale = 1; + + GdkMonitor *monitor = gdk_display_get_monitor (gdpy, i); + gdk_monitor_get_geometry (monitor, &rec); + + /* GTK returns scaled sizes for the workareas. */ + scale = pgtk_get_monitor_scale_factor (gdk_monitor_get_model (monitor)); + if (scale == 0.0) + scale = gdk_monitor_get_scale_factor (monitor); + rec.x = rec.x * scale + 0.5; + rec.y = rec.y * scale + 0.5; + rec.width = rec.width * scale + 0.5; + rec.height = rec.height * scale + 0.5; + + height = max (height, rec.y + rec.height); + } + + unblock_input (); + + return make_fixnum (height); +} + +DEFUN ("pgtk-display-monitor-attributes-list", Fpgtk_display_monitor_attributes_list, + Spgtk_display_monitor_attributes_list, + 0, 1, 0, + doc: /* Return a list of physical monitor attributes on the X display TERMINAL. + +The optional argument TERMINAL specifies which display to ask about. +TERMINAL should be a terminal object, a frame or a display name (a string). +If omitted or nil, that stands for the selected frame's display. + +In addition to the standard attribute keys listed in +`display-monitor-attributes-list', the following keys are contained in +the attributes: + + source -- String describing the source from which multi-monitor + information is obtained, \"Gdk\" + +Internal use only, use `display-monitor-attributes-list' instead. */) + (Lisp_Object terminal) +{ + struct pgtk_display_info *dpyinfo = check_pgtk_display_info (terminal); + Lisp_Object attributes_list = Qnil; + + GdkDisplay *gdpy; + gint primary_monitor = 0, n_monitors, i; + Lisp_Object monitor_frames, rest, frame; + static const char *source = "Gdk"; + struct MonitorInfo *monitors; + + block_input (); + gdpy = dpyinfo->gdpy; + n_monitors = gdk_display_get_n_monitors (gdpy); + monitor_frames = make_nil_vector (n_monitors); + monitors = xzalloc (n_monitors * sizeof *monitors); + + FOR_EACH_FRAME (rest, frame) + { + struct frame *f = XFRAME (frame); + + if (FRAME_PGTK_P (f) + && FRAME_DISPLAY_INFO (f) == dpyinfo + && !FRAME_TOOLTIP_P (f)) + { + GdkWindow *gwin = gtk_widget_get_window (FRAME_GTK_WIDGET (f)); + + for (i = 0; i < n_monitors; i++) + if (gdk_display_get_monitor_at_window (gdpy, gwin) + == gdk_display_get_monitor (gdpy, i)) + break; + ASET (monitor_frames, i, Fcons (frame, AREF (monitor_frames, i))); + } + } + + for (i = 0; i < n_monitors; ++i) + { + gint width_mm, height_mm; + GdkRectangle rec, work; + struct MonitorInfo *mi = &monitors[i]; + double scale = 1; + + GdkMonitor *monitor = gdk_display_get_monitor (gdpy, i); + if (gdk_monitor_is_primary (monitor)) + primary_monitor = i; + gdk_monitor_get_geometry (monitor, &rec); + + width_mm = gdk_monitor_get_width_mm (monitor); + height_mm = gdk_monitor_get_height_mm (monitor); + gdk_monitor_get_workarea (monitor, &work); + + /* GTK returns scaled sizes for the workareas. */ + scale = pgtk_get_monitor_scale_factor (gdk_monitor_get_model (monitor)); + if (scale == 0.0) + scale = gdk_monitor_get_scale_factor (monitor); + rec.x = rec.x * scale + 0.5; + rec.y = rec.y * scale + 0.5; + rec.width = rec.width * scale + 0.5; + rec.height = rec.height * scale + 0.5; + work.x = work.x * scale + 0.5; + work.y = work.y * scale + 0.5; + work.width = work.width * scale + 0.5; + work.height = work.height * scale + 0.5; + + mi->geom.x = rec.x; + mi->geom.y = rec.y; + mi->geom.width = rec.width; + mi->geom.height = rec.height; + mi->work.x = work.x; + mi->work.y = work.y; + mi->work.width = work.width; + mi->work.height = work.height; + mi->mm_width = width_mm; + mi->mm_height = height_mm; + mi->scale_factor = scale; + + dupstring (&mi->name, (gdk_monitor_get_model (monitor))); + } + + attributes_list = make_monitor_attribute_list (monitors, + n_monitors, + primary_monitor, + monitor_frames, + source); + free_monitors (monitors, n_monitors); + unblock_input (); + + return attributes_list; +} + +double +pgtk_frame_scale_factor (struct frame *f) +{ + struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); + GdkDisplay *gdpy = dpyinfo->gdpy; + + block_input (); + + GdkWindow *gwin = gtk_widget_get_window (FRAME_GTK_WIDGET (f)); + GdkMonitor *gmon = gdk_display_get_monitor_at_window (gdpy, gwin); + + /* GTK returns scaled sizes for the workareas. */ + double scale = pgtk_get_monitor_scale_factor (gdk_monitor_get_model (gmon)); + if (scale == 0.0) + scale = gdk_monitor_get_scale_factor (gmon); + + unblock_input (); + + return scale; +} + +DEFUN ("x-display-planes", Fx_display_planes, Sx_display_planes, 0, 1, 0, + doc: /* Return the number of bitplanes of the display TERMINAL. +The optional argument TERMINAL specifies which display to ask about. +TERMINAL should be a terminal object, a frame or a display name (a string). +If omitted or nil, that stands for the selected frame's display. */) + (Lisp_Object terminal) +{ + check_pgtk_display_info (terminal); + return make_fixnum (32); +} + + +DEFUN ("x-display-color-cells", Fx_display_color_cells, Sx_display_color_cells, 0, 1, 0, + doc: /* Returns the number of color cells of the display TERMINAL. +The optional argument TERMINAL specifies which display to ask about. +TERMINAL should be a terminal object, a frame or a display name (a string). +If omitted or nil, that stands for the selected frame's display. */) + (Lisp_Object terminal) +{ + struct pgtk_display_info *dpyinfo = check_pgtk_display_info (terminal); + /* We force 24+ bit depths to 24-bit to prevent an overflow. */ + return make_fixnum (1 << min (dpyinfo->n_planes, 24)); +} + +/*********************************************************************** + Tool tips + ***********************************************************************/ + +/* 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. */ +GtkWidget *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 +unwind_create_tip_frame (Lisp_Object frame) +{ + Lisp_Object deleted; + + deleted = unwind_create_frame (frame); + if (EQ (deleted, Qt)) + { + tip_window = NULL; + tip_frame = Qnil; + } +} + + +/* Create a frame for a tooltip on the display described by DPYINFO. + PARMS is a list of frame parameters. TEXT is the string to + display in the tip frame. Value is the frame. + + Note that functions called here, esp. gui_default_parameter can + signal errors, for instance when a specified color name is + undefined. We have to make sure that we're in a consistent state + when this happens. */ + +static Lisp_Object +x_create_tip_frame (struct pgtk_display_info *dpyinfo, Lisp_Object parms, struct frame *p) +{ + struct frame *f; + Lisp_Object frame; + Lisp_Object name; + ptrdiff_t count = SPECPDL_INDEX (); + bool face_change_before = face_change; + + if (!dpyinfo->terminal->name) + error ("Terminal is not live, can't create new frames on it"); + + parms = Fcopy_alist (parms); + + /* Get the name of the frame to use for resource lookup. */ + name = gui_display_get_arg (dpyinfo, parms, Qname, "name", "Name", + RES_TYPE_STRING); + if (!STRINGP (name) + && !EQ (name, Qunbound) + && !NILP (name)) + error ("Invalid frame name--not a string or nil"); + + frame = Qnil; + f = make_frame (false); + f->wants_modeline = false; + XSETFRAME (frame, f); + record_unwind_protect (unwind_create_tip_frame, frame); + + f->terminal = dpyinfo->terminal; + + /* By setting the output method, we're essentially saying that + the frame is live, as per FRAME_LIVE_P. If we get a signal + from this point on, x_destroy_window might screw up reference + counts etc. */ + f->output_method = output_pgtk; + f->output_data.pgtk = xzalloc (sizeof *f->output_data.pgtk); +#if 0 + f->output_data.pgtk->icon_bitmap = -1; +#endif + FRAME_FONTSET (f) = -1; + f->output_data.pgtk->white_relief.pixel = -1; + f->output_data.pgtk->black_relief.pixel = -1; + + f->tooltip = true; + fset_icon_name (f, Qnil); + FRAME_DISPLAY_INFO (f) = dpyinfo; + f->output_data.pgtk->parent_desc = FRAME_DISPLAY_INFO (f)->root_window; + f->output_data.pgtk->explicit_parent = false; + + /* These colors will be set anyway later, but it's important + to get the color reference counts right, so initialize them! */ + { + Lisp_Object black; + + /* Function x_decode_color can signal an error. Make + sure to initialize color slots so that we won't try + to free colors we haven't allocated. */ + FRAME_FOREGROUND_PIXEL (f) = -1; + FRAME_BACKGROUND_PIXEL (f) = -1; + f->output_data.pgtk->border_pixel = -1; + + black = build_string ("black"); + FRAME_FOREGROUND_PIXEL (f) + = x_decode_color (f, black, BLACK_PIX_DEFAULT (f)); + FRAME_BACKGROUND_PIXEL (f) + = x_decode_color (f, black, BLACK_PIX_DEFAULT (f)); + f->output_data.pgtk->border_pixel + = x_decode_color (f, black, BLACK_PIX_DEFAULT (f)); + } + + /* Set the name; the functions to which we pass f expect the name to + be set. */ + if (EQ (name, Qunbound) || NILP (name)) + { + fset_name (f, build_string (dpyinfo->x_id_name)); + f->explicit_name = false; + } + else + { + fset_name (f, name); + f->explicit_name = true; + /* use the frame's title when getting resources for this frame. */ + specbind (Qx_resource_name, name); + } + + register_font_driver (&ftcrfont_driver, f); +#ifdef HAVE_HARFBUZZ + register_font_driver (&ftcrhbfont_driver, f); +#endif /* HAVE_HARFBUZZ */ + + 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); + + /* Extract the window parameters from the supplied values that are + needed to determine window geometry. */ + pgtk_default_font_parameter (f, parms); + + gui_default_parameter (f, parms, Qborder_width, make_fixnum (0), + "borderWidth", "BorderWidth", RES_TYPE_NUMBER); + + /* This defaults to 2 in order to match xterm. We recognize either + internalBorderWidth or internalBorder (which is what xterm calls + it). */ + if (NILP (Fassq (Qinternal_border_width, parms))) + { + Lisp_Object value; + + value = gui_display_get_arg (dpyinfo, parms, Qinternal_border_width, + "internalBorder", "internalBorder", + RES_TYPE_NUMBER); + if (! EQ (value, Qunbound)) + parms = Fcons (Fcons (Qinternal_border_width, value), + parms); + } + + gui_default_parameter (f, parms, Qinternal_border_width, make_fixnum (1), + "internalBorderWidth", "internalBorderWidth", + 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); + + /* Also do the stuff which must be set before the window exists. */ + 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, Qmouse_color, build_string ("black"), + "pointerColor", "Foreground", RES_TYPE_STRING); + gui_default_parameter (f, parms, Qcursor_color, build_string ("black"), + "cursorColor", "Foreground", RES_TYPE_STRING); + gui_default_parameter (f, parms, Qborder_color, build_string ("black"), + "borderColor", "BorderColor", RES_TYPE_STRING); + gui_default_parameter (f, parms, Qno_special_glyphs, Qnil, + NULL, NULL, RES_TYPE_BOOLEAN); + + /* Init faces before gui_default_parameter is called for the + scroll-bar-width parameter because otherwise we end up in + init_iterator with a null face cache, which should not happen. */ + init_frame_faces (f); + + f->output_data.pgtk->parent_desc = FRAME_DISPLAY_INFO (f)->root_window; + + gui_default_parameter (f, parms, Qinhibit_double_buffering, Qnil, + "inhibitDoubleBuffering", "InhibitDoubleBuffering", + RES_TYPE_BOOLEAN); + + gui_figure_window_size (f, parms, false, false); + + xg_create_frame_widgets (f); + pgtk_set_event_handler (f); + tip_window = FRAME_GTK_OUTER_WIDGET (f); + gtk_window_set_transient_for (GTK_WINDOW (tip_window), + GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (p))); + gtk_window_set_attached_to (GTK_WINDOW (tip_window), FRAME_GTK_WIDGET (p)); + gtk_window_set_destroy_with_parent (GTK_WINDOW (tip_window), TRUE); + gtk_window_set_decorated (GTK_WINDOW (tip_window), FALSE); + gtk_window_set_type_hint (GTK_WINDOW (tip_window), GDK_WINDOW_TYPE_HINT_TOOLTIP); + f->output_data.pgtk->current_cursor = f->output_data.pgtk->text_cursor; + +#if 0 + x_make_gc (f); +#endif + + gui_default_parameter (f, parms, Qauto_raise, Qnil, + "autoRaise", "AutoRaiseLower", RES_TYPE_BOOLEAN); + gui_default_parameter (f, parms, Qauto_lower, Qnil, + "autoLower", "AutoRaiseLower", RES_TYPE_BOOLEAN); + gui_default_parameter (f, parms, Qcursor_type, Qbox, + "cursorType", "CursorType", RES_TYPE_SYMBOL); + gui_default_parameter (f, parms, Qalpha, Qnil, + "alpha", "Alpha", RES_TYPE_NUMBER); + + /* Add `tooltip' frame parameter's default value. */ + if (NILP (Fframe_parameter (frame, Qtooltip))) + { + AUTO_FRAME_ARG (arg, Qtooltip, Qt); + Fmodify_frame_parameters (frame, arg); + } + + /* FIXME - can this be done in a similar way to normal frames? + https://lists.gnu.org/r/emacs-devel/2007-10/msg00641.html */ + + /* Set the `display-type' frame parameter before setting up faces. */ + { + Lisp_Object disptype; + + disptype = intern ("color"); + + if (NILP (Fframe_parameter (frame, Qdisplay_type))) + { + AUTO_FRAME_ARG (arg, Qdisplay_type, disptype); + Fmodify_frame_parameters (frame, arg); + } + } + + /* Set up faces after all frame parameters are known. This call + also merges in face attributes specified for new frames. + + Frame parameters may be changed if .Xdefaults contains + specifications for the default font. For example, if there is an + `Emacs.default.attributeBackground: pink', the `background-color' + attribute of the frame get's set, which let's the internal border + of the tooltip frame appear in pink. Prevent this. */ + { + 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); + } + } + + f->no_split = true; + + /* Now that the frame will be official, it counts as a reference to + its display and terminal. */ + FRAME_DISPLAY_INFO (f)->reference_count++; + f->terminal->reference_count++; + + /* It is now ok to make the frame official even if we get an error + below. And the frame needs to be on Vframe_list or making it + visible won't work. */ + Vframe_list = Fcons (frame, Vframe_list); + f->can_set_window_size = true; + adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f), + 0, true, Qtip_frame); + + /* Setting attributes of faces of the tooltip frame from resources + and similar will set face_change, which leads to the clearing of + all current matrices. Since this isn't necessary here, avoid it + by resetting face_change to the value it had before we created + the tip frame. */ + face_change = face_change_before; + + /* Discard the unwind_protect. */ + return unbind_to (count, frame); +} + +/* Compute where to display tip frame F. PARMS is the list of frame + parameters for F. DX and DY are specified offsets from the current + location of the mouse. WIDTH and HEIGHT are the width and height + of the tooltip. Return coordinates relative to the root window of + the display in *ROOT_X, and *ROOT_Y. */ + +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, min_y, max_x, max_y = -1; + + /* 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 ((!INTEGERP (left) && !INTEGERP (right)) + || (!INTEGERP (top) && !INTEGERP (bottom))) + { + Lisp_Object frame, attributes, monitor, geometry; + GdkSeat *seat = + gdk_display_get_default_seat (FRAME_DISPLAY_INFO (f)->gdpy); + GdkDevice *dev = gdk_seat_get_pointer (seat); + GdkScreen *scr; + + block_input (); + gdk_device_get_position (dev, &scr, root_x, root_y); + unblock_input (); + + XSETFRAME (frame, f); + attributes = Fpgtk_display_monitor_attributes_list (frame); + + /* Try to determine the monitor where the mouse pointer is and + its geometry. See bug#22549. */ + while (CONSP (attributes)) + { + monitor = XCAR (attributes); + geometry = Fassq (Qgeometry, monitor); + if (CONSP (geometry)) + { + min_x = XFIXNUM (Fnth (make_fixnum (1), geometry)); + min_y = XFIXNUM (Fnth (make_fixnum (2), geometry)); + max_x = min_x + XFIXNUM (Fnth (make_fixnum (3), geometry)); + max_y = min_y + XFIXNUM (Fnth (make_fixnum (4), geometry)); + if (min_x <= *root_x && *root_x < max_x + && min_y <= *root_y && *root_y < max_y) + { + break; + } + max_y = -1; + } + + attributes = XCDR (attributes); + } + } + + /* It was not possible to determine the monitor's geometry, so we + assign some sane defaults here: */ + if (max_y < 0) + { + min_x = 0; + min_y = 0; + max_x = x_display_pixel_width (FRAME_DISPLAY_INFO (f)); + max_y = x_display_pixel_height (FRAME_DISPLAY_INFO (f)); + } + + if (INTEGERP (top)) + *root_y = XFIXNUM (top); + else if (INTEGERP (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 (INTEGERP (left)) + *root_x = XFIXNUM (left); + else if (INTEGERP (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; +} + + +/* Hide tooltip. Delete its frame if DELETE is true. */ +static Lisp_Object +x_hide_tip (bool delete) +{ + if (!NILP (tip_timer)) + { + call1 (Qcancel_timer, tip_timer); + tip_timer = Qnil; + } + + /* Any GTK+ system tooltip can be found via the x_output structure of + tip_last_frame, provided that frame is still live. Any Emacs + tooltip is found via the tip_frame variable. Note that the current + value of x_gtk_use_system_tooltips might not be the same as used + for the tooltip we have to hide, see Bug#30399. */ + if ((NILP (tip_last_frame) && NILP (tip_frame)) + || (!x_gtk_use_system_tooltips + && !delete + && FRAMEP (tip_frame) + && FRAME_LIVE_P (XFRAME (tip_frame)) + && !FRAME_VISIBLE_P (XFRAME (tip_frame)))) + /* Either there's no tooltip to hide or it's an already invisible + Emacs tooltip and we don't want to change its type. Return + quickly. */ + return Qnil; + else + { + ptrdiff_t count; + Lisp_Object was_open = Qnil; + + count = SPECPDL_INDEX (); + specbind (Qinhibit_redisplay, Qt); + specbind (Qinhibit_quit, Qt); + + /* Try to hide the GTK+ system tip first. */ + if (FRAMEP (tip_last_frame)) + { + struct frame *f = XFRAME (tip_last_frame); + + if (FRAME_LIVE_P (f)) + { + if (xg_hide_tooltip (f)) + was_open = Qt; + } + } + + /* When using GTK+ system tooltips (compare Bug#41200) reset + tip_last_frame. It will be reassigned when showing the next + GTK+ system tooltip. */ + if (x_gtk_use_system_tooltips) + tip_last_frame = Qnil; + + /* Now look whether there's an Emacs tip around. */ + if (FRAMEP (tip_frame)) + { + struct frame *f = XFRAME (tip_frame); + + if (FRAME_LIVE_P (f)) + { + if (delete || x_gtk_use_system_tooltips) + { + /* Delete the Emacs tooltip frame when DELETE is true + or we change the tooltip type from an Emacs one to + a GTK+ system one. */ + delete_frame (tip_frame, Qnil); + tip_frame = Qnil; + } + else + pgtk_make_frame_invisible (f); + + was_open = Qt; + } + else + tip_frame = Qnil; + } + else + tip_frame = Qnil; + + return unbind_to (count, was_open); + } +} + +DEFUN ("x-show-tip", Fx_show_tip, Sx_show_tip, 1, 6, 0, + doc: /* Show STRING in a "tooltip" window on frame FRAME. +A tooltip window is a small X window displaying a string. + +This is an internal function; Lisp code should call `tooltip-show'. + +FRAME nil or omitted means use the selected frame. + +PARMS is an optional list of frame parameters which can be used to +change the tooltip's appearance. + +Automatically hide the tooltip after TIMEOUT seconds. TIMEOUT nil +means use the default timeout of 5 seconds. + +If the list of frame parameters PARMS contains a `left' parameter, +display the tooltip at that x-position. If the list of frame parameters +PARMS contains no `left' but a `right' parameter, display the tooltip +right-adjusted at that x-position. Otherwise display it at the +x-position of the mouse, with offset DX added (default is 5 if DX isn't +specified). + +Likewise for the y-position: If a `top' frame parameter is specified, it +determines the position of the upper edge of the tooltip window. If a +`bottom' parameter but no `top' frame parameter is specified, it +determines the position of the lower edge of the tooltip window. +Otherwise display the tooltip window at the y-position of the mouse, +with offset DY added (default is -10). + +A tooltip's maximum size is specified by `x-max-tooltip-size'. +Text larger than the specified size is clipped. */) + (Lisp_Object string, Lisp_Object frame, Lisp_Object parms, + Lisp_Object timeout, Lisp_Object dx, Lisp_Object dy) +{ + struct frame *f, *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 (SCHARS (string) == 0) + string = make_unibyte_string (" ", 1); + + if (NILP (frame)) + frame = selected_frame; + f = decode_window_system_frame (frame); + + if (!FRAME_GTK_OUTER_WIDGET (f)) + return unbind_to (count, Qnil); + + 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 (x_gtk_use_system_tooltips) + { + bool ok; + + /* Hide a previous tip, if any. */ + Fx_hide_tip (); + + block_input (); + + ok = true; + xg_show_tooltip (f, string); + tip_last_frame = frame; + + unblock_input (); + if (ok) goto start_timer; + } + + if (FRAMEP (tip_frame) && FRAME_LIVE_P (XFRAME (tip_frame))) + { + if (FRAME_VISIBLE_P (XFRAME (tip_frame)) + && EQ (frame, tip_last_frame) + && !NILP (Fequal_including_properties (tip_last_string, string)) + && !NILP (Fequal (tip_last_parms, parms))) + { + /* Only DX and DY have changed. */ + tip_f = XFRAME (tip_frame); + if (!NILP (tip_timer)) + { + call1 (Qcancel_timer, tip_timer); + tip_timer = Qnil; + } + + block_input (); + compute_tip_xy (tip_f, parms, dx, dy, FRAME_PIXEL_WIDTH (tip_f), + FRAME_PIXEL_HEIGHT (tip_f), &root_x, &root_y); + gtk_window_move (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (tip_f)), root_x, root_y); + 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 every parameter in what is left of + tip_last_parms with a non-nil value has an association in + PARMS. */ + 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; + } + } + + x_hide_tip (delete); + } + else + x_hide_tip (true); + } + else + x_hide_tip (true); + + tip_last_frame = frame; + tip_last_string = string; + tip_last_parms = parms; + + if (!FRAMEP (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 = x_create_tip_frame (FRAME_DISPLAY_INFO (f), parms, f))) + /* Creating the tip frame failed. */ + 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; + + /* 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) = w->total_cols; + adjust_frame_glyphs (tip_f); + + /* Insert STRING into 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, + 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); + + /* Show tooltip frame. */ + block_input (); + gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (tip_f)), width, height); + gtk_window_move (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (tip_f)), root_x, root_y); + gtk_widget_show_all (FRAME_GTK_OUTER_WIDGET (tip_f)); + SET_FRAME_VISIBLE (tip_f, 1); + gdk_window_set_cursor (gtk_widget_get_window (FRAME_GTK_OUTER_WIDGET (tip_f)), + f->output_data.pgtk->current_cursor); + + unblock_input (); + + pgtk_cr_update_surface_desired_size (tip_f, width, height, false); + + w->must_be_updated_p = true; + update_single_window (w); + flush_frame (tip_f); + set_buffer_internal_1 (old_buffer); + unbind_to (count_1, Qnil); + 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: /* Hide the current tooltip window, if there is any. +Value is t if tooltip was open, nil otherwise. */) + (void) +{ + return x_hide_tip (!tooltip_reuse_hidden_frame); +} + +/* 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); + Lisp_Object fullscreen_symbol = Fframe_parameter (frame, Qfullscreen); + bool fullscreen = (EQ (fullscreen_symbol, Qfullboth) + || EQ (fullscreen_symbol, Qfullscreen)); + int border = fullscreen ? 0 : f->border_width; + int title_height = 0; + int native_width = FRAME_PIXEL_WIDTH (f); + int native_height = FRAME_PIXEL_HEIGHT (f); + int outer_width = native_width + 2 * border; + int outer_height = native_height + 2 * border + title_height; + + /* Get these here because they can't be got in configure_event(). */ + int left_pos, top_pos; + + if (FRAME_GTK_OUTER_WIDGET (f)) + { + gtk_window_get_position (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), + &left_pos, &top_pos); + } + else + { + GtkAllocation alloc; + + if (FRAME_GTK_WIDGET (f) == NULL) + return Qnil; /* This can occur while creating a frame. */ + + gtk_widget_get_allocation (FRAME_GTK_WIDGET (f), &alloc); + left_pos = alloc.x; + top_pos = alloc.y; + } + + int native_left = left_pos + border; + int native_top = top_pos + border + title_height; + int native_right = left_pos + outer_width - border; + int native_bottom = top_pos + outer_height - border; + int internal_border_width = FRAME_INTERNAL_BORDER_WIDTH (f); + int tab_bar_height = 0, tab_bar_width = 0; + int tool_bar_height = FRAME_TOOLBAR_HEIGHT (f); + int tool_bar_width = (tool_bar_height + ? outer_width - 2 * internal_border_width : 0); + + tab_bar_height = FRAME_TAB_BAR_HEIGHT (f); + tab_bar_width = (tab_bar_height + ? native_width - 2 * internal_border_width : 0); + /* inner_top += tab_bar_height; */ + + /* Construct list. */ + if (EQ (attribute, Qouter_edges)) + return list4 (make_fixnum (left_pos), make_fixnum (top_pos), + make_fixnum (left_pos + outer_width), + make_fixnum (top_pos + outer_height)); + else if (EQ (attribute, Qnative_edges)) + return list4 (make_fixnum (native_left), make_fixnum (native_top), + make_fixnum (native_right), make_fixnum (native_bottom)); + else if (EQ (attribute, Qinner_edges)) + return list4 (make_fixnum (native_left + internal_border_width), + make_fixnum (native_top + + tool_bar_height + + internal_border_width), + make_fixnum (native_right - internal_border_width), + make_fixnum (native_bottom - internal_border_width)); + else + return + list (Fcons (Qouter_position, + Fcons (make_fixnum (left_pos), + make_fixnum (top_pos))), + Fcons (Qouter_size, + Fcons (make_fixnum (outer_width), + make_fixnum (outer_height))), + Fcons (Qexternal_border_size, + (fullscreen + ? Fcons (make_fixnum (0), make_fixnum (0)) + : Fcons (make_fixnum (border), make_fixnum (border)))), + Fcons (Qtitle_bar_size, + Fcons (make_fixnum (0), make_fixnum (title_height))), + Fcons (Qmenu_bar_external, Qnil), + Fcons (Qmenu_bar_size, Fcons (make_fixnum (0), make_fixnum (0))), + Fcons (Qtab_bar_size, + Fcons (make_fixnum (tab_bar_width), + make_fixnum (tab_bar_height))), + Fcons (Qtool_bar_external, + FRAME_EXTERNAL_TOOL_BAR (f) ? Qt : Qnil), + Fcons (Qtool_bar_position, FRAME_TOOL_BAR_POSITION (f)), + Fcons (Qtool_bar_size, + Fcons (make_fixnum (tool_bar_width), + make_fixnum (tool_bar_height))), + Fcons (Qinternal_border_width, + make_fixnum (internal_border_width))); +} + +DEFUN ("pgtk-frame-geometry", Fpgtk_frame_geometry, Spgtk_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 ("pgtk-frame-edges", Fpgtk_frame_edges, Spgtk_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 ("pgtk-set-mouse-absolute-pixel-position", Fpgtk_set_mouse_absolute_pixel_position, Spgtk_set_mouse_absolute_pixel_position, 2, 2, 0, + doc: /* Move mouse pointer to absolute pixel position (X, Y). +The coordinates X and Y are interpreted in pixels relative to a position +\(0, 0) of the selected frame's display. */) + (Lisp_Object x, Lisp_Object y) +{ + struct frame *f = SELECTED_FRAME (); + GtkWidget *widget = gtk_widget_get_toplevel (FRAME_WIDGET (f)); + GdkWindow *window = gtk_widget_get_window (widget); + GdkDisplay *gdpy = gdk_window_get_display (window); + GdkScreen *gscr = gdk_window_get_screen (window); + GdkSeat *seat = gdk_display_get_default_seat (gdpy); + GdkDevice *device = gdk_seat_get_pointer (seat); + + gdk_device_warp (device, gscr, XFIXNUM (x), XFIXNUM (y)); /* No effect on wayland. */ + + return Qnil; +} + +DEFUN ("pgtk-mouse-absolute-pixel-position", Fpgtk_mouse_absolute_pixel_position, Spgtk_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 terminal. */) + (void) +{ + struct frame *f = SELECTED_FRAME (); + GtkWidget *widget = gtk_widget_get_toplevel (FRAME_WIDGET (f)); + GdkWindow *window = gtk_widget_get_window (widget); + GdkDisplay *gdpy = gdk_window_get_display (window); + GdkScreen *gscr; + GdkSeat *seat = gdk_display_get_default_seat (gdpy); + GdkDevice *device = gdk_seat_get_pointer (seat); + int x = 0, y = 0; + + gdk_device_get_position (device, &gscr, &x, &y); /* can't get on wayland? */ + + return Fcons (make_fixnum (x), make_fixnum (y)); +} + + +DEFUN ("pgtk-page-setup-dialog", Fpgtk_page_setup_dialog, Spgtk_page_setup_dialog, 0, 0, 0, + doc: /* Pop up a page setup dialog. +The current page setup can be obtained using `x-get-page-setup'. */) + (void) +{ + block_input (); + xg_page_setup_dialog (); + unblock_input (); + + return Qnil; +} + +DEFUN ("pgtk-get-page-setup", Fpgtk_get_page_setup, Spgtk_get_page_setup, 0, 0, 0, + doc: /* Return the value of the current page setup. +The return value is an alist containing the following keys: + +orientation: page orientation (symbol `portrait', `landscape', +`reverse-portrait', or `reverse-landscape'). +width, height: page width/height in points not including margins. +left-margin, right-margin, top-margin, bottom-margin: print margins, +which is the parts of the page that the printer cannot print +on, in points. + +The paper width can be obtained as the sum of width, left-margin, and +right-margin values if the page orientation is `portrait' or +`reverse-portrait'. Otherwise, it is the sum of width, top-margin, +and bottom-margin values. Likewise, the paper height is the sum of +height, top-margin, and bottom-margin values if the page orientation +is `portrait' or `reverse-portrait'. Otherwise, it is the sum of +height, left-margin, and right-margin values. */) + (void) +{ + Lisp_Object result; + + block_input (); + result = xg_get_page_setup (); + unblock_input (); + + return result; +} + +DEFUN ("pgtk-print-frames-dialog", Fpgtk_print_frames_dialog, Spgtk_print_frames_dialog, 0, 1, "", + doc: /* Pop up a print dialog to print the current contents of FRAMES. +FRAMES should be nil (the selected frame), a frame, or a list of +frames (each of which corresponds to one page). Each frame should be +visible. */) + (Lisp_Object frames) +{ + Lisp_Object rest, tmp; + int count; + + if (!CONSP (frames)) + frames = list1 (frames); + + tmp = Qnil; + for (rest = frames; CONSP (rest); rest = XCDR (rest)) + { + struct frame *f = decode_window_system_frame (XCAR (rest)); + Lisp_Object frame; + + XSETFRAME (frame, f); + if (!FRAME_VISIBLE_P (f)) + error ("Frames to be printed must be visible."); + tmp = Fcons (frame, tmp); + } + frames = Fnreverse (tmp); + + /* Make sure the current matrices are up-to-date. */ + count = SPECPDL_INDEX (); + specbind (Qredisplay_dont_pause, Qt); + redisplay_preserve_echo_area (32); + unbind_to (count, Qnil); + + block_input (); + xg_print_frames_dialog (frames); + unblock_input (); + + return Qnil; +} + +static void +clean_up_dialog (void) +{ + pgtk_menu_set_in_use (false); +} + +DEFUN ("x-file-dialog", Fx_file_dialog, Sx_file_dialog, 2, 5, 0, + doc: /* Read file name, prompting with PROMPT in directory DIR. +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 PGTK, NS, 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 +directory where the user selected a file, and will open that directory +instead of DIR on subsequent invocations of this function with the same +value of DIR as in previous invocations; this is standard MS Windows behavior. */) + (Lisp_Object prompt, Lisp_Object dir, Lisp_Object default_filename, + Lisp_Object mustmatch, Lisp_Object only_dir_p) +{ + struct frame *f = SELECTED_FRAME (); + char *fn; + Lisp_Object file = Qnil; + Lisp_Object decoded_file; + ptrdiff_t count = SPECPDL_INDEX (); + char *cdef_file; + + check_window_system (f); + + if (popup_activated ()) + error ("Trying to use a menu from within a menu-entry"); + else + pgtk_menu_set_in_use (true); + + CHECK_STRING (prompt); + CHECK_STRING (dir); + + /* Prevent redisplay. */ + specbind (Qinhibit_redisplay, Qt); + record_unwind_protect_void (clean_up_dialog); + + block_input (); + + if (STRINGP (default_filename)) + cdef_file = SSDATA (default_filename); + else + cdef_file = SSDATA (dir); + + fn = xg_get_file_name (f, SSDATA (prompt), cdef_file, + !NILP (mustmatch), !NILP (only_dir_p)); + + if (fn) + { + file = build_string (fn); + xfree (fn); + } + + unblock_input (); + + /* Make "Cancel" equivalent to C-g. */ + if (NILP (file)) + quit (); + + decoded_file = DECODE_FILE (file); + + return unbind_to (count, decoded_file); +} + +DEFUN ("pgtk-backend-display-class", Fpgtk_backend_display_class, Spgtk_backend_display_class, 0, 1, "", + doc: /* Return the name of the Gdk backend display class of TERMINAL. +The optional argument TERMINAL specifies which display to ask about. +TERMINAL should be a terminal object, a frame or a display name (a string). +If omitted or nil, that stands for the selected frame's display. */) + (Lisp_Object terminal) +{ + struct pgtk_display_info *dpyinfo = check_pgtk_display_info (terminal); + GdkDisplay *gdpy = dpyinfo->gdpy; + const gchar *type_name = G_OBJECT_TYPE_NAME (G_OBJECT (gdpy)); + return build_string (type_name); +} + +DEFUN ("x-select-font", Fx_select_font, Sx_select_font, 0, 2, 0, + doc: /* Read a font using a GTK dialog and return a font spec. + +FRAME is the frame on which to pop up the font chooser. If omitted or +nil, it defaults to the selected frame. */) + (Lisp_Object frame, Lisp_Object ignored) +{ + struct frame *f = decode_window_system_frame (frame); + Lisp_Object font; + Lisp_Object font_param; + char *default_name = NULL; + ptrdiff_t count = SPECPDL_INDEX (); + + if (popup_activated ()) + error ("Trying to use a menu from within a menu-entry"); + else + pgtk_menu_set_in_use (true); + + /* Prevent redisplay. */ + specbind (Qinhibit_redisplay, Qt); + record_unwind_protect_void (clean_up_dialog); + + block_input (); + + XSETFONT (font, FRAME_FONT (f)); + font_param = Ffont_get (font, QCname); + if (STRINGP (font_param)) + default_name = xlispstrdup (font_param); + else + { + font_param = Fframe_parameter (frame, Qfont_parameter); + if (STRINGP (font_param)) + default_name = xlispstrdup (font_param); + } + + font = xg_get_font (f, default_name); + xfree (default_name); + + unblock_input (); + + if (NILP (font)) + quit (); + + return unbind_to (count, font); +} + +/* ========================================================================== + + Lisp interface declaration + + ========================================================================== */ + +void +syms_of_pgtkfns (void) +{ + DEFSYM (Qfont_parameter, "font-parameter"); + DEFSYM (Qfontsize, "fontsize"); + DEFSYM (Qcancel_timer, "cancel-timer"); + DEFSYM (Qframe_title_format, "frame-title-format"); + DEFSYM (Qicon_title_format, "icon-title-format"); + DEFSYM (Qdark, "dark"); + DEFSYM (Qhide, "hide"); + DEFSYM (Qresize_mode, "resize-mode"); + + DEFVAR_LISP ("x-cursor-fore-pixel", Vx_cursor_fore_pixel, + doc: /* A string indicating the foreground color of the cursor box. */); + Vx_cursor_fore_pixel = Qnil; + + DEFVAR_LISP ("pgtk-icon-type-alist", Vpgtk_icon_type_alist, + doc: /* Alist of elements (REGEXP . IMAGE) for images of icons associated to frames. +If the title of a frame matches REGEXP, then IMAGE.tiff is +selected as the image of the icon representing the frame when it's +miniaturized. If an element is t, then Emacs tries to select an icon +based on the filetype of the visited file. + +The images have to be installed in a folder called English.lproj in the +Emacs folder. You have to restart Emacs after installing new icons. + +Example: Install an icon Gnus.tiff and execute the following code + +(setq pgtk-icon-type-alist +(append pgtk-icon-type-alist +\\='((\"^\\\\*\\\\(Group\\\\*$\\\\|Summary \\\\|Article\\\\*$\\\\)\" +. \"Gnus\")))) + +When you miniaturize a Group, Summary or Article frame, Gnus.tiff will +be used as the image of the icon representing the frame. */); + Vpgtk_icon_type_alist = list1 (Qt); + + + /* Provide x-toolkit also for GTK. Internally GTK does not use Xt so it + is not an X toolkit in that sense (USE_X_TOOLKIT is not defined). + But for a user it is a toolkit for X, and indeed, configure + accepts --with-x-toolkit=gtk. */ + Fprovide (intern_c_string ("x-toolkit"), Qnil); + Fprovide (intern_c_string ("gtk"), Qnil); + Fprovide (intern_c_string ("move-toolbar"), Qnil); + + DEFVAR_LISP ("gtk-version-string", Vgtk_version_string, + doc: /* Version info for GTK+. */); + { + char *ver = g_strdup_printf ("%d.%d.%d", + GTK_MAJOR_VERSION, GTK_MINOR_VERSION, + GTK_MICRO_VERSION); + int len = strlen (ver); + Vgtk_version_string = make_pure_string (ver, len, len, false); + g_free (ver); + } + + + Fprovide (intern_c_string ("cairo"), Qnil); + + DEFVAR_LISP ("cairo-version-string", Vcairo_version_string, + doc: /* Version info for cairo. */); + { + char *ver = g_strdup_printf ("%d.%d.%d", + CAIRO_VERSION_MAJOR, CAIRO_VERSION_MINOR, + CAIRO_VERSION_MICRO); + int len = strlen (ver); + Vcairo_version_string = make_pure_string (ver, len, len, false); + g_free (ver); + } + + + defsubr (&Spgtk_set_resource); + defsubr (&Sxw_display_color_p); /* this and next called directly by C code */ + defsubr (&Sx_display_grayscale_p); + defsubr (&Spgtk_font_name); + defsubr (&Sxw_color_defined_p); + defsubr (&Sxw_color_values); + defsubr (&Sx_server_max_request_size); + defsubr (&Sx_display_pixel_width); + defsubr (&Sx_display_pixel_height); + defsubr (&Spgtk_display_monitor_attributes_list); + defsubr (&Spgtk_frame_geometry); + defsubr (&Spgtk_frame_edges); + defsubr (&Spgtk_frame_restack); + defsubr (&Spgtk_set_mouse_absolute_pixel_position); + defsubr (&Spgtk_mouse_absolute_pixel_position); + defsubr (&Sx_display_mm_width); + defsubr (&Sx_display_mm_height); + defsubr (&Sx_display_screens); + defsubr (&Sx_display_planes); + defsubr (&Sx_display_color_cells); + defsubr (&Sx_display_visual_class); + defsubr (&Sx_display_backing_store); + defsubr (&Sx_display_save_under); + defsubr (&Sx_create_frame); + defsubr (&Sx_open_connection); + defsubr (&Sx_close_connection); + defsubr (&Sx_display_list); + + defsubr (&Spgtk_hide_others); + defsubr (&Spgtk_hide_emacs); + + defsubr (&Sx_show_tip); + defsubr (&Sx_hide_tip); + + defsubr (&Sx_export_frames); + defsubr (&Spgtk_page_setup_dialog); + defsubr (&Spgtk_get_page_setup); + defsubr (&Spgtk_print_frames_dialog); + defsubr (&Spgtk_backend_display_class); + + defsubr (&Spgtk_set_monitor_scale_factor); + + defsubr (&Sx_file_dialog); + defsubr (&Sx_select_font); + + as_status = 0; + as_script = Qnil; + as_result = 0; + + monitor_scale_factor_alist = Qnil; + staticpro (&monitor_scale_factor_alist); + + 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); + + /* This is not ifdef:ed, so other builds than GTK can customize it. */ + DEFVAR_BOOL ("x-gtk-use-old-file-dialog", x_gtk_use_old_file_dialog, + doc: /* Non-nil means prompt with the old GTK file selection dialog. +If nil or if the file selection dialog is not available, the new GTK file +chooser is used instead. To turn off all file dialogs set the +variable `use-file-dialog'. */); + x_gtk_use_old_file_dialog = false; + + DEFVAR_BOOL ("x-gtk-show-hidden-files", x_gtk_show_hidden_files, + doc: /* If non-nil, the GTK file chooser will by default show hidden files. +Note that this is just the default, there is a toggle button on the file +chooser to show or not show hidden files on a case by case basis. */); + x_gtk_show_hidden_files = false; + + DEFVAR_BOOL ("x-gtk-file-dialog-help-text", x_gtk_file_dialog_help_text, + doc: /* If non-nil, the GTK file chooser will show additional help text. +If more space for files in the file chooser dialog is wanted, set this to nil +to turn the additional text off. */); + x_gtk_file_dialog_help_text = true; + + DEFVAR_BOOL ("x-gtk-use-system-tooltips", x_gtk_use_system_tooltips, + doc: /* If non-nil with a Gtk+ built Emacs, the Gtk+ tooltip is used. +Otherwise use Emacs own tooltip implementation. +When using Gtk+ tooltips, the tooltip face is not used. */); + x_gtk_use_system_tooltips = true; + + DEFVAR_LISP ("x-max-tooltip-size", Vx_max_tooltip_size, + doc: /* Maximum size for tooltips. +Value is a pair (COLUMNS . ROWS). Text larger than this is clipped. */); + Vx_max_tooltip_size = Fcons (make_fixnum (80), make_fixnum (40)); + + DEFVAR_LISP ("x-gtk-resize-child-frames", x_gtk_resize_child_frames, + doc: /* If non-nil, resize child frames specially with GTK builds. +If this is nil, resize child frames like any other frames. This is the +default and usually works with most desktops. Some desktop environments +(GNOME shell in particular when using the mutter window manager), +however, may refuse to resize a child frame when Emacs is built with +GTK3. For those environments, the two settings below are provided. + +If this equals the symbol 'hide', Emacs temporarily hides the child +frame during resizing. This approach seems to work reliably, may +however induce some flicker when the frame is made visible again. + +If this equals the symbol 'resize-mode', Emacs uses GTK's resize mode to +always trigger an immediate resize of the child frame. This method is +deprecated by GTK and may not work in future versions of that toolkit. +It also may freeze Emacs when used with other desktop environments. It +avoids, however, the unpleasant flicker induced by the hiding approach. + +This variable is considered a temporary workaround and will be hopefully +eliminated in future versions of Emacs. */); + x_gtk_resize_child_frames = Qnil; + + + DEFSYM (Qmono, "mono"); + DEFSYM (Qassq_delete_all, "assq-delete-all"); + + DEFSYM (Qpdf, "pdf"); + + DEFSYM (Qorientation, "orientation"); + DEFSYM (Qtop_margin, "top-margin"); + DEFSYM (Qbottom_margin, "bottom-margin"); + DEFSYM (Qportrait, "portrait"); + DEFSYM (Qlandscape, "landscape"); + DEFSYM (Qreverse_portrait, "reverse-portrait"); + DEFSYM (Qreverse_landscape, "reverse-landscape"); +} + +#endif diff --git a/src/pgtkgui.h b/src/pgtkgui.h new file mode 100644 index 00000000000..9703fe6a02a --- /dev/null +++ b/src/pgtkgui.h @@ -0,0 +1,119 @@ +/* Definitions and headers for communication on the pure Gtk+3. + Copyright (C) 1995, 2005, 2008-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 <https://www.gnu.org/licenses/>. */ + +#ifndef __PGTKGUI_H__ +#define __PGTKGUI_H__ + +/* Emulate XCharStruct. */ +typedef struct _XCharStruct +{ + int rbearing; + int lbearing; + int width; + int ascent; + int descent; +} XCharStruct; + +/* Fake structure from Xlib.h to represent two-byte characters. */ +typedef unsigned short unichar; +typedef unichar XChar2b; + +#define STORE_XCHAR2B(chp, b1, b2) \ + (*(chp) = ((XChar2b)((((b1) & 0x00ff) << 8) | ((b2) & 0x00ff)))) + +#define XCHAR2B_BYTE1(chp) \ + ((*(chp) & 0xff00) >> 8) + +#define XCHAR2B_BYTE2(chp) \ + (*(chp) & 0x00ff) + + +typedef struct _GdkCursor *Emacs_Cursor; + +typedef void *Color; +typedef int Window; +typedef struct _GdkDisplay Display; + +/* Xism */ +typedef void *XrmDatabase; + + +/* Some sort of attempt to normalize rectangle handling.. seems a bit much + for what is accomplished. */ +typedef struct +{ + int x, y; + unsigned width, height; +} XRectangle; + +/* This stuff is needed by frame.c. */ +#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 */ + + +#define NativeRectangle XRectangle + +#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)) + +#endif /* __PGTKGUI_H__ */ diff --git a/src/pgtkim.c b/src/pgtkim.c new file mode 100644 index 00000000000..a38599c5a9c --- /dev/null +++ b/src/pgtkim.c @@ -0,0 +1,311 @@ +/* Pure Gtk+-3 communication module. + +Copyright (C) 1989, 1993-1994, 2005-2006, 2008-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 <https://www.gnu.org/licenses/>. */ + +/* This should be the first include, as it may set up #defines affecting + interpretation of even the system includes. */ +#include <config.h> + +#include "pgtkterm.h" + +static void +im_context_commit_cb (GtkIMContext * imc, gchar * str, gpointer user_data) +{ + struct pgtk_display_info *dpyinfo = user_data; + struct frame *f = dpyinfo->im.focused_frame; + + if (dpyinfo->im.context == NULL) + return; + if (f == NULL) + return; + + pgtk_enqueue_string (f, str); +} + +static gboolean +im_context_retrieve_surrounding_cb (GtkIMContext * imc, gpointer user_data) +{ + gtk_im_context_set_surrounding (imc, "", -1, 0); + return TRUE; +} + +static gboolean +im_context_delete_surrounding_cb (GtkIMContext * imc, int offset, int n_chars, + gpointer user_data) +{ + return TRUE; +} + +static Lisp_Object +make_color_string (PangoAttrColor * pac) +{ + char buf[256]; + sprintf (buf, "#%02x%02x%02x", + pac->color.red >> 8, pac->color.green >> 8, pac->color.blue >> 8); + return build_string (buf); +} + +static void +im_context_preedit_changed_cb (GtkIMContext * imc, gpointer user_data) +{ + struct pgtk_display_info *dpyinfo = user_data; + struct frame *f = dpyinfo->im.focused_frame; + char *str; + PangoAttrList *attrs; + int pos; + + if (dpyinfo->im.context == NULL) + return; + if (f == NULL) + return; + + gtk_im_context_get_preedit_string (imc, &str, &attrs, &pos); + + + /* + * ( + * (TEXT (ul . COLOR) (bg . COLOR) (fg . COLOR)) + * ... + * ) + */ + Lisp_Object list = Qnil; + + PangoAttrIterator *iter; + iter = pango_attr_list_get_iterator (attrs); + do + { + int st, ed; + int has_underline = 0; + Lisp_Object part = Qnil; + + pango_attr_iterator_range (iter, &st, &ed); + + if (ed > strlen (str)) + ed = strlen (str); + if (st >= ed) + continue; + + Lisp_Object text = make_string (str + st, ed - st); + part = Fcons (text, part); + + PangoAttrInt *ul = + (PangoAttrInt *) pango_attr_iterator_get (iter, PANGO_ATTR_UNDERLINE); + if (ul != NULL) + { + if (ul->value != PANGO_UNDERLINE_NONE) + has_underline = 1; + } + + PangoAttrColor *pac; + if (has_underline) + { + pac = + (PangoAttrColor *) pango_attr_iterator_get (iter, + PANGO_ATTR_UNDERLINE_COLOR); + if (pac != NULL) + part = Fcons (Fcons (Qul, make_color_string (pac)), part); + else + part = Fcons (Fcons (Qul, Qt), part); + } + + pac = + (PangoAttrColor *) pango_attr_iterator_get (iter, + PANGO_ATTR_FOREGROUND); + if (pac != NULL) + part = Fcons (Fcons (Qfg, make_color_string (pac)), part); + + pac = + (PangoAttrColor *) pango_attr_iterator_get (iter, + PANGO_ATTR_BACKGROUND); + if (pac != NULL) + part = Fcons (Fcons (Qbg, make_color_string (pac)), part); + + part = Fnreverse (part); + list = Fcons (part, list); + } + while (pango_attr_iterator_next (iter)); + + list = Fnreverse (list); + pgtk_enqueue_preedit (f, list); + + g_free (str); + pango_attr_list_unref (attrs); +} + +static void +im_context_preedit_end_cb (GtkIMContext * imc, gpointer user_data) +{ + struct pgtk_display_info *dpyinfo = user_data; + struct frame *f = dpyinfo->im.focused_frame; + + if (dpyinfo->im.context == NULL) + return; + if (f == NULL) + return; + + pgtk_enqueue_preedit (f, Qnil); +} + +static void +im_context_preedit_start_cb (GtkIMContext * imc, gpointer user_data) +{ +} + +void +pgtk_im_focus_in (struct frame *f) +{ + struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); + if (dpyinfo->im.context != NULL) + { + gtk_im_context_reset (dpyinfo->im.context); + gtk_im_context_set_client_window (dpyinfo->im.context, + gtk_widget_get_window + (FRAME_GTK_WIDGET (f))); + gtk_im_context_focus_in (dpyinfo->im.context); + } + dpyinfo->im.focused_frame = f; +} + +void +pgtk_im_focus_out (struct frame *f) +{ + struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); + if (dpyinfo->im.focused_frame == f) + { + if (dpyinfo->im.context != NULL) + { + gtk_im_context_reset (dpyinfo->im.context); + gtk_im_context_focus_out (dpyinfo->im.context); + gtk_im_context_set_client_window (dpyinfo->im.context, NULL); + } + dpyinfo->im.focused_frame = NULL; + } +} + +bool +pgtk_im_filter_keypress (struct frame *f, GdkEventKey * ev) +{ + struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); + if (dpyinfo->im.context != NULL) + { + if (gtk_im_context_filter_keypress (dpyinfo->im.context, ev)) + return true; + } + return false; +} + +void +pgtk_im_set_cursor_location (struct frame *f, int x, int y, int width, + int height) +{ + struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); + if (dpyinfo->im.context != NULL && dpyinfo->im.focused_frame == f) + { + GdkRectangle area = { x, y, width, height }; + gtk_im_context_set_cursor_location (dpyinfo->im.context, &area); + } +} + +static void +pgtk_im_use_context (struct pgtk_display_info *dpyinfo, bool use_p) +{ + if (!use_p) + { + if (dpyinfo->im.context != NULL) + { + gtk_im_context_reset (dpyinfo->im.context); + gtk_im_context_focus_out (dpyinfo->im.context); + gtk_im_context_set_client_window (dpyinfo->im.context, NULL); + + g_object_unref (dpyinfo->im.context); + dpyinfo->im.context = NULL; + } + } + else + { + if (dpyinfo->im.context == NULL) + { + dpyinfo->im.context = gtk_im_multicontext_new (); + g_signal_connect (dpyinfo->im.context, "commit", + G_CALLBACK (im_context_commit_cb), dpyinfo); + g_signal_connect (dpyinfo->im.context, "retrieve-surrounding", + G_CALLBACK (im_context_retrieve_surrounding_cb), + dpyinfo); + g_signal_connect (dpyinfo->im.context, "delete-surrounding", + G_CALLBACK (im_context_delete_surrounding_cb), + dpyinfo); + g_signal_connect (dpyinfo->im.context, "preedit-changed", + G_CALLBACK (im_context_preedit_changed_cb), + dpyinfo); + g_signal_connect (dpyinfo->im.context, "preedit-end", + G_CALLBACK (im_context_preedit_end_cb), dpyinfo); + g_signal_connect (dpyinfo->im.context, "preedit-start", + G_CALLBACK (im_context_preedit_start_cb), + dpyinfo); + gtk_im_context_set_use_preedit (dpyinfo->im.context, TRUE); + + if (dpyinfo->im.focused_frame) + pgtk_im_focus_in (dpyinfo->im.focused_frame); + } + } +} + +void +pgtk_im_init (struct pgtk_display_info *dpyinfo) +{ + dpyinfo->im.context = NULL; + + pgtk_im_use_context (dpyinfo, !NILP (Vpgtk_use_im_context_on_new_connection)); +} + +void +pgtk_im_finish (struct pgtk_display_info *dpyinfo) +{ + if (dpyinfo->im.context != NULL) + g_object_unref (dpyinfo->im.context); + dpyinfo->im.context = NULL; +} + +DEFUN ("pgtk-use-im-context", Fpgtk_use_im_context, Spgtk_use_im_context, 1, 2, 0, + doc: /* Set whether to use GtkIMContext. */) + (Lisp_Object use_p, Lisp_Object terminal) +{ + struct pgtk_display_info *dpyinfo = check_pgtk_display_info (terminal); + + pgtk_im_use_context (dpyinfo, !NILP (use_p)); + + return Qnil; +} + +void +syms_of_pgtkim (void) +{ + defsubr (&Spgtk_use_im_context); + + DEFSYM (Qpgtk_refresh_preedit, "pgtk-refresh-preedit"); + DEFSYM (Qul, "ul"); + DEFSYM (Qfg, "fg"); + DEFSYM (Qbg, "bg"); + + DEFVAR_LISP ("pgtk-use-im-context-on-new-connection", Vpgtk_use_im_context_on_new_connection, + doc: /* Whether to use GtkIMContext on a new connection. +If you want to change it after connection, use the `pgtk-use-im-context' +function. */ ); + Vpgtk_use_im_context_on_new_connection = Qt; +} diff --git a/src/pgtkmenu.c b/src/pgtkmenu.c new file mode 100644 index 00000000000..dbab2f9645b --- /dev/null +++ b/src/pgtkmenu.c @@ -0,0 +1,1159 @@ +/* Pure GTK3 menu and toolbar module. + Copyright (C) 2019-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 <https://www.gnu.org/licenses/>. */ + +/* + */ + + +/* This should be the first include, as it may set up #defines affecting + interpretation of even the system includes. */ +#include <config.h> + +#include "lisp.h" +#include "frame.h" +#include "window.h" +#include "character.h" +#include "buffer.h" +#include "keymap.h" +#include "coding.h" +#include "commands.h" +#include "blockinput.h" +#include "termhooks.h" +#include "keyboard.h" +#include "menu.h" +#include "pdumper.h" +#include "xgselect.h" + +#include "gtkutil.h" +#include <gtk/gtk.h> + +/* Flag which when set indicates a dialog or menu has been posted by + Xt on behalf of one of the widget sets. */ +static int popup_activated_flag; + +/* Set menu_items_inuse so no other popup menu or dialog is created. */ + +void +pgtk_menu_set_in_use (bool in_use) +{ + Lisp_Object frames, frame; + + menu_items_inuse = in_use; + popup_activated_flag = in_use; + + /* Don't let frames in `above' z-group obscure popups. */ + FOR_EACH_FRAME (frames, frame) + { + struct frame *f = XFRAME (frame); + + if (in_use && FRAME_Z_GROUP_ABOVE (f)) + x_set_z_group (f, Qabove_suspended, Qabove); + else if (!in_use && FRAME_Z_GROUP_ABOVE_SUSPENDED (f)) + x_set_z_group (f, Qabove, Qabove_suspended); + } +} + +DEFUN ("x-menu-bar-open-internal", Fx_menu_bar_open_internal, Sx_menu_bar_open_internal, 0, 1, "i", + doc: /* Start key navigation of the menu bar in FRAME. + This initially opens the first menu bar item and you can then navigate with the + arrow keys, select a menu entry with the return key or cancel with the + escape key. If FRAME has no menu bar this function does nothing. + + If FRAME is nil or not given, use the selected frame. */) + (Lisp_Object frame) +{ + GtkWidget *menubar; + struct frame *f; + + block_input (); + f = decode_window_system_frame (frame); + + if (FRAME_EXTERNAL_MENU_BAR (f)) + set_frame_menubar (f, true); + + menubar = FRAME_X_OUTPUT (f)->menubar_widget; + if (menubar) + { + /* Activate the first menu. */ + GList *children = gtk_container_get_children (GTK_CONTAINER (menubar)); + + if (children) + { + g_signal_emit_by_name (children->data, "activate_item"); + g_list_free (children); + } + } + unblock_input (); + + return Qnil; +} + +/* Loop util popup_activated_flag is set to zero in a callback. + Used for popup menus and dialogs. */ + +static void +popup_widget_loop (bool do_timers, GtkWidget *widget) +{ + ++popup_activated_flag; + + /* Process events in the Gtk event loop until done. */ + while (popup_activated_flag) + gtk_main_iteration (); +} + +void +pgtk_activate_menubar (struct frame *f) +{ + set_frame_menubar (f, true); + + popup_activated_flag = 1; + + /* f->output_data.pgtk->menubar_active = 1; */ +} + +/* This callback is invoked when a dialog or menu is finished being + used and has been unposted. */ + +static void +popup_deactivate_callback (GtkWidget *widget, gpointer client_data) +{ + popup_activated_flag = 0; +} + +/* Function that finds the frame for WIDGET and shows the HELP text + for that widget. + F is the frame if known, or NULL if not known. */ +static void +show_help_event (struct frame *f, GtkWidget *widget, Lisp_Object help) +{ + /* Don't show this tooltip. + * Tooltips are always tied to main widget, so stacking order + * on Wayland is: + * (above) + * - menu + * - tooltip + * - main widget + * (below) + * This is applicable to tooltips for menu, and menu tooltips + * are shown below menus. + * As a workaround, I entrust Gtk with menu tooltips, and + * let emacs not to show menu tooltips. + */ + +#if 0 + Lisp_Object frame; + + if (f) + { + XSETFRAME (frame, f); + kbd_buffer_store_help_event (frame, help); + } + else + show_help_echo (help, Qnil, Qnil, Qnil); +#endif +} + +/* Callback called when menu items are highlighted/unhighlighted + while moving the mouse over them. WIDGET is the menu bar or menu + popup widget. ID is its LWLIB_ID. CALL_DATA contains a pointer to + the data structure for the menu item, or null in case of + unhighlighting. */ + +static void +menu_highlight_callback (GtkWidget *widget, gpointer call_data) +{ + xg_menu_item_cb_data *cb_data; + Lisp_Object help; + + cb_data = g_object_get_data (G_OBJECT (widget), XG_ITEM_DATA); + if (!cb_data) + return; + + help = call_data ? cb_data->help : Qnil; + + /* If popup_activated_flag is greater than 1 we are in a popup menu. + Don't pass the frame to show_help_event for those. + Passing frame creates an Emacs event. As we are looping in + popup_widget_loop, it won't be handled. Passing NULL shows the tip + directly without using an Emacs event. This is what the Lucid code + does below. */ + show_help_event (popup_activated_flag <= 1 ? cb_data->cl_data->f : NULL, + widget, help); +} + +/* Gtk calls callbacks just because we tell it what item should be + selected in a radio group. If this variable is set to a non-zero + value, we are creating menus and don't want callbacks right now. +*/ +static bool xg_crazy_callback_abort; + +/* This callback is called from the menu bar pulldown menu + when the user makes a selection. + Figure out what the user chose + and put the appropriate events into the keyboard buffer. */ +static void +menubar_selection_callback (GtkWidget *widget, gpointer client_data) +{ + xg_menu_item_cb_data *cb_data = client_data; + + if (xg_crazy_callback_abort) + return; + + if (!cb_data || !cb_data->cl_data || !cb_data->cl_data->f) + return; + + /* For a group of radio buttons, GTK calls the selection callback first + for the item that was active before the selection and then for the one that + is active after the selection. For C-h k this means we get the help on + the deselected item and then the selected item is executed. Prevent that + by ignoring the non-active item. */ + if (GTK_IS_RADIO_MENU_ITEM (widget) + && !gtk_check_menu_item_get_active (GTK_CHECK_MENU_ITEM (widget))) + return; + + /* When a menu is popped down, X generates a focus event (i.e. focus + goes back to the frame below the menu). Since GTK buffers events, + we force it out here before the menu selection event. Otherwise + sit-for will exit at once if the focus event follows the menu selection + event. */ + + block_input (); + while (gtk_events_pending ()) + gtk_main_iteration (); + unblock_input (); + + find_and_call_menu_selection (cb_data->cl_data->f, + cb_data->cl_data->menu_bar_items_used, + cb_data->cl_data->menu_bar_vector, + cb_data->call_data); +} + +/* Recompute all the widgets of frame F, when the menu bar has been + changed. */ + +static void +update_frame_menubar (struct frame *f) +{ + xg_update_frame_menubar (f); +} + +/* Set the contents of the menubar widgets of frame F. + The argument FIRST_TIME is currently ignored; + it is set the first time this is called, from initialize_frame_menubar. */ + +void +set_frame_menubar (struct frame *f, bool deep_p) +{ + GtkWidget *menubar_widget; + Lisp_Object items; + widget_value *wv, *first_wv, *prev_wv = 0; + int i; + int *submenu_start, *submenu_end; + bool *submenu_top_level_items; + int *submenu_n_panes; + + + menubar_widget = f->output_data.pgtk->menubar_widget; + + XSETFRAME (Vmenu_updating_frame, f); + + if (!menubar_widget) + deep_p = true; + + if (deep_p) + { + 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); + int subitems; + + /* If we are making a new widget, its contents are empty, + do always reinitialize them. */ + if (!menubar_widget) + 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; + subitems = ASIZE (items) / 4; + 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_top_level_items = alloca (subitems + * sizeof *submenu_top_level_items); + init_menu_items (); + for (i = 0; i < subitems; i++) + { + Lisp_Object key, string, maps; + + key = AREF (items, 4 * i); + string = AREF (items, 4 * i + 1); + maps = AREF (items, 4 * i + 2); + if (NILP (string)) + break; + + submenu_start[i] = menu_items_used; + + menu_items_n_panes = 0; + submenu_top_level_items[i] + = parse_single_submenu (key, string, maps); + submenu_n_panes[i] = menu_items_n_panes; + + submenu_end[i] = menu_items_used; + } + + submenu_start[i] = -1; + finish_menu_items (); + + /* Convert menu_items into widget_value trees + to display the menu. This cannot evaluate Lisp code. */ + + wv = make_widget_value ("menubar", NULL, true, Qnil); + wv->button_type = BUTTON_TYPE_NONE; + first_wv = wv; + + for (i = 0; submenu_start[i] >= 0; i++) + { + menu_items_n_panes = submenu_n_panes[i]; + wv = digest_single_submenu (submenu_start[i], submenu_end[i], + submenu_top_level_items[i]); + if (prev_wv) + prev_wv->next = wv; + else + first_wv->contents = wv; + /* Don't set wv->name here; GC during the loop might relocate it. */ + wv->enabled = true; + wv->button_type = BUTTON_TYPE_NONE; + prev_wv = wv; + } + + set_buffer_internal_1 (prev); + + /* If there has been no change in the Lisp-level contents + of the menu bar, skip redisplaying it. Just exit. */ + + /* Compare the new menu items with the ones computed last time. */ + for (i = 0; i < previous_menu_items_used; i++) + if (menu_items_used == i + || (!EQ (previous_items[i], AREF (menu_items, i)))) + break; + if (i == menu_items_used && i == previous_menu_items_used && i != 0) + { + /* The menu items have not changed. Don't bother updating + the menus in any form, since it would be a no-op. */ + free_menubar_widget_value_tree (first_wv); + discard_menu_items (); + unbind_to (specpdl_count, Qnil); + return; + } + + /* The menu items are different, so store them in the frame. */ + fset_menu_bar_vector (f, menu_items); + f->menu_bar_items_used = menu_items_used; + + /* This undoes save_menu_items. */ + unbind_to (specpdl_count, Qnil); + + /* Now GC cannot happen during the lifetime of the widget_value, + so it's safe to store data from a Lisp_String. */ + wv = first_wv->contents; + for (i = 0; i < ASIZE (items); i += 4) + { + Lisp_Object string; + string = AREF (items, i + 1); + if (NILP (string)) + break; + wv->name = SSDATA (string); + update_submenu_strings (wv->contents); + wv = wv->next; + } + + } + else + { + /* Make a widget-value tree containing + just the top level menu bar strings. */ + + wv = make_widget_value ("menubar", NULL, true, Qnil); + wv->button_type = BUTTON_TYPE_NONE; + first_wv = wv; + + items = FRAME_MENU_BAR_ITEMS (f); + for (i = 0; i < ASIZE (items); i += 4) + { + Lisp_Object string; + + string = AREF (items, i + 1); + if (NILP (string)) + break; + + wv = make_widget_value (SSDATA (string), NULL, true, Qnil); + wv->button_type = BUTTON_TYPE_NONE; + /* This prevents lwlib from assuming this + menu item is really supposed to be empty. */ + /* The intptr_t cast avoids a warning. + This value just has to be different from small integers. */ + wv->call_data = (void *) (intptr_t) (-1); + + if (prev_wv) + prev_wv->next = wv; + else + first_wv->contents = wv; + prev_wv = wv; + } + + /* Forget what we thought we knew about what is in the + detailed contents of the menu bar menus. + Changing the top level always destroys the contents. */ + f->menu_bar_items_used = 0; + } + + block_input (); + + xg_crazy_callback_abort = true; + if (menubar_widget) + { + /* The fourth arg is DEEP_P, which says to consider the entire + menu trees we supply, rather than just the menu bar item names. */ + xg_modify_menubar_widgets (menubar_widget, + f, + first_wv, + deep_p, + G_CALLBACK (menubar_selection_callback), + G_CALLBACK (popup_deactivate_callback), + G_CALLBACK (menu_highlight_callback)); + } + else + { + menubar_widget + = xg_create_widget ("menubar", "menubar", f, first_wv, + G_CALLBACK (menubar_selection_callback), + G_CALLBACK (popup_deactivate_callback), + G_CALLBACK (menu_highlight_callback)); + + f->output_data.pgtk->menubar_widget = menubar_widget; + } + + free_menubar_widget_value_tree (first_wv); + update_frame_menubar (f); + + xg_crazy_callback_abort = false; + + unblock_input (); +} + +/* Called from Fx_create_frame to create the initial menubar of a frame + before it is mapped, so that the window is mapped with the menubar already + there instead of us tacking it on later and thrashing the window after it + is visible. */ + +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); +} + + +/* x_menu_show actually displays a menu using the panes and items in menu_items + and returns the value selected from it. + There are two versions of x_menu_show, one for Xt and one for Xlib. + Both assume input is blocked by the caller. */ + +/* F is the frame the menu is for. + X and Y are the frame-relative specified position, + relative to the inside upper left corner of the frame F. + Bitfield MENUFLAGS bits are: + MENU_FOR_CLICK is set if this menu was invoked for a mouse click. + MENU_KEYMAPS is set if this menu was specified with keymaps; + in that case, we return a list containing the chosen item's value + and perhaps also the pane's prefix. + TITLE is the specified menu title. + ERROR is a place to store an error message string in case of failure. + (We return nil on failure, but the value doesn't actually matter.) */ + +/* The item selected in the popup menu. */ +static Lisp_Object *volatile menu_item_selection; + +static void +popup_selection_callback (GtkWidget *widget, gpointer client_data) +{ + xg_menu_item_cb_data *cb_data = client_data; + + if (xg_crazy_callback_abort) + return; + if (cb_data) + menu_item_selection = cb_data->call_data; +} + +static void +pop_down_menu (void *arg) +{ + popup_activated_flag = 0; + block_input (); + gtk_widget_destroy (GTK_WIDGET (arg)); + unblock_input (); +} + +/* Pop up the menu for frame F defined by FIRST_WV at X/Y and loop until the + menu pops down. + menu_item_selection will be set to the selection. */ +static void +create_and_show_popup_menu (struct frame *f, widget_value * first_wv, + int x, int y, bool for_click) +{ + GtkWidget *menu; + ptrdiff_t specpdl_count = SPECPDL_INDEX (); + + eassert (FRAME_PGTK_P (f)); + + xg_crazy_callback_abort = true; + menu = xg_create_widget ("popup", first_wv->name, f, first_wv, + G_CALLBACK (popup_selection_callback), + G_CALLBACK (popup_deactivate_callback), + G_CALLBACK (menu_highlight_callback)); + xg_crazy_callback_abort = false; + + /* Display the menu. */ + gtk_widget_show_all (menu); + + if (for_click) + gtk_menu_popup_at_pointer (GTK_MENU (menu), + FRAME_DISPLAY_INFO (f)->last_click_event); + else + { + GdkRectangle rect; + rect.x = x; + rect.y = y; + rect.width = 1; + rect.height = 1; + gtk_menu_popup_at_rect (GTK_MENU (menu), + gtk_widget_get_window (FRAME_GTK_WIDGET (f)), + &rect, + GDK_GRAVITY_NORTH_WEST, GDK_GRAVITY_NORTH_WEST, + FRAME_DISPLAY_INFO (f)->last_click_event); + } + + record_unwind_protect_ptr (pop_down_menu, menu); + + if (gtk_widget_get_mapped (menu)) + { + /* Set this to one. popup_widget_loop increases it by one, so it becomes + two. show_help_echo uses this to detect popup menus. */ + popup_activated_flag = 1; + /* Process events that apply to the menu. */ + popup_widget_loop (true, menu); + } + + unbind_to (specpdl_count, Qnil); + + /* Must reset this manually because the button release event is not passed + to Emacs event loop. */ + FRAME_DISPLAY_INFO (f)->grabbed = 0; +} + +static void +cleanup_widget_value_tree (void *arg) +{ + free_menubar_widget_value_tree (arg); +} + +Lisp_Object +pgtk_menu_show (struct frame *f, int x, int y, int menuflags, + Lisp_Object title, const char **error_name) +{ + int i; + widget_value *wv, *save_wv = 0, *first_wv = 0, *prev_wv = 0; + widget_value **submenu_stack + = alloca (menu_items_used * sizeof *submenu_stack); + Lisp_Object *subprefix_stack + = alloca (menu_items_used * sizeof *subprefix_stack); + int submenu_depth = 0; + + ptrdiff_t specpdl_count = SPECPDL_INDEX (); + + eassert (FRAME_PGTK_P (f)); + + *error_name = NULL; + + if (!FRAME_GTK_OUTER_WIDGET (f)) { + *error_name = "Can't popup from child frames."; + return Qnil; + } + + if (menu_items_used <= MENU_ITEMS_PANE_LENGTH) + { + *error_name = "Empty menu"; + return Qnil; + } + + block_input (); + + /* Create a tree of widget_value objects + representing the panes and their items. */ + wv = make_widget_value ("menu", NULL, true, Qnil); + wv->button_type = BUTTON_TYPE_NONE; + first_wv = wv; + bool first_pane = true; + + /* Loop over all panes and items, filling in the tree. */ + i = 0; + while (i < menu_items_used) + { + if (NILP (AREF (menu_items, i))) + { + submenu_stack[submenu_depth++] = save_wv; + save_wv = prev_wv; + prev_wv = 0; + first_pane = true; + i++; + } + else if (EQ (AREF (menu_items, i), Qlambda)) + { + prev_wv = save_wv; + save_wv = submenu_stack[--submenu_depth]; + first_pane = false; + i++; + } + else if (EQ (AREF (menu_items, i), Qt) && submenu_depth != 0) + 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 if (EQ (AREF (menu_items, i), Qt)) + { + /* Create a new pane. */ + Lisp_Object pane_name, prefix; + const char *pane_string; + + pane_name = AREF (menu_items, i + MENU_ITEMS_PANE_NAME); + prefix = AREF (menu_items, i + MENU_ITEMS_PANE_PREFIX); + +#ifndef HAVE_MULTILINGUAL_MENU + if (STRINGP (pane_name) && STRING_MULTIBYTE (pane_name)) + { + pane_name = ENCODE_MENU_STRING (pane_name); + ASET (menu_items, i + MENU_ITEMS_PANE_NAME, pane_name); + } +#endif + pane_string = (NILP (pane_name) ? "" : SSDATA (pane_name)); + /* If there is just one top-level pane, put all its items directly + under the top-level menu. */ + if (menu_items_n_panes == 1) + pane_string = ""; + + /* If the pane has a meaningful name, + make the pane a top-level menu item + with its items as a submenu beneath it. */ + if (!(menuflags & MENU_KEYMAPS) && strcmp (pane_string, "")) + { + wv = make_widget_value (pane_string, NULL, true, Qnil); + if (save_wv) + save_wv->next = wv; + else + first_wv->contents = wv; + if ((menuflags & MENU_KEYMAPS) && !NILP (prefix)) + wv->name++; + wv->button_type = BUTTON_TYPE_NONE; + save_wv = wv; + prev_wv = 0; + } + else if (first_pane) + { + save_wv = wv; + prev_wv = 0; + } + first_pane = false; + i += MENU_ITEMS_PANE_LENGTH; + } + else + { + /* Create a new item within current pane. */ + Lisp_Object item_name, enable, descrip, def, type, 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); + type = AREF (menu_items, i + MENU_ITEMS_ITEM_TYPE); + selected = AREF (menu_items, i + MENU_ITEMS_ITEM_SELECTED); + help = AREF (menu_items, i + MENU_ITEMS_ITEM_HELP); + +#ifndef HAVE_MULTILINGUAL_MENU + if (STRINGP (item_name) && STRING_MULTIBYTE (item_name)) + { + item_name = ENCODE_MENU_STRING (item_name); + ASET (menu_items, i + MENU_ITEMS_ITEM_NAME, item_name); + } + + if (STRINGP (descrip) && STRING_MULTIBYTE (descrip)) + { + descrip = ENCODE_MENU_STRING (descrip); + ASET (menu_items, i + MENU_ITEMS_ITEM_EQUIV_KEY, descrip); + } +#endif /* not HAVE_MULTILINGUAL_MENU */ + + wv = make_widget_value (SSDATA (item_name), NULL, !NILP (enable), + STRINGP (help) ? help : Qnil); + if (prev_wv) + prev_wv->next = wv; + else + save_wv->contents = wv; + if (!NILP (descrip)) + wv->key = SSDATA (descrip); + /* If this item has a null value, + make the call_data null so that it won't display a box + when the mouse is on it. */ + wv->call_data = !NILP (def) ? aref_addr (menu_items, i) : 0; + + if (NILP (type)) + wv->button_type = BUTTON_TYPE_NONE; + else if (EQ (type, QCtoggle)) + wv->button_type = BUTTON_TYPE_TOGGLE; + else if (EQ (type, QCradio)) + wv->button_type = BUTTON_TYPE_RADIO; + else + emacs_abort (); + + wv->selected = !NILP (selected); + + prev_wv = wv; + + i += MENU_ITEMS_ITEM_LENGTH; + } + } + + /* Deal with the title, if it is non-nil. */ + if (!NILP (title)) + { + widget_value *wv_title; + widget_value *wv_sep1 = make_widget_value ("--", NULL, false, Qnil); + widget_value *wv_sep2 = make_widget_value ("--", NULL, false, Qnil); + + wv_sep2->next = first_wv->contents; + wv_sep1->next = wv_sep2; + +#ifndef HAVE_MULTILINGUAL_MENU + if (STRING_MULTIBYTE (title)) + title = ENCODE_MENU_STRING (title); +#endif + + wv_title = make_widget_value (SSDATA (title), NULL, true, Qnil); + wv_title->button_type = BUTTON_TYPE_NONE; + wv_title->next = wv_sep1; + first_wv->contents = wv_title; + } + + /* No selection has been chosen yet. */ + menu_item_selection = 0; + + /* Make sure to free the widget_value objects we used to specify the + contents even with longjmp. */ + record_unwind_protect_ptr (cleanup_widget_value_tree, first_wv); + + /* Actually create and show the menu until popped down. */ + create_and_show_popup_menu (f, first_wv, x, y, menuflags & MENU_FOR_CLICK); + + unbind_to (specpdl_count, Qnil); + + /* Find the selected item, and its pane, to return + the proper value. */ + if (menu_item_selection != 0) + { + 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); + } + unblock_input (); + return entry; + } + i += MENU_ITEMS_ITEM_LENGTH; + } + } + } + else if (!(menuflags & MENU_FOR_CLICK)) + { + unblock_input (); + /* Make "Cancel" equivalent to C-g. */ + quit (); + } + + unblock_input (); + return Qnil; +} + +static void +dialog_selection_callback (GtkWidget *widget, gpointer client_data) +{ + /* Treat the pointer as an integer. There's no problem + as long as pointers have enough bits to hold small integers. */ + if ((intptr_t) client_data != -1) + menu_item_selection = client_data; + + popup_activated_flag = 0; +} + +/* Pop up the dialog for frame F defined by FIRST_WV and loop until the + dialog pops down. + menu_item_selection will be set to the selection. */ +static void +create_and_show_dialog (struct frame *f, widget_value *first_wv) +{ + GtkWidget *menu; + + eassert (FRAME_PGTK_P (f)); + + menu = xg_create_widget ("dialog", first_wv->name, f, first_wv, + G_CALLBACK (dialog_selection_callback), + G_CALLBACK (popup_deactivate_callback), 0); + + if (menu) + { + ptrdiff_t specpdl_count = SPECPDL_INDEX (); + record_unwind_protect_ptr (pop_down_menu, menu); + + /* Display the menu. */ + gtk_widget_show_all (menu); + + /* Process events that apply to the menu. */ + popup_widget_loop (true, menu); + + unbind_to (specpdl_count, Qnil); + } +} + +static const char *button_names[] = { + "button1", "button2", "button3", "button4", "button5", + "button6", "button7", "button8", "button9", "button10" +}; + +Lisp_Object +pgtk_dialog_show (struct frame *f, Lisp_Object title, + Lisp_Object header, const char **error_name) +{ + int i, nb_buttons = 0; + char dialog_name[6]; + + widget_value *wv, *first_wv = 0, *prev_wv = 0; + + /* Number of elements seen so far, before boundary. */ + int left_count = 0; + /* Whether we've seen the boundary between left-hand elts and right-hand. */ + bool boundary_seen = false; + + ptrdiff_t specpdl_count = SPECPDL_INDEX (); + + eassert (FRAME_PGTK_P (f)); + + *error_name = NULL; + + if (!FRAME_GTK_OUTER_WIDGET (f)) { + *error_name = "Can't popup from child frames."; + return Qnil; + } + + if (menu_items_n_panes > 1) + { + *error_name = "Multiple panes in dialog box"; + return Qnil; + } + + /* Create a tree of widget_value objects + representing the text label and buttons. */ + { + Lisp_Object pane_name; + const char *pane_string; + pane_name = AREF (menu_items, MENU_ITEMS_PANE_NAME); + pane_string = (NILP (pane_name) ? "" : SSDATA (pane_name)); + prev_wv = make_widget_value ("message", (char *) pane_string, true, Qnil); + first_wv = prev_wv; + + /* Loop over all panes and items, filling in the tree. */ + i = MENU_ITEMS_PANE_LENGTH; + while (i < menu_items_used) + { + + /* Create a new item within current pane. */ + Lisp_Object item_name, enable, descrip; + 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); + + if (NILP (item_name)) + { + free_menubar_widget_value_tree (first_wv); + *error_name = "Submenu in dialog items"; + return Qnil; + } + if (EQ (item_name, Qquote)) + { + /* This is the boundary between left-side elts + and right-side elts. Stop incrementing right_count. */ + boundary_seen = true; + i++; + continue; + } + if (nb_buttons >= 9) + { + free_menubar_widget_value_tree (first_wv); + *error_name = "Too many dialog items"; + return Qnil; + } + + wv = make_widget_value (button_names[nb_buttons], + SSDATA (item_name), !NILP (enable), Qnil); + prev_wv->next = wv; + if (!NILP (descrip)) + wv->key = SSDATA (descrip); + wv->call_data = aref_addr (menu_items, i); + prev_wv = wv; + + if (!boundary_seen) + left_count++; + + nb_buttons++; + i += MENU_ITEMS_ITEM_LENGTH; + } + + /* If the boundary was not specified, + by default put half on the left and half on the right. */ + if (!boundary_seen) + left_count = nb_buttons - nb_buttons / 2; + + wv = make_widget_value (dialog_name, NULL, false, Qnil); + + /* Frame title: 'Q' = Question, 'I' = Information. + Can also have 'E' = Error if, one day, we want + a popup for errors. */ + if (NILP (header)) + dialog_name[0] = 'Q'; + else + dialog_name[0] = 'I'; + + /* Dialog boxes use a really stupid name encoding + which specifies how many buttons to use + and how many buttons are on the right. */ + dialog_name[1] = '0' + nb_buttons; + dialog_name[2] = 'B'; + dialog_name[3] = 'R'; + /* Number of buttons to put on the right. */ + dialog_name[4] = '0' + nb_buttons - left_count; + dialog_name[5] = 0; + wv->contents = first_wv; + first_wv = wv; + } + + /* No selection has been chosen yet. */ + menu_item_selection = 0; + + /* Make sure to free the widget_value objects we used to specify the + contents even with longjmp. */ + record_unwind_protect_ptr (cleanup_widget_value_tree, first_wv); + + /* Actually create and show the dialog. */ + create_and_show_dialog (f, first_wv); + + unbind_to (specpdl_count, Qnil); + + /* Find the selected item, and its pane, to return + the proper value. */ + if (menu_item_selection != 0) + { + i = 0; + while (i < menu_items_used) + { + Lisp_Object entry; + + if (EQ (AREF (menu_items, i), Qt)) + i += MENU_ITEMS_PANE_LENGTH; + else if (EQ (AREF (menu_items, i), Qquote)) + { + /* This is the boundary between left-side elts and + right-side elts. */ + ++i; + } + else + { + entry = AREF (menu_items, i + MENU_ITEMS_ITEM_VALUE); + if (menu_item_selection == aref_addr (menu_items, i)) + return entry; + i += MENU_ITEMS_ITEM_LENGTH; + } + } + } + else + /* Make "Cancel" equivalent to C-g. */ + quit (); + + return Qnil; +} + +Lisp_Object +pgtk_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents) +{ + Lisp_Object title; + const char *error_name; + 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 = pgtk_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; +} + +/* Detect if a dialog or menu has been posted. MSDOS has its own + implementation on msdos.c. */ + +int +popup_activated (void) +{ + return popup_activated_flag; +} + +/* The following is used by delayed window autoselection. */ + +DEFUN ("menu-or-popup-active-p", Fmenu_or_popup_active_p, Smenu_or_popup_active_p, 0, 0, 0, + doc: /* Return t if a menu or popup dialog is active. +\(On MS Windows, this refers to the selected frame.) */) + (void) +{ + return (popup_activated ())? Qt : Qnil; +} + +static void syms_of_pgtkmenu_for_pdumper (void); + +void +syms_of_pgtkmenu (void) +{ + DEFSYM (Qdebug_on_next_call, "debug-on-next-call"); + defsubr (&Smenu_or_popup_active_p); + + DEFSYM (Qframe_monitor_workarea, "frame-monitor-workarea"); + + defsubr (&Sx_menu_bar_open_internal); + Ffset (intern_c_string ("accelerate-menu"), + intern_c_string (Sx_menu_bar_open_internal.s.symbol_name)); + + pdumper_do_now_and_after_load (syms_of_pgtkmenu_for_pdumper); +} + +static void +syms_of_pgtkmenu_for_pdumper (void) +{ +} diff --git a/src/pgtkselect.c b/src/pgtkselect.c new file mode 100644 index 00000000000..2a96caf0320 --- /dev/null +++ b/src/pgtkselect.c @@ -0,0 +1,632 @@ +/* Gtk selection processing for emacs. + Copyright (C) 1993-1994, 2005-2006, 2008-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 <https://www.gnu.org/licenses/>. */ + +/* +Originally by Carl Edman +Updated by Christian Limpach (chris@nice.ch) +OpenStep/Rhapsody port by Scott Bender (sbender@harmony-ds.com) +macOS/Aqua port by Christophe de Dinechin (descubes@earthlink.net) +GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu) +*/ + +/* This should be the first include, as it may set up #defines affecting + interpretation of even the system includes. */ +#include <config.h> + +#include "lisp.h" +#include "pgtkterm.h" +#include "termhooks.h" +#include "keyboard.h" +#include "pgtkselect.h" +#include <gdk/gdk.h> + +#if 0 +static Lisp_Object Vselection_alist; +#endif + +static GQuark quark_primary_data = 0; +static GQuark quark_primary_size = 0; +static GQuark quark_secondary_data = 0; +static GQuark quark_secondary_size = 0; +static GQuark quark_clipboard_data = 0; +static GQuark quark_clipboard_size = 0; + +/* ========================================================================== + + Internal utility functions + + ========================================================================== */ + +/* From a Lisp_Object, return a suitable frame for selection + operations. OBJECT may be a frame, a terminal object, or nil + (which stands for the selected frame--or, if that is not an pgtk + frame, the first pgtk display on the list). If no suitable frame can + be found, return NULL. */ + +static struct frame * +frame_for_pgtk_selection (Lisp_Object object) +{ + Lisp_Object tail, frame; + struct frame *f; + + if (NILP (object)) + { + f = XFRAME (selected_frame); + if (FRAME_PGTK_P (f) && FRAME_LIVE_P (f)) + return f; + + FOR_EACH_FRAME (tail, frame) + { + f = XFRAME (frame); + if (FRAME_PGTK_P (f) && FRAME_LIVE_P (f)) + return f; + } + } + else if (TERMINALP (object)) + { + struct terminal *t = decode_live_terminal (object); + + if (t->type == output_pgtk) + FOR_EACH_FRAME (tail, frame) + { + f = XFRAME (frame); + if (FRAME_LIVE_P (f) && f->terminal == t) + return f; + } + } + else if (FRAMEP (object)) + { + f = XFRAME (object); + if (FRAME_PGTK_P (f) && FRAME_LIVE_P (f)) + return f; + } + + return NULL; +} + +static GtkClipboard * +symbol_to_gtk_clipboard (GtkWidget * widget, Lisp_Object symbol) +{ + GdkAtom atom; + + CHECK_SYMBOL (symbol); + if (NILP (symbol)) + { + atom = GDK_SELECTION_PRIMARY; + } + else if (EQ (symbol, QCLIPBOARD)) + { + atom = GDK_SELECTION_CLIPBOARD; + } + else if (EQ (symbol, QPRIMARY)) + { + atom = GDK_SELECTION_PRIMARY; + } + else if (EQ (symbol, QSECONDARY)) + { + atom = GDK_SELECTION_SECONDARY; + } + else if (EQ (symbol, Qt)) + { + atom = GDK_SELECTION_SECONDARY; + } + else + { + atom = 0; + error ("Bad selection"); + } + + return gtk_widget_get_clipboard (widget, atom); +} + +static void +selection_type_to_quarks (GdkAtom type, GQuark * quark_data, + GQuark * quark_size) +{ + if (type == GDK_SELECTION_PRIMARY) + { + *quark_data = quark_primary_data; + *quark_size = quark_primary_size; + } + else if (type == GDK_SELECTION_SECONDARY) + { + *quark_data = quark_secondary_data; + *quark_size = quark_secondary_size; + } + else if (type == GDK_SELECTION_CLIPBOARD) + { + *quark_data = quark_clipboard_data; + *quark_size = quark_clipboard_size; + } + else + { + /* fixme: Is it safe to use 'error' here? */ + error ("Unknown selection type."); + } +} + +static void +get_func (GtkClipboard * cb, GtkSelectionData * data, guint info, + gpointer user_data_or_owner) +{ + GObject *obj = G_OBJECT (user_data_or_owner); + const char *str; + int size; + GQuark quark_data, quark_size; + + selection_type_to_quarks (gtk_clipboard_get_selection (cb), &quark_data, + &quark_size); + + str = g_object_get_qdata (obj, quark_data); + size = GPOINTER_TO_SIZE (g_object_get_qdata (obj, quark_size)); + gtk_selection_data_set_text (data, str, size); +} + +static void +clear_func (GtkClipboard * cb, gpointer user_data_or_owner) +{ + GObject *obj = G_OBJECT (user_data_or_owner); + GQuark quark_data, quark_size; + + selection_type_to_quarks (gtk_clipboard_get_selection (cb), &quark_data, + &quark_size); + + g_object_set_qdata (obj, quark_data, NULL); + g_object_set_qdata (obj, quark_size, 0); +} + + +/* ========================================================================== + + Functions used externally + + ========================================================================== */ + +void +pgtk_selection_init (void) +{ + if (quark_primary_data == 0) + { + quark_primary_data = g_quark_from_static_string ("pgtk-primary-data"); + quark_primary_size = g_quark_from_static_string ("pgtk-primary-size"); + quark_secondary_data = + g_quark_from_static_string ("pgtk-secondary-data"); + quark_secondary_size = + g_quark_from_static_string ("pgtk-secondary-size"); + quark_clipboard_data = + g_quark_from_static_string ("pgtk-clipboard-data"); + quark_clipboard_size = + g_quark_from_static_string ("pgtk-clipboard-size"); + } +} + +void +pgtk_selection_lost (GtkWidget * widget, GdkEventSelection * event, + gpointer user_data) +{ + GQuark quark_data, quark_size; + + selection_type_to_quarks (event->selection, &quark_data, &quark_size); + + g_object_set_qdata (G_OBJECT (widget), quark_data, NULL); + g_object_set_qdata (G_OBJECT (widget), quark_size, 0); +} + +static bool +pgtk_selection_usable (void) +{ + if (pgtk_enable_selection_on_multi_display) + return true; + + /* + * https://github.com/GNOME/gtk/blob/gtk-3-24/gdk/wayland/gdkselection-wayland.c#L1033 + * + * Gdk uses gdk_display_get_default() when handling selections, so + * selections don't work properly on multi-display environment. + * + * ---------------- + * #include <gtk/gtk.h> + * + * static GtkWidget *top1, *top2; + * + * int main (int argc, char **argv) + * { + * GtkWidget *w; + * GtkTextBuffer *buf; + * + * gtk_init (&argc, &argv); + * + * static char *text = "\ + * It is fine today.\n\ + * It will be fine tomorrow too.\n\ + * It is too hot."; + * + * top1 = gtk_window_new (GTK_WINDOW_TOPLEVEL); + * gtk_window_set_title (GTK_WINDOW (top1), "default"); + * gtk_widget_show (top1); + * w = gtk_text_view_new (); + * gtk_container_add (GTK_CONTAINER (top1), w); + * gtk_widget_show (w); + * buf = gtk_text_view_get_buffer (GTK_TEXT_VIEW (w)); + * gtk_text_buffer_insert_at_cursor (buf, text, strlen (text)); + * gtk_text_buffer_add_selection_clipboard (buf, gtk_widget_get_clipboard (w, GDK_SELECTION_PRIMARY)); + * + * unsetenv ("GDK_BACKEND"); + * GdkDisplay *gdpy; + * const char *dpyname2; + * if (strcmp (G_OBJECT_TYPE_NAME (gtk_widget_get_window (top1)), "GdkWaylandWindow") == 0) + * dpyname2 = ":0"; + * else + * dpyname2 = "wayland-0"; + * gdpy = gdk_display_open (dpyname2); + * top2 = gtk_window_new (GTK_WINDOW_TOPLEVEL); + * gtk_window_set_title (GTK_WINDOW (top2), dpyname2); + * gtk_window_set_screen (GTK_WINDOW (top2), gdk_display_get_default_screen (gdpy)); + * gtk_widget_show (top2); + * w = gtk_text_view_new (); + * gtk_container_add (GTK_CONTAINER (top2), w); + * gtk_widget_show (w); + * buf = gtk_text_view_get_buffer (GTK_TEXT_VIEW (w)); + * gtk_text_buffer_insert_at_cursor (buf, text, strlen (text)); + * gtk_text_buffer_add_selection_clipboard (buf, gtk_widget_get_clipboard (w, GDK_SELECTION_PRIMARY)); + * + * gtk_main (); + * + * return 0; + * } + * ---------------- + * + * This code fails if + * GDK_BACKEND=x11 ./test + * and select on both of windows. + * + * ---------------- + * (test:15345): GLib-GObject-CRITICAL **: 01:56:38.041: g_object_ref: assertion 'G_IS_OBJECT (object)' failed + * + * (test:15345): GLib-GObject-CRITICAL **: 01:56:38.042: g_object_ref: assertion 'G_IS_OBJECT (object)' failed + * + * (test:15345): GLib-GObject-CRITICAL **: 01:56:39.113: g_object_ref: assertion 'G_IS_OBJECT (object)' failed + * + * (test:15345): GLib-GObject-CRITICAL **: 01:56:39.113: g_object_ref: assertion 'G_IS_OBJECT (object)' failed + * ---------------- + * (gtk-3.24.10) + * + * This function checks whether selections work by the number of displays. + * If you use more than 2 displays, then selection is disabled. + */ + + GdkDisplayManager *dpyman = gdk_display_manager_get (); + GSList *list = gdk_display_manager_list_displays (dpyman); + int len = g_slist_length (list); + g_slist_free (list); + return len < 2; +} + +/* ========================================================================== + + Lisp Defuns + + ========================================================================== */ + + +DEFUN ("pgtk-own-selection-internal", Fpgtk_own_selection_internal, Spgtk_own_selection_internal, 2, 3, 0, + doc: /* Assert an X selection of type SELECTION and value VALUE. +SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'. +\(Those are literal upper-case symbol names, since that's what X expects.) +VALUE is typically a string, or a cons of two markers, but may be +anything that the functions on `selection-converter-alist' know about. + +FRAME should be a frame that should own the selection. If omitted or +nil, it defaults to the selected frame. */) + (Lisp_Object selection, Lisp_Object value, Lisp_Object frame) +{ + Lisp_Object successful_p = Qnil; + Lisp_Object target_symbol, rest; + GtkClipboard *cb; + struct frame *f; + GQuark quark_data, quark_size; + + check_window_system (NULL); + + if (!pgtk_selection_usable ()) + return Qnil; + + if (NILP (frame)) + frame = selected_frame; + if (!FRAME_LIVE_P (XFRAME (frame)) || !FRAME_PGTK_P (XFRAME (frame))) + error ("pgtk selection unavailable for this frame"); + f = XFRAME (frame); + + cb = symbol_to_gtk_clipboard (FRAME_GTK_WIDGET (f), selection); + selection_type_to_quarks (gtk_clipboard_get_selection (cb), &quark_data, + &quark_size); + + /* We only support copy of text. */ + target_symbol = QTEXT; + if (STRINGP (value)) + { + GtkTargetList *list; + GtkTargetEntry *targets; + gint n_targets; + GtkWidget *widget; + + list = gtk_target_list_new (NULL, 0); + gtk_target_list_add_text_targets (list, 0); + + { + /* text/plain: Strings encoded by Gtk are not correctly decoded by Chromium(Wayland). */ + GdkAtom atom_text_plain = gdk_atom_intern ("text/plain", false); + gtk_target_list_remove (list, atom_text_plain); + } + + targets = gtk_target_table_new_from_list (list, &n_targets); + + int size = SBYTES (value); + gchar *str = xmalloc (size + 1); + memcpy (str, SSDATA (value), size); + str[size] = '\0'; + + widget = FRAME_GTK_WIDGET (f); + g_object_set_qdata_full (G_OBJECT (widget), quark_data, str, xfree); + g_object_set_qdata_full (G_OBJECT (widget), quark_size, + GSIZE_TO_POINTER (size), NULL); + + if (gtk_clipboard_set_with_owner (cb, + targets, n_targets, + get_func, clear_func, + G_OBJECT (FRAME_GTK_WIDGET (f)))) + { + successful_p = Qt; + } + gtk_clipboard_set_can_store (cb, NULL, 0); + + gtk_target_table_free (targets, n_targets); + gtk_target_list_unref (list); + } + + if (!EQ (Vpgtk_sent_selection_hooks, Qunbound)) + { + /* FIXME: Use run-hook-with-args! */ + for (rest = Vpgtk_sent_selection_hooks; CONSP (rest); + rest = Fcdr (rest)) + call3 (Fcar (rest), selection, target_symbol, successful_p); + } + + return value; +} + + +DEFUN ("pgtk-disown-selection-internal", Fpgtk_disown_selection_internal, Spgtk_disown_selection_internal, 1, 3, 0, + doc: /* If we own the selection SELECTION, disown it. +Disowning it means there is no such selection. + +Sets the last-change time for the selection to TIME-OBJECT (by default +the time of the last event). + +TERMINAL should be a terminal object or a frame specifying the X +server to query. If omitted or nil, that stands for the selected +frame's display, or the first available X display. + +On Nextstep, the TIME-OBJECT and TERMINAL arguments are unused. +On MS-DOS, all this does is return non-nil if we own the selection. +On PGTK, the TIME-OBJECT is unused. */) + (Lisp_Object selection, Lisp_Object time_object, Lisp_Object terminal) +{ + struct frame *f = frame_for_pgtk_selection (terminal); + GtkClipboard *cb; + + if (!pgtk_selection_usable ()) + return Qnil; + + if (!f) + return Qnil; + + cb = symbol_to_gtk_clipboard (FRAME_GTK_WIDGET (f), selection); + + gtk_clipboard_clear (cb); + + return Qt; +} + + +DEFUN ("pgtk-selection-exists-p", Fpgtk_selection_exists_p, Spgtk_selection_exists_p, 0, 2, 0, + doc: /* Whether there is an owner for the given X selection. +SELECTION should be the name of the selection in question, typically +one of the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'. (X expects +these literal upper-case names.) The symbol nil is the same as +`PRIMARY', and t is the same as `SECONDARY'. + +TERMINAL should be a terminal object or a frame specifying the X +server to query. If omitted or nil, that stands for the selected +frame's display, or the first available X display. + +On Nextstep, TERMINAL is unused. */) + (Lisp_Object selection, Lisp_Object terminal) +{ + struct frame *f = frame_for_pgtk_selection (terminal); + GtkClipboard *cb; + + if (!pgtk_selection_usable ()) + return Qnil; + + if (!f) + return Qnil; + + cb = symbol_to_gtk_clipboard (FRAME_GTK_WIDGET (f), selection); + + return gtk_clipboard_wait_is_text_available (cb) ? Qt : Qnil; +} + + +DEFUN ("pgtk-selection-owner-p", Fpgtk_selection_owner_p, Spgtk_selection_owner_p, 0, 2, 0, + doc: /* Whether the current Emacs process owns the given X Selection. +The arg should be the name of the selection in question, typically one of +the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'. +\(Those are literal upper-case symbol names, since that's what X expects.) +For convenience, the symbol nil is the same as `PRIMARY', +and t is the same as `SECONDARY'. + +TERMINAL should be a terminal object or a frame specifying the X +server to query. If omitted or nil, that stands for the selected +frame's display, or the first available X display. + +On Nextstep, TERMINAL is unused. */) + (Lisp_Object selection, Lisp_Object terminal) +{ + struct frame *f = frame_for_pgtk_selection (terminal); + GtkClipboard *cb; + GObject *obj; + GQuark quark_data, quark_size; + + if (!pgtk_selection_usable ()) + return Qnil; + + cb = symbol_to_gtk_clipboard (FRAME_GTK_WIDGET (f), selection); + selection_type_to_quarks (gtk_clipboard_get_selection (cb), &quark_data, + &quark_size); + + obj = gtk_clipboard_get_owner (cb); + + return obj && g_object_get_qdata (obj, quark_data) != NULL ? Qt : Qnil; +} + + +DEFUN ("pgtk-get-selection-internal", Fpgtk_get_selection_internal, Spgtk_get_selection_internal, 2, 4, 0, + doc: /* Return text selected from some X window. +SELECTION-SYMBOL is typically `PRIMARY', `SECONDARY', or `CLIPBOARD'. +\(Those are literal upper-case symbol names, since that's what X expects.) +TARGET-TYPE is the type of data desired, typically `STRING'. + +TIME-STAMP is the time to use in the XConvertSelection call for foreign +selections. If omitted, defaults to the time for the last event. + +TERMINAL should be a terminal object or a frame specifying the X +server to query. If omitted or nil, that stands for the selected +frame's display, or the first available X display. + +On Nextstep, TIME-STAMP and TERMINAL are unused. +On PGTK, TIME-STAMP is unused. */) + (Lisp_Object selection_symbol, Lisp_Object target_type, + Lisp_Object time_stamp, Lisp_Object terminal) +{ + struct frame *f = frame_for_pgtk_selection (terminal); + GtkClipboard *cb; + + CHECK_SYMBOL (selection_symbol); + CHECK_SYMBOL (target_type); + if (EQ (target_type, QMULTIPLE)) + error ("Retrieving MULTIPLE selections is currently unimplemented"); + if (!f) + error ("PGTK selection unavailable for this frame"); + + if (!pgtk_selection_usable ()) + return Qnil; + + cb = symbol_to_gtk_clipboard (FRAME_GTK_WIDGET (f), selection_symbol); + + GdkAtom target_atom = gdk_atom_intern (SSDATA (SYMBOL_NAME (target_type)), false); + GtkSelectionData *seldata = gtk_clipboard_wait_for_contents (cb, target_atom); + + if (seldata == NULL) + return Qnil; + + const guchar *sd_data = gtk_selection_data_get_data (seldata); + int sd_len = gtk_selection_data_get_length (seldata); + int sd_format = gtk_selection_data_get_format (seldata); + GdkAtom sd_type = gtk_selection_data_get_data_type (seldata); + + if (sd_format == 8) + { + Lisp_Object str, lispy_type; + + str = make_unibyte_string ((char *) sd_data, sd_len); + /* Indicate that this string is from foreign selection by a text + property `foreign-selection' so that the caller of + x-get-selection-internal (usually x-get-selection) can know + that the string must be decode. */ + if (sd_type == gdk_atom_intern ("COMPOUND_TEXT", false)) + lispy_type = QCOMPOUND_TEXT; + else if (sd_type == gdk_atom_intern ("UTF8_STRING", false)) + lispy_type = QUTF8_STRING; + else if (sd_type == gdk_atom_intern ("text/plain;charset=utf-8", false)) + lispy_type = Qtext_plain_charset_utf_8; + else + lispy_type = QSTRING; + Fput_text_property (make_fixnum (0), make_fixnum (sd_len), + Qforeign_selection, lispy_type, str); + + gtk_selection_data_free (seldata); + return str; + } + + gtk_selection_data_free (seldata); + return Qnil; +} + + +void +nxatoms_of_pgtkselect (void) +{ +} + +void +syms_of_pgtkselect (void) +{ + DEFSYM (QCLIPBOARD, "CLIPBOARD"); + DEFSYM (QSECONDARY, "SECONDARY"); + DEFSYM (QTEXT, "TEXT"); + DEFSYM (QFILE_NAME, "FILE_NAME"); + DEFSYM (QMULTIPLE, "MULTIPLE"); + + DEFSYM (Qforeign_selection, "foreign-selection"); + DEFSYM (QUTF8_STRING, "UTF8_STRING"); + DEFSYM (QSTRING, "STRING"); + DEFSYM (QCOMPOUND_TEXT, "COMPOUND_TEXT"); + DEFSYM (Qtext_plain_charset_utf_8, "text/plain;charset=utf-8"); + + defsubr (&Spgtk_disown_selection_internal); + defsubr (&Spgtk_get_selection_internal); + defsubr (&Spgtk_own_selection_internal); + defsubr (&Spgtk_selection_exists_p); + defsubr (&Spgtk_selection_owner_p); + +#if 0 + Vselection_alist = Qnil; + staticpro (&Vselection_alist); +#endif + + DEFVAR_LISP ("pgtk-sent-selection-hooks", Vpgtk_sent_selection_hooks, + "A list of functions to be called when Emacs answers a selection request.\n\ +The functions are called with four arguments:\n\ + - the selection name (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\ + - the selection-type which Emacs was asked to convert the\n\ + selection into before sending (for example, `STRING' or `LENGTH');\n\ + - a flag indicating success or failure for responding to the request.\n\ +We might have failed (and declined the request) for any number of reasons,\n\ +including being asked for a selection that we no longer own, or being asked\n\ +to convert into a type that we don't know about or that is inappropriate.\n\ +This hook doesn't let you change the behavior of Emacs's selection replies,\n\ +it merely informs you that they have happened."); + Vpgtk_sent_selection_hooks = Qnil; + + DEFVAR_BOOL ("pgtk-enable-selection-on-multi-display", pgtk_enable_selection_on_multi_display, + doc: /* Enable selection on multi display environment. +This may cause crash. */); + pgtk_enable_selection_on_multi_display = false; +} diff --git a/src/pgtkselect.h b/src/pgtkselect.h new file mode 100644 index 00000000000..294eefc11d9 --- /dev/null +++ b/src/pgtkselect.h @@ -0,0 +1,33 @@ +/* Definitions and headers for selection of pure Gtk+3. + Copyright (C) 1989, 1993, 2005, 2008-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 <https://www.gnu.org/licenses/>. */ + + +#include "dispextern.h" +#include "frame.h" + +#ifdef HAVE_PGTK + +#include <gtk/gtk.h> + +extern void pgtk_selection_init (void); +extern void pgtk_selection_lost (GtkWidget * widget, + GdkEventSelection * event, + gpointer user_data); + +#endif /* HAVE_PGTK */ diff --git a/src/pgtkterm.c b/src/pgtkterm.c new file mode 100644 index 00000000000..c2e684272fb --- /dev/null +++ b/src/pgtkterm.c @@ -0,0 +1,7226 @@ +/* Pure Gtk+-3 communication module. -*- coding: utf-8 -*- + +Copyright (C) 1989, 1993-1994, 2005-2006, 2008-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 <https://www.gnu.org/licenses/>. */ + +/* This should be the first include, as it may set up #defines affecting + interpretation of even the system includes. */ +#include <config.h> + +#include <cairo.h> +#include <fcntl.h> +#include <math.h> +#include <pthread.h> +#include <sys/types.h> +#include <time.h> +#include <signal.h> +#include <unistd.h> +#include <errno.h> + +#include <c-ctype.h> +#include <c-strcase.h> +#include <ftoastr.h> + +#include "lisp.h" +#include "blockinput.h" +#include "frame.h" +#include "sysselect.h" +#include "gtkutil.h" +#include "systime.h" +#include "character.h" +#include "xwidget.h" +#include "fontset.h" +#include "composite.h" +#include "ccl.h" +#include "dynlib.h" + +#include "termhooks.h" +#include "termopts.h" +#include "termchar.h" +#include "emacs-icon.h" +#include "menu.h" +#include "window.h" +#include "keyboard.h" +#include "atimer.h" +#include "buffer.h" +#include "font.h" +#include "xsettings.h" +#include "pgtkselect.h" +#include "emacsgtkfixed.h" + +#ifdef GDK_WINDOWING_WAYLAND +#include <gdk/gdkwayland.h> +#endif + +#define STORE_KEYSYM_FOR_DEBUG(keysym) ((void)0) + +#define FRAME_CR_CONTEXT(f) ((f)->output_data.pgtk->cr_context) +#define FRAME_CR_ACTIVE_CONTEXT(f) ((f)->output_data.pgtk->cr_active) +#define FRAME_CR_SURFACE(f) (cairo_get_target (FRAME_CR_CONTEXT (f))) + +/* Non-zero means that a HELP_EVENT has been generated since Emacs + start. */ + +static bool any_help_event_p; + +struct pgtk_display_info *x_display_list; /* Chain of existing displays */ +extern Lisp_Object tip_frame; + +static struct event_queue_t +{ + union buffered_input_event *q; + int nr, cap; +} event_q = { + NULL, 0, 0, +}; + +/* Non-zero timeout value means ignore next mouse click if it arrives + before that timeout elapses (i.e. as part of the same sequence of + events resulting from clicking on a frame to select it). */ + +static Time ignore_next_mouse_click_timeout; + +static Lisp_Object xg_default_icon_file; + +static void pgtk_delete_display (struct pgtk_display_info *dpyinfo); +static void pgtk_clear_frame_area (struct frame *f, int x, int y, int width, + int height); +static void pgtk_fill_rectangle (struct frame *f, unsigned long color, int x, + int y, int width, int height); +static void pgtk_clip_to_row (struct window *w, struct glyph_row *row, + enum glyph_row_area area, cairo_t * cr); +static struct frame *pgtk_any_window_to_frame (GdkWindow * window); + +/* + * This is not a flip context in the same sense as gpu rendering + * scences, it only occurs when a new context was required due to a + * resize or other fundamental change. This is called when that + * context's surface has completed drawing + */ + +static void +flip_cr_context (struct frame *f) +{ + cairo_t *cr = FRAME_CR_ACTIVE_CONTEXT (f); + + block_input (); + if (cr != FRAME_CR_CONTEXT (f)) + { + cairo_destroy (cr); + FRAME_CR_ACTIVE_CONTEXT (f) = cairo_reference (FRAME_CR_CONTEXT (f)); + + } + unblock_input (); +} + + +static void +evq_enqueue (union buffered_input_event *ev) +{ + struct event_queue_t *evq = &event_q; + if (evq->cap == 0) + { + evq->cap = 4; + evq->q = xmalloc (sizeof *evq->q * evq->cap); + } + + if (evq->nr >= evq->cap) + { + evq->cap += evq->cap / 2; + evq->q = xrealloc (evq->q, sizeof *evq->q * evq->cap); + } + + evq->q[evq->nr++] = *ev; + raise (SIGIO); +} + +static int +evq_flush (struct input_event *hold_quit) +{ + struct event_queue_t *evq = &event_q; + int i, n = evq->nr; + for (i = 0; i < n; i++) + kbd_buffer_store_buffered_event (&evq->q[i], hold_quit); + evq->nr = 0; + return n; +} + +void +mark_pgtkterm (void) +{ + struct event_queue_t *evq = &event_q; + int i, n = evq->nr; + for (i = 0; i < n; i++) + { + union buffered_input_event *ev = &evq->q[i]; + mark_object (ev->ie.x); + mark_object (ev->ie.y); + mark_object (ev->ie.frame_or_window); + mark_object (ev->ie.arg); + } +} + +char * +get_keysym_name (int keysym) +/* -------------------------------------------------------------------------- + Called by keyboard.c. Not sure if the return val is important, except + that it be unique. + -------------------------------------------------------------------------- */ +{ + static char value[16]; + sprintf (value, "%d", keysym); + return value; +} + +void +frame_set_mouse_pixel_position (struct frame *f, int pix_x, int pix_y) +/* -------------------------------------------------------------------------- + Programmatically reposition mouse pointer in pixel coordinates + -------------------------------------------------------------------------- */ +{ +} + +/* Raise frame F. */ + +static void +pgtk_raise_frame (struct frame *f) +{ + /* This works only for non-child frames on X. + It does not work for child frames on X, and it does not work + on Wayland too. */ + block_input (); + if (FRAME_VISIBLE_P (f)) + gdk_window_raise (gtk_widget_get_window (FRAME_WIDGET (f))); + unblock_input (); +} + +/* Lower frame F. */ + +static void +pgtk_lower_frame (struct frame *f) +{ + if (FRAME_VISIBLE_P (f)) + { + block_input (); + gdk_window_lower (gtk_widget_get_window (FRAME_WIDGET (f))); + unblock_input (); + } +} + +static void +pgtk_frame_raise_lower (struct frame *f, bool raise_flag) +{ + if (raise_flag) + pgtk_raise_frame (f); + else + pgtk_lower_frame (f); +} + +/* Free X resources of frame F. */ + +void +x_free_frame_resources (struct frame *f) +{ + struct pgtk_display_info *dpyinfo; + Mouse_HLInfo *hlinfo; + + check_window_system (f); + dpyinfo = FRAME_DISPLAY_INFO (f); + hlinfo = MOUSE_HL_INFO (f); + + block_input (); + +#ifdef HAVE_XWIDGETS + kill_frame_xwidget_views (f); +#endif + free_frame_faces (f); + + if (FRAME_X_OUTPUT (f)->scale_factor_atimer != NULL) + { + cancel_atimer (FRAME_X_OUTPUT (f)->scale_factor_atimer); + FRAME_X_OUTPUT (f)->scale_factor_atimer = NULL; + } + +#define CLEAR_IF_EQ(FIELD) \ + do { if (f == dpyinfo->FIELD) dpyinfo->FIELD = 0; } while (false) + + CLEAR_IF_EQ (x_focus_frame); + CLEAR_IF_EQ (highlight_frame); + CLEAR_IF_EQ (x_focus_event_frame); + CLEAR_IF_EQ (last_mouse_frame); + CLEAR_IF_EQ (last_mouse_motion_frame); + CLEAR_IF_EQ (last_mouse_glyph_frame); + CLEAR_IF_EQ (im.focused_frame); + +#undef CLEAR_IF_EQ + + if (f == hlinfo->mouse_face_mouse_frame) + reset_mouse_highlight (hlinfo); + + g_clear_object (&FRAME_X_OUTPUT (f)->text_cursor); + g_clear_object (&FRAME_X_OUTPUT (f)->nontext_cursor); + g_clear_object (&FRAME_X_OUTPUT (f)->modeline_cursor); + g_clear_object (&FRAME_X_OUTPUT (f)->hand_cursor); + g_clear_object (&FRAME_X_OUTPUT (f)->hourglass_cursor); + g_clear_object (&FRAME_X_OUTPUT (f)->horizontal_drag_cursor); + g_clear_object (&FRAME_X_OUTPUT (f)->vertical_drag_cursor); + g_clear_object (&FRAME_X_OUTPUT (f)->left_edge_cursor); + g_clear_object (&FRAME_X_OUTPUT (f)->right_edge_cursor); + g_clear_object (&FRAME_X_OUTPUT (f)->top_edge_cursor); + g_clear_object (&FRAME_X_OUTPUT (f)->bottom_edge_cursor); + g_clear_object (&FRAME_X_OUTPUT (f)->top_left_corner_cursor); + g_clear_object (&FRAME_X_OUTPUT (f)->top_right_corner_cursor); + g_clear_object (&FRAME_X_OUTPUT (f)->bottom_right_corner_cursor); + g_clear_object (&FRAME_X_OUTPUT (f)->bottom_left_corner_cursor); + + + if (FRAME_X_OUTPUT (f)->border_color_css_provider != NULL) + { + GtkStyleContext *ctxt = gtk_widget_get_style_context (FRAME_WIDGET (f)); + GtkCssProvider *old = FRAME_X_OUTPUT (f)->border_color_css_provider; + gtk_style_context_remove_provider (ctxt, GTK_STYLE_PROVIDER (old)); + g_object_unref (old); + FRAME_X_OUTPUT (f)->border_color_css_provider = NULL; + } + + if (FRAME_X_OUTPUT (f)->scrollbar_foreground_css_provider != NULL) + { + GtkCssProvider *old = + FRAME_X_OUTPUT (f)->scrollbar_foreground_css_provider; + g_object_unref (old); + FRAME_X_OUTPUT (f)->scrollbar_foreground_css_provider = NULL; + } + + if (FRAME_X_OUTPUT (f)->scrollbar_background_css_provider != NULL) + { + GtkCssProvider *old = + FRAME_X_OUTPUT (f)->scrollbar_background_css_provider; + g_object_unref (old); + FRAME_X_OUTPUT (f)->scrollbar_background_css_provider = NULL; + } + + gtk_widget_destroy (FRAME_WIDGET (f)); + + if (FRAME_X_OUTPUT (f)->cr_surface_visible_bell != NULL) + { + cairo_surface_destroy (FRAME_X_OUTPUT (f)->cr_surface_visible_bell); + FRAME_X_OUTPUT (f)->cr_surface_visible_bell = NULL; + } + + if (FRAME_X_OUTPUT (f)->atimer_visible_bell != NULL) + { + cancel_atimer (FRAME_X_OUTPUT (f)->atimer_visible_bell); + FRAME_X_OUTPUT (f)->atimer_visible_bell = NULL; + } + + xfree (f->output_data.pgtk); + f->output_data.pgtk = NULL; + + unblock_input (); +} + +void +x_destroy_window (struct frame *f) +/* -------------------------------------------------------------------------- + External: Delete the window + -------------------------------------------------------------------------- */ +{ + struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); + + check_window_system (f); + if (dpyinfo->gdpy != NULL) + x_free_frame_resources (f); + + dpyinfo->reference_count--; +} + +/* Calculate the absolute position in frame F + from its current recorded position values and gravity. */ + +static void +x_calc_absolute_position (struct frame *f) +{ + int flags = f->size_hint_flags; + struct frame *p = FRAME_PARENT_FRAME (f); + + /* We have nothing to do if the current position + is already for the top-left corner. */ + if (! ((flags & XNegative) || (flags & YNegative))) + return; + + /* Treat negative positions as relative to the leftmost bottommost + position that fits on the screen. */ + if ((flags & XNegative) && (f->left_pos <= 0)) + { + int width = FRAME_PIXEL_WIDTH (f); + + /* A frame that has been visible at least once should have outer + edges. */ + if (f->output_data.pgtk->has_been_visible && !p) + { + Lisp_Object frame; + Lisp_Object edges = Qnil; + + XSETFRAME (frame, f); + edges = Fpgtk_frame_edges (frame, Qouter_edges); + if (!NILP (edges)) + width = (XFIXNUM (Fnth (make_fixnum (2), edges)) + - XFIXNUM (Fnth (make_fixnum (0), edges))); + } + + if (p) + f->left_pos = (FRAME_PIXEL_WIDTH (p) - width - 2 * f->border_width + + f->left_pos); + else + f->left_pos = (x_display_pixel_width (FRAME_DISPLAY_INFO (f)) + - width + f->left_pos); + + } + + if ((flags & YNegative) && (f->top_pos <= 0)) + { + int height = FRAME_PIXEL_HEIGHT (f); + + if (f->output_data.pgtk->has_been_visible && !p) + { + Lisp_Object frame; + Lisp_Object edges = Qnil; + + XSETFRAME (frame, f); + if (NILP (edges)) + edges = Fpgtk_frame_edges (frame, Qouter_edges); + if (!NILP (edges)) + height = (XFIXNUM (Fnth (make_fixnum (3), edges)) + - XFIXNUM (Fnth (make_fixnum (1), edges))); + } + + if (p) + f->top_pos = (FRAME_PIXEL_HEIGHT (p) - height - 2 * f->border_width + + f->top_pos); + else + f->top_pos = (x_display_pixel_height (FRAME_DISPLAY_INFO (f)) + - height + f->top_pos); + } + + /* The left_pos and top_pos + are now relative to the top and left screen edges, + so the flags should correspond. */ + f->size_hint_flags &= ~ (XNegative | YNegative); +} + +/* CHANGE_GRAVITY is 1 when calling from Fset_frame_position, + to really change the position, and 0 when calling from + x_make_frame_visible (in that case, XOFF and YOFF are the current + position values). It is -1 when calling from x_set_frame_parameters, + which means, do adjust for borders but don't change the gravity. */ + +static void +x_set_offset (struct frame *f, int xoff, int yoff, int change_gravity) +/* -------------------------------------------------------------------------- + External: Position the window + -------------------------------------------------------------------------- */ +{ + int modified_top, modified_left; + + if (change_gravity > 0) + { + f->top_pos = yoff; + f->left_pos = xoff; + f->size_hint_flags &= ~ (XNegative | YNegative); + if (xoff < 0) + f->size_hint_flags |= XNegative; + if (yoff < 0) + f->size_hint_flags |= YNegative; + f->win_gravity = NorthWestGravity; + } + + x_calc_absolute_position (f); + + block_input (); + x_wm_set_size_hint (f, 0, false); + + if (x_gtk_use_window_move) + { + if (change_gravity != 0) + { + if (FRAME_GTK_OUTER_WIDGET (f)) + { + gtk_window_move (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), + f->left_pos, f->top_pos); + } + else + { + GtkWidget *fixed = FRAME_GTK_WIDGET (f); + GtkWidget *parent = gtk_widget_get_parent (fixed); + gtk_fixed_move (GTK_FIXED (parent), fixed, + f->left_pos, f->top_pos); + } + } + unblock_input (); + return; + } + + modified_left = f->left_pos; + modified_top = f->top_pos; + + if (FRAME_GTK_OUTER_WIDGET (f)) + { + gtk_window_move (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), + modified_left, modified_top); + } + else + { + GtkWidget *fixed = FRAME_GTK_WIDGET (f); + GtkWidget *parent = gtk_widget_get_parent (fixed); + gtk_fixed_move (GTK_FIXED (parent), fixed, + modified_left, modified_top); + } + + unblock_input (); +} + +static void +pgtk_set_window_size (struct frame *f, bool change_gravity, + int width, int height) +/* -------------------------------------------------------------------------- + Adjust window pixel size based on given character grid size + Impl is a bit more complex than other terms, need to do some + internal clipping. + -------------------------------------------------------------------------- */ +{ + int pixelwidth, pixelheight; + + block_input (); + + gtk_widget_get_size_request (FRAME_GTK_WIDGET (f), &pixelwidth, + &pixelheight); + +#if 0 + if (pixelwise) + { + pixelwidth = FRAME_TEXT_TO_PIXEL_WIDTH (f, width); + pixelheight = FRAME_TEXT_TO_PIXEL_HEIGHT (f, height); + } + else + { + pixelwidth = FRAME_TEXT_COLS_TO_PIXEL_WIDTH (f, width); + pixelheight = FRAME_TEXT_LINES_TO_PIXEL_HEIGHT (f, height); + } +#else + pixelwidth = width; + pixelheight = height; +#endif + +#if 0 + frame_size_history_add + (f, Qx_set_window_size_1, width, height, + list5 (Fcons (make_fixnum (pixelwidth), make_fixnum (pixelheight)), + Fcons (make_fixnum (pixelwidth), make_fixnum (pixelheight)), + make_fixnum (f->border_width), + make_fixnum (FRAME_PGTK_TITLEBAR_HEIGHT (f)), + make_fixnum (FRAME_TOOLBAR_HEIGHT (f)))); +#endif + + for (GtkWidget * w = FRAME_GTK_WIDGET (f); w != NULL; + w = gtk_widget_get_parent (w)) + { + gint wd, hi; + gtk_widget_get_size_request (w, &wd, &hi); + } + + f->output_data.pgtk->preferred_width = pixelwidth; + f->output_data.pgtk->preferred_height = pixelheight; + x_wm_set_size_hint (f, 0, 0); + xg_frame_set_char_size (f, pixelwidth, pixelheight); + gtk_widget_queue_resize (FRAME_WIDGET (f)); + + unblock_input (); +} + +void +pgtk_iconify_frame (struct frame *f) +/* -------------------------------------------------------------------------- + External: Iconify window + -------------------------------------------------------------------------- */ +{ + /* Don't keep the highlight on an invisible frame. */ + if (FRAME_DISPLAY_INFO (f)->highlight_frame == f) + FRAME_DISPLAY_INFO (f)->highlight_frame = 0; + + if (FRAME_ICONIFIED_P (f)) + return; + + block_input (); + +#if 0 + x_set_bitmap_icon (f); +#endif + + if (FRAME_GTK_OUTER_WIDGET (f)) + { + if (!FRAME_VISIBLE_P (f)) + gtk_widget_show_all (FRAME_GTK_OUTER_WIDGET (f)); + + gtk_window_iconify (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f))); + SET_FRAME_VISIBLE (f, 0); + SET_FRAME_ICONIFIED (f, true); + unblock_input (); + return; + } + + /* Make sure the X server knows where the window should be positioned, + in case the user deiconifies with the window manager. */ + if (!FRAME_VISIBLE_P (f) && !FRAME_ICONIFIED_P (f) +#if 0 + && !FRAME_X_EMBEDDED_P (f) +#endif + ) + x_set_offset (f, f->left_pos, f->top_pos, 0); + +#if 0 + if (!FRAME_VISIBLE_P (f)) + { + /* If the frame was withdrawn, before, we must map it. */ + XMapRaised (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f)); + } +#endif + + SET_FRAME_ICONIFIED (f, true); + SET_FRAME_VISIBLE (f, 0); + + unblock_input (); +} + +static gboolean +pgtk_make_frame_visible_wait_for_map_event_cb (GtkWidget * widget, + GdkEventAny * event, + gpointer user_data) +{ + int *foundptr = user_data; + *foundptr = 1; + return FALSE; +} + +static gboolean +pgtk_make_frame_visible_wait_for_map_event_timeout (gpointer user_data) +{ + int *timedoutptr = user_data; + *timedoutptr = 1; + return FALSE; +} + +static void +pgtk_wait_for_map_event (struct frame *f, bool multiple_times) +{ + if (FLOATP (Vpgtk_wait_for_event_timeout)) + { + guint msec = + (guint) (XFLOAT_DATA (Vpgtk_wait_for_event_timeout) * 1000); + int found = 0; + int timed_out = 0; + gulong id = + g_signal_connect (FRAME_WIDGET (f), "map-event", + G_CALLBACK + (pgtk_make_frame_visible_wait_for_map_event_cb), + &found); + guint src = + g_timeout_add (msec, + pgtk_make_frame_visible_wait_for_map_event_timeout, + &timed_out); + + if (!multiple_times) + { + while (!found && !timed_out) + gtk_main_iteration (); + } + else + { + while (!timed_out) + gtk_main_iteration (); + } + + g_signal_handler_disconnect (FRAME_WIDGET (f), id); + if (!timed_out) + g_source_remove (src); + } +} + +void +pgtk_make_frame_visible (struct frame *f) +/* -------------------------------------------------------------------------- + External: Show the window (X11 semantics) + -------------------------------------------------------------------------- */ +{ + GtkWidget *win = FRAME_GTK_OUTER_WIDGET (f); + + if (!FRAME_VISIBLE_P (f)) + { + gtk_widget_show (FRAME_WIDGET (f)); + if (win) + gtk_window_deiconify (GTK_WINDOW (win)); + + pgtk_wait_for_map_event (f, false); + } +} + + +void +pgtk_make_frame_invisible (struct frame *f) +/* -------------------------------------------------------------------------- + External: Hide the window (X11 semantics) + -------------------------------------------------------------------------- */ +{ + gtk_widget_hide (FRAME_WIDGET (f)); + + /* Map events are emitted many times, and + * map_event() do SET_FRAME_VISIBLE(f, 1). + * I expect visible = 0, so process those map events here and + * SET_FRAME_VISIBLE(f, 0) after that. + */ + pgtk_wait_for_map_event (f, true); + + SET_FRAME_VISIBLE (f, 0); + SET_FRAME_ICONIFIED (f, false); +} + +static void +pgtk_make_frame_visible_invisible (struct frame *f, bool visible) +{ + if (visible) + pgtk_make_frame_visible (f); + else + pgtk_make_frame_invisible (f); +} + +static Lisp_Object +pgtk_new_font (struct frame *f, Lisp_Object font_object, int fontset) +{ + struct font *font = XFONT_OBJECT (font_object); + int font_ascent, font_descent; + + if (fontset < 0) + fontset = fontset_from_font (font_object); + FRAME_FONTSET (f) = fontset; + + if (FRAME_FONT (f) == font) + { + /* This font is already set in frame F. There's nothing more to + do. */ + return font_object; + } + + FRAME_FONT (f) = font; + + FRAME_BASELINE_OFFSET (f) = font->baseline_offset; + FRAME_COLUMN_WIDTH (f) = font->average_width; + get_font_ascent_descent (font, &font_ascent, &font_descent); + FRAME_LINE_HEIGHT (f) = font_ascent + font_descent; + + /* We could use a more elaborate calculation here. */ + FRAME_TAB_BAR_HEIGHT (f) = FRAME_TAB_BAR_LINES (f) * FRAME_LINE_HEIGHT (f); + + /* Compute the scroll bar width in character columns. */ + if (FRAME_CONFIG_SCROLL_BAR_WIDTH (f) > 0) + { + int wid = FRAME_COLUMN_WIDTH (f); + FRAME_CONFIG_SCROLL_BAR_COLS (f) + = (FRAME_CONFIG_SCROLL_BAR_WIDTH (f) + wid - 1) / wid; + } + else + { + int wid = FRAME_COLUMN_WIDTH (f); + FRAME_CONFIG_SCROLL_BAR_COLS (f) = (14 + wid - 1) / wid; + } + + /* Compute the scroll bar height in character lines. */ + if (FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) > 0) + { + int height = FRAME_LINE_HEIGHT (f); + FRAME_CONFIG_SCROLL_BAR_LINES (f) + = (FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) + height - 1) / height; + } + else + { + int height = FRAME_LINE_HEIGHT (f); + FRAME_CONFIG_SCROLL_BAR_LINES (f) = (14 + height - 1) / height; + } + + /* Now make the frame display the given font. */ + if (FRAME_GTK_WIDGET (f) != NULL) + adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f), + FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), 3, + false, Qfont); + + return font_object; +} + +int +x_display_pixel_height (struct pgtk_display_info *dpyinfo) +{ + GdkDisplay *gdpy = dpyinfo->gdpy; + GdkScreen *gscr = gdk_display_get_default_screen (gdpy); + return gdk_screen_get_height (gscr); +} + +int +x_display_pixel_width (struct pgtk_display_info *dpyinfo) +{ + GdkDisplay *gdpy = dpyinfo->gdpy; + GdkScreen *gscr = gdk_display_get_default_screen (gdpy); + return gdk_screen_get_width (gscr); +} + +void +x_set_parent_frame (struct frame *f, Lisp_Object new_value, + Lisp_Object old_value) +/* -------------------------------------------------------------------------- + Set frame F's `parent-frame' parameter. If non-nil, make F a child + frame of the frame specified by that parameter. Technically, this + makes F's window-system window a child window of the parent frame's + window-system window. If nil, make F's window-system window a + top-level window--a child of its display's root window. + + A child frame's `left' and `top' parameters specify positions + relative to the top-left corner of its parent frame's native + rectangle. On macOS moving a parent frame moves all its child + frames too, keeping their position relative to the parent + unaltered. When a parent frame is iconified or made invisible, its + child frames are made invisible. When a parent frame is deleted, + its child frames are deleted too. + + Whether a child frame has a tool bar may be window-system or window + manager dependent. It's advisable to disable it via the frame + parameter settings. + + Some window managers may not honor this parameter. + -------------------------------------------------------------------------- */ +{ + struct frame *p = NULL; + + if (!NILP (new_value) + && (!FRAMEP (new_value) + || !FRAME_LIVE_P (p = XFRAME (new_value)) + || !FRAME_PGTK_P (p))) + { + store_frame_param (f, Qparent_frame, old_value); + error ("Invalid specification of `parent-frame'"); + } + + if (p != FRAME_PARENT_FRAME (f)) + { + block_input (); + + if (p != NULL) + { + if (FRAME_DISPLAY_INFO (f) != FRAME_DISPLAY_INFO (p)) + error ("Cross display reparent."); + } + + GtkWidget *fixed = FRAME_GTK_WIDGET (f); + + GtkAllocation alloc; + gtk_widget_get_allocation (fixed, &alloc); + g_object_ref (fixed); + + /* Remember the css provider, and restore it later. */ + GtkCssProvider *provider = FRAME_X_OUTPUT (f)->border_color_css_provider; + FRAME_X_OUTPUT (f)->border_color_css_provider = NULL; + { + GtkStyleContext *ctxt = gtk_widget_get_style_context (FRAME_WIDGET (f)); + if (provider != NULL) + gtk_style_context_remove_provider (ctxt, GTK_STYLE_PROVIDER (provider)); + } + + { + GtkWidget *whbox_of_f = gtk_widget_get_parent (fixed); + /* Here, unhighlight can be called and may change border_color_css_provider. */ + gtk_container_remove (GTK_CONTAINER (whbox_of_f), fixed); + + if (FRAME_GTK_OUTER_WIDGET (f)) + { + gtk_widget_destroy (FRAME_GTK_OUTER_WIDGET (f)); + FRAME_GTK_OUTER_WIDGET (f) = NULL; + FRAME_OUTPUT_DATA (f)->vbox_widget = NULL; + FRAME_OUTPUT_DATA (f)->hbox_widget = NULL; + FRAME_OUTPUT_DATA (f)->menubar_widget = NULL; + FRAME_OUTPUT_DATA (f)->toolbar_widget = NULL; + FRAME_OUTPUT_DATA (f)->ttip_widget = NULL; + FRAME_OUTPUT_DATA (f)->ttip_lbl = NULL; + FRAME_OUTPUT_DATA (f)->ttip_window = NULL; + } + } + + if (p == NULL) + { + xg_create_frame_outer_widgets (f); + pgtk_set_event_handler (f); + gtk_box_pack_start (GTK_BOX (f->output_data.pgtk->hbox_widget), fixed, TRUE, TRUE, 0); + f->output_data.pgtk->preferred_width = alloc.width; + f->output_data.pgtk->preferred_height = alloc.height; + x_wm_set_size_hint (f, 0, 0); + xg_frame_set_char_size (f, FRAME_PIXEL_TO_TEXT_WIDTH (f, alloc.width), + FRAME_PIXEL_TO_TEXT_HEIGHT (f, alloc.height)); + gtk_widget_queue_resize (FRAME_WIDGET (f)); + gtk_widget_show_all (FRAME_GTK_OUTER_WIDGET (f)); + } + else + { + GtkWidget *fixed_of_p = FRAME_GTK_WIDGET (p); + gtk_fixed_put (GTK_FIXED (fixed_of_p), fixed, f->left_pos, f->top_pos); + gtk_widget_set_size_request (fixed, alloc.width, alloc.height); + gtk_widget_show_all (fixed); + } + + /* Restore css provider. */ + GtkStyleContext *ctxt = gtk_widget_get_style_context (FRAME_WIDGET (f)); + GtkCssProvider *old = FRAME_X_OUTPUT (f)->border_color_css_provider; + FRAME_X_OUTPUT (f)->border_color_css_provider = provider; + if (provider != NULL) + { + gtk_style_context_add_provider (ctxt, GTK_STYLE_PROVIDER (provider), + GTK_STYLE_PROVIDER_PRIORITY_USER); + } + if (old != NULL) + { + gtk_style_context_remove_provider (ctxt, GTK_STYLE_PROVIDER (old)); + g_object_unref(old); + } + + g_object_unref (fixed); + + if (FRAME_GTK_OUTER_WIDGET (f)) + { + if (EQ (x_gtk_resize_child_frames, Qresize_mode)) + gtk_container_set_resize_mode + (GTK_CONTAINER (FRAME_GTK_OUTER_WIDGET (f)), + p ? GTK_RESIZE_IMMEDIATE : GTK_RESIZE_QUEUE); + } + + unblock_input (); + + fset_parent_frame (f, new_value); + } +} + + +void +x_set_no_focus_on_map (struct frame *f, Lisp_Object new_value, + Lisp_Object old_value) +/* Set frame F's `no-focus-on-map' parameter which, if non-nil, means + * that F's window-system window does not want to receive input focus + * when it is mapped. (A frame's window is mapped when the frame is + * displayed for the first time and when the frame changes its state + * from `iconified' or `invisible' to `visible'.) + * + * Some window managers may not honor this parameter. */ +{ + /* doesn't work on wayland. */ + + if (!EQ (new_value, old_value)) + { + xg_set_no_focus_on_map (f, new_value); + FRAME_NO_FOCUS_ON_MAP (f) = !NILP (new_value); + } +} + +void +x_set_no_accept_focus (struct frame *f, Lisp_Object new_value, + Lisp_Object old_value) +/* Set frame F's `no-accept-focus' parameter which, if non-nil, hints + * that F's window-system window does not want to receive input focus + * via mouse clicks or by moving the mouse into it. + * + * If non-nil, 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. */ +{ + /* doesn't work on wayland. */ + + xg_set_no_accept_focus (f, new_value); + FRAME_NO_ACCEPT_FOCUS (f) = !NILP (new_value); +} + +void +x_set_z_group (struct frame *f, Lisp_Object new_value, Lisp_Object old_value) +/* Set frame F's `z-group' parameter. If `above', F's window-system + window is displayed above all windows that do not have the `above' + property set. If nil, F's window is shown below all windows that + have the `above' property set and above all windows that have the + `below' property set. If `below', F's window is displayed below + all windows that do. + + Some window managers may not honor this parameter. */ +{ + /* doesn't work on wayland. */ + + if (!FRAME_GTK_OUTER_WIDGET (f)) + return; + + if (NILP (new_value)) + { + gtk_window_set_keep_above (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), + FALSE); + gtk_window_set_keep_below (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), + FALSE); + FRAME_Z_GROUP (f) = z_group_none; + } + else if (EQ (new_value, Qabove)) + { + gtk_window_set_keep_above (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), + TRUE); + gtk_window_set_keep_below (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), + FALSE); + FRAME_Z_GROUP (f) = z_group_above; + } + else if (EQ (new_value, Qabove_suspended)) + { + gtk_window_set_keep_above (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), + FALSE); + FRAME_Z_GROUP (f) = z_group_above_suspended; + } + else if (EQ (new_value, Qbelow)) + { + gtk_window_set_keep_above (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), + FALSE); + gtk_window_set_keep_below (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), + TRUE); + FRAME_Z_GROUP (f) = z_group_below; + } + else + error ("Invalid z-group specification"); +} + +static void +pgtk_initialize_display_info (struct pgtk_display_info *dpyinfo) +/* -------------------------------------------------------------------------- + Initialize global info and storage for display. + -------------------------------------------------------------------------- */ +{ + dpyinfo->resx = 96; + dpyinfo->resy = 96; + dpyinfo->color_p = 1; + dpyinfo->n_planes = 32; + dpyinfo->root_window = 42; /* a placeholder.. */ + dpyinfo->highlight_frame = dpyinfo->x_focus_frame = NULL; + dpyinfo->n_fonts = 0; + dpyinfo->smallest_font_height = 1; + dpyinfo->smallest_char_width = 1; + + reset_mouse_highlight (&dpyinfo->mouse_highlight); +} + +/* Set S->gc to a suitable GC for drawing glyph string S in cursor + face. */ + +static void +x_set_cursor_gc (struct glyph_string *s) +{ + if (s->font == FRAME_FONT (s->f) + && s->face->background == FRAME_BACKGROUND_PIXEL (s->f) + && s->face->foreground == FRAME_FOREGROUND_PIXEL (s->f) && !s->cmp) + s->xgcv = FRAME_X_OUTPUT (s->f)->cursor_xgcv; + else + { + /* Cursor on non-default face: must merge. */ + Emacs_GC xgcv; + + xgcv.background = FRAME_X_OUTPUT (s->f)->cursor_color; + xgcv.foreground = s->face->background; + + /* If the glyph would be invisible, try a different foreground. */ + if (xgcv.foreground == xgcv.background) + xgcv.foreground = s->face->foreground; + if (xgcv.foreground == xgcv.background) + xgcv.foreground = FRAME_X_OUTPUT (s->f)->cursor_foreground_color; + if (xgcv.foreground == xgcv.background) + xgcv.foreground = s->face->foreground; + + /* Make sure the cursor is distinct from text in this face. */ + if (xgcv.background == s->face->background + && xgcv.foreground == s->face->foreground) + { + xgcv.background = s->face->foreground; + xgcv.foreground = s->face->background; + } + + s->xgcv = xgcv; + } +} + + +/* Set up S->gc of glyph string S for drawing text in mouse face. */ + +static void +x_set_mouse_face_gc (struct glyph_string *s) +{ + prepare_face_for_display (s->f, s->face); + + if (s->font == s->face->font) + { + s->xgcv.foreground = s->face->foreground; + s->xgcv.background = s->face->background; + } + else + { + /* Otherwise construct scratch_cursor_gc with values from FACE + except for FONT. */ + Emacs_GC xgcv; + + xgcv.background = s->face->background; + xgcv.foreground = s->face->foreground; + + s->xgcv = xgcv; + + } +} + + +/* Set S->gc of glyph string S to a GC suitable for drawing a mode line. + Faces to use in the mode line have already been computed when the + matrix was built, so there isn't much to do, here. */ + +static void +x_set_mode_line_face_gc (struct glyph_string *s) +{ + s->xgcv.foreground = s->face->foreground; + s->xgcv.background = s->face->background; +} + + +/* Set S->gc of glyph string S for drawing that glyph string. Set + S->stippled_p to a non-zero value if the face of S has a stipple + pattern. */ + +static void +x_set_glyph_string_gc (struct glyph_string *s) +{ + prepare_face_for_display (s->f, s->face); + + if (s->hl == DRAW_NORMAL_TEXT) + { + s->xgcv.foreground = s->face->foreground; + s->xgcv.background = s->face->background; + s->stippled_p = s->face->stipple != 0; + } + else if (s->hl == DRAW_INVERSE_VIDEO) + { + x_set_mode_line_face_gc (s); + s->stippled_p = s->face->stipple != 0; + } + else if (s->hl == DRAW_CURSOR) + { + x_set_cursor_gc (s); + s->stippled_p = false; + } + else if (s->hl == DRAW_MOUSE_FACE) + { + x_set_mouse_face_gc (s); + s->stippled_p = s->face->stipple != 0; + } + else if (s->hl == DRAW_IMAGE_RAISED || s->hl == DRAW_IMAGE_SUNKEN) + { + s->xgcv.foreground = s->face->foreground; + s->xgcv.background = s->face->background; + s->stippled_p = s->face->stipple != 0; + } + else + emacs_abort (); +} + + +/* Set clipping for output of glyph string S. S may be part of a mode + line or menu if we don't have X toolkit support. */ + +static void +x_set_glyph_string_clipping (struct glyph_string *s, cairo_t * cr) +{ + XRectangle r[2]; + int n = get_glyph_string_clip_rects (s, r, 2); + + if (n > 0) + { + for (int i = 0; i < n; i++) + { + cairo_rectangle (cr, r[i].x, r[i].y, r[i].width, r[i].height); + } + cairo_clip (cr); + } +} + + +/* Set SRC's clipping for output of glyph string DST. This is called + when we are drawing DST's left_overhang or right_overhang only in + the area of SRC. */ + +static void +x_set_glyph_string_clipping_exactly (struct glyph_string *src, + struct glyph_string *dst, cairo_t * cr) +{ + dst->clip[0].x = src->x; + dst->clip[0].y = src->y; + dst->clip[0].width = src->width; + dst->clip[0].height = src->height; + dst->num_clips = 1; + + cairo_rectangle (cr, src->x, src->y, src->width, src->height); + cairo_clip (cr); +} + + +/* RIF: + Compute left and right overhang of glyph string S. */ + +static void +pgtk_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) + { + unsigned *code = alloca (sizeof (unsigned) * s->nchars); + struct font *font = s->font; + int i; + + for (i = 0; i < s->nchars; i++) + code[i] = s->char2b[i]; + font->driver->text_extents (font, code, 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; + } +} + + +/* Fill rectangle X, Y, W, H with background color of glyph string S. */ + +static void +x_clear_glyph_string_rect (struct glyph_string *s, int x, int y, int w, int h) +{ + pgtk_fill_rectangle (s->f, s->xgcv.background, x, y, w, h); +} + + +static void +fill_background_by_face (struct frame *f, struct face *face, int x, int y, + int width, int height) +{ + cairo_t *cr = pgtk_begin_cr_clip (f); + + cairo_rectangle (cr, x, y, width, height); + cairo_clip (cr); + + double r = ((face->background >> 16) & 0xff) / 255.0; + double g = ((face->background >> 8) & 0xff) / 255.0; + double b = ((face->background >> 0) & 0xff) / 255.0; + cairo_set_source_rgb (cr, r, g, b); + cairo_paint (cr); + + if (face->stipple != 0) + { + cairo_pattern_t *mask = + FRAME_DISPLAY_INFO (f)->bitmaps[face->stipple - 1].pattern; + + double r = ((face->foreground >> 16) & 0xff) / 255.0; + double g = ((face->foreground >> 8) & 0xff) / 255.0; + double b = ((face->foreground >> 0) & 0xff) / 255.0; + cairo_set_source_rgb (cr, r, g, b); + cairo_mask (cr, mask); + } + + pgtk_end_cr_clip (f); +} + +static void +fill_background (struct glyph_string *s, int x, int y, int width, int height) +{ + fill_background_by_face (s->f, s->face, x, y, width, height); +} + +/* Draw the background of glyph_string S. If S->background_filled_p + is non-zero don't draw it. FORCE_P non-zero means draw the + background even if it wouldn't be drawn normally. This is used + when a string preceding S draws into the background of S, or S + contains the first component of a composition. */ + +static void +x_draw_glyph_string_background (struct glyph_string *s, bool force_p) +{ + /* Nothing to do if background has already been drawn or if it + shouldn't be drawn in the first place. */ + if (!s->background_filled_p) + { + int box_line_width = max (s->face->box_horizontal_line_width, 0); + + if (s->stippled_p) + { + /* Fill background with a stipple pattern. */ + + fill_background (s, + s->x, s->y + box_line_width, + s->background_width, + s->height - 2 * box_line_width); + s->background_filled_p = true; + } + else if (FONT_HEIGHT (s->font) < s->height - 2 * box_line_width + /* When xdisp.c ignores FONT_HEIGHT, we cannot trust + font dimensions, since the actual glyphs might be + much smaller. So in that case we always clear the + rectangle with background color. */ + || FONT_TOO_HIGH (s->font) + || s->font_not_found_p + || s->extends_to_end_of_line_p || force_p) + { + x_clear_glyph_string_rect (s, s->x, s->y + box_line_width, + s->background_width, + s->height - 2 * box_line_width); + s->background_filled_p = true; + } + } +} + + +static void +pgtk_draw_rectangle (struct frame *f, unsigned long color, int x, int y, + int width, int height) +{ + cairo_t *cr; + + cr = pgtk_begin_cr_clip (f); + pgtk_set_cr_source_with_color (f, color); + cairo_rectangle (cr, x + 0.5, y + 0.5, width, height); + cairo_set_line_width (cr, 1); + cairo_stroke (cr); + pgtk_end_cr_clip (f); +} + +/* Draw the foreground of glyph string S. */ + +static void +x_draw_glyph_string_foreground (struct glyph_string *s) +{ + int i, x; + + /* If first glyph of S has a left box line, start drawing the text + of S to the right of that box line. */ + if (s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p) + x = s->x + max (s->face->box_vertical_line_width, 0); + else + x = s->x; + + /* Draw characters of S as rectangles if S's font could not be + loaded. */ + if (s->font_not_found_p) + { + for (i = 0; i < s->nchars; ++i) + { + struct glyph *g = s->first_glyph + i; + pgtk_draw_rectangle (s->f, + s->face->foreground, x, s->y, + g->pixel_width - 1, s->height - 1); + x += g->pixel_width; + } + } + else + { + struct font *font = s->font; + int boff = font->baseline_offset; + int y; + + if (font->vertical_centering) + boff = VCENTER_BASELINE_OFFSET (font, s->f) - boff; + + y = s->ybase - boff; + if (s->for_overlaps || (s->background_filled_p && s->hl != DRAW_CURSOR)) + font->driver->draw (s, 0, s->nchars, x, y, false); + else + font->driver->draw (s, 0, s->nchars, x, y, true); + if (s->face->overstrike) + font->driver->draw (s, 0, s->nchars, x + 1, y, false); + } +} + +/* Draw the foreground of composite glyph string S. */ + +static void +x_draw_composite_glyph_string_foreground (struct glyph_string *s) +{ + int i, j, x; + struct font *font = s->font; + + /* If first glyph of S has a left box line, start drawing the text + of S to the right of that box line. */ + if (s->face && s->face->box != FACE_NO_BOX + && s->first_glyph->left_box_line_p) + x = s->x + max (s->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) + { + if (s->cmp_from == 0) + pgtk_draw_rectangle (s->f, s->face->foreground, x, s->y, + s->width - 1, s->height - 1); + } + 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 (s->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 (s->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 (s->face->overstrike) + font->driver->draw (s, j, i, x + 1, y, false); + } + } +} + + +/* Draw the foreground of glyph string S for glyphless characters. */ + +static void +x_draw_glyphless_glyph_string_foreground (struct glyph_string *s) +{ + struct glyph *glyph = s->first_glyph; + unsigned char2b[8]; + int x, i, j; + + /* If first glyph of S has a left box line, start drawing the text + of S to the right of that box line. */ + if (s->face && s->face->box != FACE_NO_BOX + && s->first_glyph->left_box_line_p) + x = s->x + max (s->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); + } + if (glyph->u.glyphless.method != GLYPHLESS_DISPLAY_THIN_SPACE) + pgtk_draw_rectangle (s->f, s->face->foreground, + x, s->ybase - glyph->ascent, + glyph->pixel_width - 1, + glyph->ascent + glyph->descent - 1); + x += glyph->pixel_width; + } +} + +/* Brightness beyond which a color won't have its highlight brightness + boosted. + + Nominally, highlight colors for `3d' faces are calculated by + brightening an object's color by a constant scale factor, but this + doesn't yield good results for dark colors, so for colors who's + brightness is less than this value (on a scale of 0-65535) have an + use an additional additive factor. + + The value here is set so that the default menu-bar/mode-line color + (grey75) will not have its highlights changed at all. */ +#define HIGHLIGHT_COLOR_DARK_BOOST_LIMIT 48000 + + +/* Allocate a color which is lighter or darker than *PIXEL by FACTOR + or DELTA. Try a color with RGB values multiplied by FACTOR first. + If this produces the same color as PIXEL, try a color where all RGB + values have DELTA added. Return the allocated color in *PIXEL. + DISPLAY is the X display, CMAP is the colormap to operate on. + Value is non-zero if successful. */ + +static bool +x_alloc_lighter_color (struct frame *f, unsigned long *pixel, double factor, + int delta) +{ + Emacs_Color color, new; + long bright; + bool success_p; + + /* Get RGB color values. */ + color.pixel = *pixel; + pgtk_query_color (f, &color); + + /* Change RGB values by specified FACTOR. Avoid overflow! */ + eassert (factor >= 0); + new.red = min (0xffff, factor * color.red); + new.green = min (0xffff, factor * color.green); + new.blue = min (0xffff, factor * color.blue); + + /* Calculate brightness of COLOR. */ + bright = (2 * color.red + 3 * color.green + color.blue) / 6; + + /* We only boost colors that are darker than + HIGHLIGHT_COLOR_DARK_BOOST_LIMIT. */ + if (bright < HIGHLIGHT_COLOR_DARK_BOOST_LIMIT) + /* Make an additive adjustment to NEW, because it's dark enough so + that scaling by FACTOR alone isn't enough. */ + { + /* How far below the limit this color is (0 - 1, 1 being darker). */ + double dimness = 1 - (double) bright / HIGHLIGHT_COLOR_DARK_BOOST_LIMIT; + /* The additive adjustment. */ + int min_delta = delta * dimness * factor / 2; + + if (factor < 1) + { + new.red = max (0, new.red - min_delta); + new.green = max (0, new.green - min_delta); + new.blue = max (0, new.blue - min_delta); + } + else + { + new.red = min (0xffff, min_delta + new.red); + new.green = min (0xffff, min_delta + new.green); + new.blue = min (0xffff, min_delta + new.blue); + } + } + + /* Try to allocate the color. */ + new.pixel = new.red >> 8 << 16 | new.green >> 8 << 8 | new.blue >> 8; + success_p = true; + if (success_p) + { + if (new.pixel == *pixel) + { + /* If we end up with the same color as before, try adding + delta to the RGB values. */ + new.red = min (0xffff, delta + color.red); + new.green = min (0xffff, delta + color.green); + new.blue = min (0xffff, delta + color.blue); + new.pixel = + new.red >> 8 << 16 | new.green >> 8 << 8 | new.blue >> 8; + success_p = true; + } + else + success_p = true; + *pixel = new.pixel; + } + + return success_p; +} + +static void +x_fill_trapezoid_for_relief (struct frame *f, unsigned long color, int x, + int y, int width, int height, int top_p) +{ + cairo_t *cr; + + cr = pgtk_begin_cr_clip (f); + pgtk_set_cr_source_with_color (f, color); + cairo_move_to (cr, top_p ? x : x + height, y); + cairo_line_to (cr, x, y + height); + cairo_line_to (cr, top_p ? x + width - height : x + width, y + height); + cairo_line_to (cr, x + width, y); + cairo_fill (cr); + pgtk_end_cr_clip (f); +} + +enum corners +{ + CORNER_BOTTOM_RIGHT, /* 0 -> pi/2 */ + CORNER_BOTTOM_LEFT, /* pi/2 -> pi */ + CORNER_TOP_LEFT, /* pi -> 3pi/2 */ + CORNER_TOP_RIGHT, /* 3pi/2 -> 2pi */ + CORNER_LAST +}; + +static void +x_erase_corners_for_relief (struct frame *f, unsigned long color, int x, + int y, int width, int height, double radius, + double margin, int corners) +{ + cairo_t *cr; + int i; + + cr = pgtk_begin_cr_clip (f); + pgtk_set_cr_source_with_color (f, color); + for (i = 0; i < CORNER_LAST; i++) + if (corners & (1 << i)) + { + double xm, ym, xc, yc; + + if (i == CORNER_TOP_LEFT || i == CORNER_BOTTOM_LEFT) + xm = x - margin, xc = xm + radius; + else + xm = x + width + margin, xc = xm - radius; + if (i == CORNER_TOP_LEFT || i == CORNER_TOP_RIGHT) + ym = y - margin, yc = ym + radius; + else + ym = y + height + margin, yc = ym - radius; + + cairo_move_to (cr, xm, ym); + cairo_arc (cr, xc, yc, radius, i * M_PI_2, (i + 1) * M_PI_2); + } + cairo_clip (cr); + cairo_rectangle (cr, x, y, width, height); + cairo_fill (cr); + pgtk_end_cr_clip (f); +} + +/* Set up the foreground color for drawing relief lines of glyph + string S. RELIEF is a pointer to a struct relief containing the GC + with which lines will be drawn. Use a color that is FACTOR or + DELTA lighter or darker than the relief's background which is found + in S->f->output_data.pgtk->relief_background. If such a color cannot + be allocated, use DEFAULT_PIXEL, instead. */ + +static void +x_setup_relief_color (struct frame *f, struct relief *relief, double factor, + int delta, unsigned long default_pixel) +{ + Emacs_GC xgcv; + struct pgtk_output *di = FRAME_X_OUTPUT (f); + unsigned long pixel; + unsigned long background = di->relief_background; + + /* Allocate new color. */ + xgcv.foreground = default_pixel; + pixel = background; + if (x_alloc_lighter_color (f, &pixel, factor, delta)) + xgcv.foreground = relief->pixel = pixel; + + relief->xgcv = xgcv; +} + +/* Set up colors for the relief lines around glyph string S. */ + +static void +x_setup_relief_colors (struct glyph_string *s) +{ + struct pgtk_output *di = FRAME_X_OUTPUT (s->f); + unsigned long color; + + if (s->face->use_box_color_for_shadows_p) + color = s->face->box_color; + else if (s->first_glyph->type == IMAGE_GLYPH + && s->img->pixmap + && !IMAGE_BACKGROUND_TRANSPARENT (s->img, s->f, 0)) + color = IMAGE_BACKGROUND (s->img, s->f, 0); + else + { + /* Get the background color of the face. */ + color = s->xgcv.background; + } + + if (TRUE) + { + di->relief_background = color; + x_setup_relief_color (s->f, &di->white_relief, 1.2, 0x8000, + WHITE_PIX_DEFAULT (s->f)); + x_setup_relief_color (s->f, &di->black_relief, 0.6, 0x4000, + BLACK_PIX_DEFAULT (s->f)); + } +} + + +static void +x_set_clip_rectangles (struct frame *f, cairo_t * cr, XRectangle * rectangles, + int n) +{ + if (n > 0) + { + for (int i = 0; i < n; i++) + { + cairo_rectangle (cr, + rectangles[i].x, + rectangles[i].y, + rectangles[i].width, rectangles[i].height); + } + cairo_clip (cr); + } +} + +/* Draw a relief on frame F inside the rectangle given by LEFT_X, + TOP_Y, RIGHT_X, and BOTTOM_Y. WIDTH is the thickness of the relief + to draw, it must be >= 0. RAISED_P means draw a raised + relief. LEFT_P means draw a relief on the left side of + the rectangle. RIGHT_P means draw a relief on the right + side of the rectangle. CLIP_RECT is the clipping rectangle to use + when drawing. */ + +static void +x_draw_relief_rect (struct frame *f, + 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, + XRectangle * clip_rect) +{ + unsigned long top_left_color, bottom_right_color; + int corners = 0; + + cairo_t *cr = pgtk_begin_cr_clip (f); + + if (raised_p) + { + top_left_color = FRAME_X_OUTPUT (f)->white_relief.xgcv.foreground; + bottom_right_color = FRAME_X_OUTPUT (f)->black_relief.xgcv.foreground; + } + else + { + top_left_color = FRAME_X_OUTPUT (f)->black_relief.xgcv.foreground; + bottom_right_color = FRAME_X_OUTPUT (f)->white_relief.xgcv.foreground; + } + + x_set_clip_rectangles (f, cr, clip_rect, 1); + + if (left_p) + { + pgtk_fill_rectangle (f, top_left_color, left_x, top_y, + vwidth, bottom_y + 1 - top_y); + if (top_p) + corners |= 1 << CORNER_TOP_LEFT; + if (bot_p) + corners |= 1 << CORNER_BOTTOM_LEFT; + } + if (right_p) + { + pgtk_fill_rectangle (f, bottom_right_color, right_x + 1 - vwidth, top_y, + vwidth, bottom_y + 1 - top_y); + if (top_p) + corners |= 1 << CORNER_TOP_RIGHT; + if (bot_p) + corners |= 1 << CORNER_BOTTOM_RIGHT; + } + if (top_p) + { + if (!right_p) + pgtk_fill_rectangle (f, top_left_color, left_x, top_y, + right_x + 1 - left_x, hwidth); + else + x_fill_trapezoid_for_relief (f, top_left_color, left_x, top_y, + right_x + 1 - left_x, hwidth, 1); + } + if (bot_p) + { + if (!left_p) + pgtk_fill_rectangle (f, bottom_right_color, left_x, + bottom_y + 1 - hwidth, right_x + 1 - left_x, + hwidth); + else + x_fill_trapezoid_for_relief (f, bottom_right_color, + left_x, bottom_y + 1 - hwidth, + right_x + 1 - left_x, hwidth, 0); + } + if (left_p && vwidth > 1) + pgtk_fill_rectangle (f, bottom_right_color, left_x, top_y, + 1, bottom_y + 1 - top_y); + if (top_p && hwidth > 1) + pgtk_fill_rectangle (f, bottom_right_color, left_x, top_y, + right_x + 1 - left_x, 1); + if (corners) + { + x_erase_corners_for_relief (f, FRAME_BACKGROUND_PIXEL (f), left_x, + top_y, right_x - left_x + 1, + bottom_y - top_y + 1, 6, 1, corners); + } + + pgtk_end_cr_clip (f); +} + +/* Draw a box on frame F inside the rectangle given by LEFT_X, TOP_Y, + RIGHT_X, and BOTTOM_Y. WIDTH is the thickness of the lines to + draw, it must be >= 0. LEFT_P means draw a line on the + left side of the rectangle. RIGHT_P means draw a line + on the right side of the rectangle. CLIP_RECT is the clipping + rectangle to use when drawing. */ + +static void +x_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, + XRectangle * clip_rect) +{ + unsigned long foreground_backup; + + cairo_t *cr = pgtk_begin_cr_clip (s->f); + + foreground_backup = s->xgcv.foreground; + s->xgcv.foreground = s->face->box_color; + + x_set_clip_rectangles (s->f, cr, clip_rect, 1); + + /* Top. */ + pgtk_fill_rectangle (s->f, s->xgcv.foreground, + left_x, top_y, right_x - left_x + 1, hwidth); + + /* Left. */ + if (left_p) + pgtk_fill_rectangle (s->f, s->xgcv.foreground, + left_x, top_y, vwidth, bottom_y - top_y + 1); + + /* Bottom. */ + pgtk_fill_rectangle (s->f, s->xgcv.foreground, + left_x, bottom_y - hwidth + 1, right_x - left_x + 1, + hwidth); + + /* Right. */ + if (right_p) + pgtk_fill_rectangle (s->f, s->xgcv.foreground, + right_x - vwidth + 1, top_y, vwidth, + bottom_y - top_y + 1); + + s->xgcv.foreground = foreground_backup; + + pgtk_end_cr_clip (s->f); +} + + +/* Draw a box around glyph string S. */ + +static void +x_draw_glyph_string_box (struct glyph_string *s) +{ + int hwidth, vwidth, left_x, right_x, top_y, bottom_y, last_x; + bool raised_p, left_p, right_p; + struct glyph *last_glyph; + XRectangle clip_rect; + + 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. */ + last_glyph = (s->cmp || s->img + ? s->first_glyph : s->first_glyph + s->nchars - 1); + + vwidth = eabs (s->face->box_vertical_line_width); + hwidth = eabs (s->face->box_horizontal_line_width); + raised_p = s->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 (s->face->box == FACE_SIMPLE_BOX) + x_draw_box_rect (s, left_x, top_y, right_x, bottom_y, hwidth, + vwidth, left_p, right_p, &clip_rect); + else + { + x_setup_relief_colors (s); + x_draw_relief_rect (s->f, left_x, top_y, right_x, bottom_y, hwidth, + vwidth, raised_p, true, true, left_p, right_p, + &clip_rect); + } +} + +static void +x_get_scale_factor (int *scale_x, int *scale_y) +{ + *scale_x = *scale_y = 1; +} + +static void +x_draw_horizontal_wave (struct frame *f, unsigned long color, int x, int y, + int width, int height, int wave_length) +{ + cairo_t *cr; + double dx = wave_length, dy = height - 1; + int xoffset, n; + + cr = pgtk_begin_cr_clip (f); + pgtk_set_cr_source_with_color (f, color); + cairo_rectangle (cr, x, y, width, height); + cairo_clip (cr); + + if (x >= 0) + { + xoffset = x % (wave_length * 2); + if (xoffset == 0) + xoffset = wave_length * 2; + } + else + xoffset = x % (wave_length * 2) + wave_length * 2; + n = (width + xoffset) / wave_length + 1; + if (xoffset > wave_length) + { + xoffset -= wave_length; + --n; + y += height - 1; + dy = -dy; + } + + cairo_move_to (cr, x - xoffset + 0.5, y + 0.5); + while (--n >= 0) + { + cairo_rel_line_to (cr, dx, dy); + dy = -dy; + } + cairo_set_line_width (cr, 1); + cairo_stroke (cr); + pgtk_end_cr_clip (f); +} + +/* + Draw a wavy line under S. The wave fills wave_height pixels from y0. + + x0 wave_length = 2 + -- + y0 * * * * * + |* * * * * * * * * + wave_height = 3 | * * * * + +*/ +static void +x_draw_underwave (struct glyph_string *s, unsigned long color) +{ + /* Adjust for scale/HiDPI. */ + int scale_x, scale_y; + + x_get_scale_factor (&scale_x, &scale_y); + + int wave_height = 3 * scale_y, wave_length = 2 * scale_x; + + x_draw_horizontal_wave (s->f, color, s->x, s->ybase - wave_height + 3, + s->width, wave_height, wave_length); +} + +/* Draw a relief around the image glyph string S. */ + +static void +x_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; + XRectangle r; + int x = s->x; + int y = s->ybase - image_ascent (s->img, s->face, &s->slice); + + /* If first glyph of S has a left box line, start drawing it to the + right of that line. */ + if (s->face->box != FACE_NO_BOX + && s->first_glyph->left_box_line_p + && s->slice.x == 0) + x += max (s->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 = false; + + if (s->slice.x == 0) + x -= thick + extra_x, left_p = true; + if (s->slice.y == 0) + y -= thick + extra_y, top_p = true; + if (s->slice.x + s->slice.width == s->img->width) + x1 += thick + extra_x, right_p = true; + if (s->slice.y + s->slice.height == s->img->height) + y1 += thick + extra_y, bot_p = true; + + x_setup_relief_colors (s); + get_glyph_string_clip_rect (s, &r); + x_draw_relief_rect (s->f, x, y, x1, y1, thick, thick, raised_p, + top_p, bot_p, left_p, right_p, &r); +} + +/* Draw part of the background of glyph string S. X, Y, W, and H + give the rectangle to draw. */ + +static void +x_draw_glyph_string_bg_rect (struct glyph_string *s, int x, int y, int w, + int h) +{ + if (s->stippled_p) + { + /* Fill background with a stipple pattern. */ + + fill_background (s, x, y, w, h); + } + else + x_clear_glyph_string_rect (s, x, y, w, h); +} + +static void +x_cr_draw_image (struct frame *f, Emacs_GC *gc, cairo_pattern_t *image, + int src_x, int src_y, int width, int height, + int dest_x, int dest_y, bool overlay_p) +{ + cairo_t *cr = pgtk_begin_cr_clip (f); + + if (overlay_p) + cairo_rectangle (cr, dest_x, dest_y, width, height); + else + { + pgtk_set_cr_source_with_gc_background (f, gc); + cairo_rectangle (cr, dest_x, dest_y, width, height); + cairo_fill_preserve (cr); + } + + cairo_translate (cr, dest_x - src_x, dest_y - src_y); + + cairo_surface_t *surface; + cairo_pattern_get_surface (image, &surface); + cairo_format_t format = cairo_image_surface_get_format (surface); + if (format != CAIRO_FORMAT_A8 && format != CAIRO_FORMAT_A1) + { + cairo_set_source (cr, image); + cairo_fill (cr); + } + else + { + pgtk_set_cr_source_with_gc_foreground (f, gc); + cairo_clip (cr); + cairo_mask (cr, image); + } + + pgtk_end_cr_clip (f); +} + +/* Draw foreground of image glyph string S. */ + +static void +x_draw_image_foreground (struct glyph_string *s) +{ + int x = s->x; + int y = s->ybase - image_ascent (s->img, s->face, &s->slice); + + /* If first glyph of S has a left box line, start drawing it to the + right of that line. */ + if (s->face->box != FACE_NO_BOX + && s->first_glyph->left_box_line_p + && s->slice.x == 0) + x += max (s->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->img->cr_data) + { + cairo_t *cr = pgtk_begin_cr_clip (s->f); + x_set_glyph_string_clipping (s, cr); + x_cr_draw_image (s->f, &s->xgcv, s->img->cr_data, + s->slice.x, s->slice.y, s->slice.width, s->slice.height, + x, y, true); + if (!s->img->mask) + { + /* When the image has a mask, we can expect that at + least part of a mouse highlight or a block cursor will + be visible. If the image doesn't have a mask, make + a block cursor visible by drawing a rectangle around + the image. I believe it's looking better if we do + nothing here for mouse-face. */ + if (s->hl == DRAW_CURSOR) + { + int relief = eabs (s->img->relief); + pgtk_draw_rectangle (s->f, s->xgcv.foreground, x - relief, y - relief, + s->slice.width + relief*2 - 1, + s->slice.height + relief*2 - 1); + } + } + pgtk_end_cr_clip (s->f); + } + else + /* Draw a rectangle if image could not be loaded. */ + pgtk_draw_rectangle (s->f, s->xgcv.foreground, x, y, + s->slice.width - 1, s->slice.height - 1); +} + +/* Draw image glyph string S. + + s->y + s->x +------------------------- + | s->face->box + | + | +------------------------- + | | s->img->margin + | | + | | +------------------- + | | | the image + + */ + +static void +x_draw_image_glyph_string (struct glyph_string *s) +{ + int box_line_hwidth = max (s->face->box_vertical_line_width, 0); + int box_line_vwidth = max (s->face->box_horizontal_line_width, 0); + int height; + + 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; + + /* Fill background with face under the image. Do it only if row is + taller than image or if image has a clip mask to reduce + flickering. */ + s->stippled_p = s->face->stipple != 0; + if (height > s->slice.height + || s->img->hmargin + || s->img->vmargin + || s->img->mask + || s->img->pixmap == 0 + || s->width != s->background_width) + { + { + int x = s->x; + int y = s->y; + int width = s->background_width; + + if (s->first_glyph->left_box_line_p + && s->slice.x == 0) + { + x += box_line_hwidth; + width -= box_line_hwidth; + } + + if (s->slice.y == 0) + y += box_line_vwidth; + + x_draw_glyph_string_bg_rect (s, x, y, width, height); + } + + s->background_filled_p = true; + } + + /* Draw the foreground. */ + x_draw_image_foreground (s); + + /* If we must draw a relief around the image, do it. */ + if (s->img->relief + || s->hl == DRAW_IMAGE_RAISED + || s->hl == DRAW_IMAGE_SUNKEN) + x_draw_image_relief (s); +} + +/* Draw stretch glyph string S. */ + +static void +x_draw_stretch_glyph_string (struct glyph_string *s) +{ + eassert (s->first_glyph->type == STRETCH_GLYPH); + + if (s->hl == DRAW_CURSOR && !x_stretch_cursor_p) + { + /* If `x-stretch-cursor' is nil, don't draw a block cursor as + wide as the stretch glyph. */ + 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; + + /* Draw cursor. */ + x_draw_glyph_string_bg_rect (s, x, s->y, width, s->height); + + /* Clear rest using the GC of the original non-cursor face. */ + if (width < background_width) + { + int y = s->y; + int w = background_width - width, h = s->height; + XRectangle r; + unsigned long color; + + if (!s->row->reversed_p) + x += width; + else + x = s->x; + if (s->row->mouse_face_p && cursor_in_mouse_face_p (s->w)) + { + x_set_mouse_face_gc (s); + color = s->xgcv.foreground; + } + else + color = s->face->background; + + cairo_t *cr = pgtk_begin_cr_clip (s->f); + + get_glyph_string_clip_rect (s, &r); + x_set_clip_rectangles (s->f, cr, &r, 1); + + if (s->face->stipple) + { + /* Fill background with a stipple pattern. */ + fill_background (s, x, y, w, h); + } + else + { + pgtk_fill_rectangle (s->f, color, x, y, w, h); + } + + pgtk_end_cr_clip (s->f); + } + } + else if (!s->background_filled_p) + { + int background_width = s->background_width; + int x = s->x, text_left_x = window_box_left_offset (s->w, TEXT_AREA); + + /* Don't draw into left fringe or scrollbar area except for + header line and mode line. */ + if (x < text_left_x && !s->row->mode_line_p) + { + int left_x = WINDOW_LEFT_SCROLL_BAR_AREA_WIDTH (s->w); + int right_x = text_left_x; + + if (WINDOW_HAS_FRINGES_OUTSIDE_MARGINS (s->w)) + left_x += WINDOW_LEFT_FRINGE_WIDTH (s->w); + else + right_x -= WINDOW_LEFT_FRINGE_WIDTH (s->w); + + /* Adjust X and BACKGROUND_WIDTH to fit inside the space + between LEFT_X and RIGHT_X. */ + if (x < left_x) + { + background_width -= left_x - x; + x = left_x; + } + if (x + background_width > right_x) + background_width = right_x - x; + } + if (background_width > 0) + x_draw_glyph_string_bg_rect (s, x, s->y, background_width, s->height); + } + + s->background_filled_p = true; +} + +static void +pgtk_draw_glyph_string (struct glyph_string *s) +{ + bool relief_drawn_p = false; + + /* If S draws into the background of its successors, draw the + background of the successors first so that S can draw into it. + This makes S->next use XDrawString instead of XDrawImageString. */ + 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) + { + cairo_t *cr = pgtk_begin_cr_clip (next->f); + x_set_glyph_string_gc (next); + x_set_glyph_string_clipping (next, cr); + if (next->first_glyph->type == STRETCH_GLYPH) + x_draw_stretch_glyph_string (next); + else + x_draw_glyph_string_background (next, true); + next->num_clips = 0; + pgtk_end_cr_clip (next->f); + } + } + + /* Set up S->gc, set clipping and draw S. */ + x_set_glyph_string_gc (s); + + cairo_t *cr = pgtk_begin_cr_clip (s->f); + + /* Draw relief (if any) in advance for char/composition so that the + glyph string can be drawn over it. */ + if (!s->for_overlaps + && s->face->box != FACE_NO_BOX + && (s->first_glyph->type == CHAR_GLYPH + || s->first_glyph->type == COMPOSITE_GLYPH)) + + { + x_set_glyph_string_clipping (s, cr); + x_draw_glyph_string_background (s, true); + x_draw_glyph_string_box (s); + x_set_glyph_string_clipping (s, cr); + relief_drawn_p = true; + } + else if (!s->clip_head /* draw_glyphs didn't specify a clip mask. */ + && !s->clip_tail + && ((s->prev && s->prev->hl != s->hl && s->left_overhang) + || (s->next && s->next->hl != s->hl && s->right_overhang))) + /* We must clip just this glyph. left_overhang part has already + drawn when s->prev was drawn, and right_overhang part will be + drawn later when s->next is drawn. */ + x_set_glyph_string_clipping_exactly (s, s, cr); + else + x_set_glyph_string_clipping (s, cr); + + switch (s->first_glyph->type) + { + case IMAGE_GLYPH: + x_draw_image_glyph_string (s); + break; + + case XWIDGET_GLYPH: + x_draw_xwidget_glyph_string (s); + break; + + case STRETCH_GLYPH: + x_draw_stretch_glyph_string (s); + break; + + case CHAR_GLYPH: + if (s->for_overlaps) + s->background_filled_p = true; + else + x_draw_glyph_string_background (s, false); + x_draw_glyph_string_foreground (s); + break; + + case COMPOSITE_GLYPH: + if (s->for_overlaps || (s->cmp_from > 0 + && !s->first_glyph->u.cmp.automatic)) + s->background_filled_p = true; + else + x_draw_glyph_string_background (s, true); + x_draw_composite_glyph_string_foreground (s); + break; + + case GLYPHLESS_GLYPH: + if (s->for_overlaps) + s->background_filled_p = true; + else + x_draw_glyph_string_background (s, true); + x_draw_glyphless_glyph_string_foreground (s); + break; + + default: + emacs_abort (); + } + + if (!s->for_overlaps) + { + /* Draw relief if not yet drawn. */ + if (!relief_drawn_p && s->face->box != FACE_NO_BOX) + x_draw_glyph_string_box (s); + + /* Draw underline. */ + if (s->face->underline) + { + if (s->face->underline == FACE_UNDER_WAVE) + { + if (s->face->underline_defaulted_p) + x_draw_underwave (s, s->xgcv.foreground); + else + { + x_draw_underwave (s, s->face->underline_color); + } + } + else if (s->face->underline == FACE_UNDER_LINE) + { + unsigned long thickness, position; + int y; + + if (s->prev && s->prev->face->underline + && s->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 + { + struct font *font = font_for_underline_metrics (s); + + /* Get the underline thickness. Default is 1 pixel. */ + if (font && font->underline_thickness > 0) + thickness = font->underline_thickness; + else + thickness = 1; + if (x_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 (x_use_underline_position_properties + && font && font->underline_position >= 0) + position = font->underline_position; + else if (font) + position = (font->descent + 1) / 2; + else + position = underline_minimum_offset; + } + position = max (position, underline_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; + if (s->face->underline_defaulted_p) + pgtk_fill_rectangle (s->f, s->xgcv.foreground, + s->x, y, s->width, thickness); + else + { + pgtk_fill_rectangle (s->f, s->face->underline_color, + s->x, y, s->width, thickness); + } + } + } + /* Draw overline. */ + if (s->face->overline_p) + { + unsigned long dy = 0, h = 1; + + if (s->face->overline_color_defaulted_p) + pgtk_fill_rectangle (s->f, s->xgcv.foreground, s->x, s->y + dy, + s->width, h); + else + { + pgtk_fill_rectangle (s->f, s->face->overline_color, s->x, + s->y + dy, s->width, h); + } + } + + /* Draw strike-through. */ + if (s->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->face->strike_through_color_defaulted_p) + pgtk_fill_rectangle (s->f, s->xgcv.foreground, s->x, glyph_y + dy, + s->width, h); + else + { + pgtk_fill_rectangle (s->f, s->face->strike_through_color, s->x, + glyph_y + dy, s->width, h); + } + } + + 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; + + prev->hl = s->hl; + x_set_glyph_string_gc (prev); + cairo_save (cr); + x_set_glyph_string_clipping_exactly (s, prev, cr); + if (prev->first_glyph->type == CHAR_GLYPH) + x_draw_glyph_string_foreground (prev); + else + x_draw_composite_glyph_string_foreground (prev); + prev->hl = save; + prev->num_clips = 0; + cairo_restore (cr); + } + } + + 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; + + next->hl = s->hl; + x_set_glyph_string_gc (next); + cairo_save (cr); + x_set_glyph_string_clipping_exactly (s, next, cr); + if (next->first_glyph->type == CHAR_GLYPH) + x_draw_glyph_string_foreground (next); + else + x_draw_composite_glyph_string_foreground (next); + cairo_restore (cr); + next->hl = save; + next->num_clips = 0; + next->clip_head = s->next; + } + } + } + + /* Reset clipping. */ + pgtk_end_cr_clip (s->f); + s->num_clips = 0; +} + +/* RIF: Define cursor CURSOR on frame F. */ + +static void +pgtk_define_frame_cursor (struct frame *f, Emacs_Cursor cursor) +{ + if (!f->pointer_invisible && FRAME_X_OUTPUT (f)->current_cursor != cursor) + gdk_window_set_cursor (gtk_widget_get_window (FRAME_GTK_WIDGET (f)), + cursor); + FRAME_X_OUTPUT (f)->current_cursor = cursor; +} + +static void +pgtk_after_update_window_line (struct window *w, + struct glyph_row *desired_row) +{ + struct frame *f; + int width, height; + + /* begin copy from other terms */ + eassert (w); + + if (!desired_row->mode_line_p && !w->pseudo_window_p) + desired_row->redraw_fringe_bitmaps_p = 1; + + /* When a window has disappeared, make sure that no rest of + full-width rows stays visible in the internal border. */ + 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)); + + block_input (); + pgtk_clear_frame_area (f, 0, y, width, height); + pgtk_clear_frame_area (f, + FRAME_PIXEL_WIDTH (f) - width, y, width, height); + unblock_input (); + } +} + +static void +pgtk_clear_frame_area (struct frame *f, int x, int y, int width, int height) +{ + pgtk_clear_area (f, x, y, width, height); +} + +/* Draw a hollow box cursor on window W in glyph row ROW. */ + +static void +x_draw_hollow_cursor (struct window *w, struct glyph_row *row) +{ + struct frame *f = XFRAME (WINDOW_FRAME (w)); + int x, y, wd, h; + struct glyph *cursor_glyph; + + /* Get the glyph the cursor is on. If we can't tell because + the current matrix is invalid or such, give up. */ + cursor_glyph = get_phys_cursor_glyph (w); + if (cursor_glyph == NULL) + return; + + /* Compute frame-relative coordinates for phys cursor. */ + get_phys_cursor_geometry (w, row, cursor_glyph, &x, &y, &h); + wd = w->phys_cursor_width - 1; + + /* The foreground of cursor_gc is typically the same as the normal + background color, which can cause the cursor box to be invisible. */ + cairo_t *cr = pgtk_begin_cr_clip (f); + pgtk_set_cr_source_with_color (f, FRAME_X_OUTPUT (f)->cursor_color); + + /* When on R2L character, show cursor at the right edge of the + glyph, unless the cursor box is as wide as the glyph or wider + (the latter happens when x-stretch-cursor is non-nil). */ + if ((cursor_glyph->resolved_level & 1) != 0 + && cursor_glyph->pixel_width > wd) + { + x += cursor_glyph->pixel_width - wd; + if (wd > 0) + wd -= 1; + } + /* Set clipping, draw the rectangle, and reset clipping again. */ + pgtk_clip_to_row (w, row, TEXT_AREA, cr); + pgtk_draw_rectangle (f, FRAME_X_OUTPUT (f)->cursor_color, x, y, wd, h - 1); + pgtk_end_cr_clip (f); +} + +/* Draw a bar cursor on window W in glyph row ROW. + + Implementation note: One would like to draw a bar cursor with an + angle equal to the one given by the font property XA_ITALIC_ANGLE. + Unfortunately, I didn't find a font yet that has this property set. + --gerd. */ + +static void +x_draw_bar_cursor (struct window *w, struct glyph_row *row, int width, + enum text_cursor_kinds kind) +{ + struct frame *f = XFRAME (w->frame); + struct glyph *cursor_glyph; + + /* If cursor is out of bounds, don't draw garbage. This can happen + in mini-buffer windows when switching between echo area glyphs + and mini-buffer. */ + cursor_glyph = get_phys_cursor_glyph (w); + if (cursor_glyph == NULL) + return; + + /* Experimental avoidance of cursor on xwidget. */ + if (cursor_glyph->type == XWIDGET_GLYPH) + return; + + /* If on an image, draw like a normal cursor. That's usually better + visible than drawing a bar, esp. if the image is large so that + the bar might not be in the window. */ + if (cursor_glyph->type == IMAGE_GLYPH) + { + struct glyph_row *r; + r = MATRIX_ROW (w->current_matrix, w->phys_cursor.vpos); + draw_phys_cursor_glyph (w, r, DRAW_CURSOR); + } + else + { + struct face *face = FACE_FROM_ID (f, cursor_glyph->face_id); + unsigned long color; + + cairo_t *cr = pgtk_begin_cr_clip (f); + + /* If the glyph's background equals the color we normally draw + the bars cursor in, the bar cursor in its normal color is + invisible. Use the glyph's foreground color instead in this + case, on the assumption that the glyph's colors are chosen so + that the glyph is legible. */ + if (face->background == FRAME_X_OUTPUT (f)->cursor_color) + color = face->foreground; + else + color = FRAME_X_OUTPUT (f)->cursor_color; + + pgtk_clip_to_row (w, row, TEXT_AREA, cr); + + if (kind == BAR_CURSOR) + { + int x = WINDOW_TEXT_TO_FRAME_PIXEL_X (w, w->phys_cursor.x); + + if (width < 0) + width = FRAME_CURSOR_WIDTH (f); + width = min (cursor_glyph->pixel_width, width); + + w->phys_cursor_width = width; + + /* If the character under cursor is R2L, draw the bar cursor + on the right of its glyph, rather than on the left. */ + if ((cursor_glyph->resolved_level & 1) != 0) + x += cursor_glyph->pixel_width - width; + + pgtk_fill_rectangle (f, color, x, + WINDOW_TO_FRAME_PIXEL_Y (w, w->phys_cursor.y), + width, row->height); + } + else /* HBAR_CURSOR */ + { + int dummy_x, dummy_y, dummy_h; + int x = WINDOW_TEXT_TO_FRAME_PIXEL_X (w, w->phys_cursor.x); + + if (width < 0) + width = row->height; + + width = min (row->height, width); + + get_phys_cursor_geometry (w, row, cursor_glyph, &dummy_x, + &dummy_y, &dummy_h); + + if ((cursor_glyph->resolved_level & 1) != 0 + && cursor_glyph->pixel_width > w->phys_cursor_width - 1) + x += cursor_glyph->pixel_width - w->phys_cursor_width + 1; + pgtk_fill_rectangle (f, color, x, + WINDOW_TO_FRAME_PIXEL_Y (w, w->phys_cursor.y + + row->height - width), + w->phys_cursor_width - 1, width); + } + + pgtk_end_cr_clip (f); + } +} + +/* RIF: Draw cursor on window W. */ + +static void +pgtk_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 (w->frame); + if (on_p) + { + w->phys_cursor_type = cursor_type; + w->phys_cursor_on_p = true; + + if (glyph_row->exact_window_width_line_p + && (glyph_row->reversed_p + ? (w->phys_cursor.hpos < 0) + : (w->phys_cursor.hpos >= glyph_row->used[TEXT_AREA]))) + { + glyph_row->cursor_in_fringe_p = true; + draw_fringe_bitmap (w, glyph_row, glyph_row->reversed_p); + } + else + { + switch (cursor_type) + { + case HOLLOW_BOX_CURSOR: + x_draw_hollow_cursor (w, glyph_row); + break; + + case FILLED_BOX_CURSOR: + draw_phys_cursor_glyph (w, glyph_row, DRAW_CURSOR); + break; + + case BAR_CURSOR: + x_draw_bar_cursor (w, glyph_row, cursor_width, BAR_CURSOR); + break; + + case HBAR_CURSOR: + x_draw_bar_cursor (w, glyph_row, cursor_width, HBAR_CURSOR); + break; + + case NO_CURSOR: + w->phys_cursor_width = 0; + break; + + default: + emacs_abort (); + } + } + + if (w == XWINDOW (f->selected_window)) + { + int frame_x = + WINDOW_TO_FRAME_PIXEL_X (w, x) + WINDOW_LEFT_FRINGE_WIDTH (w); + int frame_y = WINDOW_TO_FRAME_PIXEL_Y (w, y); + pgtk_im_set_cursor_location (f, frame_x, frame_y, + w->phys_cursor_width, + w->phys_cursor_height); + } + } + +} + +static void +pgtk_copy_bits (struct frame *f, cairo_rectangle_t * src_rect, + cairo_rectangle_t * dst_rect) +{ + cairo_t *cr; + cairo_surface_t *surface; /* temporary surface */ + + surface = + cairo_surface_create_similar (FRAME_CR_SURFACE (f), + CAIRO_CONTENT_COLOR_ALPHA, + (int) src_rect->width, + (int) src_rect->height); + + cr = cairo_create (surface); + cairo_set_source_surface (cr, FRAME_CR_SURFACE (f), -src_rect->x, + -src_rect->y); + cairo_rectangle (cr, 0, 0, src_rect->width, src_rect->height); + cairo_clip (cr); + cairo_paint (cr); + cairo_destroy (cr); + + cr = pgtk_begin_cr_clip (f); + cairo_set_source_surface (cr, surface, dst_rect->x, dst_rect->y); + cairo_rectangle (cr, dst_rect->x, dst_rect->y, dst_rect->width, + dst_rect->height); + cairo_clip (cr); + cairo_paint (cr); + pgtk_end_cr_clip (f); + + cairo_surface_destroy (surface); +} + +/* Scroll part of the display as described by RUN. */ + +static void +pgtk_scroll_run (struct window *w, struct run *run) +{ + struct frame *f = XFRAME (w->frame); + int x, y, width, height, from_y, to_y, bottom_y; + + /* Get frame-relative bounding box of the text display area of W, + without mode lines. Include in this box the left and right + fringe of W. */ + 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; + } + + block_input (); + +#ifdef HAVE_XWIDGETS + /* "Copy" xwidget views in the area that will be scrolled. */ + GtkWidget *tem, *parent = FRAME_GTK_WIDGET (f); + GList *children = gtk_container_get_children (GTK_CONTAINER (parent)); + GList *iter; + struct xwidget_view *view; + + for (iter = children; iter; iter = iter->next) + { + tem = iter->data; + view = g_object_get_data (G_OBJECT (tem), XG_XWIDGET_VIEW); + + if (view && !view->hidden) + { + int window_y = view->y + view->clip_top; + int window_height = view->clip_bottom - view->clip_top; + + Emacs_Rectangle r1, r2, result; + r1.x = w->pixel_left; + r1.y = from_y; + r1.width = w->pixel_width; + r1.height = height; + r2 = r1; + r2.y = window_y; + r2.height = window_height; + + /* The window is offscreen, just unmap it. */ + if (window_height == 0) + { + view->hidden = true; + gtk_widget_hide (tem); + continue; + } + + bool intersects_p = + gui_intersect_rectangles (&r1, &r2, &result); + + if (XWINDOW (view->w) == w && intersects_p) + { + int y = view->y + (to_y - from_y); + int text_area_x, text_area_y, text_area_width, text_area_height; + int clip_top, clip_bottom; + + window_box (w, view->area, &text_area_x, &text_area_y, + &text_area_width, &text_area_height); + + view->y = y; + + clip_top = 0; + clip_bottom = XXWIDGET (view->model)->height; + + if (y < text_area_y) + clip_top = text_area_y - y; + + if ((y + clip_bottom) > (text_area_y + text_area_height)) + { + clip_bottom -= (y + clip_bottom) - (text_area_y + text_area_height); + } + + view->clip_top = clip_top; + view->clip_bottom = clip_bottom; + + /* This means the view has moved offscreen. Unmap + it and hide it here. */ + if ((view->clip_bottom - view->clip_top) <= 0) + { + view->hidden = true; + gtk_widget_hide (tem); + } + else + { + gtk_fixed_move (GTK_FIXED (FRAME_GTK_WIDGET (f)), + tem, view->x + view->clip_left, + view->y + view->clip_top); + gtk_widget_set_size_request (tem, view->clip_right - view->clip_left, + view->clip_bottom - view->clip_top); + gtk_widget_queue_allocate (tem); + } + } + } + } + + g_list_free (children); +#endif + + /* Cursor off. Will be switched on again in x_update_window_end. */ + gui_clear_cursor (w); + + { + cairo_rectangle_t src_rect = { x, from_y, width, height }; + cairo_rectangle_t dst_rect = { x, to_y, width, height }; + pgtk_copy_bits (f, &src_rect, &dst_rect); + } + + unblock_input (); +} + +/* Icons. */ + +/* Make the x-window of frame F use the gnu icon bitmap. */ + +static bool +pgtk_bitmap_icon (struct frame *f, Lisp_Object file) +{ + ptrdiff_t bitmap_id; + + if (FRAME_GTK_WIDGET (f) == 0) + return true; + + /* Free up our existing icon bitmap and mask if any. */ + if (f->output_data.pgtk->icon_bitmap > 0) + image_destroy_bitmap (f, f->output_data.pgtk->icon_bitmap); + f->output_data.pgtk->icon_bitmap = 0; + + if (STRINGP (file)) + { + /* Use gtk_window_set_icon_from_file () if available, + It's not restricted to bitmaps */ + if (xg_set_icon (f, file)) + return false; + bitmap_id = image_create_bitmap_from_file (f, file); + } + else + { + /* Create the GNU bitmap and mask if necessary. */ + if (FRAME_DISPLAY_INFO (f)->icon_bitmap_id < 0) + { + ptrdiff_t rc = -1; + + if (xg_set_icon (f, xg_default_icon_file) + || xg_set_icon_from_xpm_data (f, gnu_xpm_bits)) + { + FRAME_DISPLAY_INFO (f)->icon_bitmap_id = -2; + return false; + } + + /* If all else fails, use the (black and white) xbm image. */ + if (rc == -1) + { + rc = image_create_bitmap_from_data (f, + (char *) gnu_xbm_bits, + gnu_xbm_width, + gnu_xbm_height); + if (rc == -1) + return true; + + FRAME_DISPLAY_INFO (f)->icon_bitmap_id = rc; + } + } + + /* The first time we create the GNU bitmap and mask, + this increments the ref-count one extra time. + As a result, the GNU bitmap and mask are never freed. + That way, we don't have to worry about allocating it again. */ + image_reference_bitmap (f, FRAME_DISPLAY_INFO (f)->icon_bitmap_id); + + bitmap_id = FRAME_DISPLAY_INFO (f)->icon_bitmap_id; + } + + if (FRAME_DISPLAY_INFO (f)->bitmaps[bitmap_id - 1].img != NULL) + { + gtk_window_set_icon (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), + FRAME_DISPLAY_INFO (f)->bitmaps[bitmap_id - 1].img); + } + f->output_data.pgtk->icon_bitmap = bitmap_id; + + return false; +} + + +/* Make the x-window of frame F use a rectangle with text. + Use ICON_NAME as the text. */ + +bool +pgtk_text_icon (struct frame *f, const char *icon_name) +{ + if (FRAME_GTK_OUTER_WIDGET (f)) + { + gtk_window_set_icon (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), NULL); + gtk_window_set_title (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), icon_name); + } + + return false; +} + +/*********************************************************************** + Starting and ending an update + ***********************************************************************/ + +/* Start an update of frame F. This function is installed as a hook + for update_begin, i.e. it is called when update_begin is called. + This function is called prior to calls to x_update_window_begin for + each window being updated. Currently, there is nothing to do here + because all interesting stuff is done on a window basis. */ + +static void +pgtk_update_begin (struct frame *f) +{ + pgtk_clear_under_internal_border (f); +} + +/* Draw a vertical window border from (x,y0) to (x,y1) */ + +static void +pgtk_draw_vertical_window_border (struct window *w, int x, int y0, int y1) +{ + struct frame *f = XFRAME (WINDOW_FRAME (w)); + struct face *face; + cairo_t *cr; + + cr = pgtk_begin_cr_clip (f); + + face = FACE_FROM_ID_OR_NULL (f, VERTICAL_BORDER_FACE_ID); + if (face) + pgtk_set_cr_source_with_color (f, face->foreground); + + cairo_rectangle (cr, x, y0, 1, y1 - y0); + cairo_fill (cr); + + pgtk_end_cr_clip (f); +} + +/* Draw a window divider from (x0,y0) to (x1,y1) */ + +static void +pgtk_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)); + cairo_t *cr = pgtk_begin_cr_clip (f); + + if (y1 - y0 > x1 - x0 && x1 - x0 > 2) + /* Vertical. */ + { + pgtk_set_cr_source_with_color (f, color_first); + cairo_rectangle (cr, x0, y0, 1, y1 - y0); + cairo_fill (cr); + pgtk_set_cr_source_with_color (f, color); + cairo_rectangle (cr, x0 + 1, y0, x1 - x0 - 2, y1 - y0); + cairo_fill (cr); + pgtk_set_cr_source_with_color (f, color_last); + cairo_rectangle (cr, x1 - 1, y0, 1, y1 - y0); + cairo_fill (cr); + } + else if (x1 - x0 > y1 - y0 && y1 - y0 > 3) + /* Horizontal. */ + { + pgtk_set_cr_source_with_color (f, color_first); + cairo_rectangle (cr, x0, y0, x1 - x0, 1); + cairo_fill (cr); + pgtk_set_cr_source_with_color (f, color); + cairo_rectangle (cr, x0, y0 + 1, x1 - x0, y1 - y0 - 2); + cairo_fill (cr); + pgtk_set_cr_source_with_color (f, color_last); + cairo_rectangle (cr, x0, y1 - 1, x1 - x0, 1); + cairo_fill (cr); + } + else + { + pgtk_set_cr_source_with_color (f, color); + cairo_rectangle (cr, x0, y0, x1 - x0, y1 - y0); + cairo_fill (cr); + } + + pgtk_end_cr_clip (f); +} + +/* End update of frame F. This function is installed as a hook in + update_end. */ + +static void +pgtk_update_end (struct frame *f) +{ + /* Mouse highlight may be displayed again. */ + MOUSE_HL_INFO (f)->mouse_face_defer = false; +} + +static void +pgtk_frame_up_to_date (struct frame *f) +{ + block_input (); + FRAME_MOUSE_UPDATE (f); + if (!buffer_flipping_blocked_p ()) + { + flip_cr_context (f); + gtk_widget_queue_draw (FRAME_GTK_WIDGET (f)); + } + unblock_input (); +} + +/* Return the current position of the mouse. + *FP should be a frame which indicates which display to ask about. + + If the mouse movement started in a scroll bar, set *FP, *BAR_WINDOW, + and *PART to the frame, window, and scroll bar part that the mouse + is over. Set *X and *Y to the portion and whole of the mouse's + position on the scroll bar. + + If the mouse movement started elsewhere, set *FP to the frame the + mouse is on, *BAR_WINDOW to nil, and *X and *Y to the character cell + the mouse is over. + + Set *TIMESTAMP to the server time-stamp for the time at which the mouse + was at this position. + + Don't store anything if we don't have a valid set of values to report. + + This clears the mouse_moved flag, so we can wait for the next mouse + movement. */ + +static void +pgtk_mouse_position (struct frame **fp, int insist, Lisp_Object * bar_window, + enum scroll_bar_part *part, Lisp_Object * x, + Lisp_Object * y, Time * timestamp) +{ + struct frame *f1; + struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (*fp); + int win_x, win_y; + GdkSeat *seat; + GdkDevice *device; + GdkModifierType mask; + GdkWindow *win; + + block_input (); + + Lisp_Object frame, tail; + + /* Clear the mouse-moved flag for every frame on this display. */ + FOR_EACH_FRAME (tail, frame) + if (FRAME_PGTK_P (XFRAME (frame)) + && FRAME_X_DISPLAY (XFRAME (frame)) == FRAME_X_DISPLAY (*fp)) + XFRAME (frame)->mouse_moved = false; + + dpyinfo->last_mouse_scroll_bar = NULL; + + if (gui_mouse_grabbed (dpyinfo)) + { + /* 1.1. use last_mouse_frame as frame where the pointer is on. */ + f1 = dpyinfo->last_mouse_frame; + } + else + { + f1 = *fp; + /* 1.2. get frame where the pointer is on. */ + win = gtk_widget_get_window (FRAME_GTK_WIDGET (*fp)); + seat = gdk_display_get_default_seat (dpyinfo->gdpy); + device = gdk_seat_get_pointer (seat); + win = + gdk_window_get_device_position (win, device, &win_x, &win_y, &mask); + if (win != NULL) + f1 = pgtk_any_window_to_frame (win); + else + { + /* crossing display server? */ + f1 = SELECTED_FRAME (); + } + } + + /* f1 can be a terminal frame. Bug#50322 */ + if (f1 == NULL || !FRAME_PGTK_P (f1)) + { + unblock_input (); + return; + } + + /* 2. get the display and the device. */ + win = gtk_widget_get_window (FRAME_GTK_WIDGET (f1)); + GdkDisplay *gdpy = gdk_window_get_display (win); + seat = gdk_display_get_default_seat (gdpy); + device = gdk_seat_get_pointer (seat); + + /* 3. get x, y relative to edit window of the frame. */ + win = gdk_window_get_device_position (win, device, &win_x, &win_y, &mask); + + if (f1 != NULL) + { + dpyinfo = FRAME_DISPLAY_INFO (f1); + remember_mouse_glyph (f1, win_x, win_y, &dpyinfo->last_mouse_glyph); + dpyinfo->last_mouse_glyph_frame = f1; + + *bar_window = Qnil; + *part = 0; + *fp = f1; + XSETINT (*x, win_x); + XSETINT (*y, win_y); + *timestamp = dpyinfo->last_mouse_movement_time; + } + + unblock_input (); +} + +/* Fringe bitmaps. */ + +static int max_fringe_bmp = 0; +static cairo_pattern_t **fringe_bmp = 0; + +static void +pgtk_define_fringe_bitmap (int which, unsigned short *bits, int h, int wd) +{ + int i, stride; + cairo_surface_t *surface; + unsigned char *data; + cairo_pattern_t *pattern; + + if (which >= max_fringe_bmp) + { + i = max_fringe_bmp; + max_fringe_bmp = which + 20; + fringe_bmp = + (cairo_pattern_t **) xrealloc (fringe_bmp, + max_fringe_bmp * + sizeof (cairo_pattern_t *)); + while (i < max_fringe_bmp) + fringe_bmp[i++] = 0; + } + + block_input (); + + surface = cairo_image_surface_create (CAIRO_FORMAT_A1, wd, h); + stride = cairo_image_surface_get_stride (surface); + data = cairo_image_surface_get_data (surface); + + for (i = 0; i < h; i++) + { + *((unsigned short *) data) = bits[i]; + data += stride; + } + + cairo_surface_mark_dirty (surface); + pattern = cairo_pattern_create_for_surface (surface); + cairo_surface_destroy (surface); + + unblock_input (); + + fringe_bmp[which] = pattern; +} + +static void +pgtk_destroy_fringe_bitmap (int which) +{ + if (which >= max_fringe_bmp) + return; + + if (fringe_bmp[which]) + { + block_input (); + cairo_pattern_destroy (fringe_bmp[which]); + unblock_input (); + } + fringe_bmp[which] = 0; +} + +static void +pgtk_clip_to_row (struct window *w, struct glyph_row *row, + enum glyph_row_area area, cairo_t * cr) +{ + int window_x, window_y, window_width; + cairo_rectangle_int_t rect; + + window_box (w, area, &window_x, &window_y, &window_width, 0); + + rect.x = window_x; + rect.y = WINDOW_TO_FRAME_PIXEL_Y (w, max (0, row->y)); + rect.y = max (rect.y, window_y); + rect.width = window_width; + rect.height = row->visible_height; + + cairo_rectangle (cr, rect.x, rect.y, rect.width, rect.height); + cairo_clip (cr); +} + +static void +pgtk_cr_draw_image (struct frame *f, Emacs_GC * gc, cairo_pattern_t * image, + int src_x, int src_y, int width, int height, + int dest_x, int dest_y, bool overlay_p) +{ + cairo_t *cr = pgtk_begin_cr_clip (f); + + if (overlay_p) + cairo_rectangle (cr, dest_x, dest_y, width, height); + else + { + pgtk_set_cr_source_with_gc_background (f, gc); + cairo_rectangle (cr, dest_x, dest_y, width, height); + cairo_fill_preserve (cr); + } + cairo_translate (cr, dest_x - src_x, dest_y - src_y); + + cairo_surface_t *surface; + cairo_pattern_get_surface (image, &surface); + cairo_format_t format = cairo_image_surface_get_format (surface); + if (format != CAIRO_FORMAT_A8 && format != CAIRO_FORMAT_A1) + { + cairo_set_source (cr, image); + cairo_fill (cr); + } + else + { + pgtk_set_cr_source_with_gc_foreground (f, gc); + cairo_clip (cr); + cairo_mask (cr, image); + } + + pgtk_end_cr_clip (f); +} + +static void +pgtk_draw_fringe_bitmap (struct window *w, struct glyph_row *row, + struct draw_fringe_bitmap_params *p) +{ + struct frame *f = XFRAME (WINDOW_FRAME (w)); + struct face *face = p->face; + + cairo_t *cr = pgtk_begin_cr_clip (f); + + /* Must clip because of partially visible lines. */ + pgtk_clip_to_row (w, row, ANY_AREA, cr); + + if (p->bx >= 0 && !p->overlay_p) + { + /* In case the same realized face is used for fringes and + for something displayed in the text (e.g. face `region' on + mono-displays, the fill style may have been changed to + FillSolid in x_draw_glyph_string_background. */ + if (face->stipple) + { + fill_background_by_face (f, face, p->bx, p->by, p->nx, p->ny); + } + else + { + pgtk_set_cr_source_with_color (f, face->background); + cairo_rectangle (cr, p->bx, p->by, p->nx, p->ny); + cairo_fill (cr); + } + } + + if (p->which && p->which < max_fringe_bmp) + { + Emacs_GC gcv; + + gcv.foreground = (p->cursor_p + ? (p->overlay_p ? face->background + : FRAME_X_OUTPUT (f)->cursor_color) + : face->foreground); + gcv.background = face->background; + pgtk_cr_draw_image (f, &gcv, fringe_bmp[p->which], 0, p->dh, + p->wd, p->h, p->x, p->y, p->overlay_p); + } + + pgtk_end_cr_clip (f); +} + +static struct atimer *hourglass_atimer = NULL; +static int hourglass_enter_count = 0; + +static void +hourglass_cb (struct atimer *timer) +{ + /*NOP*/} + +static void +pgtk_show_hourglass (struct frame *f) +{ + struct pgtk_output *x = FRAME_X_OUTPUT (f); + if (x->hourglass_widget != NULL) + gtk_widget_destroy (x->hourglass_widget); + x->hourglass_widget = gtk_event_box_new (); /* gtk_event_box is GDK_INPUT_ONLY. */ + gtk_widget_set_has_window (x->hourglass_widget, true); + gtk_fixed_put (GTK_FIXED (FRAME_GTK_WIDGET (f)), x->hourglass_widget, 0, 0); + gtk_widget_show (x->hourglass_widget); + gtk_widget_set_size_request (x->hourglass_widget, 30000, 30000); + gdk_window_raise (gtk_widget_get_window (x->hourglass_widget)); + gdk_window_set_cursor (gtk_widget_get_window (x->hourglass_widget), + x->hourglass_cursor); + + /* For cursor animation, we receive signals, set pending_signals, and dispatch. */ + if (hourglass_enter_count++ == 0) + { + struct timespec ts = make_timespec (0, 50 * 1000 * 1000); + if (hourglass_atimer != NULL) + cancel_atimer (hourglass_atimer); + hourglass_atimer = + start_atimer (ATIMER_CONTINUOUS, ts, hourglass_cb, NULL); + } + + /* Cursor frequently stops animation. gtk's bug? */ +} + +static void +pgtk_hide_hourglass (struct frame *f) +{ + struct pgtk_output *x = FRAME_X_OUTPUT (f); + if (--hourglass_enter_count == 0) + { + if (hourglass_atimer != NULL) + { + cancel_atimer (hourglass_atimer); + hourglass_atimer = NULL; + } + } + if (x->hourglass_widget != NULL) + { + gtk_widget_destroy (x->hourglass_widget); + x->hourglass_widget = NULL; + } +} + +/* Flushes changes to display. */ +static void +pgtk_flush_display (struct frame *f) +{ +} + +extern frame_parm_handler pgtk_frame_parm_handlers[]; + +static struct redisplay_interface pgtk_redisplay_interface = { + pgtk_frame_parm_handlers, + gui_produce_glyphs, + gui_write_glyphs, + gui_insert_glyphs, + gui_clear_end_of_line, + pgtk_scroll_run, + pgtk_after_update_window_line, + NULL, /* gui_update_window_begin, */ + NULL, /* gui_update_window_end, */ + pgtk_flush_display, + gui_clear_window_mouse_face, + gui_get_glyph_overhangs, + gui_fix_overlapping_area, + pgtk_draw_fringe_bitmap, + pgtk_define_fringe_bitmap, + pgtk_destroy_fringe_bitmap, + pgtk_compute_glyph_string_overhangs, + pgtk_draw_glyph_string, + pgtk_define_frame_cursor, + pgtk_clear_frame_area, + pgtk_clear_under_internal_border, + pgtk_draw_window_cursor, + pgtk_draw_vertical_window_border, + pgtk_draw_window_divider, + NULL, /* pgtk_shift_glyphs_for_insert, */ + pgtk_show_hourglass, + pgtk_hide_hourglass, + pgtk_default_font_parameter, +}; + +static void +pgtk_redraw_scroll_bars (struct frame *f) +{ +} + +void +pgtk_clear_frame (struct frame *f) +/* -------------------------------------------------------------------------- + External (hook): Erase the entire frame + -------------------------------------------------------------------------- */ +{ + /* comes on initial frame because we have + after-make-frame-functions = select-frame */ + if (!FRAME_DEFAULT_FACE (f)) + return; + + /* mark_window_cursors_off (XWINDOW (FRAME_ROOT_WINDOW (f))); */ + + block_input (); + + pgtk_clear_area (f, 0, 0, FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f)); + + /* as of 2006/11 or so this is now needed */ + pgtk_redraw_scroll_bars (f); + unblock_input (); +} + +/* Invert the middle quarter of the frame for .15 sec. */ + +static void +recover_from_visible_bell (struct atimer *timer) +{ + struct frame *f = timer->client_data; + + if (FRAME_X_OUTPUT (f)->cr_surface_visible_bell != NULL) + { + cairo_surface_destroy (FRAME_X_OUTPUT (f)->cr_surface_visible_bell); + FRAME_X_OUTPUT (f)->cr_surface_visible_bell = NULL; + } + + if (FRAME_X_OUTPUT (f)->atimer_visible_bell != NULL) + FRAME_X_OUTPUT (f)->atimer_visible_bell = NULL; +} + +static void +pgtk_flash (struct frame *f) +{ + block_input (); + + { + cairo_surface_t *surface_orig = FRAME_CR_SURFACE (f); + + int width = FRAME_CR_SURFACE_DESIRED_WIDTH (f); + int height = FRAME_CR_SURFACE_DESIRED_HEIGHT (f); + cairo_surface_t *surface = + cairo_surface_create_similar (surface_orig, CAIRO_CONTENT_COLOR_ALPHA, + width, height); + + cairo_t *cr = cairo_create (surface); + cairo_set_source_surface (cr, surface_orig, 0, 0); + cairo_rectangle (cr, 0, 0, width, height); + cairo_clip (cr); + cairo_paint (cr); + + cairo_set_source_rgb (cr, 1, 1, 1); + cairo_set_operator (cr, CAIRO_OPERATOR_DIFFERENCE); + + { + /* Get the height not including a menu bar widget. */ + int height = FRAME_PIXEL_HEIGHT (f); + /* Height of each line to flash. */ + int flash_height = FRAME_LINE_HEIGHT (f); + /* These will be the left and right margins of the rectangles. */ + int flash_left = FRAME_INTERNAL_BORDER_WIDTH (f); + int flash_right = + FRAME_PIXEL_WIDTH (f) - FRAME_INTERNAL_BORDER_WIDTH (f); + int width = flash_right - flash_left; + + /* If window is tall, flash top and bottom line. */ + if (height > 3 * FRAME_LINE_HEIGHT (f)) + { + cairo_rectangle (cr, + flash_left, + (FRAME_INTERNAL_BORDER_WIDTH (f) + + FRAME_TOP_MARGIN_HEIGHT (f)), + width, flash_height); + cairo_fill (cr); + + cairo_rectangle (cr, + flash_left, + (height - flash_height + - FRAME_INTERNAL_BORDER_WIDTH (f)), + width, flash_height); + cairo_fill (cr); + } + else + { + /* If it is short, flash it all. */ + cairo_rectangle (cr, + flash_left, FRAME_INTERNAL_BORDER_WIDTH (f), + width, height - 2 * FRAME_INTERNAL_BORDER_WIDTH (f)); + cairo_fill (cr); + } + + FRAME_X_OUTPUT (f)->cr_surface_visible_bell = surface; + { + struct timespec delay = make_timespec (0, 50 * 1000 * 1000); + if (FRAME_X_OUTPUT (f)->atimer_visible_bell != NULL) + { + cancel_atimer (FRAME_X_OUTPUT (f)->atimer_visible_bell); + FRAME_X_OUTPUT (f)->atimer_visible_bell = NULL; + } + FRAME_X_OUTPUT (f)->atimer_visible_bell = + start_atimer (ATIMER_RELATIVE, delay, recover_from_visible_bell, f); + } + + } + + cairo_destroy (cr); + } + + unblock_input (); +} + +/* Make audible bell. */ + +static void +pgtk_ring_bell (struct frame *f) +{ + if (visible_bell) + { + pgtk_flash (f); + } + else + { + block_input (); + gtk_widget_error_bell (FRAME_GTK_WIDGET (f)); + unblock_input (); + } +} + +/* Read events coming from the X server. + Return as soon as there are no more events to be read. + + Return the number of characters stored into the buffer, + thus pretending to be `read' (except the characters we store + in the keyboard buffer can be multibyte, so are not necessarily + C chars). */ + +static int +pgtk_read_socket (struct terminal *terminal, struct input_event *hold_quit) +{ + GMainContext *context; + bool context_acquired = false; + int count; + + count = evq_flush (hold_quit); + if (count > 0) + { + return count; + } + + context = g_main_context_default (); + context_acquired = g_main_context_acquire (context); + + block_input (); + + if (context_acquired) + { + while (g_main_context_pending (context)) + { + g_main_context_dispatch (context); + } + } + + unblock_input (); + + if (context_acquired) + g_main_context_release (context); + + count = evq_flush (hold_quit); + if (count > 0) + { + return count; + } + + return 0; +} + +/* Lisp window being scrolled. Set when starting to interact with + a toolkit scroll bar, reset to nil when ending the interaction. */ + +static Lisp_Object window_being_scrolled; + +static void +pgtk_send_scroll_bar_event (Lisp_Object window, enum scroll_bar_part part, + int portion, int whole, bool horizontal) +{ + union buffered_input_event inev; + + EVENT_INIT (inev.ie); + + inev.ie.kind = + horizontal ? HORIZONTAL_SCROLL_BAR_CLICK_EVENT : SCROLL_BAR_CLICK_EVENT; + inev.ie.frame_or_window = window; + inev.ie.arg = Qnil; + inev.ie.timestamp = 0; + inev.ie.code = 0; + inev.ie.part = part; + inev.ie.x = make_fixnum (portion); + inev.ie.y = make_fixnum (whole); + inev.ie.modifiers = 0; + + evq_enqueue (&inev); +} + + +/* Scroll bar callback for GTK scroll bars. WIDGET is the scroll + bar widget. DATA is a pointer to the scroll_bar structure. */ + +static gboolean +xg_scroll_callback (GtkRange * range, + GtkScrollType scroll, gdouble value, gpointer user_data) +{ + int whole = 0, portion = 0; + struct scroll_bar *bar = user_data; + enum scroll_bar_part part = scroll_bar_nowhere; + GtkAdjustment *adj = GTK_ADJUSTMENT (gtk_range_get_adjustment (range)); + + if (xg_ignore_gtk_scrollbar) + return false; + + switch (scroll) + { + case GTK_SCROLL_JUMP: +#if 0 + /* Buttons 1 2 or 3 must be grabbed. */ + if (FRAME_DISPLAY_INFO (f)->grabbed != 0 + && FRAME_DISPLAY_INFO (f)->grabbed < (1 << 4)) +#endif + { + if (bar->horizontal) + { + part = scroll_bar_horizontal_handle; + whole = (int) (gtk_adjustment_get_upper (adj) - + gtk_adjustment_get_page_size (adj)); + portion = min ((int) value, whole); + bar->dragging = portion; + } + else + { + part = scroll_bar_handle; + whole = gtk_adjustment_get_upper (adj) - + gtk_adjustment_get_page_size (adj); + portion = min ((int) value, whole); + bar->dragging = portion; + } + } + break; + case GTK_SCROLL_STEP_BACKWARD: + part = (bar->horizontal ? scroll_bar_left_arrow : scroll_bar_up_arrow); + bar->dragging = -1; + break; + case GTK_SCROLL_STEP_FORWARD: + part = (bar->horizontal + ? scroll_bar_right_arrow : scroll_bar_down_arrow); + bar->dragging = -1; + break; + case GTK_SCROLL_PAGE_BACKWARD: + part = (bar->horizontal + ? scroll_bar_before_handle : scroll_bar_above_handle); + bar->dragging = -1; + break; + case GTK_SCROLL_PAGE_FORWARD: + part = (bar->horizontal + ? scroll_bar_after_handle : scroll_bar_below_handle); + bar->dragging = -1; + break; + default: + break; + } + + if (part != scroll_bar_nowhere) + { + window_being_scrolled = bar->window; + pgtk_send_scroll_bar_event (bar->window, part, portion, whole, + bar->horizontal); + } + + return false; +} + +/* Callback for button release. Sets dragging to -1 when dragging is done. */ + +static gboolean +xg_end_scroll_callback (GtkWidget * widget, + GdkEventButton * event, gpointer user_data) +{ + struct scroll_bar *bar = user_data; + bar->dragging = -1; + if (WINDOWP (window_being_scrolled)) + { + pgtk_send_scroll_bar_event (window_being_scrolled, + scroll_bar_end_scroll, 0, 0, + bar->horizontal); + window_being_scrolled = Qnil; + } + + return false; +} + +#define SCROLL_BAR_NAME "verticalScrollBar" +#define SCROLL_BAR_HORIZONTAL_NAME "horizontalScrollBar" + +/* Create the widget for scroll bar BAR on frame F. Record the widget + and X window of the scroll bar in BAR. */ + +static void +x_create_toolkit_scroll_bar (struct frame *f, struct scroll_bar *bar) +{ + const char *scroll_bar_name = SCROLL_BAR_NAME; + + block_input (); + xg_create_scroll_bar (f, bar, G_CALLBACK (xg_scroll_callback), + G_CALLBACK (xg_end_scroll_callback), scroll_bar_name); + unblock_input (); +} + +static void +x_create_horizontal_toolkit_scroll_bar (struct frame *f, + struct scroll_bar *bar) +{ + const char *scroll_bar_name = SCROLL_BAR_HORIZONTAL_NAME; + + block_input (); + xg_create_horizontal_scroll_bar (f, bar, G_CALLBACK (xg_scroll_callback), + G_CALLBACK (xg_end_scroll_callback), + scroll_bar_name); + unblock_input (); +} + +/* Set the thumb size and position of scroll bar BAR. We are currently + displaying PORTION out of a whole WHOLE, and our position POSITION. */ + +static void +x_set_toolkit_scroll_bar_thumb (struct scroll_bar *bar, int portion, + int position, int whole) +{ + xg_set_toolkit_scroll_bar_thumb (bar, portion, position, whole); +} + +static void +x_set_toolkit_horizontal_scroll_bar_thumb (struct scroll_bar *bar, + int portion, int position, + int whole) +{ + xg_set_toolkit_horizontal_scroll_bar_thumb (bar, portion, position, whole); +} + + + +/* Create a scroll bar and return the scroll bar vector for it. W is + the Emacs window on which to create the scroll bar. TOP, LEFT, + WIDTH and HEIGHT are the pixel coordinates and dimensions of the + scroll bar. */ + +static struct scroll_bar * +x_scroll_bar_create (struct window *w, int top, int left, + int width, int height, bool horizontal) +{ + struct frame *f = XFRAME (w->frame); + struct scroll_bar *bar + = ALLOCATE_PSEUDOVECTOR (struct scroll_bar, prev, PVEC_OTHER); + Lisp_Object barobj; + + block_input (); + + if (horizontal) + x_create_horizontal_toolkit_scroll_bar (f, bar); + else + x_create_toolkit_scroll_bar (f, bar); + + XSETWINDOW (bar->window, w); + bar->top = top; + bar->left = left; + bar->width = width; + bar->height = height; + bar->start = 0; + bar->end = 0; + bar->dragging = -1; + bar->horizontal = horizontal; + + /* Add bar to its frame's list of scroll bars. */ + 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); + + /* Map the window/widget. */ + { + if (horizontal) + xg_update_horizontal_scrollbar_pos (f, bar->x_window, top, + left, width, max (height, 1)); + else + xg_update_scrollbar_pos (f, bar->x_window, top, + left, width, max (height, 1)); + } + + unblock_input (); + return bar; +} + +/* Destroy scroll bar BAR, and set its Emacs window's scroll bar to + nil. */ + +static void +x_scroll_bar_remove (struct scroll_bar *bar) +{ + struct frame *f = XFRAME (WINDOW_FRAME (XWINDOW (bar->window))); + block_input (); + + xg_remove_scroll_bar (f, bar->x_window); + + /* Dissociate this scroll bar from its window. */ + if (bar->horizontal) + wset_horizontal_scroll_bar (XWINDOW (bar->window), Qnil); + else + wset_vertical_scroll_bar (XWINDOW (bar->window), Qnil); + + unblock_input (); +} + +/* Set the handle of the vertical scroll bar for WINDOW to indicate + that we are displaying PORTION characters out of a total of WHOLE + characters, starting at POSITION. If WINDOW has no scroll bar, + create one. */ + +static void +pgtk_set_vertical_scroll_bar (struct window *w, int portion, int whole, + int position) +{ + struct frame *f = XFRAME (w->frame); + 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; + left = WINDOW_SCROLL_BAR_AREA_X (w); + width = WINDOW_SCROLL_BAR_AREA_WIDTH (w); + + /* Does the scroll bar exist yet? */ + if (NILP (w->vertical_scroll_bar)) + { + if (width > 0 && height > 0) + { + block_input (); + pgtk_clear_area (f, left, top, width, height); + unblock_input (); + } + + bar = x_scroll_bar_create (w, top, left, width, max (height, 1), false); + } + else + { + /* It may just need to be moved and resized. */ + unsigned int mask = 0; + + bar = XSCROLL_BAR (w->vertical_scroll_bar); + + block_input (); + + if (left != bar->left) + mask |= 1; + if (top != bar->top) + mask |= 1; + if (width != bar->width) + mask |= 1; + if (height != bar->height) + mask |= 1; + + /* Move/size the scroll bar widget. */ + if (mask) + { + /* Since toolkit scroll bars are smaller than the space reserved + for them on the frame, we have to clear "under" them. */ + if (width > 0 && height > 0) + pgtk_clear_area (f, left, top, width, height); + xg_update_scrollbar_pos (f, bar->x_window, top, + left, width, max (height, 1)); + } + + /* Remember new settings. */ + bar->left = left; + bar->top = top; + bar->width = width; + bar->height = height; + + unblock_input (); + } + + x_set_toolkit_scroll_bar_thumb (bar, portion, position, whole); + + XSETVECTOR (barobj, bar); + wset_vertical_scroll_bar (w, barobj); +} + + +static void +pgtk_set_horizontal_scroll_bar (struct window *w, int portion, int whole, + int position) +{ + struct frame *f = XFRAME (w->frame); + Lisp_Object barobj; + struct scroll_bar *bar; + int top, height, left, width; + int window_x, window_width; + int pixel_width = WINDOW_PIXEL_WIDTH (w); + + /* 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_SCROLL_BAR_AREA_HEIGHT (w); + + /* Does the scroll bar exist yet? */ + if (NILP (w->horizontal_scroll_bar)) + { + if (width > 0 && height > 0) + { + block_input (); + + /* Clear also part between window_width and + WINDOW_PIXEL_WIDTH. */ + pgtk_clear_area (f, left, top, pixel_width, height); + unblock_input (); + } + + bar = x_scroll_bar_create (w, top, left, width, height, true); + } + else + { + /* It may just need to be moved and resized. */ + unsigned int mask = 0; + + bar = XSCROLL_BAR (w->horizontal_scroll_bar); + + block_input (); + + if (left != bar->left) + mask |= 1; + if (top != bar->top) + mask |= 1; + if (width != bar->width) + mask |= 1; + if (height != bar->height) + mask |= 1; + + /* Move/size the scroll bar widget. */ + if (mask) + { + /* Since toolkit scroll bars are smaller than the space reserved + for them on the frame, we have to clear "under" them. */ + if (width > 0 && height > 0) + pgtk_clear_area (f, + WINDOW_LEFT_EDGE_X (w), top, + pixel_width - WINDOW_RIGHT_DIVIDER_WIDTH (w), + height); + xg_update_horizontal_scrollbar_pos (f, bar->x_window, top, left, + width, height); + } + + /* Remember new settings. */ + bar->left = left; + bar->top = top; + bar->width = width; + bar->height = height; + + unblock_input (); + } + + x_set_toolkit_horizontal_scroll_bar_thumb (bar, portion, position, whole); + + XSETVECTOR (barobj, bar); + wset_horizontal_scroll_bar (w, barobj); +} + +/* The following three hooks are used when we're doing a thorough + redisplay of the frame. We don't explicitly know which scroll bars + are going to be deleted, because keeping track of when windows go + away is a real pain - "Can you say set-window-configuration, boys + and girls?" Instead, we just assert at the beginning of redisplay + that *all* scroll bars are to be removed, and then save a scroll bar + from the fiery pit when we actually redisplay its window. */ + +/* Arrange for all scroll bars on FRAME to be removed at the next call + to `*judge_scroll_bars_hook'. A scroll bar may be spared if + `*redeem_scroll_bar_hook' is applied to its window before the judgment. */ + +static void +pgtk_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); + } +} + + +/* Un-mark WINDOW's scroll bar for deletion in this judgment cycle. + Note that WINDOW isn't necessarily condemned at all. */ + +static void +pgtk_redeem_scroll_bar (struct window *w) +{ + struct scroll_bar *bar; + Lisp_Object barobj; + struct frame *f; + + /* We can't redeem this window's scroll bar if it doesn't have one. */ + if (NILP (w->vertical_scroll_bar) && NILP (w->horizontal_scroll_bar)) + emacs_abort (); + + 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); + } +} + +/* Remove all scroll bars on FRAME that haven't been saved since the + last call to `*condemn_scroll_bars_hook'. */ + +static void +pgtk_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); + + x_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 void +set_fullscreen_state (struct frame *f) +{ + if (!FRAME_GTK_OUTER_WIDGET (f)) + return; + + GtkWindow *widget = GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)); + switch (f->want_fullscreen) + { + case FULLSCREEN_NONE: + gtk_window_unfullscreen (widget); + gtk_window_unmaximize (widget); + store_frame_param (f, Qfullscreen, Qnil); + break; + + case FULLSCREEN_BOTH: + gtk_window_unmaximize (widget); + gtk_window_fullscreen (widget); + store_frame_param (f, Qfullscreen, Qfullboth); + break; + + case FULLSCREEN_MAXIMIZED: + gtk_window_unfullscreen (widget); + gtk_window_maximize (widget); + store_frame_param (f, Qfullscreen, Qmaximized); + break; + + case FULLSCREEN_WIDTH: + case FULLSCREEN_HEIGHT: + /* Not supported by gtk. Ignore them. */ + break; + } + + f->want_fullscreen = FULLSCREEN_NONE; +} + +static void +pgtk_fullscreen_hook (struct frame *f) +{ + if (FRAME_VISIBLE_P (f)) + { + block_input (); + set_fullscreen_state (f); + unblock_input (); + } +} + +/* This function is called when the last frame on a display is deleted. */ +void +pgtk_delete_terminal (struct terminal *terminal) +{ + struct pgtk_display_info *dpyinfo = terminal->display_info.pgtk; + + /* Protect against recursive calls. delete_frame in + delete_terminal calls us back when it deletes our last frame. */ + if (!terminal->name) + return; + + block_input (); + + pgtk_im_finish (dpyinfo); + + /* Normally, the display is available... */ + if (dpyinfo->gdpy) + { + image_destroy_all_bitmaps (dpyinfo); + + g_clear_object (&dpyinfo->xg_cursor); + g_clear_object (&dpyinfo->vertical_scroll_bar_cursor); + g_clear_object (&dpyinfo->horizontal_scroll_bar_cursor); + g_clear_object (&dpyinfo->invisible_cursor); + if (dpyinfo->last_click_event != NULL) { + gdk_event_free (dpyinfo->last_click_event); + dpyinfo->last_click_event = NULL; + } + + xg_display_close (dpyinfo->gdpy); + + /* Do not close the connection here because it's already closed + by X(t)CloseDisplay (Bug#18403). */ + dpyinfo->gdpy = NULL; + } + + if (dpyinfo->connection >= 0) + emacs_close (dpyinfo->connection); + + dpyinfo->connection = -1; + + delete_keyboard_wait_descriptor (0); + + pgtk_delete_display (dpyinfo); + unblock_input (); +} + +/* Store F's background color into *BGCOLOR. */ +static void +pgtk_query_frame_background_color (struct frame *f, Emacs_Color * bgcolor) +{ + bgcolor->pixel = FRAME_BACKGROUND_PIXEL (f); + pgtk_query_color (f, bgcolor); +} + +static void +pgtk_free_pixmap (struct frame *_f, Emacs_Pixmap pixmap) +{ + if (pixmap) + { + xfree (pixmap->data); + xfree (pixmap); + } +} + +void +pgtk_focus_frame (struct frame *f, bool noactivate) +{ + struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); + + GtkWidget *wid = FRAME_WIDGET (f); + + if (dpyinfo->x_focus_frame != f && wid != NULL) + { + block_input (); + gtk_widget_grab_focus (wid); + unblock_input (); + } +} + + +static void +set_opacity_recursively (GtkWidget * w, gpointer data) +{ + gtk_widget_set_opacity (w, *(double *) data); + if (GTK_IS_CONTAINER (w)) + gtk_container_foreach (GTK_CONTAINER (w), set_opacity_recursively, data); +} + +static void +x_set_frame_alpha (struct frame *f) +{ + struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); + double alpha = 1.0; + double alpha_min = 1.0; + + if (dpyinfo->highlight_frame == f) + alpha = f->alpha[0]; + else + alpha = f->alpha[1]; + + if (alpha < 0.0) + return; + + if (FLOATP (Vframe_alpha_lower_limit)) + alpha_min = XFLOAT_DATA (Vframe_alpha_lower_limit); + else if (FIXNUMP (Vframe_alpha_lower_limit)) + alpha_min = (XFIXNUM (Vframe_alpha_lower_limit)) / 100.0; + + if (alpha > 1.0) + alpha = 1.0; + else if (alpha < alpha_min && alpha_min <= 1.0) + alpha = alpha_min; + +#if 0 + /* If there is a parent from the window manager, put the property there + also, to work around broken window managers that fail to do that. + Do this unconditionally as this function is called on reparent when + alpha has not changed on the frame. */ + + if (!FRAME_PARENT_FRAME (f)) + { + Window parent = x_find_topmost_parent (f); + if (parent != None) + XChangeProperty (dpy, parent, dpyinfo->Xatom_net_wm_window_opacity, + XA_CARDINAL, 32, PropModeReplace, + (unsigned char *) &opac, 1); + } +#endif + + set_opacity_recursively (FRAME_WIDGET (f), &alpha); + /* without this, blending mode is strange on wayland. */ + gtk_widget_queue_resize_no_redraw (FRAME_WIDGET (f)); +} + +static void +frame_highlight (struct frame *f) +{ + /* We used to only do this if Vx_no_window_manager was non-nil, but + the ICCCM (section 4.1.6) says that the window's border pixmap + and border pixel are window attributes which are "private to the + client", so we can always change it to whatever we want. */ + block_input (); + /* I recently started to get errors in this XSetWindowBorder, depending on + the window-manager in use, tho something more is at play since I've been + using that same window-manager binary for ever. Let's not crash just + because of this (bug#9310). */ + + GtkWidget *w = FRAME_WIDGET (f); + + char *css = + g_strdup_printf ("decoration { border: solid %dpx #%06x; }", + f->border_width, + (unsigned int) FRAME_X_OUTPUT (f)->border_pixel & 0x00ffffff); + + GtkStyleContext *ctxt = gtk_widget_get_style_context (w); + GtkCssProvider *css_provider = gtk_css_provider_new (); + gtk_css_provider_load_from_data (css_provider, css, -1, NULL); + gtk_style_context_add_provider (ctxt, GTK_STYLE_PROVIDER (css_provider), + GTK_STYLE_PROVIDER_PRIORITY_USER); + g_free (css); + + GtkCssProvider *old = FRAME_X_OUTPUT (f)->border_color_css_provider; + FRAME_X_OUTPUT (f)->border_color_css_provider = css_provider; + if (old != NULL) + { + gtk_style_context_remove_provider (ctxt, GTK_STYLE_PROVIDER (old)); + g_object_unref (old); + } + + unblock_input (); + gui_update_cursor (f, true); + x_set_frame_alpha (f); +} + +static void +frame_unhighlight (struct frame *f) +{ + /* We used to only do this if Vx_no_window_manager was non-nil, but + the ICCCM (section 4.1.6) says that the window's border pixmap + and border pixel are window attributes which are "private to the + client", so we can always change it to whatever we want. */ + block_input (); + /* Same as above for XSetWindowBorder (bug#9310). */ + + GtkWidget *w = FRAME_WIDGET (f); + + char *css = + g_strdup_printf ("decoration { border: dotted %dpx #ffffff; }", + f->border_width); + + GtkStyleContext *ctxt = gtk_widget_get_style_context (w); + GtkCssProvider *css_provider = gtk_css_provider_new (); + gtk_css_provider_load_from_data (css_provider, css, -1, NULL); + gtk_style_context_add_provider (ctxt, GTK_STYLE_PROVIDER (css_provider), + GTK_STYLE_PROVIDER_PRIORITY_USER); + g_free (css); + + GtkCssProvider *old = FRAME_X_OUTPUT (f)->border_color_css_provider; + FRAME_X_OUTPUT (f)->border_color_css_provider = css_provider; + if (old != NULL) + { + gtk_style_context_remove_provider (ctxt, GTK_STYLE_PROVIDER (old)); + g_object_unref (old); + } + + unblock_input (); + gui_update_cursor (f, true); + x_set_frame_alpha (f); +} + + +void +pgtk_frame_rehighlight (struct pgtk_display_info *dpyinfo) +{ + struct frame *old_highlight = dpyinfo->highlight_frame; + + if (dpyinfo->x_focus_frame) + { + dpyinfo->highlight_frame + = ((FRAMEP (FRAME_FOCUS_FRAME (dpyinfo->x_focus_frame))) + ? XFRAME (FRAME_FOCUS_FRAME (dpyinfo->x_focus_frame)) + : dpyinfo->x_focus_frame); + if (!FRAME_LIVE_P (dpyinfo->highlight_frame)) + { + fset_focus_frame (dpyinfo->x_focus_frame, Qnil); + dpyinfo->highlight_frame = dpyinfo->x_focus_frame; + } + } + else + dpyinfo->highlight_frame = 0; + + if (old_highlight) + frame_unhighlight (old_highlight); + if (dpyinfo->highlight_frame) + frame_highlight (dpyinfo->highlight_frame); +} + +/* The focus has changed, or we have redirected a frame's focus to + another frame (this happens when a frame uses a surrogate + mini-buffer frame). Shift the highlight as appropriate. + + The FRAME argument doesn't necessarily have anything to do with which + frame is being highlighted or un-highlighted; we only use it to find + the appropriate X display info. */ + +static void +XTframe_rehighlight (struct frame *frame) +{ + pgtk_frame_rehighlight (FRAME_DISPLAY_INFO (frame)); +} + + +/* Toggle mouse pointer visibility on frame F by using invisible cursor. */ + +static void +x_toggle_visible_pointer (struct frame *f, bool invisible) +{ + Emacs_Cursor cursor; + if (invisible) + cursor = FRAME_DISPLAY_INFO (f)->invisible_cursor; + else + cursor = f->output_data.pgtk->current_cursor; + gdk_window_set_cursor (gtk_widget_get_window (FRAME_GTK_WIDGET (f)), + cursor); + f->pointer_invisible = invisible; +} + +static void +x_setup_pointer_blanking (struct pgtk_display_info *dpyinfo) +{ + dpyinfo->toggle_visible_pointer = x_toggle_visible_pointer; + dpyinfo->invisible_cursor = + gdk_cursor_new_for_display (dpyinfo->gdpy, GDK_BLANK_CURSOR); +} + +static void +XTtoggle_invisible_pointer (struct frame *f, bool invisible) +{ + block_input (); + FRAME_DISPLAY_INFO (f)->toggle_visible_pointer (f, invisible); + unblock_input (); +} + +/* The focus has changed. Update the frames as necessary to reflect + the new situation. Note that we can't change the selected frame + here, because the Lisp code we are interrupting might become confused. + Each event gets marked with the frame in which it occurred, so the + Lisp code can tell when the switch took place by examining the events. */ + +static void +x_new_focus_frame (struct pgtk_display_info *dpyinfo, struct frame *frame) +{ + struct frame *old_focus = dpyinfo->x_focus_frame; + /* doesn't work on wayland */ + + if (frame != dpyinfo->x_focus_frame) + { + /* Set this before calling other routines, so that they see + the correct value of x_focus_frame. */ + dpyinfo->x_focus_frame = frame; + + if (old_focus && old_focus->auto_lower) + if (FRAME_GTK_OUTER_WIDGET (old_focus)) + gdk_window_lower (gtk_widget_get_window + (FRAME_GTK_OUTER_WIDGET (old_focus))); + + if (dpyinfo->x_focus_frame && dpyinfo->x_focus_frame->auto_raise) + if (FRAME_GTK_OUTER_WIDGET (dpyinfo->x_focus_frame)) + gdk_window_raise (gtk_widget_get_window + (FRAME_GTK_OUTER_WIDGET (dpyinfo->x_focus_frame))); + } + + pgtk_frame_rehighlight (dpyinfo); +} + +static void +pgtk_buffer_flipping_unblocked_hook (struct frame *f) +{ + block_input (); + flip_cr_context (f); + gtk_widget_queue_draw (FRAME_GTK_WIDGET (f)); + unblock_input (); +} + +static struct terminal * +pgtk_create_terminal (struct pgtk_display_info *dpyinfo) +/* -------------------------------------------------------------------------- + Set up use of Gtk before we make the first connection. + -------------------------------------------------------------------------- */ +{ + struct terminal *terminal; + + terminal = create_terminal (output_pgtk, &pgtk_redisplay_interface); + + terminal->display_info.pgtk = dpyinfo; + dpyinfo->terminal = terminal; + + terminal->clear_frame_hook = pgtk_clear_frame; + terminal->ring_bell_hook = pgtk_ring_bell; + terminal->toggle_invisible_pointer_hook = XTtoggle_invisible_pointer; + terminal->update_begin_hook = pgtk_update_begin; + terminal->update_end_hook = pgtk_update_end; + terminal->read_socket_hook = pgtk_read_socket; + terminal->frame_up_to_date_hook = pgtk_frame_up_to_date; + terminal->mouse_position_hook = pgtk_mouse_position; + terminal->frame_rehighlight_hook = XTframe_rehighlight; + terminal->buffer_flipping_unblocked_hook = pgtk_buffer_flipping_unblocked_hook; + terminal->frame_raise_lower_hook = pgtk_frame_raise_lower; + terminal->frame_visible_invisible_hook = pgtk_make_frame_visible_invisible; + terminal->fullscreen_hook = pgtk_fullscreen_hook; + terminal->menu_show_hook = pgtk_menu_show; + terminal->activate_menubar_hook = pgtk_activate_menubar; + terminal->popup_dialog_hook = pgtk_popup_dialog; + terminal->change_tab_bar_height_hook = x_change_tab_bar_height; + terminal->set_vertical_scroll_bar_hook = pgtk_set_vertical_scroll_bar; + terminal->set_horizontal_scroll_bar_hook = pgtk_set_horizontal_scroll_bar; + terminal->condemn_scroll_bars_hook = pgtk_condemn_scroll_bars; + terminal->redeem_scroll_bar_hook = pgtk_redeem_scroll_bar; + terminal->judge_scroll_bars_hook = pgtk_judge_scroll_bars; + terminal->get_string_resource_hook = pgtk_get_string_resource; + terminal->delete_frame_hook = x_destroy_window; + terminal->delete_terminal_hook = pgtk_delete_terminal; + terminal->query_frame_background_color = pgtk_query_frame_background_color; + terminal->defined_color_hook = pgtk_defined_color; + terminal->set_new_font_hook = pgtk_new_font; + terminal->set_bitmap_icon_hook = pgtk_bitmap_icon; + terminal->implicit_set_name_hook = pgtk_implicitly_set_name; + terminal->iconify_frame_hook = pgtk_iconify_frame; + terminal->set_scroll_bar_default_width_hook = + pgtk_set_scroll_bar_default_width; + terminal->set_scroll_bar_default_height_hook = + pgtk_set_scroll_bar_default_height; + terminal->set_window_size_hook = pgtk_set_window_size; + terminal->query_colors = pgtk_query_colors; + terminal->get_focus_frame = x_get_focus_frame; + terminal->focus_frame_hook = pgtk_focus_frame; + terminal->set_frame_offset_hook = x_set_offset; + terminal->free_pixmap = pgtk_free_pixmap; + + /* Other hooks are NULL by default. */ + + return terminal; +} + +struct pgtk_window_is_of_frame_recursive_t +{ + GdkWindow *window; + bool result; + GtkWidget *emacs_gtk_fixed; /* stop on emacsgtkfixed other than this. */ +}; + +static void +pgtk_window_is_of_frame_recursive (GtkWidget * widget, gpointer data) +{ + struct pgtk_window_is_of_frame_recursive_t *datap = data; + + if (datap->result) + return; + + if (EMACS_IS_FIXED (widget) && widget != datap->emacs_gtk_fixed) + return; + + if (gtk_widget_get_window (widget) == datap->window) + { + datap->result = true; + return; + } + + if (GTK_IS_CONTAINER (widget)) { + gtk_container_foreach (GTK_CONTAINER (widget), + pgtk_window_is_of_frame_recursive, datap); + } +} + +static bool +pgtk_window_is_of_frame (struct frame *f, GdkWindow * window) +{ + struct pgtk_window_is_of_frame_recursive_t data; + data.window = window; + data.result = false; + data.emacs_gtk_fixed = FRAME_GTK_WIDGET (f); + pgtk_window_is_of_frame_recursive (FRAME_WIDGET (f), &data); + return data.result; +} + +/* Like x_window_to_frame but also compares the window with the widget's + windows. */ +static struct frame * +pgtk_any_window_to_frame (GdkWindow * window) +{ + Lisp_Object tail, frame; + struct frame *f, *found = NULL; + + if (window == NULL) + return NULL; + + FOR_EACH_FRAME (tail, frame) + { + if (found) + break; + f = XFRAME (frame); + if (FRAME_PGTK_P (f)) + { + if (pgtk_window_is_of_frame (f, window)) + found = f; + } + } + + return found; +} + +static gboolean +pgtk_handle_event (GtkWidget *widget, GdkEvent *event, gpointer *data) +{ +#if GTK_CHECK_VERSION (3, 18, 0) + struct frame *f; + union buffered_input_event inev; + GtkWidget *frame_widget; + gint x, y; + + if (event->type == GDK_TOUCHPAD_PINCH + && (event->touchpad_pinch.phase + != GDK_TOUCHPAD_GESTURE_PHASE_END)) + { + f = pgtk_any_window_to_frame (gtk_widget_get_window (widget)); + frame_widget = FRAME_GTK_WIDGET (f); + + gtk_widget_translate_coordinates (widget, frame_widget, + lrint (event->touchpad_pinch.x), + lrint (event->touchpad_pinch.y), + &x, &y); + if (f) + { + + inev.ie.kind = PINCH_EVENT; + XSETFRAME (inev.ie.frame_or_window, f); + XSETINT (inev.ie.x, x); + XSETINT (inev.ie.y, y); + inev.ie.arg = list4 (make_float (event->touchpad_pinch.dx), + make_float (event->touchpad_pinch.dy), + make_float (event->touchpad_pinch.scale), + make_float (event->touchpad_pinch.angle_delta)); + inev.ie.modifiers = pgtk_gtk_to_emacs_modifiers (FRAME_DISPLAY_INFO (f), + event->touchpad_pinch.state); + evq_enqueue (&inev); + } + + return TRUE; + } +#endif + return FALSE; +} + +static void +pgtk_fill_rectangle (struct frame *f, unsigned long color, int x, int y, + int width, int height) +{ + cairo_t *cr; + cr = pgtk_begin_cr_clip (f); + pgtk_set_cr_source_with_color (f, color); + cairo_rectangle (cr, x, y, width, height); + cairo_fill (cr); + pgtk_end_cr_clip (f); +} + +void +pgtk_clear_under_internal_border (struct frame *f) +{ + if (FRAME_INTERNAL_BORDER_WIDTH (f) > 0 + && gtk_widget_get_realized (FRAME_GTK_OUTER_WIDGET (f))) + { + 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); + + block_input (); + + if (face) + { +#define x_fill_rectangle(f, gc, x, y, w, h) \ + fill_background_by_face (f, face, x, y, w, h) + x_fill_rectangle (f, gc, 0, margin, width, border); + x_fill_rectangle (f, gc, 0, 0, border, height); + x_fill_rectangle (f, gc, width - border, 0, border, height); + x_fill_rectangle (f, gc, 0, height - border, width, border); +#undef x_fill_rectangle + } + else + { +#define x_clear_area(f, x, y, w, h) pgtk_clear_area (f, x, y, w, h) + x_clear_area (f, 0, 0, border, height); + x_clear_area (f, 0, margin, width, border); + x_clear_area (f, width - border, 0, border, height); + x_clear_area (f, 0, height - border, width, border); +#undef x_clear_area + } + + unblock_input (); + } +} + +static gboolean +pgtk_handle_draw (GtkWidget * widget, cairo_t * cr, gpointer * data) +{ + struct frame *f; + + GdkWindow *win = gtk_widget_get_window (widget); + + if (win != NULL) + { + cairo_surface_t *src = NULL; + f = pgtk_any_window_to_frame (win); + if (f != NULL) + { + src = FRAME_X_OUTPUT (f)->cr_surface_visible_bell; + if (src == NULL && FRAME_CR_ACTIVE_CONTEXT (f) != NULL) + src = cairo_get_target (FRAME_CR_ACTIVE_CONTEXT (f)); + } + if (src != NULL) + { + cairo_set_source_surface (cr, src, 0, 0); + cairo_paint (cr); + } + } + return FALSE; +} + +static void +size_allocate (GtkWidget * widget, GtkAllocation * alloc, + gpointer user_data) +{ + struct frame *f = pgtk_any_window_to_frame (gtk_widget_get_window (widget)); + + /* Between a frame is created and not shown, size is allocated and + * this handler is called. When that, since the widget's window is + * NULL, we can't get f, pgtk_cr_update_surface_desired_size is not + * called, and its size is 0x0. That causes empty frame. + * + * Fortunately since we know f in pgtk_set_event_handler, we can get + * it through user_data; + */ + if (!f) + f = user_data; + + if (f) + { + xg_frame_resized (f, alloc->width, alloc->height); + pgtk_cr_update_surface_desired_size (f, alloc->width, alloc->height, false); + } +} + +static void +x_find_modifier_meanings (struct pgtk_display_info *dpyinfo) +{ + GdkDisplay *gdpy = dpyinfo->gdpy; + GdkKeymap *keymap = gdk_keymap_get_for_display (gdpy); + GdkModifierType state = GDK_META_MASK; + gboolean r = gdk_keymap_map_virtual_modifiers (keymap, &state); + if (r) + { + /* Meta key exists. */ + if (state == GDK_META_MASK) + { + dpyinfo->meta_mod_mask = GDK_MOD1_MASK; /* maybe this is meta. */ + dpyinfo->alt_mod_mask = 0; + } + else + { + dpyinfo->meta_mod_mask = state & ~GDK_META_MASK; + if (dpyinfo->meta_mod_mask == GDK_MOD1_MASK) + dpyinfo->alt_mod_mask = 0; + else + dpyinfo->alt_mod_mask = GDK_MOD1_MASK; + } + } + else + { + dpyinfo->meta_mod_mask = GDK_MOD1_MASK; + dpyinfo->alt_mod_mask = 0; + } + + state = GDK_SUPER_MASK; + r = gdk_keymap_map_virtual_modifiers (keymap, &state); + if (r) + { + /* Super key exists. */ + if (state == GDK_SUPER_MASK) + { + dpyinfo->super_mod_mask = GDK_MOD4_MASK; /* maybe this is super. */ + } + else + { + dpyinfo->super_mod_mask = state & ~GDK_SUPER_MASK; + } + } + else + { + dpyinfo->super_mod_mask = GDK_MOD4_MASK; + } + + state = GDK_HYPER_MASK; + r = gdk_keymap_map_virtual_modifiers (keymap, &state); + if (r) + { + /* Hyper key exists. */ + if (state == GDK_HYPER_MASK) + { + dpyinfo->hyper_mod_mask = GDK_MOD3_MASK; /* maybe this is hyper. */ + } + else + { + dpyinfo->hyper_mod_mask = state & ~GDK_HYPER_MASK; + } + } + else + { + dpyinfo->hyper_mod_mask = GDK_MOD3_MASK; + } + + /* If xmodmap says: + * $ xmodmap | grep mod4 + * mod4 Super_L (0x85), Super_R (0x86), Super_L (0xce), Hyper_L (0xcf) + * then, when mod4 is pressed, both of super and hyper are recognized ON. + * Maybe many people have such configuration, and they don't like such behavior, + * so I disable hyper if such configuration is detected. + */ + if (dpyinfo->hyper_mod_mask == dpyinfo->super_mod_mask) + dpyinfo->hyper_mod_mask = 0; +} + +static void +get_modifier_values (int *mod_ctrl, + int *mod_meta, + int *mod_alt, int *mod_hyper, int *mod_super) +{ + Lisp_Object tem; + + *mod_ctrl = ctrl_modifier; + *mod_meta = meta_modifier; + *mod_alt = alt_modifier; + *mod_hyper = hyper_modifier; + *mod_super = super_modifier; + + tem = Fget (Vx_ctrl_keysym, Qmodifier_value); + if (INTEGERP (tem)) + *mod_ctrl = XFIXNUM (tem) & INT_MAX; + tem = Fget (Vx_alt_keysym, Qmodifier_value); + if (INTEGERP (tem)) + *mod_alt = XFIXNUM (tem) & INT_MAX; + tem = Fget (Vx_meta_keysym, Qmodifier_value); + if (INTEGERP (tem)) + *mod_meta = XFIXNUM (tem) & INT_MAX; + tem = Fget (Vx_hyper_keysym, Qmodifier_value); + if (INTEGERP (tem)) + *mod_hyper = XFIXNUM (tem) & INT_MAX; + tem = Fget (Vx_super_keysym, Qmodifier_value); + if (INTEGERP (tem)) + *mod_super = XFIXNUM (tem) & INT_MAX; +} + +int +pgtk_gtk_to_emacs_modifiers (struct pgtk_display_info *dpyinfo, int state) +{ + int mod_ctrl; + int mod_meta; + int mod_alt; + int mod_hyper; + int mod_super; + int mod; + + get_modifier_values (&mod_ctrl, &mod_meta, &mod_alt, &mod_hyper, + &mod_super); + + mod = 0; + if (state & GDK_SHIFT_MASK) + mod |= shift_modifier; + if (state & GDK_CONTROL_MASK) + mod |= mod_ctrl; + if (state & dpyinfo->meta_mod_mask) + mod |= mod_meta; + if (state & dpyinfo->alt_mod_mask) + mod |= mod_alt; + if (state & dpyinfo->super_mod_mask) + mod |= mod_super; + if (state & dpyinfo->hyper_mod_mask) + mod |= mod_hyper; + return mod; +} + +int +pgtk_emacs_to_gtk_modifiers (struct pgtk_display_info *dpyinfo, int state) +{ + int mod_ctrl; + int mod_meta; + int mod_alt; + int mod_hyper; + int mod_super; + int mask; + + get_modifier_values (&mod_ctrl, &mod_meta, &mod_alt, &mod_hyper, + &mod_super); + + mask = 0; + if (state & mod_alt) + mask |= dpyinfo->alt_mod_mask; + if (state & mod_super) + mask |= dpyinfo->super_mod_mask; + if (state & mod_hyper) + mask |= dpyinfo->hyper_mod_mask; + if (state & shift_modifier) + mask |= GDK_SHIFT_MASK; + if (state & mod_ctrl) + mask |= GDK_CONTROL_MASK; + if (state & mod_meta) + mask |= dpyinfo->meta_mod_mask; + return mask; +} + +#define IsCursorKey(keysym) (0xff50 <= (keysym) && (keysym) < 0xff60) +#define IsMiscFunctionKey(keysym) (0xff60 <= (keysym) && (keysym) < 0xff6c) +#define IsKeypadKey(keysym) (0xff80 <= (keysym) && (keysym) < 0xffbe) +#define IsFunctionKey(keysym) (0xffbe <= (keysym) && (keysym) < 0xffe1) +#define IsModifierKey(keysym) \ + ((((keysym) >= GDK_KEY_Shift_L) && ((keysym) <= GDK_KEY_Hyper_R)) \ + || (((keysym) >= GDK_KEY_ISO_Lock) && ((keysym) <= GDK_KEY_ISO_Level5_Lock)) \ + || ((keysym) == GDK_KEY_Mode_switch) \ + || ((keysym) == GDK_KEY_Num_Lock)) + + +void +pgtk_enqueue_string (struct frame *f, gchar * str) +{ + gunichar *ustr; + + ustr = g_utf8_to_ucs4 (str, -1, NULL, NULL, NULL); + if (ustr == NULL) + return; + for (; *ustr != 0; ustr++) + { + union buffered_input_event inev; + Lisp_Object c = make_fixnum (*ustr); + EVENT_INIT (inev.ie); + inev.ie.kind = (SINGLE_BYTE_CHAR_P (XFIXNAT (c)) + ? ASCII_KEYSTROKE_EVENT + : MULTIBYTE_CHAR_KEYSTROKE_EVENT); + inev.ie.arg = Qnil; + inev.ie.code = XFIXNAT (c); + XSETFRAME (inev.ie.frame_or_window, f); + inev.ie.modifiers = 0; + inev.ie.timestamp = 0; + evq_enqueue (&inev); + } + +} + +void +pgtk_enqueue_preedit (struct frame *f, Lisp_Object preedit) +{ + union buffered_input_event inev; + EVENT_INIT (inev.ie); + inev.ie.kind = PGTK_PREEDIT_TEXT_EVENT; + inev.ie.arg = preedit; + inev.ie.code = 0; + XSETFRAME (inev.ie.frame_or_window, f); + inev.ie.modifiers = 0; + inev.ie.timestamp = 0; + evq_enqueue (&inev); +} + +static gboolean +key_press_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data) +{ + struct coding_system coding; + union buffered_input_event inev; + ptrdiff_t nbytes = 0; + Mouse_HLInfo *hlinfo; + + USE_SAFE_ALLOCA; + + EVENT_INIT (inev.ie); + inev.ie.kind = NO_EVENT; + inev.ie.arg = Qnil; + + struct frame *f = pgtk_any_window_to_frame (gtk_widget_get_window (widget)); + hlinfo = MOUSE_HL_INFO (f); + + /* If mouse-highlight is an integer, input clears out + mouse highlighting. */ + if (!hlinfo->mouse_face_hidden && INTEGERP (Vmouse_highlight)) + { + clear_mouse_face (hlinfo); + hlinfo->mouse_face_hidden = true; + } + + if (f != 0) + { + /* While super is pressed, gtk_im_context_filter_keypress() always process the + * key events ignoring super. + * As a work around, don't call it while super or hyper are pressed... + */ + struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); + if (!(event->key.state & (dpyinfo->super_mod_mask | dpyinfo->hyper_mod_mask))) + { + if (pgtk_im_filter_keypress (f, &event->key)) + return TRUE; + } + } + + if (f != 0) + { + guint keysym, orig_keysym; + /* al%imercury@uunet.uu.net says that making this 81 + instead of 80 fixed a bug whereby meta chars made + his Emacs hang. + + It seems that some version of XmbLookupString has + a bug of not returning XBufferOverflow in + status_return even if the input is too long to + fit in 81 bytes. So, we must prepare sufficient + bytes for copy_buffer. 513 bytes (256 chars for + two-byte character set) seems to be a fairly good + approximation. -- 2000.8.10 handa@etl.go.jp */ + unsigned char copy_buffer[513]; + unsigned char *copy_bufptr = copy_buffer; + int copy_bufsiz = sizeof (copy_buffer); + int modifiers; + Lisp_Object coding_system = Qlatin_1; + Lisp_Object c; + guint state = event->key.state; + + state |= + pgtk_emacs_to_gtk_modifiers (FRAME_DISPLAY_INFO (f), + extra_keyboard_modifiers); + modifiers = state; + + /* This will have to go some day... */ + + /* make_lispy_event turns chars into control chars. + Don't do it here because XLookupString is too eager. */ + state &= ~GDK_CONTROL_MASK; + state &= ~(GDK_META_MASK + | GDK_SUPER_MASK | GDK_HYPER_MASK | GDK_MOD1_MASK); + + nbytes = event->key.length; + if (nbytes > copy_bufsiz) + nbytes = copy_bufsiz; + memcpy (copy_bufptr, event->key.string, nbytes); + + keysym = event->key.keyval; + orig_keysym = keysym; + + /* Common for all keysym input events. */ + XSETFRAME (inev.ie.frame_or_window, f); + inev.ie.modifiers = + pgtk_gtk_to_emacs_modifiers (FRAME_DISPLAY_INFO (f), modifiers); + inev.ie.timestamp = event->key.time; + + /* 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 done; + } + + /* 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 done; + } + + /* Now non-ASCII. */ + if (HASH_TABLE_P (Vpgtk_keysym_table) + && (c = Fgethash (make_fixnum (keysym), + Vpgtk_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 done; + } + + /* Random non-modifier sorts of keysyms. */ + if (((keysym >= GDK_KEY_BackSpace && keysym <= GDK_KEY_Escape) + || keysym == GDK_KEY_Delete +#ifdef GDK_KEY_ISO_Left_Tab + || (keysym >= GDK_KEY_ISO_Left_Tab && keysym <= GDK_KEY_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. */ + || (GDK_KEY_Select <= keysym && keysym < GDK_KEY_KP_Space) +#endif +#ifdef GDK_KEY_dead_circumflex + || orig_keysym == GDK_KEY_dead_circumflex +#endif +#ifdef GDK_KEY_dead_grave + || orig_keysym == GDK_KEY_dead_grave +#endif +#ifdef GDK_KEY_dead_tilde + || orig_keysym == GDK_KEY_dead_tilde +#endif +#ifdef GDK_KEY_dead_diaeresis + || orig_keysym == GDK_KEY_dead_diaeresis +#endif +#ifdef GDK_KEY_dead_macron + || orig_keysym == GDK_KEY_dead_macron +#endif +#ifdef GDK_KEY_dead_degree + || orig_keysym == GDK_KEY_dead_degree +#endif +#ifdef GDK_KEY_dead_acute + || orig_keysym == GDK_KEY_dead_acute +#endif +#ifdef GDK_KEY_dead_cedilla + || orig_keysym == GDK_KEY_dead_cedilla +#endif +#ifdef GDK_KEY_dead_breve + || orig_keysym == GDK_KEY_dead_breve +#endif +#ifdef GDK_KEY_dead_ogonek + || orig_keysym == GDK_KEY_dead_ogonek +#endif +#ifdef GDK_KEY_dead_caron + || orig_keysym == GDK_KEY_dead_caron +#endif +#ifdef GDK_KEY_dead_doubleacute + || orig_keysym == GDK_KEY_dead_doubleacute +#endif +#ifdef GDK_KEY_dead_abovedot + || orig_keysym == GDK_KEY_dead_abovedot +#endif + || IsKeypadKey (keysym) /* 0xff80 <= x < 0xffbe */ + || IsFunctionKey (keysym) /* 0xffbe <= x < 0xffe1 */ + /* Any "vendor-specific" key is ok. */ + || (orig_keysym & (1 << 28)) + || (keysym != GDK_KEY_VoidSymbol && nbytes == 0)) + && !(event->key.is_modifier + /* Gtk's modifier keys are different from Xlib's ones. + * I need to exclude them. + */ + || IsModifierKey (orig_keysym) + /* The symbols from GDK_KEY_ISO_Lock + to GDK_KEY_ISO_Last_Group_Lock + don't have real modifiers but + should be treated similarly to + Mode_switch by Emacs. */ +#if defined GDK_KEY_ISO_Lock && defined GDK_KEY_ISO_Last_Group_Lock + || (GDK_KEY_ISO_Lock <= orig_keysym + && orig_keysym <= GDK_KEY_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 done; + } + + { /* Raw bytes, not keysym. */ + ptrdiff_t i; + int nchars, len; + + 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. */ + + /* The input should be decoded with locale `coding_system'. */ + if (!NILP (Vlocale_coding_system)) + coding_system = Vlocale_coding_system; + setup_coding_system (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, copy_bufptr, nbytes, Qnil); + nbytes = coding.produced; + nchars = coding.produced_char; + copy_bufptr = coding.destination; + } + + /* Convert the input data to a sequence of + character events. */ + for (i = 0; i < nbytes; i += len) + { + int ch; + if (nchars == nbytes) + ch = copy_bufptr[i], len = 1; + else + ch = string_char_and_length (copy_bufptr + i, &len); + inev.ie.kind = (SINGLE_BYTE_CHAR_P (ch) + ? ASCII_KEYSTROKE_EVENT + : MULTIBYTE_CHAR_KEYSTROKE_EVENT); + inev.ie.code = ch; + evq_enqueue (&inev); + } + + /* count += nchars; */ + + inev.ie.kind = NO_EVENT; /* Already stored above. */ + + if (keysym == GDK_KEY_VoidSymbol) + goto done; + } + } + +done: + if (inev.ie.kind != NO_EVENT) + { + XSETFRAME (inev.ie.frame_or_window, f); + evq_enqueue (&inev); + /* count++; */ + } + + SAFE_FREE (); + + return TRUE; +} + +static gboolean +key_release_event (GtkWidget *widget, + GdkEvent *event, + gpointer *user_data) +{ + return TRUE; +} + +static gboolean +configure_event (GtkWidget *widget, + GdkEvent *event, + gpointer *user_data) +{ + struct frame *f = pgtk_any_window_to_frame (event->configure.window); + if (f && widget == FRAME_GTK_OUTER_WIDGET (f)) + { + if (any_help_event_p) + { + Lisp_Object frame; + if (f) + XSETFRAME (frame, f); + else + frame = Qnil; + help_echo_string = Qnil; + gen_help_event (Qnil, frame, Qnil, Qnil, 0); + } + } + return FALSE; +} + +static gboolean +map_event (GtkWidget *widget, + GdkEvent *event, + gpointer *user_data) +{ + struct frame *f = pgtk_any_window_to_frame (event->any.window); + union buffered_input_event inev; + + EVENT_INIT (inev.ie); + inev.ie.kind = NO_EVENT; + inev.ie.arg = Qnil; + + if (f) + { + bool iconified = FRAME_ICONIFIED_P (f); + + /* Check if fullscreen was specified before we where mapped the + first time, i.e. from the command line. */ + if (!FRAME_X_OUTPUT (f)->has_been_visible) + { + set_fullscreen_state (f); + } + + if (!iconified) + { + /* The `z-group' is reset every time a frame becomes + invisible. Handle this here. */ + if (FRAME_Z_GROUP (f) == z_group_above) + x_set_z_group (f, Qabove, Qnil); + else if (FRAME_Z_GROUP (f) == z_group_below) + x_set_z_group (f, Qbelow, Qnil); + } + + SET_FRAME_VISIBLE (f, 1); + SET_FRAME_ICONIFIED (f, false); + FRAME_X_OUTPUT (f)->has_been_visible = true; + + if (iconified) + { + inev.ie.kind = DEICONIFY_EVENT; + XSETFRAME (inev.ie.frame_or_window, f); + } + } + + if (inev.ie.kind != NO_EVENT) + evq_enqueue (&inev); + return FALSE; +} + +static gboolean +window_state_event (GtkWidget *widget, + GdkEvent *event, + gpointer *user_data) +{ + struct frame *f = pgtk_any_window_to_frame (event->window_state.window); + union buffered_input_event inev; + + EVENT_INIT (inev.ie); + inev.ie.kind = NO_EVENT; + inev.ie.arg = Qnil; + + if (f) + { + if (event->window_state.new_window_state & GDK_WINDOW_STATE_FOCUSED) + { + if (FRAME_ICONIFIED_P (f)) + { + /* Gnome shell does not iconify us when C-z is pressed. + It hides the frame. So if our state says we aren't + hidden anymore, treat it as deiconified. */ + SET_FRAME_VISIBLE (f, 1); + SET_FRAME_ICONIFIED (f, false); + FRAME_X_OUTPUT (f)->has_been_visible = true; + inev.ie.kind = DEICONIFY_EVENT; + XSETFRAME (inev.ie.frame_or_window, f); + } + } + } + + if (inev.ie.kind != NO_EVENT) + evq_enqueue (&inev); + return FALSE; +} + +static gboolean +delete_event (GtkWidget *widget, + GdkEvent *event, gpointer *user_data) +{ + struct frame *f = pgtk_any_window_to_frame (event->any.window); + union buffered_input_event inev; + + EVENT_INIT (inev.ie); + inev.ie.kind = NO_EVENT; + inev.ie.arg = Qnil; + + if (f) + { + inev.ie.kind = DELETE_WINDOW_EVENT; + XSETFRAME (inev.ie.frame_or_window, f); + } + + if (inev.ie.kind != NO_EVENT) + evq_enqueue (&inev); + return TRUE; +} + +/* The focus may have changed. Figure out if it is a real focus change, + by checking both FocusIn/Out and Enter/LeaveNotify events. + + Returns FOCUS_IN_EVENT event in *BUFP. */ + +/* Handle FocusIn and FocusOut state changes for FRAME. + If FRAME has focus and there exists more than one frame, puts + a FOCUS_IN_EVENT into *BUFP. */ + +static void +x_focus_changed (gboolean is_enter, int state, + struct pgtk_display_info *dpyinfo, struct frame *frame, + union buffered_input_event *bufp) +{ + if (is_enter) + { + if (dpyinfo->x_focus_event_frame != frame) + { + x_new_focus_frame (dpyinfo, frame); + dpyinfo->x_focus_event_frame = frame; + + /* Don't stop displaying the initial startup message + for a switch-frame event we don't need. */ + /* When run as a daemon, Vterminal_frame is always NIL. */ + bufp->ie.arg = (((NILP (Vterminal_frame) + || !FRAME_PGTK_P (XFRAME (Vterminal_frame)) + || EQ (Fdaemonp (), Qt)) + && CONSP (Vframe_list) + && !NILP (XCDR (Vframe_list))) ? Qt : Qnil); + bufp->ie.kind = FOCUS_IN_EVENT; + XSETFRAME (bufp->ie.frame_or_window, frame); + } + + frame->output_data.pgtk->focus_state |= state; + + } + else + { + frame->output_data.pgtk->focus_state &= ~state; + + if (dpyinfo->x_focus_event_frame == frame) + { + dpyinfo->x_focus_event_frame = 0; + x_new_focus_frame (dpyinfo, 0); + + bufp->ie.kind = FOCUS_OUT_EVENT; + XSETFRAME (bufp->ie.frame_or_window, frame); + } + + if (frame->pointer_invisible) + XTtoggle_invisible_pointer (frame, false); + } +} + +static gboolean +enter_notify_event (GtkWidget *widget, GdkEvent *event, + gpointer *user_data) +{ + union buffered_input_event inev; + struct frame *frame = + pgtk_any_window_to_frame (gtk_widget_get_window (widget)); + if (frame == NULL) + return FALSE; + struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (frame); + struct frame *focus_frame = dpyinfo->x_focus_frame; + int focus_state + = focus_frame ? focus_frame->output_data.pgtk->focus_state : 0; + + EVENT_INIT (inev.ie); + inev.ie.kind = NO_EVENT; + inev.ie.arg = Qnil; + + if (event->crossing.detail != GDK_NOTIFY_INFERIOR + && event->crossing.focus && !(focus_state & FOCUS_EXPLICIT)) + x_focus_changed (TRUE, FOCUS_IMPLICIT, dpyinfo, frame, &inev); + if (inev.ie.kind != NO_EVENT) + evq_enqueue (&inev); + return TRUE; +} + +static gboolean +leave_notify_event (GtkWidget *widget, GdkEvent *event, + gpointer *user_data) +{ + union buffered_input_event inev; + struct frame *frame = + pgtk_any_window_to_frame (gtk_widget_get_window (widget)); + if (frame == NULL) + return FALSE; + struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (frame); + struct frame *focus_frame = dpyinfo->x_focus_frame; + int focus_state + = focus_frame ? focus_frame->output_data.pgtk->focus_state : 0; + Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (frame); + + if (frame == 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; + } + + EVENT_INIT (inev.ie); + inev.ie.kind = NO_EVENT; + inev.ie.arg = Qnil; + + if (event->crossing.detail != GDK_NOTIFY_INFERIOR + && event->crossing.focus && !(focus_state & FOCUS_EXPLICIT)) + x_focus_changed (FALSE, FOCUS_IMPLICIT, dpyinfo, frame, &inev); + + if (frame) + { + if (any_help_event_p) + { + Lisp_Object frame_obj; + XSETFRAME (frame_obj, frame); + help_echo_string = Qnil; + gen_help_event (Qnil, frame_obj, Qnil, Qnil, 0); + } + } + + if (inev.ie.kind != NO_EVENT) + evq_enqueue (&inev); + return TRUE; +} + +static gboolean +focus_in_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data) +{ + union buffered_input_event inev; + struct frame *frame = + pgtk_any_window_to_frame (gtk_widget_get_window (widget)); + + if (frame == NULL) + return TRUE; + + EVENT_INIT (inev.ie); + inev.ie.kind = NO_EVENT; + inev.ie.arg = Qnil; + + x_focus_changed (TRUE, FOCUS_EXPLICIT, + FRAME_DISPLAY_INFO (frame), frame, &inev); + if (inev.ie.kind != NO_EVENT) + evq_enqueue (&inev); + + pgtk_im_focus_in (frame); + + return TRUE; +} + +static gboolean +focus_out_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data) +{ + union buffered_input_event inev; + struct frame *frame = + pgtk_any_window_to_frame (gtk_widget_get_window (widget)); + + if (frame == NULL) + return TRUE; + + EVENT_INIT (inev.ie); + inev.ie.kind = NO_EVENT; + inev.ie.arg = Qnil; + + x_focus_changed (FALSE, FOCUS_EXPLICIT, + FRAME_DISPLAY_INFO (frame), frame, &inev); + if (inev.ie.kind != NO_EVENT) + evq_enqueue (&inev); + + pgtk_im_focus_out (frame); + + return TRUE; +} + +/* Function to report a mouse movement to the mainstream Emacs code. + The input handler calls this. + + We have received a mouse movement event, which is given in *event. + If the mouse is over a different glyph than it was last time, tell + the mainstream emacs code by setting mouse_moved. If not, ask for + another motion event, so we can check again the next time it moves. */ + +static bool +note_mouse_movement (struct frame *frame, const GdkEventMotion * event) +{ + XRectangle *r; + struct pgtk_display_info *dpyinfo; + + if (!FRAME_X_OUTPUT (frame)) + return false; + + dpyinfo = FRAME_DISPLAY_INFO (frame); + dpyinfo->last_mouse_movement_time = event->time; + dpyinfo->last_mouse_motion_frame = frame; + dpyinfo->last_mouse_motion_x = event->x; + dpyinfo->last_mouse_motion_y = event->y; + + if (event->window != gtk_widget_get_window (FRAME_GTK_WIDGET (frame))) + { + frame->mouse_moved = true; + dpyinfo->last_mouse_scroll_bar = NULL; + note_mouse_highlight (frame, -1, -1); + dpyinfo->last_mouse_glyph_frame = NULL; + return true; + } + + + /* Has the mouse moved off the glyph it was on at the last sighting? */ + r = &dpyinfo->last_mouse_glyph; + if (frame != dpyinfo->last_mouse_glyph_frame + || event->x < r->x || event->x >= r->x + r->width + || event->y < r->y || event->y >= r->y + r->height) + { + frame->mouse_moved = true; + dpyinfo->last_mouse_scroll_bar = NULL; + note_mouse_highlight (frame, event->x, event->y); + /* Remember which glyph we're now on. */ + remember_mouse_glyph (frame, event->x, event->y, r); + dpyinfo->last_mouse_glyph_frame = frame; + return true; + } + + return false; +} + +static gboolean +motion_notify_event (GtkWidget * widget, GdkEvent * event, + gpointer * user_data) +{ + union buffered_input_event inev; + struct frame *f, *frame; + struct pgtk_display_info *dpyinfo; + Mouse_HLInfo *hlinfo; + + /* This is needed to make pointer visible when motion_notify event */ + pending_signals = true; + + EVENT_INIT (inev.ie); + inev.ie.kind = NO_EVENT; + inev.ie.arg = Qnil; + + previous_help_echo_string = help_echo_string; + help_echo_string = Qnil; + + frame = pgtk_any_window_to_frame (gtk_widget_get_window (widget)); + dpyinfo = FRAME_DISPLAY_INFO (frame); + f = (gui_mouse_grabbed (dpyinfo) ? dpyinfo->last_mouse_frame + : pgtk_any_window_to_frame (gtk_widget_get_window (widget))); + hlinfo = MOUSE_HL_INFO (f); + + if (hlinfo->mouse_face_hidden) + { + hlinfo->mouse_face_hidden = false; + clear_mouse_face (hlinfo); + } + + if (f && xg_event_is_for_scrollbar (f, event)) + f = 0; + 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) + /* 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, event->motion.x, event->motion.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 (!note_mouse_movement (f, &event->motion)) + help_echo_string = previous_help_echo_string; + } + else + { + /* 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. */ + int do_help = 0; + if (!NILP (help_echo_string) || !NILP (previous_help_echo_string)) + do_help = 1; + + if (inev.ie.kind != NO_EVENT) + evq_enqueue (&inev); + + if (do_help > 0) + { + Lisp_Object frame; + + if (f) + XSETFRAME (frame, f); + else + frame = Qnil; + + any_help_event_p = true; + gen_help_event (help_echo_string, frame, help_echo_window, + help_echo_object, help_echo_pos); + } + + return TRUE; +} + +/* Mouse clicks and mouse movement. Rah. + + Formerly, we used PointerMotionHintMask (in standard_event_mask) + so that we would have to call XQueryPointer after each MotionNotify + event to ask for another such event. However, this made mouse tracking + slow, and there was a bug that made it eventually stop. + + Simply asking for MotionNotify all the time seems to work better. + + In order to avoid asking for motion events and then throwing most + of them away or busy-polling the server for mouse positions, we ask + the server for pointer motion hints. This means that we get only + one event per group of mouse movements. "Groups" are delimited by + other kinds of events (focus changes and button clicks, for + example), or by XQueryPointer calls; when one of these happens, we + get another MotionNotify event the next time the mouse moves. This + is at least as efficient as getting motion events when mouse + tracking is on, and I suspect only negligibly worse when tracking + is off. */ + +/* Prepare a mouse-event in *RESULT for placement in the input queue. + + If the event is a button press, then note that we have grabbed + the mouse. */ + +static Lisp_Object +construct_mouse_click (struct input_event *result, + const GdkEventButton * event, struct frame *f) +{ + /* Make the event type NO_EVENT; we'll change that when we decide + otherwise. */ + result->kind = MOUSE_CLICK_EVENT; + result->code = event->button - 1; + result->timestamp = event->time; + result->modifiers = + (pgtk_gtk_to_emacs_modifiers (FRAME_DISPLAY_INFO (f), event->state) | + (event->type == GDK_BUTTON_RELEASE ? up_modifier : down_modifier)); + + XSETINT (result->x, event->x); + XSETINT (result->y, event->y); + XSETFRAME (result->frame_or_window, f); + result->arg = Qnil; + return Qnil; +} + +static gboolean +button_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data) +{ + union buffered_input_event inev; + struct frame *f, *frame; + struct pgtk_display_info *dpyinfo; + + /* If we decide we want to generate an event to be seen + by the rest of Emacs, we put it here. */ + bool tab_bar_p = false; + bool tool_bar_p = false; + Lisp_Object tab_bar_arg = Qnil; + + EVENT_INIT (inev.ie); + inev.ie.kind = NO_EVENT; + inev.ie.arg = Qnil; + + /* ignore double click and triple click. */ + if (event->type != GDK_BUTTON_PRESS && event->type != GDK_BUTTON_RELEASE) + return TRUE; + + frame = pgtk_any_window_to_frame (gtk_widget_get_window (widget)); + dpyinfo = FRAME_DISPLAY_INFO (frame); + + dpyinfo->last_mouse_glyph_frame = NULL; +#if 0 + x_display_set_last_user_time (dpyinfo, event->button.time); +#endif + + if (gui_mouse_grabbed (dpyinfo)) + f = dpyinfo->last_mouse_frame; + else + { + f = pgtk_any_window_to_frame (gtk_widget_get_window (widget)); + + if (f && event->button.type == GDK_BUTTON_PRESS + && !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 (); + gtk_widget_grab_focus (FRAME_GTK_WIDGET (f)); + + if (FRAME_GTK_OUTER_WIDGET (f)) + gtk_window_present (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f))); + unblock_input (); + } + } + } + + /* xg_event_is_for_scrollbar() doesn't work correctly on sway, and + * we shouldn't need it. + */ +#if 0 + 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 = event->button.x; + int y = event->button.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, event->type == GDK_BUTTON_PRESS, + pgtk_gtk_to_emacs_modifiers (dpyinfo, event->button.state)); + } + } + + if (f) + { + if (!(tab_bar_p && NILP (tab_bar_arg)) && !tool_bar_p) + { + if (ignore_next_mouse_click_timeout) + { + if (event->type == GDK_BUTTON_PRESS + && event->button.time > ignore_next_mouse_click_timeout) + { + ignore_next_mouse_click_timeout = 0; + construct_mouse_click (&inev.ie, &event->button, f); + } + if (event->type == GDK_BUTTON_RELEASE) + ignore_next_mouse_click_timeout = 0; + } + else + construct_mouse_click (&inev.ie, &event->button, f); + + if (!NILP (tab_bar_arg)) + inev.ie.arg = tab_bar_arg; + } +#if 0 + if (FRAME_X_EMBEDDED_P (f)) + xembed_send_message (f, event->button.time, + XEMBED_REQUEST_FOCUS, 0, 0, 0); +#endif + } + + if (event->type == GDK_BUTTON_PRESS) + { + dpyinfo->grabbed |= (1 << event->button.button); + dpyinfo->last_mouse_frame = f; + + if (dpyinfo->last_click_event != NULL) + gdk_event_free (dpyinfo->last_click_event); + dpyinfo->last_click_event = gdk_event_copy (event); + } + else + dpyinfo->grabbed &= ~(1 << event->button.button); + + /* Ignore any mouse motion that happened before this event; + any subsequent mouse-movement Emacs events should reflect + only motion after the ButtonPress/Release. */ + if (f != 0) + f->mouse_moved = false; + + if (inev.ie.kind != NO_EVENT) + evq_enqueue (&inev); + return TRUE; +} + +static gboolean +scroll_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data) +{ + union buffered_input_event inev; + struct frame *f, *frame; + struct pgtk_display_info *dpyinfo; + GdkScrollDirection dir; + double delta_x, delta_y; + + EVENT_INIT (inev.ie); + inev.ie.kind = NO_EVENT; + inev.ie.arg = Qnil; + + frame = pgtk_any_window_to_frame (gtk_widget_get_window (widget)); + dpyinfo = FRAME_DISPLAY_INFO (frame); + + if (gui_mouse_grabbed (dpyinfo)) + f = dpyinfo->last_mouse_frame; + else + f = pgtk_any_window_to_frame (gtk_widget_get_window (widget)); + + inev.ie.kind = NO_EVENT; + inev.ie.timestamp = event->scroll.time; + inev.ie.modifiers = + pgtk_gtk_to_emacs_modifiers (FRAME_DISPLAY_INFO (f), event->scroll.state); + XSETINT (inev.ie.x, event->scroll.x); + XSETINT (inev.ie.y, event->scroll.y); + XSETFRAME (inev.ie.frame_or_window, f); + inev.ie.arg = Qnil; + + if (gdk_event_is_scroll_stop_event (event)) + { + inev.ie.kind = TOUCH_END_EVENT; + evq_enqueue (&inev); + return TRUE; + } + + if (gdk_event_get_scroll_direction (event, &dir)) + { + switch (dir) + { + case GDK_SCROLL_UP: + inev.ie.kind = WHEEL_EVENT; + inev.ie.modifiers |= up_modifier; + break; + case GDK_SCROLL_DOWN: + inev.ie.kind = WHEEL_EVENT; + inev.ie.modifiers |= down_modifier; + break; + case GDK_SCROLL_LEFT: + inev.ie.kind = HORIZ_WHEEL_EVENT; + inev.ie.modifiers |= up_modifier; + break; + case GDK_SCROLL_RIGHT: + inev.ie.kind = HORIZ_WHEEL_EVENT; + inev.ie.modifiers |= down_modifier; + break; + case GDK_SCROLL_SMOOTH: /* shut up warning */ + break; + } + } + else if (gdk_event_get_scroll_deltas (event, &delta_x, &delta_y)) + { + if (!mwheel_coalesce_scroll_events) + { + inev.ie.kind = ((fabs (delta_x) > fabs (delta_y)) + ? HORIZ_WHEEL_EVENT + : WHEEL_EVENT); + inev.ie.modifiers |= (inev.ie.kind == HORIZ_WHEEL_EVENT + ? (delta_x >= 0 ? down_modifier : up_modifier) + : (delta_y >= 0 ? down_modifier : up_modifier)); + inev.ie.arg = list3 (Qnil, make_float (delta_x * 100), + make_float (-delta_y * 100)); + } + else + { + dpyinfo->scroll.acc_x += delta_x; + dpyinfo->scroll.acc_y += delta_y; + if (dpyinfo->scroll.acc_y >= dpyinfo->scroll.y_per_line) + { + int nlines = dpyinfo->scroll.acc_y / dpyinfo->scroll.y_per_line; + inev.ie.kind = WHEEL_EVENT; + inev.ie.modifiers |= down_modifier; + inev.ie.arg = list3 (make_fixnum (nlines), + make_float (-dpyinfo->scroll.acc_x * 100), + make_float (-dpyinfo->scroll.acc_y * 100)); + dpyinfo->scroll.acc_y -= dpyinfo->scroll.y_per_line * nlines; + } + else if (dpyinfo->scroll.acc_y <= -dpyinfo->scroll.y_per_line) + { + int nlines = -dpyinfo->scroll.acc_y / dpyinfo->scroll.y_per_line; + inev.ie.kind = WHEEL_EVENT; + inev.ie.modifiers |= up_modifier; + inev.ie.arg = list3 (make_fixnum (nlines), + make_float (-dpyinfo->scroll.acc_x * 100), + make_float (-dpyinfo->scroll.acc_y * 100)); + + dpyinfo->scroll.acc_y -= -dpyinfo->scroll.y_per_line * nlines; + } + else if (dpyinfo->scroll.acc_x >= dpyinfo->scroll.x_per_char + || !mwheel_coalesce_scroll_events) + { + int nchars = dpyinfo->scroll.acc_x / dpyinfo->scroll.x_per_char; + inev.ie.kind = HORIZ_WHEEL_EVENT; + inev.ie.modifiers |= up_modifier; + inev.ie.arg = list3 (make_fixnum (nchars), + make_float (-dpyinfo->scroll.acc_x * 100), + make_float (-dpyinfo->scroll.acc_y * 100)); + + dpyinfo->scroll.acc_x -= dpyinfo->scroll.x_per_char * nchars; + } + else if (dpyinfo->scroll.acc_x <= -dpyinfo->scroll.x_per_char) + { + int nchars = -dpyinfo->scroll.acc_x / dpyinfo->scroll.x_per_char; + inev.ie.kind = HORIZ_WHEEL_EVENT; + inev.ie.modifiers |= down_modifier; + inev.ie.arg = list3 (make_fixnum (nchars), + make_float (-dpyinfo->scroll.acc_x * 100), + make_float (-dpyinfo->scroll.acc_y * 100)); + + dpyinfo->scroll.acc_x -= -dpyinfo->scroll.x_per_char * nchars; + } + } + } + + if (inev.ie.kind != NO_EVENT) + evq_enqueue (&inev); + return TRUE; +} + +static void +drag_data_received (GtkWidget * widget, GdkDragContext * context, + gint x, gint y, + GtkSelectionData * data, + guint info, guint time, gpointer user_data) +{ + struct frame *f = pgtk_any_window_to_frame (gtk_widget_get_window (widget)); + gchar **uris = gtk_selection_data_get_uris (data); + + if (uris != NULL) + { + for (int i = 0; uris[i] != NULL; i++) + { + union buffered_input_event inev; + Lisp_Object arg = Qnil; + + EVENT_INIT (inev.ie); + inev.ie.kind = NO_EVENT; + inev.ie.arg = Qnil; + + arg = list2 (Qurl, build_string (uris[i])); + + inev.ie.kind = DRAG_N_DROP_EVENT; + inev.ie.modifiers = 0; + XSETINT (inev.ie.x, x); + XSETINT (inev.ie.y, y); + XSETFRAME (inev.ie.frame_or_window, f); + inev.ie.arg = arg; + inev.ie.timestamp = 0; + + evq_enqueue (&inev); + } + } + + gtk_drag_finish (context, TRUE, FALSE, time); +} + +void +pgtk_set_event_handler (struct frame *f) +{ + if (f->tooltip) + { + g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "draw", + G_CALLBACK (pgtk_handle_draw), NULL); + return; + } + + gtk_drag_dest_set (FRAME_GTK_WIDGET (f), GTK_DEST_DEFAULT_ALL, NULL, 0, + GDK_ACTION_COPY); + gtk_drag_dest_add_uri_targets (FRAME_GTK_WIDGET (f)); + + if (FRAME_GTK_OUTER_WIDGET (f)) + { + g_signal_connect (G_OBJECT (FRAME_GTK_OUTER_WIDGET (f)), + "window-state-event", G_CALLBACK (window_state_event), + NULL); + g_signal_connect (G_OBJECT (FRAME_GTK_OUTER_WIDGET (f)), "delete-event", + G_CALLBACK (delete_event), NULL); + g_signal_connect (G_OBJECT (FRAME_GTK_OUTER_WIDGET (f)), "event", + G_CALLBACK (pgtk_handle_event), NULL); + g_signal_connect (G_OBJECT (FRAME_GTK_OUTER_WIDGET (f)), "configure-event", + G_CALLBACK (configure_event), NULL); + } + + g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "map-event", + G_CALLBACK (map_event), NULL); + g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "size-allocate", + G_CALLBACK (size_allocate), f); + g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "key-press-event", + G_CALLBACK (key_press_event), NULL); + g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "key-release-event", + G_CALLBACK (key_release_event), NULL); + g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "focus-in-event", + G_CALLBACK (focus_in_event), NULL); + g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "focus-out-event", + G_CALLBACK (focus_out_event), NULL); + g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "enter-notify-event", + G_CALLBACK (enter_notify_event), NULL); + g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "leave-notify-event", + G_CALLBACK (leave_notify_event), NULL); + g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "motion-notify-event", + G_CALLBACK (motion_notify_event), NULL); + g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "button-press-event", + G_CALLBACK (button_event), NULL); + g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "button-release-event", + G_CALLBACK (button_event), NULL); + g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "scroll-event", + G_CALLBACK (scroll_event), NULL); + g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "selection-clear-event", + G_CALLBACK (pgtk_selection_lost), NULL); + g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "configure-event", + G_CALLBACK (configure_event), NULL); + g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "drag-data-received", + G_CALLBACK (drag_data_received), NULL); + g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "draw", + G_CALLBACK (pgtk_handle_draw), NULL); + g_signal_connect (G_OBJECT (FRAME_GTK_WIDGET (f)), "event", + G_CALLBACK (pgtk_handle_event), NULL); +} + +static void +my_log_handler (const gchar * log_domain, GLogLevelFlags log_level, + const gchar * msg, gpointer user_data) +{ + if (!strstr (msg, "g_set_prgname")) + fprintf (stderr, "%s-WARNING **: %s", log_domain, msg); +} + +/* Test whether two display-name strings agree up to the dot that separates + the screen number from the server number. */ +static bool +same_x_server (const char *name1, const char *name2) +{ + bool seen_colon = false; + Lisp_Object sysname = Fsystem_name (); + const char *system_name = SSDATA (sysname); + ptrdiff_t system_name_length = SBYTES (sysname); + ptrdiff_t length_until_period = 0; + + while (system_name[length_until_period] != 0 + && system_name[length_until_period] != '.') + length_until_period++; + + /* Treat `unix' like an empty host name. */ + if (!strncmp (name1, "unix:", 5)) + name1 += 4; + if (!strncmp (name2, "unix:", 5)) + name2 += 4; + /* Treat this host's name like an empty host name. */ + if (!strncmp (name1, system_name, system_name_length) + && name1[system_name_length] == ':') + name1 += system_name_length; + if (!strncmp (name2, system_name, system_name_length) + && name2[system_name_length] == ':') + name2 += system_name_length; + /* Treat this host's domainless name like an empty host name. */ + if (!strncmp (name1, system_name, length_until_period) + && name1[length_until_period] == ':') + name1 += length_until_period; + if (!strncmp (name2, system_name, length_until_period) + && name2[length_until_period] == ':') + name2 += length_until_period; + + for (; *name1 != '\0' && *name1 == *name2; name1++, name2++) + { + if (*name1 == ':') + seen_colon = true; + if (seen_colon && *name1 == '.') + return true; + } + return (seen_colon + && (*name1 == '.' || *name1 == '\0') + && (*name2 == '.' || *name2 == '\0')); +} + +#define GNOME_INTERFACE_SCHEMA "org.gnome.desktop.interface" + +static gdouble pgtk_text_scaling_factor (void) +{ + GSettingsSchemaSource *schema_source = g_settings_schema_source_get_default (); + if (schema_source != NULL) + { + GSettingsSchema *schema = g_settings_schema_source_lookup (schema_source, + GNOME_INTERFACE_SCHEMA, true); + if (schema != NULL) + { + g_settings_schema_unref (schema); + GSettings *set = g_settings_new (GNOME_INTERFACE_SCHEMA); + return g_settings_get_double (set, "text-scaling-factor"); + } + } + return 1; +} + + +/* Open a connection to X display DISPLAY_NAME, and return + the structure that describes the open display. + If we cannot contact the display, return null. */ + +struct pgtk_display_info * +pgtk_term_init (Lisp_Object display_name, char *resource_name) +{ + GdkDisplay *dpy; + struct terminal *terminal; + struct pgtk_display_info *dpyinfo; + static int x_initialized = 0; + static unsigned x_display_id = 0; + static char *initial_display = NULL; + static dynlib_handle_ptr *handle = NULL; + char *dpy_name; + Lisp_Object lisp_dpy_name = Qnil; + + block_input (); + + if (!x_initialized) + { + any_help_event_p = false; + + Fset_input_interrupt_mode (Qt); + baud_rate = 19200; + +#ifdef USE_CAIRO + gui_init_fringe (&pgtk_redisplay_interface); +#endif + + ++x_initialized; + } + + dpy_name = SSDATA (display_name); + if (strlen (dpy_name) == 0 && initial_display != NULL) + dpy_name = initial_display; + lisp_dpy_name = build_string (dpy_name); + + { +#define NUM_ARGV 10 + int argc; + char *argv[NUM_ARGV]; + char **argv2 = argv; + guint id; + + if (x_initialized++ > 1) + { + xg_display_open (dpy_name, &dpy); + } + else + { + static char display_opt[] = "--display"; + static char name_opt[] = "--name"; + + for (argc = 0; argc < NUM_ARGV; ++argc) + argv[argc] = 0; + + argc = 0; + argv[argc++] = initial_argv[0]; + + if (strlen (dpy_name) != 0) + { + argv[argc++] = display_opt; + argv[argc++] = dpy_name; + } + + argv[argc++] = name_opt; + argv[argc++] = resource_name; + + /* Work around GLib bug that outputs a faulty warning. See + https://bugzilla.gnome.org/show_bug.cgi?id=563627. */ + id = g_log_set_handler ("GLib", G_LOG_LEVEL_WARNING | G_LOG_FLAG_FATAL + | G_LOG_FLAG_RECURSION, my_log_handler, NULL); + + /* gtk_init does set_locale. Fix locale before and after. */ + fixup_locale (); + unrequest_sigio (); /* See comment in x_display_ok. */ + gtk_init (&argc, &argv2); + request_sigio (); + fixup_locale (); + + + g_log_remove_handler ("GLib", id); + + xg_initialize (); + + dpy = DEFAULT_GDK_DISPLAY (); + + initial_display = g_strdup (gdk_display_get_name (dpy)); + dpy_name = initial_display; + lisp_dpy_name = build_string (dpy_name); + } + } + + /* Detect failure. */ + if (dpy == 0) + { + unblock_input (); + return 0; + } + + + dpyinfo = xzalloc (sizeof *dpyinfo); + pgtk_initialize_display_info (dpyinfo); + terminal = pgtk_create_terminal (dpyinfo); + + { + struct pgtk_display_info *share; + + for (share = x_display_list; share; share = share->next) + if (same_x_server (SSDATA (XCAR (share->name_list_element)), dpy_name)) + break; + if (share) + terminal->kboard = share->terminal->kboard; + else + { + terminal->kboard = allocate_kboard (Qpgtk); + + /* Don't let the initial kboard remain current longer than necessary. + That would cause problems if a file loaded on startup tries to + prompt in the mini-buffer. */ + if (current_kboard == initial_kboard) + current_kboard = terminal->kboard; + } + terminal->kboard->reference_count++; + } + + /* Put this display on the chain. */ + dpyinfo->next = x_display_list; + x_display_list = dpyinfo; + + dpyinfo->name_list_element = Fcons (lisp_dpy_name, Qnil); + dpyinfo->gdpy = dpy; + + /* https://lists.gnu.org/r/emacs-devel/2015-11/msg00194.html */ + dpyinfo->smallest_font_height = 1; + dpyinfo->smallest_char_width = 1; + + /* Set the name of the terminal. */ + terminal->name = xlispstrdup (lisp_dpy_name); + + Lisp_Object system_name = Fsystem_name (); + ptrdiff_t nbytes; + if (INT_ADD_WRAPV (SBYTES (Vinvocation_name), SBYTES (system_name) + 2, + &nbytes)) + memory_full (SIZE_MAX); + dpyinfo->x_id = ++x_display_id; + dpyinfo->x_id_name = xmalloc (nbytes); + char *nametail = lispstpcpy (dpyinfo->x_id_name, Vinvocation_name); + *nametail++ = '@'; + lispstpcpy (nametail, system_name); + + /* Figure out which modifier bits mean what. */ + x_find_modifier_meanings (dpyinfo); + + /* Get the scroll bar cursor. */ + /* We must create a GTK cursor, it is required for GTK widgets. */ + dpyinfo->xg_cursor = xg_create_default_cursor (dpyinfo->gdpy); + + dpyinfo->vertical_scroll_bar_cursor + = gdk_cursor_new_for_display (dpyinfo->gdpy, GDK_SB_V_DOUBLE_ARROW); + + dpyinfo->horizontal_scroll_bar_cursor + = gdk_cursor_new_for_display (dpyinfo->gdpy, GDK_SB_H_DOUBLE_ARROW); + + dpyinfo->icon_bitmap_id = -1; + + reset_mouse_highlight (&dpyinfo->mouse_highlight); + + { + GdkScreen *gscr = gdk_display_get_default_screen (dpyinfo->gdpy); + + gdouble dpi = gdk_screen_get_resolution (gscr); + if (dpi < 0) + dpi = 96.0; + + dpi *= pgtk_text_scaling_factor (); + dpyinfo->resx = dpi; + dpyinfo->resy = dpi; + } + + /* smooth scroll setting */ + dpyinfo->scroll.x_per_char = 2; + dpyinfo->scroll.y_per_line = 2; + + dpyinfo->connection = -1; + + if (!handle) + handle = dynlib_open (NULL); + +#ifdef GDK_WINDOWING_X11 + if (!strcmp (G_OBJECT_TYPE_NAME (dpy), "GdkX11Display") && handle) + { + void *(*gdk_x11_display_get_xdisplay) (GdkDisplay *) + = dynlib_sym (handle, "gdk_x11_display_get_xdisplay"); + int (*x_connection_number) (void *) + = dynlib_sym (handle, "XConnectionNumber"); + + if (x_connection_number + && gdk_x11_display_get_xdisplay) + dpyinfo->connection + = x_connection_number (gdk_x11_display_get_xdisplay (dpy)); + } +#endif + +#ifdef GDK_WINDOWING_WAYLAND + if (GDK_IS_WAYLAND_DISPLAY (dpy) && handle) + { + struct wl_display *wl_dpy = gdk_wayland_display_get_wl_display (dpy); + int (*display_get_fd) (struct wl_display *) + = dynlib_sym (handle, "wl_display_get_fd"); + + if (display_get_fd) + dpyinfo->connection = display_get_fd (wl_dpy); + } +#endif + + if (dpyinfo->connection >= 0) + { + add_keyboard_wait_descriptor (dpyinfo->connection); +#ifdef F_SETOWN + fcntl (dpyinfo->connection, F_SETOWN, getpid ()); +#endif /* ! defined (F_SETOWN) */ + + if (interrupt_input) + init_sigio (dpyinfo->connection); + } + + x_setup_pointer_blanking (dpyinfo); + + xsettings_initialize (dpyinfo); + + pgtk_selection_init (); + + pgtk_im_init (dpyinfo); + + unblock_input (); + + return dpyinfo; +} + +/* Get rid of display DPYINFO, deleting all frames on it, + and without sending any more commands to the X server. */ + +static void +pgtk_delete_display (struct pgtk_display_info *dpyinfo) +{ + struct terminal *t; + + /* Close all frames and delete the generic struct terminal for this + X display. */ + for (t = terminal_list; t; t = t->next_terminal) + if (t->type == output_pgtk && t->display_info.pgtk == dpyinfo) + { + delete_terminal (t); + break; + } + + if (x_display_list == dpyinfo) + x_display_list = dpyinfo->next; + else + { + struct pgtk_display_info *tail; + + for (tail = x_display_list; tail; tail = tail->next) + if (tail->next == dpyinfo) + tail->next = tail->next->next; + } + + xfree (dpyinfo); +} + +char * +pgtk_xlfd_to_fontname (const char *xlfd) +/* -------------------------------------------------------------------------- + Convert an X font name (XLFD) to an Gtk font name. + Only family is used. + The string returned is temporarily allocated. + -------------------------------------------------------------------------- */ +{ + char *name = xmalloc (180); + + if (!strncmp (xlfd, "--", 2)) + { + if (sscanf (xlfd, "--%179[^-]-", name) != 1) + name[0] = '\0'; + } + else + { + if (sscanf (xlfd, "-%*[^-]-%179[^-]-", name) != 1) + name[0] = '\0'; + } + + /* stopgap for malformed XLFD input */ + if (strlen (name) == 0) + strcpy (name, "Monospace"); + + return name; +} + +bool +pgtk_defined_color (struct frame *f, + const char *name, + Emacs_Color * color_def, bool alloc, bool makeIndex) +/* -------------------------------------------------------------------------- + Return true if named color found, and set color_def rgb accordingly. + If makeIndex and alloc are nonzero put the color in the color_table, + and set color_def pixel to the resulting index. + If makeIndex is zero, set color_def pixel to ARGB. + Return false if not found + -------------------------------------------------------------------------- */ +{ + int r; + + block_input (); + r = xg_check_special_colors (f, name, color_def); + if (!r) + r = pgtk_parse_color (f, name, color_def); + unblock_input (); + return r; +} + +/* On frame F, translate the color name to RGB values. Use cached + information, if possible. + + Note that there is currently no way to clean old entries out of the + cache. However, it is limited to names in the server's database, + and names we've actually looked up; list-colors-display is probably + the most color-intensive case we're likely to hit. */ + +int +pgtk_parse_color (struct frame *f, const char *color_name, + Emacs_Color * color) +{ + GdkRGBA rgba; + if (gdk_rgba_parse (&rgba, color_name)) + { + color->red = rgba.red * 65535; + color->green = rgba.green * 65535; + color->blue = rgba.blue * 65535; + color->pixel = + (color->red >> 8) << 16 | + (color->green >> 8) << 8 | + (color->blue >> 8) << 0; + return 1; + } + return 0; +} + +/* On frame F, translate pixel colors to RGB values for the NCOLORS + colors in COLORS. On W32, we no longer try to map colors to + a palette. */ +void +pgtk_query_colors (struct frame *f, Emacs_Color * colors, int ncolors) +{ + int i; + + for (i = 0; i < ncolors; i++) + { + unsigned long pixel = colors[i].pixel; + /* Convert to a 16 bit value in range 0 - 0xffff. */ +#define GetRValue(p) (((p) >> 16) & 0xff) +#define GetGValue(p) (((p) >> 8) & 0xff) +#define GetBValue(p) (((p) >> 0) & 0xff) + colors[i].red = GetRValue (pixel) * 257; + colors[i].green = GetGValue (pixel) * 257; + colors[i].blue = GetBValue (pixel) * 257; + } +} + +void +pgtk_query_color (struct frame *f, Emacs_Color * color) +{ + pgtk_query_colors (f, color, 1); +} + +void +pgtk_clear_area (struct frame *f, int x, int y, int width, int height) +{ + cairo_t *cr; + + eassert (width > 0 && height > 0); + + cr = pgtk_begin_cr_clip (f); + pgtk_set_cr_source_with_color (f, FRAME_X_OUTPUT (f)->background_color); + cairo_rectangle (cr, x, y, width, height); + cairo_fill (cr); + pgtk_end_cr_clip (f); +} + + +void +syms_of_pgtkterm (void) +{ + /* from 23+ we need to tell emacs what modifiers there are.. */ + DEFSYM (Qmodifier_value, "modifier-value"); + DEFSYM (Qalt, "alt"); + DEFSYM (Qhyper, "hyper"); + DEFSYM (Qmeta, "meta"); + DEFSYM (Qsuper, "super"); + DEFSYM (Qcontrol, "control"); + DEFSYM (QUTF8_STRING, "UTF8_STRING"); + + DEFSYM (Qfile, "file"); + DEFSYM (Qurl, "url"); + + DEFSYM (Qlatin_1, "latin-1"); + + xg_default_icon_file = + build_pure_c_string ("icons/hicolor/scalable/apps/emacs.svg"); + staticpro (&xg_default_icon_file); + + DEFSYM (Qx_gtk_map_stock, "x-gtk-map-stock"); + + + Fput (Qalt, Qmodifier_value, make_fixnum (alt_modifier)); + Fput (Qhyper, Qmodifier_value, make_fixnum (hyper_modifier)); + Fput (Qmeta, Qmodifier_value, make_fixnum (meta_modifier)); + Fput (Qsuper, Qmodifier_value, make_fixnum (super_modifier)); + Fput (Qcontrol, Qmodifier_value, make_fixnum (ctrl_modifier)); + + DEFVAR_LISP ("x-ctrl-keysym", Vx_ctrl_keysym, + doc: /* Which keys Emacs uses for the ctrl modifier. +This should be one of the symbols `ctrl', `alt', `hyper', `meta', +`super'. For example, `ctrl' means use the Ctrl_L and Ctrl_R keysyms. +The default is nil, which is the same as `ctrl'. */ ); + Vx_ctrl_keysym = Qnil; + + DEFVAR_LISP ("x-alt-keysym", Vx_alt_keysym, + doc: /* Which keys Emacs uses for the alt modifier. +This should be one of the symbols `ctrl', `alt', `hyper', `meta', +`super'. For example, `alt' means use the Alt_L and Alt_R keysyms. +The default is nil, which is the same as `alt'. */ ); + Vx_alt_keysym = Qnil; + + DEFVAR_LISP ("x-hyper-keysym", Vx_hyper_keysym, + doc: /* Which keys Emacs uses for the hyper modifier. +This should be one of the symbols `ctrl', `alt', `hyper', `meta', +`super'. For example, `hyper' means use the Hyper_L and Hyper_R +keysyms. The default is nil, which is the same as `hyper'. */ ); + Vx_hyper_keysym = Qnil; + + DEFVAR_LISP ("x-meta-keysym", Vx_meta_keysym, + doc: /* Which keys Emacs uses for the meta modifier. +This should be one of the symbols `ctrl', `alt', `hyper', `meta', +`super'. For example, `meta' means use the Meta_L and Meta_R keysyms. +The default is nil, which is the same as `meta'. */ ); + Vx_meta_keysym = Qnil; + + DEFVAR_LISP ("x-super-keysym", Vx_super_keysym, + doc: /* Which keys Emacs uses for the super modifier. +This should be one of the symbols `ctrl', `alt', `hyper', `meta', +`super'. For example, `super' means use the Super_L and Super_R +keysyms. The default is nil, which is the same as `super'. */ ); + Vx_super_keysym = Qnil; + + /* TODO: move to common code */ + DEFVAR_LISP ("x-toolkit-scroll-bars", Vx_toolkit_scroll_bars, + doc: /* Which toolkit scroll bars Emacs uses, if any. +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. */ ); + /* Vx_toolkit_scroll_bars = Qt; */ + Vx_toolkit_scroll_bars = intern_c_string ("gtk"); + + DEFVAR_BOOL ("x-use-underline-position-properties", x_use_underline_position_properties, + doc: /*Non-nil means make use of UNDERLINE_POSITION font properties. +A value of nil means ignore them. If you encounter fonts with bogus +UNDERLINE_POSITION font properties, for example 7x13 on XFree prior +to 4.1, set this to nil. */); + x_use_underline_position_properties = 0; + + DEFVAR_BOOL ("x-underline-at-descent-line", x_underline_at_descent_line, + doc: /* Non-nil means to draw the underline at the same place as the descent line. +A value of nil means to draw the underline according to the value of the +variable `x-use-underline-position-properties', which is usually at the +baseline level. The default value is nil. */); + x_underline_at_descent_line = 0; + + DEFVAR_BOOL ("x-gtk-use-window-move", x_gtk_use_window_move, + doc: /* Non-nil means rely on gtk_window_move to set frame positions. +If this variable is t (the default), the GTK build uses the function +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_LISP ("pgtk-wait-for-event-timeout", Vpgtk_wait_for_event_timeout, + doc: /* How long to wait for X events. + +Emacs will wait up to this many seconds to receive X events after +making changes which affect the state of the graphical interface. +Under some window managers this can take an indefinite amount of time, +so it is important to limit the wait. + +If set to a non-float value, there will be no wait at all. */); + Vpgtk_wait_for_event_timeout = make_float (0.1); + + DEFVAR_LISP ("pgtk-keysym-table", Vpgtk_keysym_table, + doc: /* Hash table of character codes indexed by X keysym codes. */); + Vpgtk_keysym_table = + make_hash_table (hashtest_eql, 900, DEFAULT_REHASH_SIZE, + DEFAULT_REHASH_THRESHOLD, Qnil, false); + + window_being_scrolled = Qnil; + staticpro (&window_being_scrolled); + + /* Tell Emacs about this window system. */ + Fprovide (Qpgtk, Qnil); +} + +/* Cairo does not allow resizing a surface/context after it is + * created, so we need to trash the old context, create a new context + * on the next cr_clip_begin with the new dimensions and request a + * re-draw. + * + * This Will leave the active context available to present on screen + * until a redrawn frame is completed. + */ +void +pgtk_cr_update_surface_desired_size (struct frame *f, int width, int height, bool force) +{ + if (FRAME_CR_SURFACE_DESIRED_WIDTH (f) != width + || FRAME_CR_SURFACE_DESIRED_HEIGHT (f) != height + || force) + { + pgtk_cr_destroy_frame_context (f); + FRAME_CR_SURFACE_DESIRED_WIDTH (f) = width; + FRAME_CR_SURFACE_DESIRED_HEIGHT (f) = height; + SET_FRAME_GARBAGED (f); + } +} + + +cairo_t * +pgtk_begin_cr_clip (struct frame *f) +{ + cairo_t *cr = FRAME_CR_CONTEXT (f); + + if (!cr) + { + cairo_surface_t *surface = + gdk_window_create_similar_surface (gtk_widget_get_window + (FRAME_GTK_WIDGET (f)), + CAIRO_CONTENT_COLOR_ALPHA, + FRAME_CR_SURFACE_DESIRED_WIDTH (f), + FRAME_CR_SURFACE_DESIRED_HEIGHT + (f)); + + cr = FRAME_CR_CONTEXT (f) = cairo_create (surface); + cairo_surface_destroy (surface); + } + + cairo_save (cr); + + return cr; +} + +void +pgtk_end_cr_clip (struct frame *f) +{ + cairo_restore (FRAME_CR_CONTEXT (f)); +} + +void +pgtk_set_cr_source_with_gc_foreground (struct frame *f, Emacs_GC * gc) +{ + pgtk_set_cr_source_with_color (f, gc->foreground); +} + +void +pgtk_set_cr_source_with_gc_background (struct frame *f, Emacs_GC * gc) +{ + pgtk_set_cr_source_with_color (f, gc->background); +} + +void +pgtk_set_cr_source_with_color (struct frame *f, unsigned long color) +{ + Emacs_Color col; + col.pixel = color; + pgtk_query_color (f, &col); + cairo_set_source_rgb (FRAME_CR_CONTEXT (f), col.red / 65535.0, + col.green / 65535.0, col.blue / 65535.0); +} + +void +pgtk_cr_draw_frame (cairo_t * cr, struct frame *f) +{ + cairo_set_source_surface (cr, FRAME_CR_SURFACE (f), 0, 0); + cairo_paint (cr); +} + +static cairo_status_t +pgtk_cr_accumulate_data (void *closure, const unsigned char *data, + unsigned int length) +{ + Lisp_Object *acc = (Lisp_Object *) closure; + + *acc = Fcons (make_unibyte_string ((char const *) data, length), *acc); + + return CAIRO_STATUS_SUCCESS; +} + +void +pgtk_cr_destroy_frame_context (struct frame *f) +{ + if (FRAME_CR_CONTEXT (f) != NULL) + { + cairo_destroy (FRAME_CR_CONTEXT (f)); + FRAME_CR_CONTEXT (f) = NULL; + } +} + +static void +pgtk_cr_destroy (void *cr) +{ + block_input (); + cairo_destroy (cr); + unblock_input (); +} + + + +Lisp_Object +pgtk_cr_export_frames (Lisp_Object frames, cairo_surface_type_t surface_type) +{ + struct frame *f; + cairo_surface_t *surface; + cairo_t *cr; + int width, height; + void (*surface_set_size_func) (cairo_surface_t *, double, double) = NULL; + Lisp_Object acc = Qnil; + ptrdiff_t count = SPECPDL_INDEX (); + + specbind (Qredisplay_dont_pause, Qt); + redisplay_preserve_echo_area (31); + + f = XFRAME (XCAR (frames)); + frames = XCDR (frames); + width = FRAME_PIXEL_WIDTH (f); + height = FRAME_PIXEL_HEIGHT (f); + + block_input (); +#ifdef CAIRO_HAS_PDF_SURFACE + if (surface_type == CAIRO_SURFACE_TYPE_PDF) + { + surface = cairo_pdf_surface_create_for_stream (pgtk_cr_accumulate_data, &acc, + width, height); + surface_set_size_func = cairo_pdf_surface_set_size; + } + else +#endif +#ifdef CAIRO_HAS_PNG_FUNCTIONS + if (surface_type == CAIRO_SURFACE_TYPE_IMAGE) + surface = cairo_image_surface_create (CAIRO_FORMAT_RGB24, width, height); + else +#endif +#ifdef CAIRO_HAS_PS_SURFACE + if (surface_type == CAIRO_SURFACE_TYPE_PS) + { + surface = cairo_ps_surface_create_for_stream (pgtk_cr_accumulate_data, &acc, + width, height); + surface_set_size_func = cairo_ps_surface_set_size; + } + else +#endif +#ifdef CAIRO_HAS_SVG_SURFACE + if (surface_type == CAIRO_SURFACE_TYPE_SVG) + surface = cairo_svg_surface_create_for_stream (pgtk_cr_accumulate_data, &acc, + width, height); + else +#endif + abort (); + + cr = cairo_create (surface); + cairo_surface_destroy (surface); + record_unwind_protect_ptr (pgtk_cr_destroy, cr); + + while (1) + { + cairo_t *saved_cr = FRAME_CR_CONTEXT (f); + FRAME_CR_CONTEXT (f) = cr; + pgtk_clear_area (f, 0, 0, width, height); + expose_frame (f, 0, 0, width, height); + FRAME_CR_CONTEXT (f) = saved_cr; + + if (NILP (frames)) + break; + + cairo_surface_show_page (surface); + f = XFRAME (XCAR (frames)); + frames = XCDR (frames); + width = FRAME_PIXEL_WIDTH (f); + height = FRAME_PIXEL_HEIGHT (f); + if (surface_set_size_func) + (*surface_set_size_func) (surface, width, height); + + unblock_input (); + maybe_quit (); + block_input (); + } + +#ifdef CAIRO_HAS_PNG_FUNCTIONS + if (surface_type == CAIRO_SURFACE_TYPE_IMAGE) + { + cairo_surface_flush (surface); + cairo_surface_write_to_png_stream (surface, pgtk_cr_accumulate_data, &acc); + } +#endif + unblock_input (); + + unbind_to (count, Qnil); + + return CALLN (Fapply, intern ("concat"), Fnreverse (acc)); +} + + +void +init_pgtkterm (void) +{ +} diff --git a/src/pgtkterm.h b/src/pgtkterm.h new file mode 100644 index 00000000000..22ebadf559c --- /dev/null +++ b/src/pgtkterm.h @@ -0,0 +1,668 @@ +/* Definitions and headers for communication with pure Gtk+3. + Copyright (C) 1989, 1993, 2005, 2008-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 <https://www.gnu.org/licenses/>. */ + +#ifndef _PGTKTERM_H_ +#define _PGTKTERM_H_ + +#include "dispextern.h" +#include "frame.h" +#include "character.h" +#include "font.h" +#include "sysselect.h" + +#ifdef HAVE_PGTK + +#include <gtk/gtk.h> + +#ifdef CAIRO_HAS_PDF_SURFACE +#include <cairo-pdf.h> +#endif +#ifdef CAIRO_HAS_PS_SURFACE +#include <cairo-ps.h> +#endif +#ifdef CAIRO_HAS_SVG_SURFACE +#include <cairo-svg.h> +#endif + +/* could use list to store these, but rest of emacs has a big infrastructure + for managing a table of bitmap "records" */ +struct pgtk_bitmap_record +{ + void *img; + char *file; + int refcount; + int height, width, depth; + cairo_pattern_t *pattern; +}; + +#define RGB_TO_ULONG(r, g, b) (((r) << 16) | ((g) << 8) | (b)) +#define ARGB_TO_ULONG(a, r, g, b) (((a) << 24) | ((r) << 16) | ((g) << 8) | (b)) + +#define ALPHA_FROM_ULONG(color) ((color) >> 24) +#define RED_FROM_ULONG(color) (((color) >> 16) & 0xff) +#define GREEN_FROM_ULONG(color) (((color) >> 8) & 0xff) +#define BLUE_FROM_ULONG(color) ((color) & 0xff) + +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 from `x_window' down will not be traced by the GC. */ + + /* The X window representing this scroll bar. */ + Window x_window; + + /* The position and size of the scroll bar in pixels, relative to the + frame. */ + int top, left, width, height; + + /* The starting and ending positions of the handle, relative to the + handle area (i.e. zero is the top position, not + SCROLL_BAR_TOP_BORDER). If they're equal, that means the handle + hasn't been drawn yet. + + These are not actually the locations where the beginning and end + are drawn; in order to keep handles from becoming invisible when + editing large files, we establish a minimum height by always + drawing handle bottoms VERTICAL_SCROLL_BAR_MIN_HANDLE pixels below + where they would be normally; the bottom and top are in a + different co-ordinate system. */ + int start, end; + + /* If the scroll bar handle is currently being dragged by the user, + this is the number of pixels from the top of the handle to the + place where the user grabbed it. If the handle isn't currently + being dragged, this is -1. */ + int dragging; + +#if defined (USE_TOOLKIT_SCROLL_BARS) && defined (USE_LUCID) + /* Last scroll bar part seen in xaw_jump_callback and xaw_scroll_callback. */ + enum scroll_bar_part last_seen_part; +#endif + +#if defined (USE_TOOLKIT_SCROLL_BARS) && !defined (USE_GTK) + /* Last value of whole for horizontal scrollbars. */ + int whole; +#endif + + /* True if the scroll bar is horizontal. */ + bool horizontal; +}; + + +/* init'd in pgtk_initialize_display_info () */ +struct pgtk_display_info +{ + /* Chain of all pgtk_display_info structures. */ + struct pgtk_display_info *next; + + /* The generic display parameters corresponding to this PGTK display. */ + struct terminal *terminal; + + /* This says how to access this display in Gdk. */ + GdkDisplay *gdpy; + + /* This is a cons cell of the form (NAME . FONT-LIST-CACHE). */ + Lisp_Object name_list_element; + + /* Number of frames that are on this display. */ + int reference_count; + + /* Logical identifier of this display. */ + unsigned x_id; + + /* Default name for all frames on this display. */ + char *x_id_name; + + /* The number of fonts loaded. */ + int n_fonts; + + /* Minimum width over all characters in all fonts in font_table. */ + int smallest_char_width; + + /* Minimum font height over all fonts in font_table. */ + int smallest_font_height; + + struct pgtk_bitmap_record *bitmaps; + ptrdiff_t bitmaps_size; + ptrdiff_t bitmaps_last; + + /* DPI resolution of this screen */ + double resx, resy; + + /* Mask of things that cause the mouse to be grabbed */ + int grabbed; + + int n_planes; + + int color_p; + + /* Emacs bitmap-id of the default icon bitmap for this frame. + Or -1 if none has been allocated yet. */ + ptrdiff_t icon_bitmap_id; + + Window root_window; + + /* Xism */ + XrmDatabase rdb; + + /* The cursor to use for vertical scroll bars. */ + Emacs_Cursor vertical_scroll_bar_cursor; + + /* The cursor to use for horizontal scroll bars. */ + Emacs_Cursor horizontal_scroll_bar_cursor; + + /* Information about the range of text currently shown in + mouse-face. */ + Mouse_HLInfo mouse_highlight; + + struct frame *highlight_frame; + struct frame *x_focus_frame; + + /* The last frame mentioned in a FocusIn or FocusOut event. This is + separate from x_focus_frame, because whether or not LeaveNotify + events cause us to lose focus depends on whether or not we have + received a FocusIn event for it. */ + struct frame *x_focus_event_frame; + + /* The frame where the mouse was last time we reported a mouse event. */ + struct frame *last_mouse_frame; + + /* The frame where the mouse was last time we reported a mouse motion. */ + struct frame *last_mouse_motion_frame; + + /* Position where the mouse was last time we reported a motion. + This is a position on last_mouse_motion_frame. */ + int last_mouse_motion_x; + int last_mouse_motion_y; + + /* Where the mouse was last time we reported a mouse position. */ + XRectangle last_mouse_glyph; + + /* Time of last mouse movement. */ + Time last_mouse_movement_time; + + /* The scroll bar in which the last motion event occurred. */ + void *last_mouse_scroll_bar; + + /* The invisible cursor used for pointer blanking. + Unused if this display supports Xfixes extension. */ + Emacs_Cursor invisible_cursor; + + /* Function used to toggle pointer visibility on this display. */ + void (*toggle_visible_pointer) (struct frame *, bool); + + /* The GDK cursor for scroll bars and popup menus. */ + GdkCursor *xg_cursor; + + + /* The frame where the mouse was last time we reported a mouse position. */ + struct frame *last_mouse_glyph_frame; + + /* Modifier masks in gdk */ + int meta_mod_mask, alt_mod_mask, super_mod_mask, hyper_mod_mask; + + /* The last click event. */ + GdkEvent *last_click_event; + + /* input method */ + struct + { + GtkIMContext *context; + struct frame *focused_frame; + } im; + + struct + { + double acc_x, acc_y; + double x_per_char, y_per_line; + } scroll; + + int connection; +}; + +/* This is a chain of structures for all the PGTK displays currently in use. */ +extern struct pgtk_display_info *x_display_list; + +struct pgtk_output +{ +#if 0 + void *view; + void *miniimage; +#endif + unsigned long foreground_color; + unsigned long background_color; + void *toolbar; + + /* Cursors */ + Emacs_Cursor current_cursor; + 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; + + /* PGTK-specific */ + Emacs_Cursor current_pointer; + + /* border color */ + unsigned long border_pixel; + GtkCssProvider *border_color_css_provider; + + /* scrollbar color */ + GtkCssProvider *scrollbar_foreground_css_provider; + GtkCssProvider *scrollbar_background_css_provider; + + /* Widget whose cursor is hourglass_cursor. This widget is temporarily + mapped to display an hourglass cursor. */ + GtkWidget *hourglass_widget; + + Emacs_GC cursor_xgcv; + + /* lord knows why Emacs needs to know about our Window ids.. */ + Window window_desc, parent_desc; + char explicit_parent; + + /* If >=0, a bitmap index. The indicated bitmap is used for the + icon. */ + ptrdiff_t icon_bitmap; + + struct font *font; + int baseline_offset; + + /* If a fontset is specified for this frame instead of font, this + value contains an ID of the fontset, else -1. */ + int fontset; /* only used with font_backend */ + + unsigned long mouse_color; + unsigned long cursor_color; + unsigned long cursor_foreground_color; + + int icon_top; + int icon_left; + + /* The size of the extra width currently allotted for vertical + scroll bars, in pixels. */ + int vertical_scroll_bar_extra; + + /* The height of the titlebar decoration (included in PGTKWindow's frame). */ + int titlebar_height; + + /* The height of the toolbar if displayed, else 0. */ + int toolbar_height; + + /* This is the Emacs structure for the PGTK display this frame is on. */ + struct pgtk_display_info *display_info; + + /* Non-zero if we are zooming (maximizing) the frame. */ + int zooming; + + /* Non-zero if we are doing an animation, e.g. toggling the tool bar. */ + int in_animation; + + /* The last size hints set. */ + GdkGeometry size_hints; + long hint_flags; + int preferred_width, preferred_height; + + /* The widget of this screen. This is the window of a top widget. */ + GtkWidget *widget; + /* The widget of the edit portion of this screen; the window in + "window_desc" is inside of this. */ + GtkWidget *edit_widget; + /* The widget used for laying out widgets vertically. */ + GtkWidget *vbox_widget; + /* The widget used for laying out widgets horizontally. */ + GtkWidget *hbox_widget; + /* The menubar in this frame. */ + GtkWidget *menubar_widget; + /* The tool bar in this frame */ + GtkWidget *toolbar_widget; + /* True if tool bar is packed into the hbox widget (i.e. vertical). */ + bool_bf toolbar_in_hbox:1; + bool_bf toolbar_is_packed:1; + + GtkTooltip *ttip_widget; + GtkWidget *ttip_lbl; + GtkWindow *ttip_window; + + /* Height of menu bar widget, in pixels. This value + is not meaningful if the menubar is turned off. */ + int menubar_height; + + /* Height of tool bar widget, in pixels. top_height is used if tool bar + at top, bottom_height if tool bar is at the bottom. + Zero if not using an external tool bar or if tool bar is vertical. */ + int toolbar_top_height, toolbar_bottom_height; + + /* Width of tool bar widget, in pixels. left_width is used if tool bar + at left, right_width if tool bar is at the right. + Zero if not using an external tool bar or if tool bar is horizontal. */ + int toolbar_left_width, toolbar_right_width; + +#ifdef USE_CAIRO + /* Cairo drawing contexts. */ + cairo_t *cr_context, *cr_active; + int cr_surface_desired_width, cr_surface_desired_height; + /* Cairo surface for double buffering */ + cairo_surface_t *cr_surface_visible_bell; +#endif + struct atimer *atimer_visible_bell; + + int has_been_visible; + + /* Relief GCs, colors etc. */ + struct relief + { + Emacs_GC xgcv; + unsigned long pixel; + } + black_relief, white_relief; + + /* The background for which the above relief GCs were set up. + They are changed only when a different background is involved. */ + unsigned long relief_background; + + /* Keep track of focus. May be EXPLICIT if we received a FocusIn for this + frame, or IMPLICIT if we received an EnterNotify. + FocusOut and LeaveNotify clears EXPLICIT/IMPLICIT. */ + int focus_state; + + /* Keep track of scale factor. If monitor's scale factor is changed, or + monitor is switched and scale factor is changed, then recreate cairo_t + and cairo_surface_t. I need GTK's such signal, but there isn't, so + I watch it periodically with atimer. */ + double watched_scale_factor; + struct atimer *scale_factor_atimer; +}; + +/* this dummy decl needed to support TTYs */ +struct x_output +{ + int unused; +}; + +enum +{ + /* Values for focus_state, used as bit mask. + EXPLICIT means we received a FocusIn for the frame and know it has + the focus. IMPLICIT means we received an EnterNotify and the frame + may have the focus if no window manager is running. + FocusOut and LeaveNotify clears EXPLICIT/IMPLICIT. */ + FOCUS_NONE = 0, + FOCUS_IMPLICIT = 1, + FOCUS_EXPLICIT = 2 +}; + +/* This gives the pgtk_display_info structure for the display F is on. */ +#define FRAME_X_OUTPUT(f) ((f)->output_data.pgtk) +#define FRAME_OUTPUT_DATA(f) FRAME_X_OUTPUT (f) + +#define FRAME_DISPLAY_INFO(f) (FRAME_X_OUTPUT (f)->display_info) +#define FRAME_FOREGROUND_COLOR(f) (FRAME_X_OUTPUT (f)->foreground_color) +#define FRAME_BACKGROUND_COLOR(f) (FRAME_X_OUTPUT (f)->background_color) +#define FRAME_CURSOR_COLOR(f) (FRAME_X_OUTPUT (f)->cursor_color) +#define FRAME_POINTER_TYPE(f) (FRAME_X_OUTPUT (f)->current_pointer) +#define FRAME_FONT(f) (FRAME_X_OUTPUT (f)->font) +#define FRAME_GTK_OUTER_WIDGET(f) (FRAME_X_OUTPUT (f)->widget) +#define FRAME_GTK_WIDGET(f) (FRAME_X_OUTPUT (f)->edit_widget) +#define FRAME_WIDGET(f) (FRAME_GTK_OUTER_WIDGET (f) ? \ + FRAME_GTK_OUTER_WIDGET (f) : \ + FRAME_GTK_WIDGET (f)) + +/* aliases */ +#define FRAME_PGTK_VIEW(f) FRAME_GTK_WIDGET (f) +#define FRAME_X_WINDOW(f) FRAME_GTK_OUTER_WIDGET (f) +#define FRAME_NATIVE_WINDOW(f) GTK_WINDOW (FRAME_X_WINDOW (f)) + +#define FRAME_X_DISPLAY(f) (FRAME_DISPLAY_INFO (f)->gdpy) + +#define DEFAULT_GDK_DISPLAY() gdk_display_get_default () + +/* Turning a lisp vector value into a pointer to a struct scroll_bar. */ +#define XSCROLL_BAR(vec) ((struct scroll_bar *) XVECTOR (vec)) + +#define PGTK_FACE_FOREGROUND(f) ((f)->foreground) +#define PGTK_FACE_BACKGROUND(f) ((f)->background) +#define FRAME_DEFAULT_FACE(f) FACE_FROM_ID_OR_NULL (f, DEFAULT_FACE_ID) + +/* Compute pixel height of the frame's titlebar. */ +#define FRAME_PGTK_TITLEBAR_HEIGHT(f) 0 + +/* Compute pixel size for vertical scroll bars */ +#define PGTK_SCROLL_BAR_WIDTH(f) \ + (FRAME_HAS_VERTICAL_SCROLL_BARS (f) \ + ? rint (FRAME_CONFIG_SCROLL_BAR_WIDTH (f) > 0 \ + ? FRAME_CONFIG_SCROLL_BAR_WIDTH (f) \ + : (FRAME_SCROLL_BAR_COLS (f) * FRAME_COLUMN_WIDTH (f))) \ + : 0) + +/* Compute pixel size for horizontal scroll bars */ +#define PGTK_SCROLL_BAR_HEIGHT(f) \ + (FRAME_HAS_HORIZONTAL_SCROLL_BARS (f) \ + ? rint (FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) > 0 \ + ? FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) \ + : (FRAME_SCROLL_BAR_LINES (f) * FRAME_LINE_HEIGHT (f))) \ + : 0) + +/* Difference btwn char-column-calculated and actual SB widths. + This is only a concern for rendering when SB on left. */ +#define PGTK_SCROLL_BAR_ADJUST(w, f) \ + (WINDOW_HAS_VERTICAL_SCROLL_BAR_ON_LEFT (w) ? \ + (FRAME_SCROLL_BAR_COLS (f) * FRAME_COLUMN_WIDTH (f) \ + - PGTK_SCROLL_BAR_WIDTH (f)) : 0) + +/* Difference btwn char-line-calculated and actual SB heights. + This is only a concern for rendering when SB on top. */ +#define PGTK_SCROLL_BAR_ADJUST_HORIZONTALLY(w, f) \ + (WINDOW_HAS_HORIZONTAL_SCROLL_BARS (w) ? \ + (FRAME_SCROLL_BAR_LINES (f) * FRAME_LINE_HEIGHT (f) \ + - PGTK_SCROLL_BAR_HEIGHT (f)) : 0) + +#define FRAME_MENUBAR_HEIGHT(f) (FRAME_X_OUTPUT (f)->menubar_height) + +/* Calculate system coordinates of the left and top of the parent + window or, if there is no parent window, the screen. */ +#define PGTK_PARENT_WINDOW_LEFT_POS(f) \ + (FRAME_PARENT_FRAME (f) != NULL \ + ? [[FRAME_PGTK_VIEW (f) window] parentWindow].frame.origin.x : 0) +#define PGTK_PARENT_WINDOW_TOP_POS(f) \ + (FRAME_PARENT_FRAME (f) != NULL \ + ? ([[FRAME_PGTK_VIEW (f) window] parentWindow].frame.origin.y \ + + [[FRAME_PGTK_VIEW (f) window] parentWindow].frame.size.height \ + - FRAME_PGTK_TITLEBAR_HEIGHT (FRAME_PARENT_FRAME (f))) \ + : [[[PGTKScreen screepgtk] objectAtIndex: 0] frame].size.height) + +#define FRAME_PGTK_FONT_TABLE(f) (FRAME_DISPLAY_INFO (f)->font_table) + +#define FRAME_TOOLBAR_TOP_HEIGHT(f) ((f)->output_data.pgtk->toolbar_top_height) +#define FRAME_TOOLBAR_BOTTOM_HEIGHT(f) \ + ((f)->output_data.pgtk->toolbar_bottom_height) +#define FRAME_TOOLBAR_HEIGHT(f) \ + (FRAME_TOOLBAR_TOP_HEIGHT (f) + FRAME_TOOLBAR_BOTTOM_HEIGHT (f)) +#define FRAME_TOOLBAR_LEFT_WIDTH(f) ((f)->output_data.pgtk->toolbar_left_width) +#define FRAME_TOOLBAR_RIGHT_WIDTH(f) ((f)->output_data.pgtk->toolbar_right_width) +#define FRAME_TOOLBAR_WIDTH(f) \ + (FRAME_TOOLBAR_LEFT_WIDTH (f) + FRAME_TOOLBAR_RIGHT_WIDTH (f)) + +#define FRAME_FONTSET(f) (FRAME_X_OUTPUT (f)->fontset) + +#define FRAME_BASELINE_OFFSET(f) (FRAME_X_OUTPUT (f)->baseline_offset) +#define BLACK_PIX_DEFAULT(f) 0x000000 +#define WHITE_PIX_DEFAULT(f) 0xFFFFFF + +/* First position where characters can be shown (instead of scrollbar, if + it is on left. */ +#define FIRST_CHAR_POSITION(f) \ + (! (FRAME_HAS_VERTICAL_SCROLL_BARS_ON_LEFT (f)) ? 0 \ + : FRAME_SCROLL_BAR_COLS (f)) + +#define FRAME_CR_SURFACE_DESIRED_WIDTH(f) \ + ((f)->output_data.pgtk->cr_surface_desired_width) +#define FRAME_CR_SURFACE_DESIRED_HEIGHT(f) \ + ((f)->output_data.pgtk->cr_surface_desired_height) + +/* Display init/shutdown functions implemented in pgtkterm.c */ +extern struct pgtk_display_info *pgtk_term_init (Lisp_Object display_name, + char *resource_name); +extern void pgtk_term_shutdown (int sig); + +/* Implemented in pgtkterm, published in or needed from pgtkfns. */ +extern void pgtk_clear_frame (struct frame *f); +extern char *pgtk_xlfd_to_fontname (const char *xlfd); + +/* Implemented in pgtkfns. */ +extern void pgtk_set_doc_edited (void); +extern const char *pgtk_get_defaults_value (const char *key); +extern const char *pgtk_get_string_resource (XrmDatabase rdb, + const char *name, + const char *class); +extern void pgtk_implicitly_set_name (struct frame *f, Lisp_Object arg, + Lisp_Object oldval); + +/* Color management implemented in pgtkterm. */ +extern bool pgtk_defined_color (struct frame *f, + const char *name, + Emacs_Color * color_def, bool alloc, + bool makeIndex); +extern void pgtk_query_color (struct frame *f, Emacs_Color * color); +extern void pgtk_query_colors (struct frame *f, Emacs_Color * colors, + int ncolors); +extern int pgtk_parse_color (struct frame *f, const char *color_name, + Emacs_Color * color); + +/* Implemented in pgtkterm.c */ +extern void pgtk_clear_area (struct frame *f, int x, int y, int width, + int height); +extern int pgtk_gtk_to_emacs_modifiers (struct pgtk_display_info *dpyinfo, + int state); +extern void pgtk_clear_under_internal_border (struct frame *f); +extern void pgtk_set_event_handler (struct frame *f); + +/* Implemented in pgtkterm.c */ +extern int x_display_pixel_height (struct pgtk_display_info *); +extern int x_display_pixel_width (struct pgtk_display_info *); + +/* Implemented in pgtkterm.c */ +extern void x_destroy_window (struct frame *f); +extern void x_set_parent_frame (struct frame *f, Lisp_Object new_value, + Lisp_Object old_value); +extern void x_set_no_focus_on_map (struct frame *f, Lisp_Object new_value, + Lisp_Object old_value); +extern void x_set_no_accept_focus (struct frame *f, Lisp_Object new_value, + Lisp_Object old_value); +extern void x_set_z_group (struct frame *f, Lisp_Object new_value, + Lisp_Object old_value); + +/* Cairo related functions implemented in pgtkterm.c */ +extern void pgtk_cr_update_surface_desired_size (struct frame *, int, int, bool); +extern cairo_t *pgtk_begin_cr_clip (struct frame *f); +extern void pgtk_end_cr_clip (struct frame *f); +extern void pgtk_set_cr_source_with_gc_foreground (struct frame *f, + Emacs_GC * gc); +extern void pgtk_set_cr_source_with_gc_background (struct frame *f, + Emacs_GC * gc); +extern void pgtk_set_cr_source_with_color (struct frame *f, + unsigned long color); +extern void pgtk_cr_draw_frame (cairo_t * cr, struct frame *f); +extern void pgtk_cr_destroy_frame_context (struct frame *f); +extern Lisp_Object pgtk_cr_export_frames (Lisp_Object frames, cairo_surface_type_t surface_type); + +/* Defined in pgtkmenu.c */ +extern Lisp_Object pgtk_popup_dialog (struct frame *f, Lisp_Object header, + Lisp_Object contents); +extern Lisp_Object pgtk_dialog_show (struct frame *f, Lisp_Object title, + Lisp_Object header, + const char **error_name); +extern void initialize_frame_menubar (struct frame *); + + +/* Symbol initializations implemented in each pgtk sources. */ +extern void syms_of_pgtkterm (void); +extern void syms_of_pgtkfns (void); +extern void syms_of_pgtkmenu (void); +extern void syms_of_pgtkselect (void); +extern void syms_of_pgtkim (void); + +/* Implemented in pgtkselect. */ +extern void nxatoms_of_pgtkselect (void); + +/* Initialization and marking implemented in pgtkterm.c */ +extern void init_pgtkterm (void); +extern void mark_pgtkterm (void); +extern void pgtk_delete_terminal (struct terminal *terminal); + +extern void pgtk_make_frame_visible (struct frame *f); +extern void pgtk_make_frame_invisible (struct frame *f); +extern void x_wm_set_size_hint (struct frame *, long, bool); +extern void x_free_frame_resources (struct frame *); +extern void pgtk_iconify_frame (struct frame *f); +extern void pgtk_focus_frame (struct frame *f, bool noactivate); +extern void pgtk_set_scroll_bar_default_width (struct frame *f); +extern void pgtk_set_scroll_bar_default_height (struct frame *f); +extern Lisp_Object x_get_focus_frame (struct frame *frame); + +extern void pgtk_frame_rehighlight (struct pgtk_display_info *dpyinfo); + +extern void x_change_tab_bar_height (struct frame *, int); + +extern struct pgtk_display_info *check_pgtk_display_info (Lisp_Object object); + +extern void pgtk_default_font_parameter (struct frame *f, Lisp_Object parms); + +extern void pgtk_menu_set_in_use (bool in_use); + + +extern void pgtk_enqueue_string (struct frame *f, gchar * str); +extern void pgtk_enqueue_preedit (struct frame *f, Lisp_Object image_data); +extern void pgtk_im_focus_in (struct frame *f); +extern void pgtk_im_focus_out (struct frame *f); +extern bool pgtk_im_filter_keypress (struct frame *f, GdkEventKey * ev); +extern void pgtk_im_set_cursor_location (struct frame *f, int x, int y, + int width, int height); +extern void pgtk_im_init (struct pgtk_display_info *dpyinfo); +extern void pgtk_im_finish (struct pgtk_display_info *dpyinfo); + +extern bool xg_set_icon (struct frame *, Lisp_Object); +extern bool xg_set_icon_from_xpm_data (struct frame *f, const char **data); + +extern bool pgtk_text_icon (struct frame *f, const char *icon_name); + +extern double pgtk_frame_scale_factor (struct frame *); +extern int pgtk_emacs_to_gtk_modifiers (struct pgtk_display_info *, int); + +#endif /* HAVE_PGTK */ +#endif /* _PGTKTERM_H_ */ diff --git a/src/print.c b/src/print.c index 9f684bbeb53..9f3d8317ae3 100644 --- a/src/print.c +++ b/src/print.c @@ -564,7 +564,7 @@ temp_output_buffer_setup (const char *bufname) Fset_buffer (Fget_buffer_create (build_string (bufname), Qnil)); - Fkill_all_local_variables (); + Fkill_all_local_variables (Qnil); delete_all_overlays (current_buffer); bset_directory (current_buffer, BVAR (old, directory)); bset_read_only (current_buffer, Qnil); @@ -1521,8 +1521,31 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, printchar ('>', printcharfun); break; - case PVEC_XWIDGET: case PVEC_XWIDGET_VIEW: - print_c_string ("#<xwidget ", printcharfun); + case PVEC_XWIDGET: +#ifdef HAVE_XWIDGETS + { + if (NILP (XXWIDGET (obj)->buffer)) + print_c_string ("#<killed xwidget>", printcharfun); + else + { +#ifdef USE_GTK + int len = sprintf (buf, "#<xwidget %u %p>", + XXWIDGET (obj)->xwidget_id, + XXWIDGET (obj)->widget_osr); +#else + int len = sprintf (buf, "#<xwidget %u %p>", + XXWIDGET (obj)->xwidget_id, + XXWIDGET (obj)->xwWidget); +#endif + strout (buf, len, len, printcharfun); + } + break; + } +#else + emacs_abort (); +#endif + case PVEC_XWIDGET_VIEW: + print_c_string ("#<xwidget view", printcharfun); printchar ('>', printcharfun); break; @@ -1857,6 +1880,22 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, } break; #endif + case PVEC_SQLITE: + { + print_c_string ("#<sqlite ", printcharfun); + int i = sprintf (buf, "db=%p", XSQLITE (obj)->db); + strout (buf, i, i, printcharfun); + if (XSQLITE (obj)->is_statement) + { + i = sprintf (buf, " stmt=%p", XSQLITE (obj)->stmt); + strout (buf, i, i, printcharfun); + } + i = sprintf (buf, " name=%s", XSQLITE (obj)->name); + strout (buf, i, i, printcharfun); + printchar ('>', printcharfun); + } + break; + default: emacs_abort (); } diff --git a/src/process.c b/src/process.c index 1d307d5242c..76094988f25 100644 --- a/src/process.c +++ b/src/process.c @@ -261,7 +261,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); @@ -2169,7 +2169,8 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir) p->pty_flag = pty_flag; pset_status (p, Qrun); - if (!EQ (p->command, Qt)) + if (!EQ (p->command, Qt) + && !EQ (p->filter, Qt)) add_process_read_fd (inchannel); ptrdiff_t count = SPECPDL_INDEX (); @@ -2287,7 +2288,8 @@ create_pty (Lisp_Object process) pset_status (p, Qrun); setup_process_coding_systems (process); - add_process_read_fd (pty_fd); + if (!EQ (p->filter, Qt)) + add_process_read_fd (pty_fd); pset_tty_name (p, build_string (pty_name)); } @@ -2396,7 +2398,8 @@ usage: (make-pipe-process &rest ARGS) */) pset_command (p, Qt); eassert (! p->pty_flag); - if (!EQ (p->command, Qt)) + if (!EQ (p->command, Qt) + && !EQ (p->filter, Qt)) add_process_read_fd (inchannel); p->adaptive_read_buffering = (NILP (Vprocess_adaptive_read_buffering) ? 0 @@ -3131,7 +3134,8 @@ usage: (make-serial-process &rest ARGS) */) pset_command (p, Qt); eassert (! p->pty_flag); - if (!EQ (p->command, Qt)) + if (!EQ (p->command, Qt) + && !EQ (p->filter, Qt)) add_process_read_fd (fd); update_process_mark (p); @@ -5586,6 +5590,15 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, timeout = make_timespec (0, 0); #endif +#if !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; +#endif + /* Non-macOS HAVE_GLIB builds call thread_select in xgselect.c. */ #if defined HAVE_GLIB && !defined HAVE_NS nfds = xg_select (max_desc + 1, @@ -5719,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, @@ -5727,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, @@ -5979,7 +5996,8 @@ read_process_output_error_handler (Lisp_Object error_val) cmd_error_internal (error_val, "error in process filter: "); Vinhibit_quit = Qt; update_echo_area (); - Fsleep_for (make_fixnum (2), Qnil); + if (process_error_pause_time > 0) + Fsleep_for (make_fixnum (process_error_pause_time), Qnil); return Qt; } @@ -7409,7 +7427,8 @@ exec_sentinel_error_handler (Lisp_Object error_val) cmd_error_internal (error_val, "error in process sentinel: "); Vinhibit_quit = Qt; update_echo_area (); - Fsleep_for (make_fixnum (2), Qnil); + if (process_error_pause_time > 0) + Fsleep_for (make_fixnum (process_error_pause_time), Qnil); return Qt; } @@ -7724,7 +7743,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. */ @@ -8574,6 +8593,12 @@ Enlarge the value only if the subprocess generates very large (megabytes) amounts of data in one go. */); read_process_output_max = 4096; + DEFVAR_INT ("process-error-pause-time", process_error_pause_time, + doc: /* The number of seconds to pause after handling process errors. +This isn't used for all process-related errors, but is used when a +sentinel or a process filter function has an error. */); + process_error_pause_time = 1; + DEFSYM (Qinternal_default_interrupt_process, "internal-default-interrupt-process"); DEFSYM (Qinterrupt_process_functions, "interrupt-process-functions"); diff --git a/src/search.c b/src/search.c index 08f1e9474f1..66e77d42b4a 100644 --- a/src/search.c +++ b/src/search.c @@ -260,7 +260,7 @@ compile_pattern (Lisp_Object pattern, struct re_registers *regp, static Lisp_Object -looking_at_1 (Lisp_Object string, bool posix) +looking_at_1 (Lisp_Object string, bool posix, bool modify_data) { Lisp_Object val; unsigned char *p1, *p2; @@ -278,11 +278,11 @@ looking_at_1 (Lisp_Object string, bool posix) CHECK_STRING (string); /* Snapshot in case Lisp changes the value. */ - bool preserve_match_data = NILP (Vinhibit_changing_match_data); + bool modify_match_data = NILP (Vinhibit_changing_match_data) && modify_data; struct regexp_cache *cache_entry = compile_pattern ( string, - preserve_match_data ? &search_regs : NULL, + modify_match_data ? &search_regs : NULL, (!NILP (BVAR (current_buffer, case_fold_search)) ? BVAR (current_buffer, case_canon_table) : Qnil), posix, @@ -316,7 +316,7 @@ looking_at_1 (Lisp_Object string, bool posix) re_match_object = Qnil; i = re_match_2 (&cache_entry->buf, (char *) p1, s1, (char *) p2, s2, PT_BYTE - BEGV_BYTE, - preserve_match_data ? &search_regs : NULL, + modify_match_data ? &search_regs : NULL, ZV_BYTE - BEGV_BYTE); if (i == -2) @@ -326,7 +326,7 @@ looking_at_1 (Lisp_Object string, bool posix) } val = (i >= 0 ? Qt : Qnil); - if (preserve_match_data && i >= 0) + if (modify_match_data && i >= 0) { for (i = 0; i < search_regs.num_regs; i++) if (search_regs.start[i] >= 0) @@ -343,35 +343,37 @@ looking_at_1 (Lisp_Object string, bool posix) return unbind_to (count, val); } -DEFUN ("looking-at", Flooking_at, Slooking_at, 1, 1, 0, +DEFUN ("looking-at", Flooking_at, Slooking_at, 1, 2, 0, doc: /* Return t if text after point matches regular expression REGEXP. -This function modifies the match data that `match-beginning', -`match-end' and `match-data' access; save and restore the match -data if you want to preserve them. */) - (Lisp_Object regexp) +By default, this function modifies the match data that +`match-beginning', `match-end' and `match-data' access. If +INHIBIT-MODIFY is non-nil, don't modify the match data. */) + (Lisp_Object regexp, Lisp_Object inhibit_modify) { - return looking_at_1 (regexp, 0); + return looking_at_1 (regexp, 0, NILP (inhibit_modify)); } -DEFUN ("posix-looking-at", Fposix_looking_at, Sposix_looking_at, 1, 1, 0, +DEFUN ("posix-looking-at", Fposix_looking_at, Sposix_looking_at, 1, 2, 0, doc: /* Return t if text after point matches REGEXP according to Posix rules. Find the longest match, in accordance with Posix regular expression rules. -This function modifies the match data that `match-beginning', -`match-end' and `match-data' access; save and restore the match -data if you want to preserve them. */) - (Lisp_Object regexp) + +By default, this function modifies the match data that +`match-beginning', `match-end' and `match-data' access. If +INHIBIT-MODIFY is non-nil, don't modify the match data. */) + (Lisp_Object regexp, Lisp_Object inhibit_modify) { - return looking_at_1 (regexp, 1); + return looking_at_1 (regexp, 1, NILP (inhibit_modify)); } static Lisp_Object string_match_1 (Lisp_Object regexp, Lisp_Object string, Lisp_Object start, - bool posix) + bool posix, bool modify_data) { ptrdiff_t val; struct re_pattern_buffer *bufp; EMACS_INT pos; ptrdiff_t pos_byte, i; + bool modify_match_data = NILP (Vinhibit_changing_match_data) && modify_data; if (running_asynch_code) save_search_regs (); @@ -400,8 +402,7 @@ string_match_1 (Lisp_Object regexp, Lisp_Object string, Lisp_Object start, BVAR (current_buffer, case_eqv_table)); bufp = &compile_pattern (regexp, - (NILP (Vinhibit_changing_match_data) - ? &search_regs : NULL), + (modify_match_data ? &search_regs : NULL), (!NILP (BVAR (current_buffer, case_fold_search)) ? BVAR (current_buffer, case_canon_table) : Qnil), posix, @@ -410,18 +411,17 @@ string_match_1 (Lisp_Object regexp, Lisp_Object string, Lisp_Object start, val = re_search (bufp, SSDATA (string), SBYTES (string), pos_byte, SBYTES (string) - pos_byte, - (NILP (Vinhibit_changing_match_data) - ? &search_regs : NULL)); + (modify_match_data ? &search_regs : NULL)); /* Set last_thing_searched only when match data is changed. */ - if (NILP (Vinhibit_changing_match_data)) + if (modify_match_data) last_thing_searched = Qt; if (val == -2) matcher_overflow (); if (val < 0) return Qnil; - if (NILP (Vinhibit_changing_match_data)) + if (modify_match_data) for (i = 0; i < search_regs.num_regs; i++) if (search_regs.start[i] >= 0) { @@ -434,32 +434,42 @@ string_match_1 (Lisp_Object regexp, Lisp_Object string, Lisp_Object start, return make_fixnum (string_byte_to_char (string, val)); } -DEFUN ("string-match", Fstring_match, Sstring_match, 2, 3, 0, +DEFUN ("string-match", Fstring_match, Sstring_match, 2, 4, 0, doc: /* Return index of start of first match for REGEXP in STRING, or nil. Matching ignores case if `case-fold-search' is non-nil. If third arg START is non-nil, start search at that index in STRING. -For index of first char beyond the match, do (match-end 0). -`match-end' and `match-beginning' also give indices of substrings -matched by parenthesis constructs in the pattern. -You can use the function `match-string' to extract the substrings -matched by the parenthesis constructions in REGEXP. */) - (Lisp_Object regexp, Lisp_Object string, Lisp_Object start) +If INHIBIT-MODIFY is non-nil, match data is not changed. + +If INHIBIT-MODIFY is nil or missing, match data is changed, and +`match-end' and `match-beginning' give indices of substrings matched +by parenthesis constructs in the pattern. You can use the function +`match-string' to extract the substrings matched by the parenthesis +constructions in REGEXP. For index of first char beyond the match, do +(match-end 0). */) + (Lisp_Object regexp, Lisp_Object string, Lisp_Object start, + Lisp_Object inhibit_modify) { - return string_match_1 (regexp, string, start, 0); + return string_match_1 (regexp, string, start, 0, NILP (inhibit_modify)); } -DEFUN ("posix-string-match", Fposix_string_match, Sposix_string_match, 2, 3, 0, +DEFUN ("posix-string-match", Fposix_string_match, Sposix_string_match, 2, 4, 0, doc: /* Return index of start of first match for Posix REGEXP in STRING, or nil. Find the longest match, in accord with Posix regular expression rules. Case is ignored if `case-fold-search' is non-nil in the current buffer. -If third arg START is non-nil, start search at that index in STRING. -For index of first char beyond the match, do (match-end 0). -`match-end' and `match-beginning' also give indices of substrings -matched by parenthesis constructs in the pattern. */) - (Lisp_Object regexp, Lisp_Object string, Lisp_Object start) + +If INHIBIT-MODIFY is non-nil, match data is not changed. + +If INHIBIT-MODIFY is nil or missing, match data is changed, and +`match-end' and `match-beginning' give indices of substrings matched +by parenthesis constructs in the pattern. You can use the function +`match-string' to extract the substrings matched by the parenthesis +constructions in REGEXP. For index of first char beyond the match, do +(match-end 0). */) + (Lisp_Object regexp, Lisp_Object string, Lisp_Object start, + Lisp_Object inhibit_modify) { - return string_match_1 (regexp, string, start, 1); + return string_match_1 (regexp, string, start, 1, NILP (inhibit_modify)); } /* Match REGEXP against STRING using translation table TABLE, 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/sqlite.c b/src/sqlite.c new file mode 100644 index 00000000000..428b84b21e7 --- /dev/null +++ b/src/sqlite.c @@ -0,0 +1,753 @@ +/* +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 <https://www.gnu.org/licenses/>. + +This file is based on the emacs-sqlite3 package written by Syohei +YOSHIDA <syohex@gmail.com>, which can be found at: + + https://github.com/syohex/emacs-sqlite3 +*/ + +#include <config.h> +#include "lisp.h" +#include "coding.h" + +#ifdef HAVE_SQLITE3 + +#include <sqlite3.h> + +#ifdef WINDOWSNT + +# include <windows.h> +# include "w32common.h" +# include "w32.h" + +DEF_DLL_FN (SQLITE_API int, sqlite3_finalize, (sqlite3_stmt*)); +DEF_DLL_FN (SQLITE_API int, sqlite3_close, (sqlite3*)); +DEF_DLL_FN (SQLITE_API int, sqlite3_open_v2, + (const char*, sqlite3**, int, const char*)); +DEF_DLL_FN (SQLITE_API int, sqlite3_reset, (sqlite3_stmt*)); +DEF_DLL_FN (SQLITE_API int, sqlite3_bind_text, + (sqlite3_stmt*, int, const char*, int, void(*)(void*))); +DEF_DLL_FN (SQLITE_API int, sqlite3_bind_int64, + (sqlite3_stmt*, int, sqlite3_int64)); +DEF_DLL_FN (SQLITE_API int, sqlite3_bind_double, (sqlite3_stmt*, int, double)); +DEF_DLL_FN (SQLITE_API int, sqlite3_bind_null, (sqlite3_stmt*, int)); +DEF_DLL_FN (SQLITE_API int, sqlite3_bind_int, (sqlite3_stmt*, int, int)); +DEF_DLL_FN (SQLITE_API const char*, sqlite3_errmsg, (sqlite3*)); +DEF_DLL_FN (SQLITE_API int, sqlite3_step, (sqlite3_stmt*)); +DEF_DLL_FN (SQLITE_API int, sqlite3_changes, (sqlite3*)); +DEF_DLL_FN (SQLITE_API int, sqlite3_column_count, (sqlite3_stmt*)); +DEF_DLL_FN (SQLITE_API int, sqlite3_column_type, (sqlite3_stmt*, int)); +DEF_DLL_FN (SQLITE_API sqlite3_int64, sqlite3_column_int64, + (sqlite3_stmt*, int)); +DEF_DLL_FN (SQLITE_API double, sqlite3_column_double, (sqlite3_stmt*, int)); +DEF_DLL_FN (SQLITE_API const void*, sqlite3_column_blob, + (sqlite3_stmt*, int)); +DEF_DLL_FN (SQLITE_API int, sqlite3_column_bytes, (sqlite3_stmt*, int)); +DEF_DLL_FN (SQLITE_API const unsigned char*, sqlite3_column_text, + (sqlite3_stmt*, int)); +DEF_DLL_FN (SQLITE_API const char*, sqlite3_column_name, (sqlite3_stmt*, int)); +DEF_DLL_FN (SQLITE_API int, sqlite3_exec, + (sqlite3*, const char*, int (*callback)(void*,int,char**,char**), + void*, char**)); +DEF_DLL_FN (SQLITE_API int, sqlite3_prepare_v2, + (sqlite3*, const char*, int, sqlite3_stmt**, const char**)); + +# ifdef HAVE_SQLITE3_LOAD_EXTENSION +DEF_DLL_FN (SQLITE_API int, sqlite3_load_extension, + (sqlite3*, const char*, const char*, char**)); +# undef sqlite3_load_extension +# define sqlite3_load_extension fn_sqlite3_load_extension +# endif + +# undef sqlite3_finalize +# undef sqlite3_close +# undef sqlite3_open_v2 +# undef sqlite3_reset +# undef sqlite3_bind_text +# undef sqlite3_bind_int64 +# undef sqlite3_bind_double +# undef sqlite3_bind_null +# undef sqlite3_bind_int +# undef sqlite3_errmsg +# undef sqlite3_step +# undef sqlite3_changes +# undef sqlite3_column_count +# undef sqlite3_column_type +# undef sqlite3_column_int64 +# undef sqlite3_column_double +# undef sqlite3_column_blob +# undef sqlite3_column_bytes +# undef sqlite3_column_text +# undef sqlite3_column_name +# undef sqlite3_exec +# undef sqlite3_prepare_v2 + +# define sqlite3_finalize fn_sqlite3_finalize +# define sqlite3_close fn_sqlite3_close +# define sqlite3_open_v2 fn_sqlite3_open_v2 +# define sqlite3_reset fn_sqlite3_reset +# define sqlite3_bind_text fn_sqlite3_bind_text +# define sqlite3_bind_int64 fn_sqlite3_bind_int64 +# define sqlite3_bind_double fn_sqlite3_bind_double +# define sqlite3_bind_null fn_sqlite3_bind_null +# define sqlite3_bind_int fn_sqlite3_bind_int +# define sqlite3_errmsg fn_sqlite3_errmsg +# define sqlite3_step fn_sqlite3_step +# define sqlite3_changes fn_sqlite3_changes +# define sqlite3_column_count fn_sqlite3_column_count +# define sqlite3_column_type fn_sqlite3_column_type +# define sqlite3_column_int64 fn_sqlite3_column_int64 +# define sqlite3_column_double fn_sqlite3_column_double +# define sqlite3_column_blob fn_sqlite3_column_blob +# define sqlite3_column_bytes fn_sqlite3_column_bytes +# define sqlite3_column_text fn_sqlite3_column_text +# define sqlite3_column_name fn_sqlite3_column_name +# define sqlite3_exec fn_sqlite3_exec +# define sqlite3_prepare_v2 fn_sqlite3_prepare_v2 + +static bool +load_dll_functions (HMODULE library) +{ + LOAD_DLL_FN (library, sqlite3_finalize); + LOAD_DLL_FN (library, sqlite3_close); + LOAD_DLL_FN (library, sqlite3_open_v2); + LOAD_DLL_FN (library, sqlite3_reset); + LOAD_DLL_FN (library, sqlite3_bind_text); + LOAD_DLL_FN (library, sqlite3_bind_int64); + LOAD_DLL_FN (library, sqlite3_bind_double); + LOAD_DLL_FN (library, sqlite3_bind_null); + LOAD_DLL_FN (library, sqlite3_bind_int); + LOAD_DLL_FN (library, sqlite3_errmsg); + LOAD_DLL_FN (library, sqlite3_step); + LOAD_DLL_FN (library, sqlite3_changes); + LOAD_DLL_FN (library, sqlite3_column_count); + LOAD_DLL_FN (library, sqlite3_column_type); + LOAD_DLL_FN (library, sqlite3_column_int64); + LOAD_DLL_FN (library, sqlite3_column_double); + LOAD_DLL_FN (library, sqlite3_column_blob); + LOAD_DLL_FN (library, sqlite3_column_bytes); + LOAD_DLL_FN (library, sqlite3_column_text); + LOAD_DLL_FN (library, sqlite3_column_name); + LOAD_DLL_FN (library, sqlite3_exec); +# ifdef HAVE_SQLITE3_LOAD_EXTENSION + LOAD_DLL_FN (library, sqlite3_load_extension); +# endif + LOAD_DLL_FN (library, sqlite3_prepare_v2); + return true; +} +#endif /* WINDOWSNT */ + +static bool +init_sqlite_functions (void) +{ +#ifdef WINDOWSNT + static bool sqlite3_initialized; + + if (!sqlite3_initialized) + { + HMODULE library = w32_delayed_load (Qsqlite3); + + if (!library) + message1 ("sqlite3 library was not found"); + else if (load_dll_functions (library)) + { + sqlite3_initialized = true; + Vlibrary_cache = Fcons (Fcons (Qsqlite3, Qt), Vlibrary_cache); + } + else + { + message1 ("sqlite3 library was found, but could not be loaded successfully"); + Vlibrary_cache = Fcons (Fcons (Qsqlite3, Qnil), Vlibrary_cache); + } + } + return sqlite3_initialized; +#else /* !WINDOWSNT */ + return true; +#endif /* !WINDOWSNT */ +} + + +static void +sqlite_free (void *arg) +{ + struct Lisp_Sqlite *ptr = (struct Lisp_Sqlite *)arg; + if (ptr->is_statement) + sqlite3_finalize (ptr->stmt); + else if (ptr->db) + sqlite3_close (ptr->db); + xfree (ptr->name); + xfree (ptr); +} + +static Lisp_Object +encode_string (Lisp_Object string) +{ + if (STRING_MULTIBYTE (string)) + return encode_string_utf_8 (string, Qnil, 0, Qt, Qt); + else + return string; +} + +static Lisp_Object +make_sqlite (bool is_statement, void *db, void *stmt, char *name) +{ + struct Lisp_Sqlite *ptr + = ALLOCATE_PLAIN_PSEUDOVECTOR (struct Lisp_Sqlite, PVEC_SQLITE); + ptr->is_statement = is_statement; + ptr->finalizer = sqlite_free; + ptr->db = db; + ptr->name = name; + ptr->stmt = stmt; + ptr->eof = false; + return make_lisp_ptr (ptr, Lisp_Vectorlike); +} + +static void +check_sqlite (Lisp_Object db, bool is_statement) +{ + init_sqlite_functions (); + CHECK_SQLITE (db); + if (is_statement && !XSQLITE (db)->is_statement) + xsignal1 (Qerror, build_string ("Invalid set object")); + else if (!is_statement && XSQLITE (db)->is_statement) + xsignal1 (Qerror, build_string ("Invalid database object")); + if (!is_statement && !XSQLITE (db)->db) + xsignal1 (Qerror, build_string ("Database closed")); + else if (is_statement && !XSQLITE (db)->db) + xsignal1 (Qerror, build_string ("Statement closed")); +} + +static int db_count = 0; + +DEFUN ("sqlite-open", Fsqlite_open, Ssqlite_open, 0, 1, 0, + doc: /* Open FILE as an sqlite database. +If FILE is nil, an in-memory database will be opened instead. */) + (Lisp_Object file) +{ + char *name; + if (!init_sqlite_functions ()) + xsignal1 (Qerror, build_string ("sqlite support is not available")); + + if (!NILP (file)) + { + CHECK_STRING (file); + file = ENCODE_FILE (Fexpand_file_name (file, Qnil)); + name = xstrdup (SSDATA (file)); + } + else + /* In-memory database. These have to have different names to + refer to different databases. */ + name = xstrdup (SSDATA (CALLN (Fformat, build_string (":memory:%d"), + make_int (++db_count)))); + + sqlite3 *sdb; + int ret = sqlite3_open_v2 (name, + &sdb, + SQLITE_OPEN_FULLMUTEX + | SQLITE_OPEN_READWRITE + | SQLITE_OPEN_CREATE + | (NILP (file) ? SQLITE_OPEN_MEMORY : 0) +#ifdef SQLITE_OPEN_URI + | SQLITE_OPEN_URI +#endif + | 0, NULL); + + if (ret != SQLITE_OK) + return Qnil; + + return make_sqlite (false, sdb, NULL, name); +} + +DEFUN ("sqlite-close", Fsqlite_close, Ssqlite_close, 1, 1, 0, + doc: /* Close the sqlite database DB. */) + (Lisp_Object db) +{ + check_sqlite (db, false); + sqlite3_close (XSQLITE (db)->db); + XSQLITE (db)->db = NULL; + return Qt; +} + +/* Bind values in a statement like + "insert into foo values (?, ?, ?)". */ +static const char * +bind_values (sqlite3 *db, sqlite3_stmt *stmt, Lisp_Object values) +{ + sqlite3_reset (stmt); + int len; + if (VECTORP (values)) + len = ASIZE (values); + else + len = list_length (values); + + for (int i = 0; i < len; ++i) + { + int ret = SQLITE_MISMATCH; + Lisp_Object value; + if (VECTORP (values)) + value = AREF (values, i); + else + { + value = XCAR (values); + values = XCDR (values); + } + Lisp_Object type = Ftype_of (value); + + if (EQ (type, Qstring)) + { + Lisp_Object encoded = encode_string (value); + ret = sqlite3_bind_text (stmt, i + 1, + SSDATA (encoded), SBYTES (encoded), + NULL); + } + else if (EQ (type, Qinteger)) + { + if (BIGNUMP (value)) + ret = sqlite3_bind_int64 (stmt, i + 1, bignum_to_intmax (value)); + else + ret = sqlite3_bind_int64 (stmt, i + 1, XFIXNUM (value)); + } + else if (EQ (type, Qfloat)) + ret = sqlite3_bind_double (stmt, i + 1, XFLOAT_DATA (value)); + else if (NILP (value)) + ret = sqlite3_bind_null (stmt, i + 1); + else if (EQ (value, Qt)) + ret = sqlite3_bind_int (stmt, i + 1, 1); + else if (EQ (value, Qfalse)) + ret = sqlite3_bind_int (stmt, i + 1, 0); + else + return "invalid argument"; + + if (ret != SQLITE_OK) + return sqlite3_errmsg (db); + } + + return NULL; +} + +DEFUN ("sqlite-execute", Fsqlite_execute, Ssqlite_execute, 2, 3, 0, + doc: /* Execute a non-select SQL statement. +If VALUES is non-nil, it should be a vector or a list of values +to bind when executing a statement like + + insert into foo values (?, ?, ...) + +Value is the number of affected rows. */) + (Lisp_Object db, Lisp_Object query, Lisp_Object values) +{ + check_sqlite (db, false); + CHECK_STRING (query); + if (!(NILP (values) || CONSP (values) || VECTORP (values))) + xsignal1 (Qerror, build_string ("VALUES must be a list or a vector")); + + sqlite3 *sdb = XSQLITE (db)->db; + Lisp_Object retval = Qnil; + const char *errmsg = NULL; + Lisp_Object encoded = encode_string (query); + sqlite3_stmt *stmt = NULL; + + /* We only execute the first statement -- if there's several + (separated by a semicolon), the subsequent statements won't be + done. */ + int ret = sqlite3_prepare_v2 (sdb, SSDATA (encoded), -1, &stmt, NULL); + if (ret != SQLITE_OK) + { + if (stmt != NULL) + { + sqlite3_finalize (stmt); + sqlite3_reset (stmt); + } + + errmsg = sqlite3_errmsg (sdb); + goto exit; + } + + /* Bind ? values. */ + if (!NILP (values)) { + const char *err = bind_values (sdb, stmt, values); + if (err != NULL) + { + errmsg = err; + goto exit; + } + } + + ret = sqlite3_step (stmt); + sqlite3_finalize (stmt); + if (ret != SQLITE_OK && ret != SQLITE_DONE) + { + errmsg = sqlite3_errmsg (sdb); + goto exit; + } + + retval = make_fixnum (sqlite3_changes (sdb)); + + exit: + if (errmsg != NULL) + xsignal1 (ret == SQLITE_LOCKED || ret == SQLITE_BUSY? + Qsqlite_locked_error: Qerror, + build_string (errmsg)); + + return retval; +} + +static Lisp_Object +row_to_value (sqlite3_stmt *stmt) +{ + int len = sqlite3_column_count (stmt); + Lisp_Object values = Qnil; + + for (int i = 0; i < len; ++i) + { + Lisp_Object v = Qnil; + + switch (sqlite3_column_type (stmt, i)) + { + case SQLITE_INTEGER: + v = make_int (sqlite3_column_int64 (stmt, i)); + break; + + case SQLITE_FLOAT: + v = make_float (sqlite3_column_double (stmt, i)); + break; + + case SQLITE_BLOB: + v = + code_convert_string_norecord + (make_unibyte_string (sqlite3_column_blob (stmt, i), + sqlite3_column_bytes (stmt, i)), + Qutf_8, false); + break; + + case SQLITE_NULL: + v = Qnil; + break; + + case SQLITE_TEXT: + v = + code_convert_string_norecord + (make_unibyte_string ((const char *)sqlite3_column_text (stmt, i), + sqlite3_column_bytes (stmt, i)), + Qutf_8, false); + break; + } + + values = Fcons (v, values); + } + + return Fnreverse (values); +} + +static Lisp_Object +column_names (sqlite3_stmt *stmt) +{ + Lisp_Object columns = Qnil; + int count = sqlite3_column_count (stmt); + for (int i = 0; i < count; ++i) + columns = Fcons (build_string (sqlite3_column_name (stmt, i)), columns); + + return Fnreverse (columns); +} + +DEFUN ("sqlite-select", Fsqlite_select, Ssqlite_select, 2, 4, 0, + doc: /* Select data from the database DB that matches QUERY. +If VALUES is non-nil, it should be a list or a vector specifying the +values that will be interpolated into a parameterized statement. + +By default, the return value is a list where the first element is a +list of column names, and the rest of the elements are the matching data. + +RETURN-TYPE can be either nil (which means that the matching data +should be returned as a list of rows), or `full' (the same, but the +first element in the return list will be the column names), or `set', +which means that we return a set object that can be queried with +`sqlite-next' and other functions to get the data. */) + (Lisp_Object db, Lisp_Object query, Lisp_Object values, + Lisp_Object return_type) +{ + check_sqlite (db, false); + CHECK_STRING (query); + + if (!(NILP (values) || CONSP (values) || VECTORP (values))) + xsignal1 (Qerror, build_string ("VALUES must be a list or a vector")); + + sqlite3 *sdb = XSQLITE (db)->db; + Lisp_Object retval = Qnil; + const char *errmsg = NULL; + Lisp_Object encoded = encode_string (query); + + sqlite3_stmt *stmt = NULL; + int ret = sqlite3_prepare_v2 (sdb, SSDATA (encoded), SBYTES (encoded), + &stmt, NULL); + if (ret != SQLITE_OK) + { + if (stmt) + sqlite3_finalize (stmt); + + goto exit; + } + + /* Query with parameters. */ + if (!NILP (values)) + { + const char *err = bind_values (sdb, stmt, values); + if (err != NULL) + { + sqlite3_finalize (stmt); + errmsg = err; + goto exit; + } + } + + /* Return a handle to get the data. */ + if (EQ (return_type, Qset)) + { + retval = make_sqlite (true, sdb, stmt, XSQLITE (db)->name); + goto exit; + } + + /* Return the data directly. */ + Lisp_Object data = Qnil; + while ((ret = sqlite3_step (stmt)) == SQLITE_ROW) + data = Fcons (row_to_value (stmt), data); + + if (EQ (return_type, Qfull)) + retval = Fcons (column_names (stmt), Fnreverse (data)); + else + retval = Fnreverse (data); + sqlite3_finalize (stmt); + + exit: + if (errmsg != NULL) + xsignal1 (Qerror, build_string (errmsg)); + + return retval; +} + +static Lisp_Object +sqlite_exec (sqlite3 *sdb, const char *query) +{ + int ret = sqlite3_exec (sdb, query, NULL, NULL, NULL); + if (ret != SQLITE_OK) + return Qnil; + + return Qt; +} + +DEFUN ("sqlite-transaction", Fsqlite_transaction, Ssqlite_transaction, 1, 1, 0, + doc: /* Start a transaction in DB. */) + (Lisp_Object db) +{ + check_sqlite (db, false); + return sqlite_exec (XSQLITE (db)->db, "begin"); +} + +DEFUN ("sqlite-commit", Fsqlite_commit, Ssqlite_commit, 1, 1, 0, + doc: /* Commit a transaction in DB. */) + (Lisp_Object db) +{ + check_sqlite (db, false); + return sqlite_exec (XSQLITE (db)->db, "commit"); +} + +DEFUN ("sqlite-rollback", Fsqlite_rollback, Ssqlite_rollback, 1, 1, 0, + doc: /* Roll back a transaction in DB. */) + (Lisp_Object db) +{ + check_sqlite (db, false); + return sqlite_exec (XSQLITE (db)->db, "rollback"); +} + +DEFUN ("sqlite-pragma", Fsqlite_pragma, Ssqlite_pragma, 2, 2, 0, + doc: /* Execute PRAGMA in DB. */) + (Lisp_Object db, Lisp_Object pragma) +{ + check_sqlite (db, false); + CHECK_STRING (pragma); + + return sqlite_exec (XSQLITE (db)->db, + SSDATA (concat2 (build_string ("PRAGMA "), pragma))); +} + +#ifdef HAVE_SQLITE3_LOAD_EXTENSION +DEFUN ("sqlite-load-extension", Fsqlite_load_extension, + Ssqlite_load_extension, 2, 2, 0, + doc: /* Load an SQlite MODULE into DB. +MODULE should be the name of an SQlite module's file, a +shared library in the system-dependent format and having a +system-dependent file-name extension. + +Only modules on Emacs' list of allowed modules can be loaded. */) + (Lisp_Object db, Lisp_Object module) +{ + check_sqlite (db, false); + CHECK_STRING (module); + + /* Add names of useful and free modules here. */ + const char *allowlist[3] = { "pcre", "csvtable", NULL }; + char *name = SSDATA (Ffile_name_nondirectory (module)); + /* Possibly skip past a common prefix. */ + const char *prefix = "libsqlite3_mod_"; + if (!strncmp (name, prefix, strlen (prefix))) + name += strlen (prefix); + + bool do_allow = false; + for (const char **allow = allowlist; *allow; allow++) + { + if (strlen (*allow) < strlen (name) + && !strncmp (*allow, name, strlen (*allow)) + && (!strcmp (name + strlen (*allow), ".so") + || !strcmp (name + strlen (*allow), ".DLL"))) + { + do_allow = true; + break; + } + } + + if (!do_allow) + xsignal (Qerror, build_string ("Module name not on allowlist")); + + int result = sqlite3_load_extension + (XSQLITE (db)->db, + SSDATA (ENCODE_FILE (Fexpand_file_name (module, Qnil))), + NULL, NULL); + if (result == SQLITE_OK) + return Qt; + return Qnil; +} +#endif /* HAVE_SQLITE3_LOAD_EXTENSION */ + +DEFUN ("sqlite-next", Fsqlite_next, Ssqlite_next, 1, 1, 0, + doc: /* Return the next result set from SET. */) + (Lisp_Object set) +{ + check_sqlite (set, true); + + int ret = sqlite3_step (XSQLITE (set)->stmt); + if (ret != SQLITE_ROW && ret != SQLITE_OK && ret != SQLITE_DONE) + xsignal1 (Qerror, build_string (sqlite3_errmsg (XSQLITE (set)->db))); + + if (ret == SQLITE_DONE) + { + XSQLITE (set)->eof = true; + return Qnil; + } + + return row_to_value (XSQLITE (set)->stmt); +} + +DEFUN ("sqlite-columns", Fsqlite_columns, Ssqlite_columns, 1, 1, 0, + doc: /* Return the column names of SET. */) + (Lisp_Object set) +{ + check_sqlite (set, true); + return column_names (XSQLITE (set)->stmt); +} + +DEFUN ("sqlite-more-p", Fsqlite_more_p, Ssqlite_more_p, 1, 1, 0, + doc: /* Say whether there are any further results in SET. */) + (Lisp_Object set) +{ + check_sqlite (set, true); + + if (XSQLITE (set)->eof) + return Qnil; + else + return Qt; +} + +DEFUN ("sqlite-finalize", Fsqlite_finalize, Ssqlite_finalize, 1, 1, 0, + doc: /* Mark this SET as being finished. +This will free the resources held by SET. */) + (Lisp_Object set) +{ + check_sqlite (set, true); + sqlite3_finalize (XSQLITE (set)->stmt); + XSQLITE (set)->db = NULL; + return Qt; +} + +#endif /* HAVE_SQLITE3 */ + +DEFUN ("sqlitep", Fsqlitep, Ssqlitep, 1, 1, 0, + doc: /* Say whether OBJECT is an SQlite object. */) + (Lisp_Object object) +{ +#ifdef HAVE_SQLITE3 + return SQLITE (object)? Qt: Qnil; +#else + return Qnil; +#endif +} + +DEFUN ("sqlite-available-p", Fsqlite_available_p, Ssqlite_available_p, 0, 0, 0, + doc: /* Return t if sqlite3 support is available in this instance of Emacs.*/) + (void) +{ +#ifdef HAVE_SQLITE3 +# ifdef WINDOWSNT + Lisp_Object found = Fassq (Qsqlite3, Vlibrary_cache); + if (CONSP (found)) + return XCDR (found); + else + return init_sqlite_functions () ? Qt : Qnil; +# else + return Qt; +#endif +#else + return Qnil; +#endif +} + +void +syms_of_sqlite (void) +{ +#ifdef HAVE_SQLITE3 + defsubr (&Ssqlite_open); + defsubr (&Ssqlite_close); + defsubr (&Ssqlite_execute); + defsubr (&Ssqlite_select); + defsubr (&Ssqlite_transaction); + defsubr (&Ssqlite_commit); + defsubr (&Ssqlite_rollback); + defsubr (&Ssqlite_pragma); +#ifdef HAVE_SQLITE3_LOAD_EXTENSION + defsubr (&Ssqlite_load_extension); +#endif + defsubr (&Ssqlite_next); + defsubr (&Ssqlite_columns); + defsubr (&Ssqlite_more_p); + defsubr (&Ssqlite_finalize); + DEFSYM (Qset, "set"); + DEFSYM (Qfull, "full"); +#endif + defsubr (&Ssqlitep); + defsubr (&Ssqlite_available_p); + + DEFSYM (Qsqlite_locked_error, "sqlite-locked-error"); + Fput (Qsqlite_locked_error, Qerror_conditions, + Fpurecopy (list2 (Qsqlite_locked_error, Qerror))); + Fput (Qsqlite_locked_error, Qerror_message, + build_pure_c_string ("Database locked")); + + DEFSYM (Qsqlitep, "sqlitep"); + DEFSYM (Qfalse, "false"); + DEFSYM (Qsqlite, "sqlite"); + DEFSYM (Qsqlite3, "sqlite3"); +} 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/sysstdio.h b/src/sysstdio.h index d4df3d74567..d6ebfb455f5 100644 --- a/src/sysstdio.h +++ b/src/sysstdio.h @@ -26,7 +26,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <stdio.h> #include "unlocked-io.h" -extern FILE *emacs_fopen (char const *, char const *); +extern FILE *emacs_fopen (char const *, char const *) ATTRIBUTE_MALLOC; extern void errputc (int); extern void errwrite (void const *, ptrdiff_t); extern void close_output_streams (void); diff --git a/src/systime.h b/src/systime.h index 08ab5bdde33..ce9403c931d 100644 --- a/src/systime.h +++ b/src/systime.h @@ -80,8 +80,7 @@ struct lisp_time /* Clock count as a Lisp integer. */ Lisp_Object ticks; - /* Clock frequency (ticks per second) as a positive Lisp integer. - (TICKS . HZ) is a valid Lisp timestamp unless HZ < 65536. */ + /* Clock frequency (ticks per second) as a positive Lisp integer. */ Lisp_Object hz; }; diff --git a/src/term.c b/src/term.c index 6f0b827cfc8..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 */ @@ -4152,10 +4154,12 @@ use the Bourne shell command 'TERM=...; export TERM' (C-shell:\n\ could return 32767. */ tty->TN_max_colors = 16777216; } - /* Fall back to xterm+direct (semicolon version) if requested - by the COLORTERM environment variable. */ - else if ((bg = getenv("COLORTERM")) != NULL - && strcasecmp(bg, "truecolor") == 0) + /* Fall back to xterm+direct (semicolon version) if Tc is set + (de-facto standard introduced by tmux) or if requested by + the COLORTERM environment variable. */ + else if ((tigetflag ("Tc") > 0) + || ((bg = getenv ("COLORTERM")) != NULL + && strcasecmp (bg, "truecolor") == 0)) { tty->TS_set_foreground = "\033[%?%p1%{8}%<%t3%p1%d%e38;2;%p1%{65536}%/%d;%p1%{256}%/%{255}%&%d;%p1%{255}%&%d%;m"; tty->TS_set_background = "\033[%?%p1%{8}%<%t4%p1%d%e48;2;%p1%{65536}%/%d;%p1%{256}%/%{255}%&%d;%p1%{255}%&%d%;m"; diff --git a/src/termhooks.h b/src/termhooks.h index 1d3cdc8fe8d..1c89a4d306f 100644 --- a/src/termhooks.h +++ b/src/termhooks.h @@ -60,7 +60,9 @@ enum output_method output_x_window, output_msdos_raw, output_w32, - output_ns + output_ns, + output_pgtk, + output_haiku }; /* Input queue declarations and hooks. */ @@ -119,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. */ @@ -255,6 +260,8 @@ enum event_kind #ifdef HAVE_XWIDGETS /* events generated by xwidgets*/ , XWIDGET_EVENT + /* Event generated when WebKit asks us to display another widget. */ + , XWIDGET_DISPLAY_EVENT #endif #ifdef USE_FILE_NOTIFY @@ -262,6 +269,45 @@ enum event_kind , FILE_NOTIFY_EVENT #endif +#ifdef HAVE_PGTK + /* Pre-edit text was changed. */ + , PGTK_PREEDIT_TEXT_EVENT +#endif + + /* Either the mouse wheel has been released without it being + clicked, or the user has lifted his finger from a touchpad. + + In the future, this may take into account other multi-touch + events generated from touchscreens and such. */ + , TOUCH_END_EVENT + + /* In a TOUCHSCREEN_UPDATE_EVENT, ARG is a list of elements of the + form (X Y ID), where X and Y are the coordinates of the + touchpoint relative to the top-left corner of the frame, and ID + is a unique number identifying the touchpoint. + + In TOUCHSCREEN_BEGIN_EVENT and TOUCHSCREEN_END_EVENT, ARG is the + unique ID of the touchpoint, and X and Y are the frame-relative + positions of the touchpoint. */ + + , TOUCHSCREEN_UPDATE_EVENT + , TOUCHSCREEN_BEGIN_EVENT + , TOUCHSCREEN_END_EVENT + + /* In a PINCH_EVENT, X and Y are the position of the pointer + relative to the top-left corner of the frame, and arg is a list + of (DX DY SCALE ANGLE), in which: + + - DX and DY are the difference between the positions of the + fingers comprising the current gesture and the last such + gesture in the same sequence. + - SCALE is the division of the current distance between the + fingers and the distance at the start of the gesture. + - DELTA-ANGLE is the delta between the angle of the current + event and the last event in the same sequence, in degrees. A + positive delta represents a change clockwise, and a negative + delta represents a change counter-clockwise. */ + , PINCH_EVENT }; /* Bit width of an enum event_kind tag at the start of structs and unions. */ @@ -442,6 +488,8 @@ struct terminal struct x_display_info *x; /* xterm.h */ 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; @@ -515,7 +563,7 @@ struct terminal BGCOLOR. */ void (*query_frame_background_color) (struct frame *f, Emacs_Color *bgcolor); -#if defined (HAVE_X_WINDOWS) || defined (HAVE_NTGUI) +#if defined (HAVE_X_WINDOWS) || defined (HAVE_NTGUI) || defined (HAVE_PGTK) /* On frame F, translate pixel colors to RGB values for the NCOLORS colors in COLORS. Use cached information, if available. */ @@ -830,6 +878,12 @@ extern struct terminal *terminal_list; #elif defined (HAVE_NS) #define TERMINAL_FONT_CACHE(t) \ (t->type == output_ns ? t->display_info.ns->name_list_element : Qnil) +#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 b83adc596bb..a9ecb63d85d 100644 --- a/src/terminal.c +++ b/src/terminal.c @@ -445,6 +445,10 @@ possible return values. */) return Qpc; case output_ns: return Qns; + case output_pgtk: + return Qpgtk; + case output_haiku: + return Qhaiku; default: emacs_abort (); } diff --git a/src/timefns.c b/src/timefns.c index a9921cdc108..74b5ca8d515 100644 --- a/src/timefns.c +++ b/src/timefns.c @@ -69,16 +69,6 @@ enum { TM_YEAR_BASE = 1900 }; # define FASTER_TIMEFNS 1 #endif -/* Whether to warn about Lisp timestamps (TICKS . HZ) that may be - instances of obsolete-format timestamps (HI . LO) where HI is - the high-order bits and LO the low-order 16 bits. Currently this - is true, but it should change to false in a future version of - Emacs. Compile with -DWARN_OBSOLETE_TIMESTAMPS=0 to see what the - future will be like. */ -#ifndef WARN_OBSOLETE_TIMESTAMPS -enum { WARN_OBSOLETE_TIMESTAMPS = true }; -#endif - /* Although current-time etc. generate list-format timestamps (HI LO US PS), the plan is to change these functions to generate frequency-based timestamps (TICKS . HZ) in a future release. @@ -817,14 +807,10 @@ decode_time_components (enum timeform form, return decode_ticks_hz (make_integer_mpz (), hz, result, dresult); } -enum { DECODE_SECS_ONLY = WARN_OBSOLETE_TIMESTAMPS + 1 }; - /* Decode a Lisp timestamp SPECIFIED_TIME that represents a time. - FLAGS specifies conversion flags. If FLAGS & DECODE_SECS_ONLY, - ignore and do not validate any sub-second components of an - old-format SPECIFIED_TIME. If FLAGS & WARN_OBSOLETE_TIMESTAMPS, - diagnose what could be obsolete (HIGH . LOW) timestamps. + If DECODE_SECS_ONLY, ignore and do not validate any sub-second + components of an old-format SPECIFIED_TIME. If RESULT is not null, store into *RESULT the converted time; otherwise, store into *DRESULT the number of seconds since the @@ -833,7 +819,7 @@ enum { DECODE_SECS_ONLY = WARN_OBSOLETE_TIMESTAMPS + 1 }; Return the form of SPECIFIED-TIME. Signal an error if unsuccessful. */ static enum timeform -decode_lisp_time (Lisp_Object specified_time, int flags, +decode_lisp_time (Lisp_Object specified_time, bool decode_secs_only, struct lisp_time *result, double *dresult) { Lisp_Object high = make_fixnum (0); @@ -854,7 +840,7 @@ decode_lisp_time (Lisp_Object specified_time, int flags, { Lisp_Object low_tail = XCDR (low); low = XCAR (low); - if (! (flags & DECODE_SECS_ONLY)) + if (! decode_secs_only) { if (CONSP (low_tail)) { @@ -877,9 +863,6 @@ decode_lisp_time (Lisp_Object specified_time, int flags, } else { - if (flags & WARN_OBSOLETE_TIMESTAMPS - && RANGED_FIXNUMP (0, low, (1 << LO_TIME_BITS) - 1)) - message ("obsolete timestamp with cdr %"pI"d", XFIXNUM (low)); form = TIMEFORM_TICKS_HZ; } @@ -1008,8 +991,7 @@ static struct lisp_time lisp_time_struct (Lisp_Object specified_time, enum timeform *pform) { struct lisp_time t; - enum timeform form - = decode_lisp_time (specified_time, WARN_OBSOLETE_TIMESTAMPS, &t, 0); + enum timeform form = decode_lisp_time (specified_time, false, &t, 0); if (pform) *pform = form; return t; @@ -1034,9 +1016,8 @@ lisp_time_argument (Lisp_Object specified_time) static time_t lisp_seconds_argument (Lisp_Object specified_time) { - int flags = WARN_OBSOLETE_TIMESTAMPS | DECODE_SECS_ONLY; struct lisp_time lt; - decode_lisp_time (specified_time, flags, <, 0); + decode_lisp_time (specified_time, true, <, 0); struct timespec t = lisp_to_timespec (lt); if (! timespec_valid_p (t)) time_overflow (); @@ -1138,24 +1119,6 @@ time_arith (Lisp_Object a, Lisp_Object b, bool subtract) mpz_t *ihz = &mpz[0]; mpz_mul (*ihz, *fa, *db); - /* When warning about obsolete timestamps, if the smaller - denominator comes from a non-(TICKS . HZ) timestamp and could - generate a (TICKS . HZ) timestamp that would look obsolete, - arrange for the result to have a higher HZ to avoid a - spurious warning by a later consumer of this function's - returned value. */ - verify (1 << LO_TIME_BITS <= ULONG_MAX); - if (WARN_OBSOLETE_TIMESTAMPS - && (da_lt_db ? aform : bform) == TIMEFORM_FLOAT - && (da_lt_db ? bform : aform) != TIMEFORM_TICKS_HZ - && mpz_cmp_ui (*hzmin, 1) > 0 - && mpz_cmp_ui (*hzmin, 1 << LO_TIME_BITS) < 0) - { - mpz_t *hzmin1 = &mpz[2 - da_lt_db]; - mpz_set_ui (*hzmin1, 1 << LO_TIME_BITS); - hzmin = hzmin1; - } - /* iticks = (fb * na) OP (fa * nb), where OP is + or -. */ mpz_t const *na = bignum_integer (iticks, ta.ticks); mpz_mul (*iticks, *fb, *na); @@ -1177,8 +1140,7 @@ time_arith (Lisp_Object a, Lisp_Object b, bool subtract) upwards by multiplying the normalized numerator and denominator so that the resulting denominator becomes at least hzmin. This rescaling avoids returning a timestamp that is less precise - than both a and b, or a timestamp that looks obsolete when that - might be a problem. */ + than both a and b. */ if (!FASTER_TIMEFNS || mpz_cmp (*ihz, *hzmin) < 0) { /* Rescale straightforwardly. Although this might not @@ -1303,7 +1265,7 @@ or (if you need time as a string) `format-time-string'. */) (Lisp_Object specified_time) { double t; - decode_lisp_time (specified_time, 0, 0, &t); + decode_lisp_time (specified_time, false, 0, &t); return make_float (t); } @@ -1651,12 +1613,11 @@ saving flag to be guessed. As an obsolescent calling convention, if this function is called with 6 or more arguments, the first 6 arguments are SECOND, MINUTE, HOUR, -DAY, MONTH, and YEAR, and specify the components of a decoded time, -where DST assumed to be -1 and FORM is omitted. If there are more -than 6 arguments the *last* argument is used as ZONE and any other -extra arguments are ignored, so that (apply #\\='encode-time -(decode-time ...)) works. In this obsolescent convention, DST and -ZONE default to -1 and nil respectively. +DAY, MONTH, and YEAR, and specify the components of a decoded time. +If there are more than 6 arguments the *last* argument is used as ZONE +and any other extra arguments are ignored, so that (apply +#\\='encode-time (decode-time ...)) works. In this obsolescent +convention, DST and ZONE default to -1 and nil respectively. Years before 1970 are not guaranteed to work. On some systems, year values as low as 1901 do work. @@ -1703,7 +1664,7 @@ usage: (encode-time TIME &rest OBSOLESCENT-ARGUMENTS) */) /* Let SEC = floor (LT.ticks / HZ), with SUBSECTICKS the remainder. */ struct lisp_time lt; - decode_lisp_time (secarg, 0, <, 0); + decode_lisp_time (secarg, false, <, 0); Lisp_Object hz = lt.hz, sec, subsecticks; if (FASTER_TIMEFNS && EQ (hz, make_fixnum (1))) { @@ -1756,9 +1717,7 @@ Truncate the returned value toward minus infinity. If FORM is nil (the default), return the same form as `current-time'. If FORM is a positive integer, return a pair of integers (TICKS . FORM), where TICKS is the number of clock ticks and FORM is the clock frequency -in ticks per second. (Currently the positive integer should be at least -65536 if the returned value is expected to be given to standard functions -expecting Lisp timestamps.) If FORM is t, return (TICKS . PHZ), where +in ticks per second. If FORM is t, return (TICKS . PHZ), where PHZ is a suitable clock frequency in ticks per second. If FORM is `integer', return an integer count of seconds. If FORM is `list', return an integer list (HIGH LOW USEC PSEC), where HIGH has the most @@ -1767,7 +1726,7 @@ bits, and USEC and PSEC are the microsecond and picosecond counts. */) (Lisp_Object time, Lisp_Object form) { struct lisp_time t; - enum timeform input_form = decode_lisp_time (time, 0, &t, 0); + enum timeform input_form = decode_lisp_time (time, false, &t, 0); if (NILP (form)) form = CURRENT_TIME_LIST ? Qlist : Qt; if (EQ (form, Qlist)) diff --git a/src/verbose.mk.in b/src/verbose.mk.in index a5ff931ed09..eee9d215ea0 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 = @@ -31,24 +33,26 @@ AM_V_GLOBALS = AM_V_NO_PD = AM_V_RC = else -AM_V_AR = @echo " AR " $@; +AM_V_AR = @$(info $ AR $@) AM_V_at = @ -AM_V_CC = @echo " CC " $@; -AM_V_CCLD = @echo " CCLD " $@; +AM_V_CC = @$(info $ CC $@) +AM_V_CXX = @$(info $ CXX $@) +AM_V_CCLD = @$(info $ CCLD $@) +AM_V_CXXLD = @$(info $ CXXLD $@) ifeq ($(HAVE_NATIVE_COMP),yes) ifeq ($(NATIVE_DISABLED),1) -AM_V_ELC = @echo " ELC " $@; +AM_V_ELC = @$(info $ ELC $@) AM_V_ELN = else -AM_V_ELC = @echo " ELC+ELN " $@; -AM_V_ELN = @echo " ELN " $@; +AM_V_ELC = @$(info $ ELC+ELN $@) +AM_V_ELN = @$(info $ ELN $@) endif else -AM_V_ELC = @echo " ELC " $@; +AM_V_ELC = @$(info $ ELC $@) AM_V_ELN = endif -AM_V_GEN = @echo " GEN " $@; -AM_V_GLOBALS = @echo " GEN " globals.h; +AM_V_GEN = @$(info $ GEN $@) +AM_V_GLOBALS = @$(info $ GEN globals.h) AM_V_NO_PD = --no-print-directory -AM_V_RC = @echo " RC " $@; +AM_V_RC = @$(info $ RC $@) endif diff --git a/src/w32.c b/src/w32.c index 80e42acf500..1de148f0343 100644 --- a/src/w32.c +++ b/src/w32.c @@ -2820,53 +2820,6 @@ sys_putenv (char *str) #define REG_ROOT "SOFTWARE\\GNU\\Emacs" -LPBYTE -w32_get_resource (const char *key, LPDWORD lpdwtype) -{ - LPBYTE lpvalue; - HKEY hrootkey = NULL; - DWORD cbData; - - /* Check both the current user and the local machine to see if - we have any resources. */ - - if (RegOpenKeyEx (HKEY_CURRENT_USER, REG_ROOT, 0, KEY_READ, &hrootkey) == ERROR_SUCCESS) - { - lpvalue = NULL; - - if (RegQueryValueEx (hrootkey, key, NULL, NULL, NULL, &cbData) == ERROR_SUCCESS - && (lpvalue = xmalloc (cbData)) != NULL - && RegQueryValueEx (hrootkey, key, NULL, lpdwtype, lpvalue, &cbData) == ERROR_SUCCESS) - { - RegCloseKey (hrootkey); - return (lpvalue); - } - - xfree (lpvalue); - - RegCloseKey (hrootkey); - } - - if (RegOpenKeyEx (HKEY_LOCAL_MACHINE, REG_ROOT, 0, KEY_READ, &hrootkey) == ERROR_SUCCESS) - { - lpvalue = NULL; - - if (RegQueryValueEx (hrootkey, key, NULL, NULL, NULL, &cbData) == ERROR_SUCCESS - && (lpvalue = xmalloc (cbData)) != NULL - && RegQueryValueEx (hrootkey, key, NULL, lpdwtype, lpvalue, &cbData) == ERROR_SUCCESS) - { - RegCloseKey (hrootkey); - return (lpvalue); - } - - xfree (lpvalue); - - RegCloseKey (hrootkey); - } - - return (NULL); -} - /* The argv[] array holds ANSI-encoded strings, and so this function works with ANS_encoded strings. */ void @@ -3077,7 +3030,7 @@ init_environment (char ** argv) int dont_free = 0; char bufc[SET_ENV_BUF_SIZE]; - if ((lpval = w32_get_resource (env_vars[i].name, &dwType)) == NULL + if ((lpval = w32_get_resource (REG_ROOT, env_vars[i].name, &dwType)) == NULL /* Also ignore empty environment variables. */ || *lpval == 0) { @@ -8595,7 +8548,7 @@ fcntl (int s, int cmd, int options) int sys_close (int fd) { - int rc; + int rc = -1; if (fd < 0) { @@ -8650,14 +8603,31 @@ sys_close (int fd) } } - if (fd >= 0 && fd < MAXDESC) - fd_info[fd].flags = 0; - /* Note that sockets do not need special treatment here (at least on NT and Windows 95 using the standard tcp/ip stacks) - it appears that closesocket is equivalent to CloseHandle, which is to be expected because socket handles are fully fledged kernel handles. */ - rc = _close (fd); + if (fd < MAXDESC) + { + if ((fd_info[fd].flags & FILE_DONT_CLOSE) == 0) + { + fd_info[fd].flags = 0; + rc = _close (fd); + } + else + { + /* We don't close here descriptors open by pipe processes + for reading from the pipe, because the reader thread + might be stuck in _sys_read_ahead, and then we will hang + here. If the reader thread exits normally, it will close + the descriptor; otherwise we will leave a zombie thread + hanging around. */ + rc = 0; + /* Leave the flag set for the reader thread to close the + descriptor. */ + fd_info[fd].flags = FILE_DONT_CLOSE; + } + } return rc; } @@ -10945,6 +10915,7 @@ register_aux_fd (int infd) } fd_info[ infd ].cp = cp; fd_info[ infd ].hnd = (HANDLE) _get_osfhandle (infd); + fd_info[ infd ].flags |= FILE_DONT_CLOSE; } #ifdef HAVE_GNUTLS diff --git a/src/w32.h b/src/w32.h index 5aba0aed9a6..bb3ec40324a 100644 --- a/src/w32.h +++ b/src/w32.h @@ -135,6 +135,7 @@ extern filedesc fd_info [ MAXDESC ]; #define FILE_SOCKET 0x0200 #define FILE_NDELAY 0x0400 #define FILE_SERIAL 0x0800 +#define FILE_DONT_CLOSE 0x1000 extern child_process * new_child (void); extern void delete_child (child_process *cp); @@ -161,8 +162,9 @@ extern void prepare_standard_handles (int in, int out, extern void reset_standard_handles (int in, int out, int err, HANDLE handles[3]); -/* Return the string resource associated with KEY of type TYPE. */ -extern LPBYTE w32_get_resource (const char * key, LPDWORD type); +/* Query Windows Registry and return the resource associated + associated with KEY and NAME of type TYPE. */ +extern LPBYTE w32_get_resource (const char * key, const char * name, LPDWORD type); extern void release_listen_threads (void); extern void init_ntproc (int); diff --git a/src/w32fns.c b/src/w32fns.c index 14d1154a2bc..02a6d78b51c 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -73,6 +73,20 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <imm.h> #include <windowsx.h> +/* + Internal/undocumented constants for Windows Dark mode. + See: https://github.com/microsoft/WindowsAppSDK/issues/41 +*/ +#define DARK_MODE_APP_NAME L"DarkMode_Explorer" +/* For Windows 10 version 1809, 1903, 1909. */ +#ifndef DWMWA_USE_IMMERSIVE_DARK_MODE_OLD +#define DWMWA_USE_IMMERSIVE_DARK_MODE_OLD 19 +#endif +/* For Windows 10 version 2004 and higher, and Windows 11. */ +#ifndef DWMWA_USE_IMMERSIVE_DARK_MODE +#define DWMWA_USE_IMMERSIVE_DARK_MODE 20 +#endif + #ifndef FOF_NO_CONNECTED_ELEMENTS #define FOF_NO_CONNECTED_ELEMENTS 0x2000 #endif @@ -185,6 +199,11 @@ typedef BOOL (WINAPI *IsDebuggerPresent_Proc) (void); typedef HRESULT (WINAPI *SetThreadDescription_Proc) (HANDLE hThread, PCWSTR lpThreadDescription); +typedef HRESULT (WINAPI * SetWindowTheme_Proc) + (IN HWND hwnd, IN LPCWSTR pszSubAppName, IN LPCWSTR pszSubIdList); +typedef HRESULT (WINAPI * DwmSetWindowAttribute_Proc) + (HWND hwnd, DWORD dwAttribute, IN LPCVOID pvAttribute, DWORD cbAttribute); + TrackMouseEvent_Proc track_mouse_event_fn = NULL; ImmGetCompositionString_Proc get_composition_string_fn = NULL; ImmGetContext_Proc get_ime_context_fn = NULL; @@ -199,6 +218,8 @@ EnumDisplayMonitors_Proc enum_display_monitors_fn = NULL; GetTitleBarInfo_Proc get_title_bar_info_fn = NULL; IsDebuggerPresent_Proc is_debugger_present = NULL; SetThreadDescription_Proc set_thread_description = NULL; +SetWindowTheme_Proc SetWindowTheme_fn = NULL; +DwmSetWindowAttribute_Proc DwmSetWindowAttribute_fn = NULL; extern AppendMenuW_Proc unicode_append_menu; @@ -252,6 +273,9 @@ int w32_major_version; int w32_minor_version; int w32_build_number; +/* If the OS is set to use dark mode. */ +BOOL w32_darkmode = FALSE; + /* Distinguish between Windows NT and Windows 95. */ int os_subtype; @@ -2279,10 +2303,36 @@ w32_init_class (HINSTANCE hinst) } } +/* Applies the Windows system theme (light or dark) to the window + handle HWND. */ +static void +w32_applytheme (HWND hwnd) +{ + if (w32_darkmode) + { + /* Set window theme to that of a built-in Windows app (Explorer), + because it has dark scroll bars and other UI elements. */ + if (SetWindowTheme_fn) + SetWindowTheme_fn (hwnd, DARK_MODE_APP_NAME, NULL); + + /* Set the titlebar to system dark mode. */ + if (DwmSetWindowAttribute_fn) + { + /* Windows 10 version 2004 and up, Windows 11. */ + DWORD attr = DWMWA_USE_IMMERSIVE_DARK_MODE; + /* Windows 10 older than 2004. */ + if (w32_build_number < 19041) + attr = DWMWA_USE_IMMERSIVE_DARK_MODE_OLD; + DwmSetWindowAttribute_fn (hwnd, attr, + &w32_darkmode, sizeof (w32_darkmode)); + } + } +} + static HWND w32_createvscrollbar (struct frame *f, struct scroll_bar * bar) { - return CreateWindow ("SCROLLBAR", "", + HWND hwnd = CreateWindow ("SCROLLBAR", "", /* Clip siblings so we don't draw over child frames. Apparently this is not always sufficient so we also try to make bar windows @@ -2291,12 +2341,15 @@ w32_createvscrollbar (struct frame *f, struct scroll_bar * bar) /* Position and size of scroll bar. */ bar->left, bar->top, bar->width, bar->height, FRAME_W32_WINDOW (f), NULL, hinst, NULL); + if (hwnd) + w32_applytheme (hwnd); + return hwnd; } static HWND w32_createhscrollbar (struct frame *f, struct scroll_bar * bar) { - return CreateWindow ("SCROLLBAR", "", + HWND hwnd = CreateWindow ("SCROLLBAR", "", /* Clip siblings so we don't draw over child frames. Apparently this is not always sufficient so we also try to make bar windows @@ -2305,6 +2358,9 @@ w32_createhscrollbar (struct frame *f, struct scroll_bar * bar) /* Position and size of scroll bar. */ bar->left, bar->top, bar->width, bar->height, FRAME_W32_WINDOW (f), NULL, hinst, NULL); + if (hwnd) + w32_applytheme (hwnd); + return hwnd; } static void @@ -2390,6 +2446,9 @@ w32_createwindow (struct frame *f, int *coords) /* Enable drag-n-drop. */ DragAcceptFiles (hwnd, TRUE); + /* Enable system light/dark theme. */ + w32_applytheme (hwnd); + /* Do this to discard the default setting specified by our parent. */ ShowWindow (hwnd, SW_HIDE); @@ -5114,6 +5173,13 @@ w32_wnd_proc (HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam) my_post_msg (&wmsg, hwnd, msg, wParam, lParam); goto dflt; + case WM_SETTINGCHANGE: + /* Inform the Lisp thread that some system-wide setting has + changed, so if Emacs is interested in some of them, it could + update its internal values. */ + my_post_msg (&wmsg, hwnd, msg, wParam, lParam); + goto dflt; + case WM_SETFOCUS: dpyinfo->faked_key = 0; reset_modifiers (); @@ -7459,7 +7525,8 @@ DEFUN ("x-show-tip", Fx_show_tip, Sx_show_tip, 1, 6, 0, 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); + make_fixnum (w->pixel_height), Qnil, + 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); @@ -10257,6 +10324,60 @@ to be converted to forward slashes by the caller. */) } #endif /* WINDOWSNT */ + +/* Query a value from the Windows Registry (under HKCU and HKLM), + where `key` is the registry key, `name` is the name, and `lpdwtype` + is a pointer to the return value's type. `lpwdtype` can be NULL if + you do not care about the type. + + Returns: pointer to the value, or null pointer if the key/name does + not exist. */ +LPBYTE +w32_get_resource (const char *key, const char *name, LPDWORD lpdwtype) +{ + LPBYTE lpvalue; + HKEY hrootkey = NULL; + DWORD cbData; + + /* Check both the current user and the local machine to see if + we have any resources. */ + + if (RegOpenKeyEx (HKEY_CURRENT_USER, key, 0, KEY_READ, &hrootkey) == ERROR_SUCCESS) + { + lpvalue = NULL; + + if (RegQueryValueEx (hrootkey, name, NULL, NULL, NULL, &cbData) == ERROR_SUCCESS + && (lpvalue = xmalloc (cbData)) != NULL + && RegQueryValueEx (hrootkey, name, NULL, lpdwtype, lpvalue, &cbData) == ERROR_SUCCESS) + { + RegCloseKey (hrootkey); + return (lpvalue); + } + + xfree (lpvalue); + + RegCloseKey (hrootkey); + } + + if (RegOpenKeyEx (HKEY_LOCAL_MACHINE, key, 0, KEY_READ, &hrootkey) == ERROR_SUCCESS) + { + lpvalue = NULL; + + if (RegQueryValueEx (hrootkey, name, NULL, NULL, NULL, &cbData) == ERROR_SUCCESS + && (lpvalue = xmalloc (cbData)) != NULL + && RegQueryValueEx (hrootkey, name, NULL, lpdwtype, lpvalue, &cbData) == ERROR_SUCCESS) + { + RegCloseKey (hrootkey); + return (lpvalue); + } + + xfree (lpvalue); + + RegCloseKey (hrootkey); + } + + return (NULL); +} /*********************************************************************** Initialization @@ -11028,6 +11149,37 @@ globals_of_w32fns (void) set_thread_description = (SetThreadDescription_Proc) get_proc_addr (hm_kernel32, "SetThreadDescription"); + /* Support OS dark mode on Windows 10 version 1809 and higher. + See `w32_applytheme` which uses appropriate APIs per version of Windows. + For future wretches who may need to understand Windows build numbers: + https://docs.microsoft.com/en-us/windows/release-health/release-information + */ + if (os_subtype == OS_SUBTYPE_NT + && w32_major_version >= 10 && w32_build_number >= 17763) + { + /* Load dwmapi.dll and uxtheme.dll, which will be needed to set + window themes. */ + HMODULE dwmapi_lib = LoadLibrary("dwmapi.dll"); + DwmSetWindowAttribute_fn = (DwmSetWindowAttribute_Proc) + get_proc_addr (dwmapi_lib, "DwmSetWindowAttribute"); + HMODULE uxtheme_lib = LoadLibrary("uxtheme.dll"); + SetWindowTheme_fn = (SetWindowTheme_Proc) + get_proc_addr (uxtheme_lib, "SetWindowTheme"); + + /* Check Windows Registry for system theme and set w32_darkmode. + TODO: "Nice to have" would be to create a lisp setting (which + defaults to this Windows Registry value), then read that lisp + value here instead. This would allow the user to forcibly + override the system theme (which is also user-configurable in + Windows settings; see MS-Windows section in Emacs manual). */ + LPBYTE val = + w32_get_resource ("Software\\Microsoft\\Windows\\CurrentVersion\\Themes\\Personalize", + "AppsUseLightTheme", + NULL); + if (val && *val == 0) + w32_darkmode = TRUE; + } + except_code = 0; except_addr = 0; #ifndef CYGWIN diff --git a/src/w32font.c b/src/w32font.c index 3025d0efa88..2d09f459f89 100644 --- a/src/w32font.c +++ b/src/w32font.c @@ -1974,10 +1974,11 @@ w32_decode_weight (int fnweight) if (fnweight >= FW_EXTRABOLD) return 205; if (fnweight >= FW_BOLD) return 200; if (fnweight >= FW_SEMIBOLD) return 180; - if (fnweight >= FW_NORMAL) return 100; - if (fnweight >= FW_LIGHT) return 50; - if (fnweight >= FW_EXTRALIGHT) return 40; - if (fnweight > FW_THIN) return 20; + if (fnweight >= FW_MEDIUM) return 100; + if (fnweight >= FW_NORMAL) return 80; + if (fnweight >= FW_LIGHT) return 50; + if (fnweight >= FW_EXTRALIGHT) return 40; + if (fnweight >= FW_THIN) return 20; return 0; } @@ -1988,10 +1989,11 @@ w32_encode_weight (int n) if (n >= 205) return FW_EXTRABOLD; if (n >= 200) return FW_BOLD; if (n >= 180) return FW_SEMIBOLD; - if (n >= 100) return FW_NORMAL; - if (n >= 50) return FW_LIGHT; - if (n >= 40) return FW_EXTRALIGHT; - if (n >= 20) return FW_THIN; + if (n >= 100) return FW_MEDIUM; + if (n >= 80) return FW_NORMAL; + if (n >= 50) return FW_LIGHT; + if (n >= 40) return FW_EXTRALIGHT; + if (n >= 20) return FW_THIN; return 0; } @@ -2000,14 +2002,15 @@ w32_encode_weight (int n) static Lisp_Object w32_to_fc_weight (int n) { - if (n >= FW_HEAVY) return intern ("black"); - if (n >= FW_EXTRABOLD) return Qextra_bold; - if (n >= FW_BOLD) return Qbold; - if (n >= FW_SEMIBOLD) return intern ("demibold"); - if (n >= FW_NORMAL) return intern ("medium"); - if (n >= FW_LIGHT) return Qlight; + if (n >= FW_HEAVY) return Qblack; + if (n >= FW_EXTRABOLD) return Qextra_bold; + if (n >= FW_BOLD) return Qbold; + if (n >= FW_SEMIBOLD) return Qsemi_bold; + if (n >= FW_MEDIUM) return Qmedium; + if (n >= FW_NORMAL) return Qnormal; + if (n >= FW_LIGHT) return Qlight; if (n >= FW_EXTRALIGHT) return Qextra_light; - return intern ("thin"); + return Qthin; } /* Fill in all the available details of LOGFONT from FONT_SPEC. */ diff --git a/src/w32inevt.c b/src/w32inevt.c index 894bc3ab089..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 (); @@ -471,13 +472,13 @@ do_mouse_event (MOUSE_EVENT_RECORD *event, int i; /* Mouse didn't move unless MOUSE_MOVED says it did. */ - SELECTED_FRAME ()->mouse_moved = 0; + 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; @@ -536,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 @@ -588,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/w32proc.c b/src/w32proc.c index 360f45e9e11..bfe720eb623 100644 --- a/src/w32proc.c +++ b/src/w32proc.c @@ -1206,6 +1206,7 @@ static DWORD WINAPI reader_thread (void *arg) { child_process *cp; + int fd; /* Our identity */ cp = (child_process *)arg; @@ -1220,12 +1221,13 @@ reader_thread (void *arg) { int rc; - if (cp->fd >= 0 && (fd_info[cp->fd].flags & FILE_CONNECT) != 0) - rc = _sys_wait_connect (cp->fd); - else if (cp->fd >= 0 && (fd_info[cp->fd].flags & FILE_LISTEN) != 0) - rc = _sys_wait_accept (cp->fd); + fd = cp->fd; + if (fd >= 0 && (fd_info[fd].flags & FILE_CONNECT) != 0) + rc = _sys_wait_connect (fd); + else if (fd >= 0 && (fd_info[fd].flags & FILE_LISTEN) != 0) + rc = _sys_wait_accept (fd); else - rc = _sys_read_ahead (cp->fd); + rc = _sys_read_ahead (fd); /* Don't bother waiting for the event if we already have been told to exit by delete_child. */ @@ -1238,7 +1240,7 @@ reader_thread (void *arg) { DebPrint (("reader_thread.SetEvent(0x%x) failed with %lu for fd %ld (PID %d)\n", (DWORD_PTR)cp->char_avail, GetLastError (), - cp->fd, cp->pid)); + fd, cp->pid)); return 1; } @@ -1266,6 +1268,13 @@ reader_thread (void *arg) if (cp->status == STATUS_READ_ERROR) break; } + /* If this thread was reading from a pipe process, close the + descriptor used for reading, as sys_close doesn't in that case. */ + if (fd_info[fd].flags == FILE_DONT_CLOSE) + { + fd_info[fd].flags = 0; + _close (fd); + } return 0; } diff --git a/src/w32term.c b/src/w32term.c index 9cf250cd73f..fdb088deda2 100644 --- a/src/w32term.c +++ b/src/w32term.c @@ -164,6 +164,10 @@ int last_scroll_bar_drag_pos; /* Keyboard code page - may be changed by language-change events. */ int w32_keyboard_codepage; +/* The number of screen lines to scroll for the default mouse-wheel + scroll amount, given by WHEEL_DELTA. */ +static UINT w32_wheel_scroll_lines; + #ifdef CYGWIN int w32_message_fd = -1; #endif /* CYGWIN */ @@ -272,6 +276,19 @@ XGetGCValues (void *ignore, XGCValues *gc, #endif static void +w32_get_mouse_wheel_vertical_delta (void) +{ + if (os_subtype != OS_SUBTYPE_NT) + return; + + UINT scroll_lines; + BOOL ret = SystemParametersInfo (SPI_GETWHEELSCROLLLINES, 0, + &scroll_lines, 0); + if (ret) + w32_wheel_scroll_lines = scroll_lines; +} + +static void w32_set_clip_rectangle (HDC hdc, RECT *rect) { if (rect) @@ -954,22 +971,6 @@ w32_set_cursor_gc (struct glyph_string *s) static void w32_set_mouse_face_gc (struct glyph_string *s) { - 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); - s->face = FACE_FROM_ID (s->f, face_id); - prepare_face_for_display (s->f, s->face); - /* If font in this face is same as S->font, use it. */ if (s->font == s->face->font) s->gc = s->face->gc; @@ -2539,6 +2540,10 @@ w32_draw_glyph_string (struct glyph_string *s) if (!s->for_overlaps) { + /* Draw relief if not yet drawn. */ + if (!relief_drawn_p && s->face->box != FACE_NO_BOX) + w32_draw_glyph_string_box (s); + /* Draw underline. */ if (s->face->underline) { @@ -2682,10 +2687,6 @@ w32_draw_glyph_string (struct glyph_string *s) } } - /* Draw relief if not yet drawn. */ - if (!relief_drawn_p && s->face->box != FACE_NO_BOX) - w32_draw_glyph_string_box (s); - if (s->prev) { struct glyph_string *prev; @@ -3219,32 +3220,94 @@ w32_construct_mouse_wheel (struct input_event *result, W32Msg *msg, { POINT p; int delta; + static int sum_delta_y = 0; result->kind = msg->msg.message == WM_MOUSEHWHEEL ? HORIZ_WHEEL_EVENT : WHEEL_EVENT; result->code = 0; result->timestamp = msg->msg.time; + result->arg = Qnil; /* A WHEEL_DELTA positive value indicates that the wheel was rotated forward, away from the user (up); a negative value indicates that the wheel was rotated backward, toward the user (down). */ delta = GET_WHEEL_DELTA_WPARAM (msg->msg.wParam); + if (delta == 0) + { + result->kind = NO_EVENT; + return Qnil; + } + + /* With multiple monitors, we can legitimately get negative + coordinates, so cast to short to interpret them correctly. */ + p.x = (short) LOWORD (msg->msg.lParam); + p.y = (short) HIWORD (msg->msg.lParam); + + if (eabs (delta) < WHEEL_DELTA) + { + /* This is high-precision mouse wheel, which sends + fine-resolution wheel events. Produce a wheel event only if + the conditions for sending such an event are fulfilled. */ + int scroll_unit = max (w32_wheel_scroll_lines, 1), nlines; + double value_to_report; + + /* w32_wheel_scroll_lines == UINT_MAX means the user asked for + "entire page" to be the scroll unit. We interpret that as + the height of the window under the mouse pointer. */ + if (w32_wheel_scroll_lines == UINT_MAX) + { + Lisp_Object window = window_from_coordinates (f, p.x, p.y, NULL, + false, false); + if (!WINDOWP (window)) + { + result->kind = NO_EVENT; + return Qnil; + } + scroll_unit = XWINDOW (window)->pixel_height; + if (scroll_unit < 1) /* paranoia */ + scroll_unit = 1; + } + + /* If mwheel-coalesce-scroll-events is non-nil, report a wheel event + only when we have accumulated enough delta's for WHEEL_DELTA. */ + if (mwheel_coalesce_scroll_events) + { + /* If the user changed the direction, reset the accumulated + deltas. */ + if ((delta > 0) != (sum_delta_y > 0)) + sum_delta_y = 0; + sum_delta_y += delta; + /* https://docs.microsoft.com/en-us/previous-versions/ms997498(v=msdn.10) */ + if (eabs (sum_delta_y) < WHEEL_DELTA) + { + result->kind = NO_EVENT; + return Qnil; + } + value_to_report = + ((double)FRAME_LINE_HEIGHT (f) * scroll_unit) + / ((double)WHEEL_DELTA / sum_delta_y); + sum_delta_y = 0; + } + else + value_to_report = + ((double)FRAME_LINE_HEIGHT (f) * scroll_unit) + / ((double)WHEEL_DELTA / delta); + nlines = value_to_report / FRAME_LINE_HEIGHT (f) + 0.5; + result->arg = list3 (make_fixnum (nlines), + make_float (0.0), + make_float (value_to_report)); + } /* The up and down modifiers indicate if the wheel was rotated up or down based on WHEEL_DELTA value. */ result->modifiers = (msg->dwModifiers | ((delta < 0 ) ? down_modifier : up_modifier)); - /* With multiple monitors, we can legitimately get negative - coordinates, so cast to short to interpret them correctly. */ - p.x = (short) LOWORD (msg->msg.lParam); - p.y = (short) HIWORD (msg->msg.lParam); /* For the case that F's w32 window is not msg->msg.hwnd. */ ScreenToClient (FRAME_W32_WINDOW (f), &p); XSETINT (result->x, p.x); XSETINT (result->y, p.y); XSETFRAME (result->frame_or_window, f); - result->arg = Qnil; return Qnil; } @@ -4921,6 +4984,14 @@ w32_read_socket (struct terminal *terminal, } break; + case WM_SETTINGCHANGE: + /* We are only interested in changes of the number of lines + to scroll when the vertical mouse wheel is moved. This + is only supported on NT. */ + if (msg.msg.wParam == SPI_SETWHEELSCROLLLINES) + w32_get_mouse_wheel_vertical_delta (); + break; + case WM_KEYDOWN: case WM_SYSKEYDOWN: f = w32_window_to_frame (dpyinfo, msg.msg.hwnd); @@ -7538,6 +7609,8 @@ w32_initialize (void) horizontal_scroll_bar_left_border = horizontal_scroll_bar_right_border = GetSystemMetrics (SM_CYHSCROLL); } + + w32_get_mouse_wheel_vertical_delta (); } void diff --git a/src/window.h b/src/window.h index 2400c422c15..8e9a2eb3177 100644 --- a/src/window.h +++ b/src/window.h @@ -756,7 +756,7 @@ wset_next_buffers (struct window *w, Lisp_Object val) #endif /* True if W is a tab bar window. */ -#if defined (HAVE_WINDOW_SYSTEM) +#if defined (HAVE_WINDOW_SYSTEM) && !defined (HAVE_PGTK) # define WINDOW_TAB_BAR_P(W) \ (WINDOWP (WINDOW_XFRAME (W)->tab_bar_window) \ && (W) == XWINDOW (WINDOW_XFRAME (W)->tab_bar_window)) diff --git a/src/xdisp.c b/src/xdisp.c index 597b12d4d68..4136079f491 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) { @@ -1179,7 +1182,13 @@ static void append_stretch_glyph (struct it *, Lisp_Object, static Lisp_Object get_it_property (struct it *, Lisp_Object); static Lisp_Object calc_line_height_property (struct it *, Lisp_Object, struct font *, int, bool); - +static int adjust_glyph_width_for_mouse_face (struct glyph *, + struct glyph_row *, + struct window *, struct face *, + struct face *); +static void get_cursor_offset_for_mouse_face (struct window *w, + struct glyph_row *row, + int *offset); #endif /* HAVE_WINDOW_SYSTEM */ static void produce_special_glyphs (struct it *, enum display_element_type); @@ -1276,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)); } } @@ -1682,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); @@ -3137,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. */ @@ -3187,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) @@ -5151,6 +5160,160 @@ 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); +} + /*********************************************************************** @@ -5199,14 +5362,21 @@ handle_display_prop (struct it *it) propval = get_char_property_and_overlay (make_fixnum (position->charpos), Qdisplay, object, &overlay); + + /* Rest of the code must have OBJECT be either a string or a buffer. */ + if (!STRINGP (it->string)) + object = it->w->contents; + + /* 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)); @@ -5260,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)) @@ -5493,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)) @@ -5640,8 +5822,15 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object, if (CONSP (XCDR (XCDR (spec)))) { Lisp_Object face_name = XCAR (XCDR (XCDR (spec))); - int face_id2 = lookup_derived_face (it->w, it->f, face_name, - FRINGE_FACE_ID, false); + int face_id2; + /* Don't allow quitting from lookup_derived_face, for when + we are displaying a non-selected window, and the buffer's + point was temporarily moved to the window-point. */ + ptrdiff_t count1 = SPECPDL_INDEX (); + specbind (Qinhibit_quit, Qt); + face_id2 = lookup_derived_face (it->w, it->f, face_name, + FRINGE_FACE_ID, false); + unbind_to (count1, Qnil); if (face_id2 >= 0) face_id = face_id2; } @@ -6640,6 +6829,27 @@ iterate_out_of_display_property (struct it *it) it->current.string_pos = it->position; } +/* Restore the IT->face_box_p flag, since it could have been + overwritten by the face of the object that we just finished + displaying. Also, set the IT->start_of_box_run_p flag if the + change in faces requires that. */ +static void +restore_face_box_flags (struct it *it, int prev_face_id) +{ + struct face *face = FACE_FROM_ID_OR_NULL (it->f, it->face_id); + + if (face) + { + struct face *prev_face = FACE_FROM_ID_OR_NULL (it->f, prev_face_id); + + if (!(it->start_of_box_run_p && prev_face && prev_face->box)) + it->start_of_box_run_p = (face->box != FACE_NO_BOX + && (prev_face == NULL + || prev_face->box == FACE_NO_BOX)); + it->face_box_p = face->box != FACE_NO_BOX; + } +} + /* Restore IT's settings from IT->stack. Called, for example, when no more overlay strings must be processed, and we return to delivering display elements from a buffer, or when the end of a string from a @@ -6652,6 +6862,7 @@ pop_it (struct it *it) struct iterator_stack_entry *p; bool from_display_prop = it->from_disp_prop_p; ptrdiff_t prev_pos = IT_CHARPOS (*it); + int prev_face_id = it->face_id; eassert (it->sp > 0); --it->sp; @@ -6683,25 +6894,13 @@ pop_it (struct it *it) break; case GET_FROM_BUFFER: { - struct face *face = FACE_FROM_ID_OR_NULL (it->f, it->face_id); - - /* Restore the face_box_p flag, since it could have been - overwritten by the face of the object that we just finished - displaying. */ - if (face) - it->face_box_p = face->box != FACE_NO_BOX; + restore_face_box_flags (it, prev_face_id); it->object = it->w->contents; } break; case GET_FROM_STRING: { - struct face *face = FACE_FROM_ID_OR_NULL (it->f, it->face_id); - - /* Restore the face_box_p flag, since it could have been - overwritten by the face of the object that we just finished - displaying. */ - if (face) - it->face_box_p = face->box != FACE_NO_BOX; + restore_face_box_flags (it, prev_face_id); it->object = it->string; } break; @@ -7196,6 +7395,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; } @@ -10637,73 +10837,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 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 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, Lisp_Object ignore_line_at_end) { struct window *w = decode_live_window (window); - Lisp_Object buffer = w->contents; - struct buffer *b; 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); - } + int c, max_x = 0, max_y = 0, x = 0, y = 0, vertical_offset = 0, doff = 0; if (NILP (from)) { @@ -10729,6 +10877,13 @@ include the height of any of these, if present, in the return value. */) break; } } + else if (CONSP (from)) + { + start = clip_to_bounds (BEGV, fix_position (XCAR (from)), ZV); + bpos = CHAR_TO_BYTE (start); + CHECK_FIXNUM (XCDR (from)); + vertical_offset = XFIXNUM (XCDR (from)); + } else { start = clip_to_bounds (BEGV, fix_position (from), ZV); @@ -10763,8 +10918,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; @@ -10773,7 +10930,9 @@ include the height of any of these, if present, in the return value. */) itdata = bidi_shelve_cache (); start_display (&it, w, startp); + int start_y = it.current_y; + /* It makes no sense to measure dimensions of region of text that crosses the point where bidi reordering changes scan direction. By using unidirectional movement here we at least support the use @@ -10782,13 +10941,50 @@ include the height of any of these, if present, in the return value. */) same directionality. */ it.bidi_p = false; - /* Start at the beginning of the line containing FROM. Otherwise - IT.current_x will be incorrectly set to zero at some arbitrary - non-zero X coordinate. */ - reseat_at_previous_visible_line_start (&it); - it.current_x = it.hpos = 0; - if (IT_CHARPOS (it) != start) - move_it_to (&it, start, -1, -1, -1, MOVE_TO_POS); + if (vertical_offset != 0) + { + int last_y; + it.current_y = 0; + + move_it_by_lines (&it, 0); + + /* `move_it_vertically_backward' is called by move_it_vertically + to move by a negative value (upwards), but it is not always + guaranteed to leave the iterator at or above the position + given by the offset, which this loop ensures. */ + if (vertical_offset < 0) + { + while (it.current_y > vertical_offset) + { + last_y = it.current_y; + move_it_vertically_backward (&it, + (abs (vertical_offset) + + it.current_y)); + + if (it.current_y == last_y) + break; + } + } + else + { + move_it_vertically (&it, vertical_offset); + } + + it.current_y = (WINDOW_TAB_LINE_HEIGHT (w) + + WINDOW_HEADER_LINE_HEIGHT (w)); + start = clip_to_bounds (BEGV, IT_CHARPOS (it), ZV); + start_y = it.current_y; + } + else + { + /* Start at the beginning of the line containing FROM. Otherwise + IT.current_x will be incorrectly set to zero at some arbitrary + non-zero X coordinate. */ + reseat_at_previous_visible_line_start (&it); + it.current_x = it.hpos = 0; + if (IT_CHARPOS (it) != start) + move_it_to (&it, start, -1, -1, -1, MOVE_TO_POS); + } /* Now move to TO. */ int start_x = it.current_x; @@ -10830,8 +11026,16 @@ include the height of any of these, if present, in the return value. */) if (IT_CHARPOS (it) == end) { x += it.pixel_width; - it.max_ascent = max (it.max_ascent, it.ascent); - it.max_descent = max (it.max_descent, it.descent); + + /* DTRT if ignore_line_at_end is t. */ + if (!NILP (ignore_line_at_end)) + doff = (max (it.max_ascent, it.ascent) + + max (it.max_descent, it.descent)); + else + { + it.max_ascent = max (it.max_ascent, it.ascent); + it.max_descent = max (it.max_descent, it.descent); + } } } else @@ -10852,32 +11056,193 @@ include the height of any of these, if present, in the return value. */) /* Subtract height of header-line and tab-line which was counted automatically by start_display. */ - y = it.current_y + it.max_ascent + it.max_descent - - WINDOW_TAB_LINE_HEIGHT (w) - WINDOW_HEADER_LINE_HEIGHT (w); + if (!NILP (ignore_line_at_end)) + y = (it.current_y + doff + - WINDOW_TAB_LINE_HEIGHT (w) + - WINDOW_HEADER_LINE_HEIGHT (w)); + else + y = (it.current_y + it.max_ascent + it.max_descent + doff + - WINDOW_TAB_LINE_HEIGHT (w) - WINDOW_HEADER_LINE_HEIGHT (w)); + /* Don't return more than Y-LIMIT. */ if (y > max_y) y = max_y; - if (EQ (mode_lines, Qtab_line) || EQ (mode_lines, Qt)) - /* Re-add height of tab-line as requested. */ - y = y + WINDOW_TAB_LINE_HEIGHT (w); + if ((EQ (mode_lines, Qtab_line) || EQ (mode_lines, Qt)) + && window_wants_tab_line (w)) + /* Add height of tab-line as requested. */ + { + Lisp_Object window_tab_line_format + = window_parameter (w, Qtab_line_format); - if (EQ (mode_lines, Qheader_line) || EQ (mode_lines, Qt)) - /* Re-add height of header-line as requested. */ - y = y + WINDOW_HEADER_LINE_HEIGHT (w); + y = y + display_mode_line (w, TAB_LINE_FACE_ID, + NILP (window_tab_line_format) + ? BVAR (current_buffer, tab_line_format) + : window_tab_line_format); + } - if (EQ (mode_lines, Qmode_line) || EQ (mode_lines, Qt)) - /* Add height of mode-line as requested. */ - y = y + WINDOW_MODE_LINE_HEIGHT (w); + if ((EQ (mode_lines, Qheader_line) || EQ (mode_lines, Qt)) + && window_wants_header_line (w)) + { + Lisp_Object window_header_line_format + = window_parameter (w, Qheader_line_format); + + y = y + display_mode_line (w, HEADER_LINE_FACE_ID, + NILP (window_header_line_format) + ? BVAR (current_buffer, header_line_format) + : window_header_line_format); + } + + if ((EQ (mode_lines, Qmode_line) || EQ (mode_lines, Qt)) + && window_wants_mode_line (w)) + { + Lisp_Object window_mode_line_format + = window_parameter (w, Qmode_line_format); + + 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); + } bidi_unshelve_cache (itdata, false); + return (!vertical_offset + ? Fcons (make_fixnum (x - start_x), make_fixnum (y)) + : list3i (x - start_x, y, start)); +} + +DEFUN ("window-text-pixel-size", Fwindow_text_pixel_size, Swindow_text_pixel_size, 0, 7, 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. + +If FROM is a cons cell, the return value includes, in addition to the +dimensions, also a third element that provides the buffer position +from which measuring of the text dimensions was actually started. + +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 a cons, its car specifies a buffer +position, and its cdr specifies the vertical offset in pixels from +that position to the first screen line to be measured. 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. + +IGNORE-LINE-AT-END, if non-nil, means to not add the height of the +screen line that includes TO to the returned height of the text. */) + (Lisp_Object window, Lisp_Object from, Lisp_Object to, Lisp_Object x_limit, + Lisp_Object y_limit, Lisp_Object mode_lines, Lisp_Object ignore_line_at_end) +{ + 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, + ignore_line_at_end); + if (old_b) - set_buffer_internal (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, + Qnil); + + unbind_to (count, Qnil); - return Fcons (make_fixnum (x - start_x), make_fixnum (y)); + 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. */) @@ -13877,7 +14242,6 @@ note_tab_bar_highlight (struct frame *f, int x, int y) clear_mouse_face (hlinfo); bool mouse_down_p = false; -#ifndef HAVE_NS /* Mouse is down, but on different tab-bar item? Or alternatively, the mouse might've been pressed somewhere we don't know about, and then have moved onto the tab bar. In this case, @@ -13890,7 +14254,6 @@ note_tab_bar_highlight (struct frame *f, int x, int y) if (mouse_down_p && f->last_tab_bar_item != prop_idx && f->last_tab_bar_item != -1) return; -#endif draw = mouse_down_p ? DRAW_IMAGE_SUNKEN : DRAW_IMAGE_RAISED; /* If tab-bar item is not enabled, don't highlight it. */ @@ -15635,13 +15998,18 @@ redisplay_internal (void) if (!fr->glyphs_initialized_p) return; -#if defined (USE_X_TOOLKIT) || defined (USE_GTK) || defined (HAVE_NS) +#if defined (USE_X_TOOLKIT) || (defined (USE_GTK) && !defined (HAVE_PGTK)) || defined (HAVE_NS) if (popup_activated ()) { return; } #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; @@ -17806,7 +18174,7 @@ compute_window_start_on_continuation_line (struct window *w) point will not be visible with any window start we compute. */ if (IT_CHARPOS (it) <= PT - || (CHARPOS (start_pos) - IT_CHARPOS (it) + && (CHARPOS (start_pos) - IT_CHARPOS (it) /* PXW: Do we need upper bounds here? */ < WINDOW_TOTAL_LINES (w) * WINDOW_TOTAL_COLS (w))) { @@ -22173,7 +22541,7 @@ extend_face_to_end_of_line (struct it *it) && face->underline == FACE_NO_UNDERLINE && !face->overline_p && !face->strike_through_p - && FACE_COLOR_TO_PIXEL (face->background, f) == FRAME_BACKGROUND_PIXEL (f) + && face->background == FRAME_BACKGROUND_PIXEL (f) #ifdef HAVE_WINDOW_SYSTEM && !face->stipple #endif @@ -22407,7 +22775,7 @@ extend_face_to_end_of_line (struct it *it) && (it->glyph_row->used[LEFT_MARGIN_AREA] < WINDOW_LEFT_MARGIN_WIDTH (it->w)) && !it->glyph_row->mode_line_p - && FACE_COLOR_TO_PIXEL (face->background, f) != FRAME_BACKGROUND_PIXEL (f)) + && face->background != FRAME_BACKGROUND_PIXEL (f)) { struct glyph *g = it->glyph_row->glyphs[LEFT_MARGIN_AREA]; struct glyph *e = g + it->glyph_row->used[LEFT_MARGIN_AREA]; @@ -22478,7 +22846,7 @@ extend_face_to_end_of_line (struct it *it) && (it->glyph_row->used[RIGHT_MARGIN_AREA] < WINDOW_RIGHT_MARGIN_WIDTH (it->w)) && !it->glyph_row->mode_line_p - && FACE_COLOR_TO_PIXEL (face->background, f) != FRAME_BACKGROUND_PIXEL (f)) + && face->background != FRAME_BACKGROUND_PIXEL (f)) { struct glyph *g = it->glyph_row->glyphs[RIGHT_MARGIN_AREA]; struct glyph *e = g + it->glyph_row->used[RIGHT_MARGIN_AREA]; @@ -24495,7 +24863,7 @@ See also `bidi-paragraph-direction'. */) DEFUN ("bidi-find-overridden-directionality", Fbidi_find_overridden_directionality, - Sbidi_find_overridden_directionality, 2, 3, 0, + Sbidi_find_overridden_directionality, 3, 4, 0, doc: /* Return position between FROM and TO where directionality was overridden. This function returns the first character position in the specified @@ -24514,12 +24882,18 @@ a buffer is preferable when the buffer is displayed in some window, because this function will then be able to correctly account for window-specific overlays, which can affect the results. +Optional argument BASE-DIR specifies the base paragraph directory +of the text. It should be a symbol, either `left-to-right' +or `right-to-left', and defaults to `left-to-right'. + Strong directional characters `L', `R', and `AL' can have their intrinsic directionality overridden by directional override -control characters RLO (u+202e) and LRO (u+202d). See the -function `get-char-code-property' for a way to inquire about +control characters RLO (u+202E) and LRO (u+202D). They can also +have their directionality affected by other formatting control +characters: LRE (u+202A), RLE (u+202B), LRI (u+2066), and RLI (u+2067). +See the function `get-char-code-property' for a way to inquire about the `bidi-class' property of a character. */) - (Lisp_Object from, Lisp_Object to, Lisp_Object object) + (Lisp_Object from, Lisp_Object to, Lisp_Object object, Lisp_Object base_dir) { struct buffer *buf = current_buffer; struct buffer *old = buf; @@ -24616,10 +24990,9 @@ the `bidi-class' property of a character. */) } ptrdiff_t found; + bidi_dir_t bdir = EQ (base_dir, Qright_to_left) ? R2L : L2R; do { - /* For the purposes of this function, the actual base direction of - the paragraph doesn't matter, so just set it to L2R. */ - bidi_paragraph_init (L2R, &itb, false); + bidi_paragraph_init (bdir, &itb, false); while ((found = bidi_find_first_overridden (&itb)) < from_pos) ; } while (found == ZV && itb.ch == '\n' && itb.charpos < to_pos); @@ -25218,6 +25591,11 @@ display_menu_bar (struct window *w) if (FRAME_W32_P (f)) return; #endif +#if defined (HAVE_PGTK) + if (FRAME_PGTK_P (f)) + return; +#endif + #if defined (USE_X_TOOLKIT) || defined (USE_GTK) if (FRAME_X_P (f)) return; @@ -25228,6 +25606,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); @@ -25528,7 +25911,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); @@ -25567,11 +25951,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) @@ -26364,8 +26748,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 @@ -27319,6 +27703,21 @@ display_string (const char *string, Lisp_Object lisp_string, Lisp_Object face_st 0, &endptr, it->base_face_id, false, 0); face = FACE_FROM_ID (it->f, it->face_id); it->face_box_p = face->box != FACE_NO_BOX; + + /* If we have a display spec, but there's no Lisp string being + displayed, then check whether we've got one from the + :propertize being passed in and use that. */ + if (NILP (lisp_string)) + { + Lisp_Object display = Fget_text_property (make_fixnum (0), Qdisplay, + face_string); + if (!NILP (display)) + { + Lisp_Object min_width = Fplist_get (display, Qmin_width); + if (!NILP (min_width)) + display_min_width (it, 0, face_string, min_width); + } + } } /* Set max_x to the maximum allowed X position. Don't let it go @@ -28147,6 +28546,19 @@ fill_composite_glyph_string (struct glyph_string *s, struct face *base_face, s->font = s->face->font; } + if (s->hl == DRAW_MOUSE_FACE + || (s->hl == DRAW_CURSOR && cursor_in_mouse_face_p (s->w))) + { + int c = COMPOSITION_GLYPH (s->cmp, 0); + Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (s->f); + s->face = FACE_FROM_ID_OR_NULL (s->f, hlinfo->mouse_face_face_id); + if (!s->face) + s->face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); + + s->face = FACE_FROM_ID (s->f, FACE_FOR_CHAR (s->f, s->face, c, -1, Qnil)); + prepare_face_for_display (s->f, s->face); + } + /* All glyph strings for the same composition has the same width, i.e. the width set for the first component of the composition. */ s->width = s->first_glyph->pixel_width; @@ -28183,7 +28595,17 @@ fill_gstring_glyph_string (struct glyph_string *s, int face_id, s->cmp_id = glyph->u.cmp.id; s->cmp_from = glyph->slice.cmp.from; s->cmp_to = glyph->slice.cmp.to + 1; - s->face = FACE_FROM_ID (s->f, face_id); + if (s->hl == DRAW_MOUSE_FACE + || (s->hl == DRAW_CURSOR && cursor_in_mouse_face_p (s->w))) + { + Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (s->f); + s->face = FACE_FROM_ID_OR_NULL (s->f, hlinfo->mouse_face_face_id); + if (!s->face) + s->face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); + prepare_face_for_display (s->f, s->face); + } + else + s->face = FACE_FROM_ID (s->f, face_id); lgstring = composition_gstring_from_id (s->cmp_id); s->font = XFONT_OBJECT (LGSTRING_FONT (lgstring)); /* The width of a composition glyph string is the sum of the @@ -28239,6 +28661,15 @@ fill_glyphless_glyph_string (struct glyph_string *s, int face_id, voffset = glyph->voffset; s->face = FACE_FROM_ID (s->f, face_id); s->font = s->face->font ? s->face->font : FRAME_FONT (s->f); + if (s->hl == DRAW_MOUSE_FACE + || (s->hl == DRAW_CURSOR && cursor_in_mouse_face_p (s->w))) + { + Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (s->f); + s->face = FACE_FROM_ID_OR_NULL (s->f, hlinfo->mouse_face_face_id); + if (!s->face) + s->face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); + prepare_face_for_display (s->f, s->face); + } s->nchars = 1; s->width = glyph->pixel_width; glyph++; @@ -28302,6 +28733,19 @@ fill_glyph_string (struct glyph_string *s, int face_id, s->font = s->face->font; + if (s->hl == DRAW_MOUSE_FACE + || (s->hl == DRAW_CURSOR && cursor_in_mouse_face_p (s->w))) + { + Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (s->f); + s->face = FACE_FROM_ID_OR_NULL (s->f, hlinfo->mouse_face_face_id); + if (!s->face) + s->face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); + s->face + = FACE_FROM_ID (s->f, FACE_FOR_CHAR (s->f, s->face, + s->first_glyph->u.ch, -1, Qnil)); + prepare_face_for_display (s->f, s->face); + } + /* If the specified font could not be loaded, use the frame's font, but record the fact that we couldn't load it in S->font_not_found_p so that we can draw rectangles for the @@ -28331,6 +28775,15 @@ fill_image_glyph_string (struct glyph_string *s) s->slice = s->first_glyph->slice.img; s->face = FACE_FROM_ID (s->f, s->first_glyph->face_id); s->font = s->face->font; + if (s->hl == DRAW_MOUSE_FACE + || (s->hl == DRAW_CURSOR && cursor_in_mouse_face_p (s->w))) + { + Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (s->f); + s->face = FACE_FROM_ID_OR_NULL (s->f, hlinfo->mouse_face_face_id); + if (!s->face) + s->face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); + prepare_face_for_display (s->f, s->face); + } s->width = s->first_glyph->pixel_width; /* Adjust base line for subscript/superscript text. */ @@ -28345,9 +28798,18 @@ fill_xwidget_glyph_string (struct glyph_string *s) eassert (s->first_glyph->type == XWIDGET_GLYPH); s->face = FACE_FROM_ID (s->f, s->first_glyph->face_id); s->font = s->face->font; + if (s->hl == DRAW_MOUSE_FACE + || (s->hl == DRAW_CURSOR && cursor_in_mouse_face_p (s->w))) + { + Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (s->f); + s->face = FACE_FROM_ID_OR_NULL (s->f, hlinfo->mouse_face_face_id); + if (!s->face) + s->face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); + prepare_face_for_display (s->f, s->face); + } s->width = s->first_glyph->pixel_width; s->ybase += s->first_glyph->voffset; - s->xwidget = s->first_glyph->u.xwidget; + s->xwidget = xwidget_from_id (s->first_glyph->u.xwidget); } #endif /* Fill glyph string S from a sequence of stretch glyphs. @@ -28370,6 +28832,15 @@ fill_stretch_glyph_string (struct glyph_string *s, int start, int end) face_id = glyph->face_id; s->face = FACE_FROM_ID (s->f, face_id); s->font = s->face->font; + if (s->hl == DRAW_MOUSE_FACE + || (s->hl == DRAW_CURSOR && cursor_in_mouse_face_p (s->w))) + { + Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (s->f); + s->face = FACE_FROM_ID_OR_NULL (s->f, hlinfo->mouse_face_face_id); + if (!s->face) + s->face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); + prepare_face_for_display (s->f, s->face); + } s->width = glyph->pixel_width; s->nchars = 1; voffset = glyph->voffset; @@ -28617,7 +29088,12 @@ right_overwriting (struct glyph_string *s) /* Set background width of glyph string S. START is the index of the first glyph following S. LAST_X is the right-most x-position + 1 - in the drawing area. */ + in the drawing area. + + If S->hl is DRAW_CURSOR, S->f is a window system frame, and the + cursor in S's window is currently inside mouse face, also update + S->width to take into account potentially differing :box + properties between the original face and the mouse face. */ static void set_glyph_string_background_width (struct glyph_string *s, int start, int last_x) @@ -28639,7 +29115,27 @@ set_glyph_string_background_width (struct glyph_string *s, int start, int last_x if (s->extends_to_end_of_line_p) s->background_width = last_x - s->x + 1; else - s->background_width = s->width; + { + s->background_width = s->width; +#ifdef HAVE_WINDOW_SYSTEM + if (FRAME_WINDOW_P (s->f) + && s->hl == DRAW_CURSOR + && cursor_in_mouse_face_p (s->w)) + { + /* Adjust the background width of the glyph string, because + if the glyph's face has the :box attribute, its + pixel_width might be different when it's displayed in the + mouse-face, if that also has the :box attribute. */ + struct glyph *g = s->first_glyph; + struct face *regular_face = FACE_FROM_ID (s->f, g->face_id); + s->background_width += + adjust_glyph_width_for_mouse_face (g, s->row, s->w, + regular_face, s->face); + /* S->width is probably worth adjusting here as well. */ + s->width = s->background_width; + } +#endif + } } @@ -29188,7 +29684,6 @@ draw_glyphs (struct window *w, int x, struct glyph_row *row, for (s = head; s; s = s->next) FRAME_RIF (f)->draw_glyph_string (s); -#ifndef HAVE_NS /* When focus a sole frame and move horizontally, this clears on_p causing a failure to erase prev cursor position. */ if (area == TEXT_AREA @@ -29207,7 +29702,6 @@ draw_glyphs (struct window *w, int x, struct glyph_row *row, notice_overwritten_cursor (w, TEXT_AREA, x0, x1, row->y, MATRIX_ROW_BOTTOM_Y (row)); } -#endif /* Value is the x-position up to which drawn, relative to AREA of W. This doesn't include parts drawn because of overhangs. */ @@ -29540,6 +30034,8 @@ produce_image_glyph (struct it *it) if (face->box != FACE_NO_BOX) { + /* If you change the logic here, please change it in + get_cursor_offset_for_mouse_face as well. */ if (face->box_horizontal_line_width > 0) { if (slice.y == 0) @@ -29716,7 +30212,7 @@ produce_xwidget_glyph (struct it *it) glyph->padding_p = 0; glyph->glyph_not_available_p = 0; glyph->face_id = it->face_id; - glyph->u.xwidget = it->xwidget; + glyph->u.xwidget = it->xwidget->xwidget_id; glyph->font_type = FONT_TYPE_UNKNOWN; if (it->bidi_p) { @@ -29899,7 +30395,8 @@ produce_stretch_glyph (struct it *it) Compute the width of the characters having this `display' property. */ struct it it2; - Lisp_Object object = it->stack[it->sp - 1].string; + Lisp_Object object = + it->sp > 0 ? it->stack[it->sp - 1].string : it->string; unsigned char *p = (STRINGP (object) ? SDATA (object) + IT_STRING_BYTEPOS (*it) : BYTE_POS_ADDR (IT_BYTEPOS (*it))); @@ -30001,7 +30498,8 @@ produce_stretch_glyph (struct it *it) if (width > 0 && height > 0 && it->glyph_row) { Lisp_Object o_object = it->object; - Lisp_Object object = it->stack[it->sp - 1].string; + Lisp_Object object = + it->sp > 0 ? it->stack[it->sp - 1].string : it->string; int n = width; if (!STRINGP (object)) @@ -30816,6 +31314,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) { @@ -31855,6 +32358,20 @@ erase_phys_cursor (struct window *w) && cursor_row->used[TEXT_AREA] > hpos && hpos >= 0) mouse_face_here_p = true; +#ifdef HAVE_WINDOW_SYSTEM + /* Since erasing the phys cursor will probably lead to corruption of + the mouse face display if the glyph's pixel_width is not kept up + to date with the :box property of the mouse face, just redraw the + mouse face. */ + if (FRAME_WINDOW_P (WINDOW_XFRAME (w)) && mouse_face_here_p) + { + w->phys_cursor_on_p = false; + w->phys_cursor_type = NO_CURSOR; + show_mouse_face (MOUSE_HL_INFO (WINDOW_XFRAME (w)), DRAW_MOUSE_FACE); + return; + } +#endif + /* Maybe clear the display under the cursor. */ if (w->phys_cursor_type == HOLLOW_BOX_CURSOR) { @@ -32126,6 +32643,9 @@ show_mouse_face (Mouse_HLInfo *hlinfo, enum draw_glyphs_face draw) && hlinfo->mouse_face_end_row < w->current_matrix->nrows) { bool phys_cursor_on_p = w->phys_cursor_on_p; +#ifdef HAVE_WINDOW_SYSTEM + int mouse_off = 0; +#endif struct glyph_row *row, *first, *last; first = MATRIX_ROW (w->current_matrix, hlinfo->mouse_face_beg_row); @@ -32199,6 +32719,15 @@ show_mouse_face (Mouse_HLInfo *hlinfo, enum draw_glyphs_face draw) row->mouse_face_p = draw == DRAW_MOUSE_FACE || draw == DRAW_IMAGE_RAISED; } +#ifdef HAVE_WINDOW_SYSTEM + /* Compute the cursor offset due to mouse-highlight. */ + if ((MATRIX_ROW_VPOS (row, w->current_matrix) == w->phys_cursor.vpos) + /* But not when highlighting a pseudo window, such as + the toolbar, which can't have a cursor anyway. */ + && !w->pseudo_window_p + && draw == DRAW_MOUSE_FACE) + get_cursor_offset_for_mouse_face (w, row, &mouse_off); +#endif } /* When we've written over the cursor, arrange for it to @@ -32208,6 +32737,7 @@ show_mouse_face (Mouse_HLInfo *hlinfo, enum draw_glyphs_face draw) { #ifdef HAVE_WINDOW_SYSTEM int hpos = w->phys_cursor.hpos; + int old_phys_cursor_x = w->phys_cursor.x; /* When the window is hscrolled, cursor hpos can legitimately be out of bounds, but we draw the cursor at the corresponding @@ -32219,7 +32749,11 @@ show_mouse_face (Mouse_HLInfo *hlinfo, enum draw_glyphs_face draw) block_input (); display_and_set_cursor (w, true, hpos, w->phys_cursor.vpos, - w->phys_cursor.x, w->phys_cursor.y); + w->phys_cursor.x + mouse_off, + w->phys_cursor.y); + /* Restore the original cursor coordinates, perhaps modified + to account for mouse-highlight. */ + w->phys_cursor.x = old_phys_cursor_x; unblock_input (); #endif /* HAVE_WINDOW_SYSTEM */ } @@ -33560,11 +34094,16 @@ note_mouse_highlight (struct frame *f, int x, int y) struct buffer *b; /* When a menu is active, don't highlight because this looks odd. */ -#if defined (USE_X_TOOLKIT) || defined (USE_GTK) || defined (HAVE_NS) || defined (MSDOS) +#if defined (USE_X_TOOLKIT) || (defined (USE_GTK) && !defined (HAVE_PGTK)) || defined (HAVE_NS) || defined (MSDOS) if (popup_activated ()) return; #endif +#if defined (HAVE_HAIKU) + if (popup_activated_p) + return; +#endif + if (!f->glyphs_initialized_p || f->pointer_invisible) return; @@ -34892,9 +35431,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"); @@ -35803,11 +36344,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, @@ -35833,10 +36376,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", @@ -36011,4 +36555,121 @@ cancel_hourglass (void) } } +/* Return a correction to be applied to G->pixel_width when it is + displayed in MOUSE_FACE. This is needed for the first and the last + glyphs of text inside a face with :box when it is displayed with + MOUSE_FACE that has a different or no :box attribute. + ORIGINAL_FACE is the face G was originally drawn in, and MOUSE_FACE + is the face it will be drawn in now. ROW is the G's glyph row and + W is its window. */ +static int +adjust_glyph_width_for_mouse_face (struct glyph *g, struct glyph_row *row, + struct window *w, + struct face *original_face, + struct face *mouse_face) +{ + int sum = 0; + + bool do_left_box_p = g->left_box_line_p; + bool do_right_box_p = g->right_box_line_p; + + /* This is required because we test some parameters of the image + slice before applying the box in produce_image_glyph. */ + if (g->type == IMAGE_GLYPH) + { + if (!row->reversed_p) + { + struct image *img = IMAGE_FROM_ID (WINDOW_XFRAME (w), + g->u.img_id); + do_left_box_p = g->left_box_line_p && + g->slice.img.x == 0; + do_right_box_p = g->right_box_line_p && + g->slice.img.x + g->slice.img.width == img->width; + } + else + { + struct image *img = IMAGE_FROM_ID (WINDOW_XFRAME (w), + g->u.img_id); + do_left_box_p = g->left_box_line_p && + g->slice.img.x + g->slice.img.width == img->width; + do_right_box_p = g->right_box_line_p && + g->slice.img.x == 0; + } + } + + /* If the glyph has a left box line, subtract it from the offset. */ + if (do_left_box_p) + sum -= max (0, original_face->box_vertical_line_width); + /* Likewise with the right box line, as there may be a + box there as well. */ + if (do_right_box_p) + sum -= max (0, original_face->box_vertical_line_width); + /* Now add the line widths from the new face. */ + if (g->left_box_line_p) + sum += max (0, mouse_face->box_vertical_line_width); + if (g->right_box_line_p) + sum += max (0, mouse_face->box_vertical_line_width); + + return sum; +} + +/* Get the offset due to mouse-highlight to apply before drawing + phys_cursor, and return it in OFFSET. ROW should be the row that + is under mouse face and contains the phys cursor. + + This is required because the produce_XXX_glyph series of functions + add the width of the various vertical box lines to the total width + of the glyphs, but that must be updated when the row is put under + mouse face, which can have different box dimensions. */ +static void +get_cursor_offset_for_mouse_face (struct window *w, struct glyph_row *row, + int *offset) +{ + int sum = 0; + /* Return because the mode line can't possibly have a cursor. */ + if (row->mode_line_p) + return; + + block_input (); + + struct frame *f = WINDOW_XFRAME (w); + Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (f); + struct glyph *start, *end; + struct face *mouse_face = FACE_FROM_ID (f, hlinfo->mouse_face_face_id); + int hpos = w->phys_cursor.hpos; + end = &row->glyphs[TEXT_AREA][hpos]; + + if (!row->reversed_p) + { + if (MATRIX_ROW_VPOS (row, w->current_matrix) == + hlinfo->mouse_face_beg_row) + start = &row->glyphs[TEXT_AREA][hlinfo->mouse_face_beg_col]; + else + start = row->glyphs[TEXT_AREA]; + } + else + { + if (MATRIX_ROW_VPOS (row, w->current_matrix) == + hlinfo->mouse_face_end_row) + start = &row->glyphs[TEXT_AREA][hlinfo->mouse_face_end_col]; + else + start = &row->glyphs[TEXT_AREA][row->used[TEXT_AREA] - 1]; + } + + /* Calculate the offset by which to correct phys_cursor x if we are + drawing the cursor inside mouse-face highlighted text. */ + + for ( ; row->reversed_p ? start > end : start < end; + row->reversed_p ? --start : ++start) + sum += adjust_glyph_width_for_mouse_face (start, row, w, + FACE_FROM_ID (f, start->face_id), + mouse_face); + + if (row->reversed_p) + sum = -sum; + + *offset = sum; + + unblock_input (); +} #endif /* HAVE_WINDOW_SYSTEM */ diff --git a/src/xfaces.c b/src/xfaces.c index 18e65d07e20..6f52637e916 100644 --- a/src/xfaces.c +++ b/src/xfaces.c @@ -246,6 +246,14 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #ifdef HAVE_NS #define GCGraphicsExposures 0 #endif /* HAVE_NS */ + +#ifdef HAVE_PGTK +#define GCGraphicsExposures 0 +#endif /* HAVE_PGTK */ + +#ifdef HAVE_HAIKU +#define GCGraphicsExposures 0 +#endif /* HAVE_HAIKU */ #endif /* HAVE_WINDOW_SYSTEM */ #include "buffer.h" @@ -555,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, @@ -575,6 +583,26 @@ x_free_gc (struct frame *f, Emacs_GC *gc) } #endif /* HAVE_NS */ +#ifdef HAVE_PGTK +/* PGTK emulation of GCs */ + +static Emacs_GC * +x_create_gc (struct frame *f, + unsigned long mask, + Emacs_GC *xgcv) +{ + Emacs_GC *gc = xmalloc (sizeof *gc); + *gc = *xgcv; + return gc; +} + +static void +x_free_gc (struct frame *f, Emacs_GC *gc) +{ + xfree (gc); +} +#endif /* HAVE_NS */ + /*********************************************************************** Frames and faces ***********************************************************************/ @@ -1416,52 +1444,6 @@ enum xlfd_field XLFD_LAST }; -/* An enumerator for each possible slant value of a font. Taken from - the XLFD specification. */ - -enum xlfd_slant -{ - XLFD_SLANT_UNKNOWN, - XLFD_SLANT_ROMAN, - XLFD_SLANT_ITALIC, - XLFD_SLANT_OBLIQUE, - XLFD_SLANT_REVERSE_ITALIC, - XLFD_SLANT_REVERSE_OBLIQUE, - XLFD_SLANT_OTHER -}; - -/* Relative font weight according to XLFD documentation. */ - -enum xlfd_weight -{ - XLFD_WEIGHT_UNKNOWN, - XLFD_WEIGHT_ULTRA_LIGHT, /* 10 */ - XLFD_WEIGHT_EXTRA_LIGHT, /* 20 */ - XLFD_WEIGHT_LIGHT, /* 30 */ - XLFD_WEIGHT_SEMI_LIGHT, /* 40: SemiLight, Book, ... */ - XLFD_WEIGHT_MEDIUM, /* 50: Medium, Normal, Regular, ... */ - XLFD_WEIGHT_SEMI_BOLD, /* 60: SemiBold, DemiBold, ... */ - XLFD_WEIGHT_BOLD, /* 70: Bold, ... */ - XLFD_WEIGHT_EXTRA_BOLD, /* 80: ExtraBold, Heavy, ... */ - XLFD_WEIGHT_ULTRA_BOLD /* 90: UltraBold, Black, ... */ -}; - -/* Relative proportionate width. */ - -enum xlfd_swidth -{ - XLFD_SWIDTH_UNKNOWN, - XLFD_SWIDTH_ULTRA_CONDENSED, /* 10 */ - XLFD_SWIDTH_EXTRA_CONDENSED, /* 20 */ - XLFD_SWIDTH_CONDENSED, /* 30: Condensed, Narrow, Compressed, ... */ - XLFD_SWIDTH_SEMI_CONDENSED, /* 40: semicondensed */ - XLFD_SWIDTH_MEDIUM, /* 50: Medium, Normal, Regular, ... */ - XLFD_SWIDTH_SEMI_EXPANDED, /* 60: SemiExpanded, DemiExpanded, ... */ - XLFD_SWIDTH_EXPANDED, /* 70: Expanded... */ - XLFD_SWIDTH_EXTRA_EXPANDED, /* 80: ExtraExpanded, Wide... */ - XLFD_SWIDTH_ULTRA_EXPANDED /* 90: UltraExpanded... */ -}; - /* Order by which font selection chooses fonts. The default values mean `first, find a best match for the font width, then for the font height, then for weight, then for slant.' This variable can be @@ -4883,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. */ @@ -4899,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; @@ -5373,6 +5355,10 @@ DEFUN ("display-supports-face-attributes-p", The optional argument DISPLAY can be a display name, a frame, or nil (meaning the selected frame's display). +For instance, to check whether the display supports underlining: + + (display-supports-face-attributes-p \\='(:underline t)) + The definition of `supported' is somewhat heuristic, but basically means that a face containing all the attributes in ATTRIBUTES, when merged with the default face for display, can be represented in a way that's @@ -5607,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); @@ -6410,20 +6397,16 @@ 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_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)); @@ -6611,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) @@ -6936,13 +6921,20 @@ syms_of_xfaces (void) DEFSYM (Qpressed_button, "pressed-button"); DEFSYM (Qflat_button, "flat-button"); DEFSYM (Qnormal, "normal"); + DEFSYM (Qthin, "thin"); DEFSYM (Qextra_light, "extra-light"); + DEFSYM (Qultra_light, "ultra-light"); DEFSYM (Qlight, "light"); DEFSYM (Qsemi_light, "semi-light"); + DEFSYM (Qmedium, "medium"); DEFSYM (Qsemi_bold, "semi-bold"); + DEFSYM (Qbook, "book"); DEFSYM (Qbold, "bold"); DEFSYM (Qextra_bold, "extra-bold"); DEFSYM (Qultra_bold, "ultra-bold"); + DEFSYM (Qheavy, "heavy"); + DEFSYM (Qultra_heavy, "ultra-heavy"); + DEFSYM (Qblack, "black"); DEFSYM (Qoblique, "oblique"); DEFSYM (Qitalic, "italic"); @@ -6978,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..bfa88b1c8cd 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -57,6 +57,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <X11/extensions/Xdbe.h> #endif +#ifdef HAVE_XINPUT2 +#include <X11/extensions/XInput2.h> +#endif + #ifdef USE_X_TOOLKIT #include <X11/Shell.h> @@ -2912,6 +2916,68 @@ initial_set_up_x_back_buffer (struct frame *f) unblock_input (); } +#if defined HAVE_XINPUT2 +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; + + block_input (); +#ifndef USE_GTK + 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); +#if 0 + XISetMask (m, XI_FocusIn); + XISetMask (m, XI_FocusOut); +#endif + XISelectEvents (FRAME_X_DISPLAY (f), + FRAME_X_WINDOW (f), + &mask, 1); + + memset (m, 0, l); +#endif /* !USE_GTK */ + + mask.deviceid = XIAllDevices; + + XISetMask (m, XI_PropertyEvent); + XISetMask (m, XI_HierarchyChanged); + XISetMask (m, XI_DeviceChanged); +#ifdef XI_TouchBegin + if (FRAME_DISPLAY_INFO (f)->xi2_version >= 2) + { + XISetMask (m, XI_TouchBegin); + XISetMask (m, XI_TouchUpdate); + XISetMask (m, XI_TouchEnd); +#ifdef XI_GesturePinchBegin + if (FRAME_DISPLAY_INFO (f)->xi2_version >= 4) + { + XISetMask (m, XI_GesturePinchBegin); + XISetMask (m, XI_GesturePinchUpdate); + XISetMask (m, XI_GesturePinchEnd); + } +#endif + } +#endif + XISelectEvents (FRAME_X_DISPLAY (f), + FRAME_X_WINDOW (f), + &mask, 1); + unblock_input (); +} +#endif + #ifdef USE_X_TOOLKIT /* Create and set up the X widget for frame F. */ @@ -3074,6 +3140,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) @@ -3200,6 +3271,11 @@ x_window (struct frame *f) unblock_input (); } #endif + +#ifdef HAVE_XINPUT2 + if (FRAME_DISPLAY_INFO (f)->supports_xi2) + setup_xi_event_mask (f); +#endif } #else /*! USE_GTK */ @@ -3254,6 +3330,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 +4497,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'. @@ -4432,6 +4514,27 @@ If omitted or nil, that stands for the selected frame's display. */) VendorRelease (dpy)); } +DEFUN ("x-server-input-extension-version", Fx_server_input_extension_version, + Sx_server_input_extension_version, 0, 1, 0, + doc: /* Return the version of the X Input Extension supported by TERMINAL. +The value is nil if TERMINAL's X server doesn't support the X Input +Extension extension, or if Emacs doesn't support the version present +on that server. Otherwise, the return value is a list of the the +major and minor versions of the X Input Extension extension running on +that server. */) + (Lisp_Object terminal) +{ +#ifdef HAVE_XINPUT2 + struct x_display_info *dpyinfo = check_x_display_info (terminal); + + return (dpyinfo->supports_xi2 + ? list2i (2, dpyinfo->xi2_version) + : Qnil); +#else + return Qnil; +#endif +} + DEFUN ("x-display-screens", Fx_display_screens, Sx_display_screens, 0, 1, 0, doc: /* Return the number of screens on the X server of display TERMINAL. The optional argument TERMINAL specifies which display to ask about. @@ -4830,6 +4933,70 @@ x_get_monitor_attributes_xrandr (struct x_display_info *dpyinfo) int i, n_monitors, primary = -1; RROutput pxid = None; struct MonitorInfo *monitors; + bool randr15_p = false; + +#if RANDR_MAJOR > 1 || (RANDR_MAJOR == 1 && RANDR_MINOR >= 5) + XRRMonitorInfo *rr_monitors; + + /* If RandR 1.5 or later is available, use that instead, as some + video drivers don't report correct dimensions via other versions + of RandR. */ + if (dpyinfo->xrandr_major_version > 1 + || (dpyinfo->xrandr_major_version == 1 + && dpyinfo->xrandr_minor_version >= 5)) + { + XRectangle workarea; + char *name; + + rr_monitors = XRRGetMonitors (dpyinfo->display, + dpyinfo->root_window, + True, &n_monitors); + if (!rr_monitors) + goto fallback; + + monitors = xzalloc (n_monitors * sizeof *monitors); + + for (int i = 0; i < n_monitors; ++i) + { + monitors[i].geom.x = rr_monitors[i].x; + monitors[i].geom.y = rr_monitors[i].y; + monitors[i].geom.width = rr_monitors[i].width; + monitors[i].geom.height = rr_monitors[i].height; + monitors[i].mm_width = rr_monitors[i].mwidth; + monitors[i].mm_height = rr_monitors[i].mheight; + + name = XGetAtomName (dpyinfo->display, rr_monitors[i].name); + if (name) + { + monitors[i].name = xstrdup (name); + XFree (name); + } + else + monitors[i].name = xstrdup ("Unknown Monitor"); + + if (rr_monitors[i].primary) + primary = i; + + if (rr_monitors[i].primary + && x_get_net_workarea (dpyinfo, &workarea)) + { + monitors[i].work = workarea; + if (!gui_intersect_rectangles (&monitors[i].geom, + &monitors[i].work, + &monitors[i].work)) + monitors[i].work = monitors[i].geom; + } + else + monitors[i].work = monitors[i].geom; + } + + XRRFreeMonitors (rr_monitors); + randr15_p = true; + goto out; + } + + fallback:; +#endif #define RANDR13_LIBRARY \ (RANDR_MAJOR > 1 || (RANDR_MAJOR == 1 && RANDR_MINOR >= 3)) @@ -4918,12 +5085,16 @@ x_get_monitor_attributes_xrandr (struct x_display_info *dpyinfo) XRRFreeOutputInfo (info); } XRRFreeScreenResources (resources); - +#if RANDR_MAJOR > 1 || (RANDR_MAJOR == 1 && RANDR_MINOR >= 5) + out: +#endif attributes_list = x_make_monitor_attribute_list (monitors, n_monitors, primary, dpyinfo, - "XRandr"); + (randr15_p + ? "XRandR 1.5" + : "XRandr")); free_monitors (monitors, n_monitors); return attributes_list; } @@ -4938,17 +5109,9 @@ x_get_monitor_attributes (struct x_display_info *dpyinfo) (void) dpy; /* Suppress unused variable warning. */ #ifdef HAVE_XRANDR - int xrr_event_base, xrr_error_base; - bool xrr_ok = false; - xrr_ok = XRRQueryExtension (dpy, &xrr_event_base, &xrr_error_base); - if (xrr_ok) - { - XRRQueryVersion (dpy, &dpyinfo->xrandr_major_version, - &dpyinfo->xrandr_minor_version); - xrr_ok = ((dpyinfo->xrandr_major_version == 1 - && dpyinfo->xrandr_minor_version >= 2) - || dpyinfo->xrandr_major_version > 1); - } + bool xrr_ok = ((dpyinfo->xrandr_major_version == 1 + && dpyinfo->xrandr_minor_version >= 2) + || dpyinfo->xrandr_major_version > 1); if (xrr_ok) attributes_list = x_get_monitor_attributes_xrandr (dpyinfo); @@ -4973,6 +5136,65 @@ x_get_monitor_attributes (struct x_display_info *dpyinfo) #endif /* !USE_GTK */ +#ifdef USE_LUCID +/* This is used by the Lucid menu widget, but it's defined here so we + can make use of a great deal of existing code. */ +static void +xlw_monitor_dimensions_at_pos_1 (struct x_display_info *dpyinfo, + Screen *screen, int src_x, int src_y, + int *x, int *y, int *width, int *height) +{ + Lisp_Object attrs, tem, val; + + attrs = x_get_monitor_attributes (dpyinfo); + + for (tem = attrs; CONSP (tem); tem = XCDR (tem)) + { + int sx, sy, swidth, sheight; + val = assq_no_quit (Qworkarea, XCAR (tem)); + if (!NILP (val)) + { + sx = XFIXNUM (XCAR (XCDR (val))); + sy = XFIXNUM (XCAR (XCDR (XCDR (val)))); + swidth = XFIXNUM (XCAR (XCDR (XCDR (XCDR (val))))); + sheight = XFIXNUM (XCAR (XCDR (XCDR (XCDR (XCDR (val)))))); + + if (sx <= src_x && src_x < (sx + swidth) + && sy <= src_y && src_y < (sy + swidth)) + { + *x = sx; + *y = sy; + *width = swidth; + *height = sheight; + return; + } + } + } + + *x = 0; + *y = 0; + *width = WidthOfScreen (screen); + *height = HeightOfScreen (screen); +} + +void +xlw_monitor_dimensions_at_pos (Display *dpy, Screen *screen, int src_x, + int src_y, int *x, int *y, int *width, int *height) +{ + struct x_display_info *dpyinfo = x_display_info_for_display (dpy); + + if (!dpyinfo) + emacs_abort (); + + block_input (); + xlw_monitor_dimensions_at_pos_1 (dpyinfo, screen, src_x, src_y, + x, y, width, height); + + unblock_input (); +} +#endif + + DEFUN ("x-display-monitor-attributes-list", Fx_display_monitor_attributes_list, Sx_display_monitor_attributes_list, 0, 1, 0, @@ -5569,8 +5791,25 @@ The coordinates X and Y are interpreted in pixels relative to a position int yval = check_integer_range (y, INT_MIN, INT_MAX); block_input (); - XWarpPointer (FRAME_X_DISPLAY (f), None, DefaultRootWindow (FRAME_X_DISPLAY (f)), - 0, 0, 0, 0, xval, yval); +#ifdef HAVE_XINPUT2 + int deviceid; + + if (FRAME_DISPLAY_INFO (f)->supports_xi2) + { + XGrabServer (FRAME_X_DISPLAY (f)); + if (XIGetClientPointer (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + &deviceid)) + { + XIWarpPointer (FRAME_X_DISPLAY (f), deviceid, None, + DefaultRootWindow (FRAME_X_DISPLAY (f)), + 0, 0, 0, 0, xval, yval); + } + XUngrabServer (FRAME_X_DISPLAY (f)); + } + else +#endif + XWarpPointer (FRAME_X_DISPLAY (f), None, DefaultRootWindow (FRAME_X_DISPLAY (f)), + 0, 0, 0, 0, xval, yval); unblock_input (); return Qnil; @@ -7095,7 +7334,8 @@ Text larger than the specified size is clipped. */) 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); + make_fixnum (w->pixel_height), Qnil, + 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); @@ -7374,7 +7614,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 @@ -7512,27 +7752,11 @@ present and mapped to the usual X keysyms. */) struct frame *f = decode_window_system_frame (frame); Display *dpy = FRAME_X_DISPLAY (f); Lisp_Object have_keys; - int major, minor, op, event, error_code; - block_input (); + if (!FRAME_DISPLAY_INFO (f)->supports_xkb) + return Qlambda; - /* Check library version in case we're dynamically linked. */ - major = XkbMajorVersion; - minor = XkbMinorVersion; - if (!XkbLibraryVersion (&major, &minor)) - { - unblock_input (); - return Qlambda; - } - - /* Check that the server supports XKB. */ - major = XkbMajorVersion; - minor = XkbMinorVersion; - if (!XkbQueryExtension (dpy, &op, &event, &error_code, &major, &minor)) - { - unblock_input (); - return Qlambda; - } + block_input (); /* In this code we check that the keyboard has physical keys with names that start with BKSP (Backspace) and DELE (Delete), and that they @@ -8038,6 +8262,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 @@ -8095,6 +8325,7 @@ eliminated in future versions of Emacs. */); defsubr (&Sx_server_max_request_size); defsubr (&Sx_server_vendor); defsubr (&Sx_server_version); + defsubr (&Sx_server_input_extension_version); defsubr (&Sx_display_pixel_width); defsubr (&Sx_display_pixel_height); defsubr (&Sx_display_mm_width); diff --git a/src/xmenu.c b/src/xmenu.c index ea2cbab2030..f3b7c45ffff 100644 --- a/src/xmenu.c +++ b/src/xmenu.c @@ -51,6 +51,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "msdos.h" #endif +#ifdef HAVE_XINPUT2 +#include <X11/extensions/XInput2.h> +#endif + #ifdef HAVE_X_WINDOWS /* This may include sys/types.h, and that somehow loses if this is not done before the other system files. */ @@ -105,7 +109,11 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ /* 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 @@ -440,6 +448,19 @@ x_activate_menubar (struct frame *f) XPutBackEvent (f->output_data.x->display_info->display, f->output_data.x->saved_menu_event); #else +#if defined USE_X_TOOLKIT && defined HAVE_XINPUT2 + struct x_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); + /* Clear the XI2 grab so Motif or lwlib can set a core grab. + Otherwise some versions of Motif will emit a warning and hang, + and lwlib will fail to destroy the menu window. */ + + if (dpyinfo->num_devices) + { + for (int i = 0; i < dpyinfo->num_devices; ++i) + XIUngrabDevice (dpyinfo->display, dpyinfo->devices[i].device_id, + CurrentTime); + } +#endif XtDispatchEvent (f->output_data.x->saved_menu_event); #endif unblock_input (); @@ -1441,7 +1462,17 @@ create_and_show_popup_menu (struct frame *f, widget_value *first_wv, /* Don't allow any geometry request from the user. */ XtSetArg (av[ac], (char *) XtNgeometry, 0); ac++; XtSetValues (menu, av, ac); +#if defined HAVE_XINPUT2 && defined USE_LUCID + struct x_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); + /* Clear the XI2 grab so lwlib can set a core grab. */ + if (dpyinfo->num_devices) + { + for (int i = 0; i < dpyinfo->num_devices; ++i) + XIUngrabDevice (dpyinfo->display, dpyinfo->devices[i].device_id, + CurrentTime); + } +#endif /* Display the menu. */ lw_popup_menu (menu, &dummy); popup_activated_flag = 1; diff --git a/src/xsettings.c b/src/xsettings.c index 58dfd43ad18..d6a715e1dfc 100644 --- a/src/xsettings.c +++ b/src/xsettings.c @@ -26,7 +26,11 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <byteswap.h> #include "lisp.h" +#ifndef HAVE_PGTK #include "xterm.h" +#else +#include "gtkutil.h" +#endif #include "xsettings.h" #include "frame.h" #include "keyboard.h" @@ -34,7 +38,12 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "termhooks.h" #include "pdumper.h" +#ifndef HAVE_PGTK #include <X11/Xproto.h> +#else +typedef unsigned short CARD16; +typedef unsigned int CARD32; +#endif #ifdef HAVE_GSETTINGS #include <glib-object.h> @@ -55,7 +64,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ static char *current_mono_font; static char *current_font; -static struct x_display_info *first_dpyinfo; +static Display_Info *first_dpyinfo; static Lisp_Object current_tool_bar_style; /* Store a config changed event in to the event queue. */ @@ -73,14 +82,18 @@ store_config_changed_event (Lisp_Object arg, Lisp_Object display_name) /* Return true if DPYINFO is still valid. */ static bool -dpyinfo_valid (struct x_display_info *dpyinfo) +dpyinfo_valid (Display_Info *dpyinfo) { bool found = false; if (dpyinfo != NULL) { - struct x_display_info *d; + Display_Info *d; for (d = x_display_list; !found && d; d = d->next) +#ifndef HAVE_PGTK found = d == dpyinfo && d->display == dpyinfo->display; +#else + found = d == dpyinfo && d->gdpy == dpyinfo->gdpy; +#endif } return found; } @@ -149,7 +162,7 @@ map_tool_bar_style (const char *tool_bar_style) static void store_tool_bar_style_changed (const char *newstyle, - struct x_display_info *dpyinfo) + Display_Info *dpyinfo) { Lisp_Object style = map_tool_bar_style (newstyle); if (EQ (current_tool_bar_style, style)) @@ -161,10 +174,12 @@ store_tool_bar_style_changed (const char *newstyle, XCAR (dpyinfo->name_list_element)); } +#ifndef HAVE_PGTK #if defined USE_CAIRO || defined HAVE_XFT #define XSETTINGS_FONT_NAME "Gtk/FontName" #endif #define XSETTINGS_TOOL_BAR_STYLE "Gtk/ToolbarStyle" +#endif enum { SEEN_AA = 0x01, @@ -321,10 +336,11 @@ something_changed_gconfCB (GConfClient *client, #endif /* USE_CAIRO || HAVE_XFT */ +#ifndef HAVE_PGTK /* Find the window that contains the XSETTINGS property values. */ static void -get_prop_window (struct x_display_info *dpyinfo) +get_prop_window (Display_Info *dpyinfo) { Display *dpy = dpyinfo->display; @@ -339,6 +355,9 @@ get_prop_window (struct x_display_info *dpyinfo) XUngrabServer (dpy); } +#endif + +#ifndef HAVE_PGTK #define PAD(nr) (((nr) + 3) & ~3) @@ -566,13 +585,15 @@ parse_settings (unsigned char *prop, return settings_seen; } +#endif +#ifndef HAVE_PGTK /* Read settings from the XSettings property window on display for DPYINFO. Store settings read in SETTINGS. Return true iff successful. */ static bool -read_settings (struct x_display_info *dpyinfo, struct xsettings *settings) +read_settings (Display_Info *dpyinfo, struct xsettings *settings) { Atom act_type; int act_form; @@ -600,12 +621,14 @@ read_settings (struct x_display_info *dpyinfo, struct xsettings *settings) return got_settings; } +#endif +#ifndef HAVE_PGTK /* Apply Xft settings in SETTINGS to the Xft library. Store a Lisp event that Xft settings changed. */ static void -apply_xft_settings (struct x_display_info *dpyinfo, +apply_xft_settings (Display_Info *dpyinfo, struct xsettings *settings) { #ifdef HAVE_XFT @@ -731,12 +754,14 @@ apply_xft_settings (struct x_display_info *dpyinfo, FcPatternDestroy (pat); #endif /* HAVE_XFT */ } +#endif +#ifndef HAVE_PGTK /* Read XSettings from the display for DPYINFO. If SEND_EVENT_P store a Lisp event settings that changed. */ static void -read_and_apply_settings (struct x_display_info *dpyinfo, bool send_event_p) +read_and_apply_settings (Display_Info *dpyinfo, bool send_event_p) { struct xsettings settings; @@ -763,11 +788,13 @@ read_and_apply_settings (struct x_display_info *dpyinfo, bool send_event_p) } #endif } +#endif +#ifndef HAVE_PGTK /* Check if EVENT for the display in DPYINFO is XSettings related. */ void -xft_settings_event (struct x_display_info *dpyinfo, const XEvent *event) +xft_settings_event (Display_Info *dpyinfo, const XEvent *event) { bool check_window_p = false, apply_settings_p = false; @@ -805,6 +832,7 @@ xft_settings_event (struct x_display_info *dpyinfo, const XEvent *event) if (apply_settings_p) read_and_apply_settings (dpyinfo, true); } +#endif /* Initialize GSettings and read startup values. */ @@ -940,10 +968,11 @@ init_gconf (void) #endif /* HAVE_GCONF */ } +#ifndef HAVE_PGTK /* Init Xsettings and read startup values. */ static void -init_xsettings (struct x_display_info *dpyinfo) +init_xsettings (Display_Info *dpyinfo) { Display *dpy = dpyinfo->display; @@ -959,13 +988,16 @@ init_xsettings (struct x_display_info *dpyinfo) unblock_input (); } +#endif void -xsettings_initialize (struct x_display_info *dpyinfo) +xsettings_initialize (Display_Info *dpyinfo) { if (first_dpyinfo == NULL) first_dpyinfo = dpyinfo; init_gconf (); +#ifndef HAVE_PGTK init_xsettings (dpyinfo); +#endif init_gsettings (); } diff --git a/src/xsettings.h b/src/xsettings.h index 26717fc08cb..dae41e8a3b8 100644 --- a/src/xsettings.h +++ b/src/xsettings.h @@ -20,12 +20,23 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #ifndef XSETTINGS_H #define XSETTINGS_H +#ifndef HAVE_PGTK #include <X11/Xlib.h> +#endif struct x_display_info; +struct pgtk_display_info; + +#ifndef HAVE_PGTK +typedef struct x_display_info Display_Info; +#else +typedef struct pgtk_display_info Display_Info; +#endif -extern void xsettings_initialize (struct x_display_info *); -extern void xft_settings_event (struct x_display_info *, const XEvent *); +extern void xsettings_initialize (Display_Info *); +#ifndef HAVE_PGTK +extern void xft_settings_event (Display_Info *, const XEvent *); +#endif extern const char *xsettings_get_system_font (void); #ifdef USE_LUCID extern const char *xsettings_get_system_normal_font (void); diff --git a/src/xterm.c b/src/xterm.c index 89885e0d889..d3d85a9e0de 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -42,6 +42,14 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <X11/extensions/Xdbe.h> #endif +#ifdef HAVE_XINPUT2 +#include <X11/extensions/XInput2.h> +#endif + +#ifdef HAVE_XRANDR +#include <X11/extensions/Xrandr.h> +#endif + /* Load sys/types.h if not already loaded. In some systems loading it twice is suicidal. */ #ifndef makedev @@ -223,9 +231,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 +349,306 @@ 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) +{ + struct xi_touch_point_t *tem, *last; + + 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); + + tem = dpyinfo->devices[i].touchpoints; + while (tem) + { + last = tem; + tem = tem->next; + xfree (last); + } + } + + 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, + XIAllDevices, + &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); + xi_device->touchpoints = NULL; + xi_device->master_p = (device->use == XIMasterKeyboard + || device->use == XIMasterPointer); + xi_device->direct_p = false; + + 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; + + if (xi_device->master_p) + { + 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 +#ifdef XITouchClass /* XInput 2.2 */ + case XITouchClass: + { + XITouchClassInfo *info; + + info = (XITouchClassInfo *) device->classes[c]; + xi_device->direct_p = info->mode == XIDirectTouch; + } +#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 && device->master_p) + { + 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; +} + +#ifdef XI_TouchBegin + +static void +xi_link_touch_point (struct xi_device_t *device, + int detail, double x, double y) +{ + struct xi_touch_point_t *touchpoint; + + touchpoint = xmalloc (sizeof *touchpoint); + touchpoint->next = device->touchpoints; + touchpoint->x = x; + touchpoint->y = y; + touchpoint->number = detail; + + device->touchpoints = touchpoint; +} + +static bool +xi_unlink_touch_point (int detail, + struct xi_device_t *device) +{ + struct xi_touch_point_t *last, *tem; + + for (last = NULL, tem = device->touchpoints; tem; + last = tem, tem = tem->next) + { + if (tem->number == detail) + { + if (!last) + device->touchpoints = tem->next; + else + last->next = tem->next; + + xfree (tem); + return true; + } + } + + return false; +} + +static struct xi_touch_point_t * +xi_find_touch_point (struct xi_device_t *device, int detail) +{ + struct xi_touch_point_t *point; + + for (point = device->touchpoints; point; point = point->next) + { + if (point->number == detail) + return point; + } + + return NULL; +} + +#endif /* XI_TouchBegin */ + +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 || !device->master_p) + 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) { @@ -1563,22 +1877,6 @@ x_set_cursor_gc (struct glyph_string *s) static void x_set_mouse_face_gc (struct glyph_string *s) { - 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); - s->face = FACE_FROM_ID (s->f, face_id); - prepare_face_for_display (s->f, s->face); - if (s->font == s->face->font) s->gc = s->face->gc; else @@ -3806,6 +4104,10 @@ x_draw_glyph_string (struct glyph_string *s) if (!s->for_overlaps) { + /* Draw relief if not yet drawn. */ + if (!relief_drawn_p && s->face->box != FACE_NO_BOX) + x_draw_glyph_string_box (s); + /* Draw underline. */ if (s->face->underline) { @@ -3961,10 +4263,6 @@ x_draw_glyph_string (struct glyph_string *s) } } - /* Draw relief if not yet drawn. */ - if (!relief_drawn_p && s->face->box != FACE_NO_BOX) - x_draw_glyph_string_box (s); - if (s->prev) { struct glyph_string *prev; @@ -4142,6 +4440,8 @@ x_show_hourglass (struct frame *f) XMapRaised (dpy, x->hourglass_window); XFlush (dpy); + /* Ensure that the spinning hourglass is shown. */ + flush_frame (f); } } } @@ -4405,6 +4705,99 @@ x_scroll_run (struct window *w, struct run *run) /* Cursor off. Will be switched on again in gui_update_window_end. */ gui_clear_cursor (w); +#ifdef HAVE_XWIDGETS + /* "Copy" xwidget windows in the area that will be scrolled. */ + Display *dpy = FRAME_X_DISPLAY (f); + Window window = FRAME_X_WINDOW (f); + + Window root, parent, *children; + unsigned int nchildren; + + if (XQueryTree (dpy, window, &root, &parent, &children, &nchildren)) + { + /* Now find xwidget views situated between from_y and to_y, and + attached to w. */ + for (unsigned int i = 0; i < nchildren; ++i) + { + Window child = children[i]; + struct xwidget_view *view = xwidget_view_from_window (child); + + if (view && !view->hidden) + { + int window_y = view->y + view->clip_top; + int window_height = view->clip_bottom - view->clip_top; + + Emacs_Rectangle r1, r2, result; + r1.x = w->pixel_left; + r1.y = from_y; + r1.width = w->pixel_width; + r1.height = height; + r2 = r1; + r2.y = window_y; + r2.height = window_height; + + /* The window is offscreen, just unmap it. */ + if (window_height == 0) + { + view->hidden = true; + XUnmapWindow (dpy, child); + continue; + } + + bool intersects_p = + gui_intersect_rectangles (&r1, &r2, &result); + + if (XWINDOW (view->w) == w && intersects_p) + { + int y = view->y + (to_y - from_y); + int text_area_x, text_area_y, text_area_width, text_area_height; + int clip_top, clip_bottom; + + window_box (w, view->area, &text_area_x, &text_area_y, + &text_area_width, &text_area_height); + + view->y = y; + + clip_top = 0; + clip_bottom = XXWIDGET (view->model)->height; + + if (y < text_area_y) + clip_top = text_area_y - y; + + if ((y + clip_bottom) > (text_area_y + text_area_height)) + { + clip_bottom -= (y + clip_bottom) - (text_area_y + text_area_height); + } + + view->clip_top = clip_top; + view->clip_bottom = clip_bottom; + + /* This means the view has moved offscreen. Unmap + it and hide it here. */ + if ((view->clip_bottom - view->clip_top) <= 0) + { + view->hidden = true; + XUnmapWindow (dpy, child); + } + else + { + XMoveResizeWindow (dpy, child, view->x + view->clip_left, + view->y + view->clip_top, + view->clip_right - view->clip_left, + view->clip_bottom - view->clip_top); + cairo_xlib_surface_set_size (view->cr_surface, + view->clip_right - view->clip_left, + view->clip_bottom - view->clip_top); + } + xwidget_expose (view); + XFlush (dpy); + } + } + } + XFree (children); + } +#endif + #ifdef USE_CAIRO if (FRAME_CR_CONTEXT (f)) { @@ -4578,8 +4971,9 @@ x_focus_changed (int type, int state, struct x_display_info *dpyinfo, struct fra } } -/* Return the Emacs frame-object corresponding to an X window. - It could be the frame's main window or an icon window. */ +/* Return the Emacs frame-object corresponding to an X window. It + could be the frame's main window, an icon window, or an xwidget + window. */ static struct frame * x_window_to_frame (struct x_display_info *dpyinfo, int wdesc) @@ -4590,6 +4984,13 @@ x_window_to_frame (struct x_display_info *dpyinfo, int wdesc) if (wdesc == None) return NULL; +#ifdef HAVE_XWIDGETS + struct xwidget_view *xvw = xwidget_view_from_window (wdesc); + + if (xvw && xvw->frame) + return xvw->frame; +#endif + FOR_EACH_FRAME (tail, frame) { f = XFRAME (frame); @@ -4681,7 +5082,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; @@ -4784,6 +5194,38 @@ 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; + +#ifdef USE_GTK + if (xi_event->evtype == XI_FocusIn + || xi_event->evtype == XI_FocusOut) + x_focus_changed ((xi_event->evtype == XI_FocusIn + ? FocusIn : FocusOut), + FOCUS_EXPLICIT, + dpyinfo, frame, bufp); + else +#endif + if ((xi_event->evtype == XI_Enter + || xi_event->evtype == XI_Leave) + && (((XIEnterEvent *) xi_event)->detail + != XINotifyInferior) + && ((XIEnterEvent *) xi_event)->focus + && !(focus_state & FOCUS_EXPLICIT)) + x_focus_changed ((xi_event->evtype == XI_Enter + ? FocusIn : FocusOut), + FOCUS_IMPLICIT, + dpyinfo, frame, bufp); + break; + } +#endif + case FocusIn: case FocusOut: /* Ignore transient focus events from hotkeys, window manager @@ -5012,7 +5454,7 @@ x_x_to_emacs_modifiers (struct x_display_info *dpyinfo, int state) | ((state & dpyinfo->hyper_mod_mask) ? mod_hyper : 0)); } -static int +int x_emacs_to_x_modifiers (struct x_display_info *dpyinfo, intmax_t state) { EMACS_INT mod_ctrl = ctrl_modifier; @@ -7888,7 +8330,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; @@ -7914,7 +8360,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. */ @@ -8226,6 +8679,18 @@ handle_one_xevent (struct x_display_info *dpyinfo, case Expose: f = x_window_to_frame (dpyinfo, event->xexpose.window); +#ifdef HAVE_XWIDGETS + { + struct xwidget_view *xv = + xwidget_view_from_window (event->xexpose.window); + + if (xv) + { + xwidget_expose (xv); + goto OTHER; + } + } +#endif if (f) { if (!FRAME_VISIBLE_P (f)) @@ -8381,6 +8846,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. */ @@ -8806,6 +9275,31 @@ handle_one_xevent (struct x_display_info *dpyinfo, x_display_set_last_user_time (dpyinfo, event->xcrossing.time); x_detect_focus_change (dpyinfo, any, event, &inev.ie); +#ifdef HAVE_XWIDGETS + { + struct xwidget_view *xvw = xwidget_view_from_window (event->xcrossing.window); + Mouse_HLInfo *hlinfo; + + if (xvw) + { + xwidget_motion_or_crossing (xvw, event); + hlinfo = MOUSE_HL_INFO (xvw->frame); + + if (xvw->frame == hlinfo->mouse_face_mouse_frame) + { + clear_mouse_face (hlinfo); + hlinfo->mouse_face_mouse_frame = 0; + } + + if (any_help_event_p) + { + do_help = -1; + } + goto OTHER; + } + } +#endif + f = any; if (f && x_mouse_click_focus_ignore_position) @@ -8849,10 +9343,28 @@ handle_one_xevent (struct x_display_info *dpyinfo, goto OTHER; case LeaveNotify: +#ifdef HAVE_XWIDGETS + { + struct xwidget_view *xvw = xwidget_view_from_window (event->xcrossing.window); + + if (xvw) + { + xwidget_motion_or_crossing (xvw, event); + goto OTHER; + } + } +#endif x_display_set_last_user_time (dpyinfo, event->xcrossing.time); x_detect_focus_change (dpyinfo, any, event, &inev.ie); f = x_top_window_to_frame (dpyinfo, event->xcrossing.window); +#if defined HAVE_X_TOOLKIT && defined HAVE_XINPUT2 + /* The XI2 event mask is set on the frame widget, so this event + likely originates from the shell widget, which we aren't + interested in. */ + if (dpyinfo->supports_xi2) + f = NULL; +#endif if (f) { if (f == hlinfo->mouse_face_mouse_frame) @@ -8899,6 +9411,12 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (f && xg_event_is_for_scrollbar (f, event)) f = 0; #endif +#ifdef HAVE_XWIDGETS + struct xwidget_view *xvw = xwidget_view_from_window (event->xmotion.window); + + if (xvw) + xwidget_motion_or_crossing (xvw, event); +#endif if (f) { /* Maybe generate a SELECT_WINDOW_EVENT for @@ -9153,6 +9671,26 @@ handle_one_xevent (struct x_display_info *dpyinfo, case ButtonRelease: case ButtonPress: { +#ifdef HAVE_XWIDGETS + struct xwidget_view *xvw = xwidget_view_from_window (event->xmotion.window); + + if (xvw) + { + xwidget_button (xvw, event->type == ButtonPress, + event->xbutton.x, event->xbutton.y, + event->xbutton.button, event->xbutton.state, + event->xbutton.time); + + if (!EQ (selected_window, xvw->w) && (event->xbutton.button < 4)) + { + inev.ie.kind = SELECT_WINDOW_EVENT; + inev.ie.frame_or_window = xvw->w; + } + + *finish = X_EVENT_DROP; + goto OTHER; + } +#endif /* 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; @@ -9352,6 +9890,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; @@ -9359,6 +9902,1278 @@ 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); + { +#ifdef HAVE_XWIDGETS + struct xwidget_view *xwidget_view = xwidget_view_from_window (enter->event); +#else + bool xwidget_view = false; +#endif + + /* 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 + /* See the comment under FocusIn in + `x_detect_focus_change'. The main relevant culprit + these days seems to be XFCE. */ + && enter->mode != XINotifyUngrab + && (xwidget_view + || (any && enter->event == FRAME_X_WINDOW (any)))) + xi_reset_scroll_valuators_for_device_id (dpyinfo, enter->deviceid); + +#ifdef HAVE_XWIDGETS + if (xwidget_view) + { + /* Don't send an enter event to the xwidget if the + first button is pressed, to avoid it releasing + the passive grab. I don't know why that happens, + but this workaround makes dragging to select text + work again. */ + if (!(enter->buttons.mask_len + && XIMaskIsSet (enter->buttons.mask, 1))) + xwidget_motion_or_crossing (xwidget_view, event); + + goto XI_OTHER; + } +#endif + } + + 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); + +#ifdef HAVE_XWIDGETS + { + struct xwidget_view *xvw + = xwidget_view_from_window (leave->event); + + if (xvw) + { + *finish = X_EVENT_DROP; + xwidget_motion_or_crossing (xvw, event); + + goto XI_OTHER; + } + } +#endif + + x_display_set_last_user_time (dpyinfo, xi_event->time); + x_detect_focus_change (dpyinfo, any, event, &inev.ie); + +#ifndef USE_X_TOOLKIT + f = x_top_window_to_frame (dpyinfo, leave->event); +#else + /* On Xt builds that have XI2, the enter and leave event + masks are set on the frame widget's window. */ + f = x_window_to_frame (dpyinfo, leave->event); +#endif + 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: + { + struct xi_device_t *device; + + states = &xev->valuators; + values = states->values; + device = xi_device_from_id (dpyinfo, xev->deviceid); + + if (!device || !device->master_p) + goto XI_OTHER; + +#ifdef XI_TouchBegin + if (xev->flags & XIPointerEmulated + && dpyinfo->xi2_version >= 2) + goto XI_OTHER; +#endif + + 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; + int scroll_height; + Lisp_Object window; + + + /* 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) + { + /* FIXME: figure out what in GTK is + causing interval values to jump by + >100 at the end of a touch sequence + when an xwidget gets a scroll event + where is_stop is TRUE. */ + if (fabs (delta) > 100) + continue; + 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 (mwheel_coalesce_scroll_events + && (fabs (val->emacs_value) < 1) + && (fabs (delta) > 0)) + continue; + + bool s = signbit (val->emacs_value); + inev.ie.kind = (fabs (delta) > 0 + ? (val->horizontal + ? HORIZ_WHEEL_EVENT + : WHEEL_EVENT) + : TOUCH_END_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); + + if (fabs (delta) > 0) + { + inev.ie.modifiers = !s ? up_modifier : down_modifier; + inev.ie.modifiers + |= x_x_to_emacs_modifiers (dpyinfo, + xev->mods.effective); + } + + window = window_from_coordinates (f, xev->event_x, + xev->event_y, NULL, + false, false); + + if (WINDOWP (window)) + scroll_height = XWINDOW (window)->pixel_height; + else + /* EVENT_X and EVENT_Y can be outside the + frame if F holds the input grab, so fall + back to the height of the frame instead. */ + scroll_height = FRAME_PIXEL_HEIGHT (f); + + scroll_unit = pow (scroll_height, 2.0 / 3.0); + + if (NUMBERP (Vx_scroll_event_delta_factor)) + scroll_unit *= XFLOATINT (Vx_scroll_event_delta_factor); + + if (fabs (delta) > 0) + { + 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)); + } + } + else + { + inev.ie.arg = Qnil; + } + + kbd_buffer_store_event_hold (&inev.ie, hold_quit); + + val->emacs_value = 0; + } + values++; + } + + inev.ie.kind = NO_EVENT; + } + +#ifdef HAVE_XWIDGETS + if (xv) + { + uint state = xev->mods.effective; + + if (xev->buttons.mask_len) + { + if (XIMaskIsSet (xev->buttons.mask, 1)) + state |= Button1Mask; + if (XIMaskIsSet (xev->buttons.mask, 2)) + state |= Button2Mask; + if (XIMaskIsSet (xev->buttons.mask, 3)) + state |= Button3Mask; + } + + if (found_valuator) + xwidget_scroll (xv, xev->event_x, xev->event_y, + -xv_total_x, -xv_total_y, state, + xev->time, (xv_total_x == 0.0 + && xv_total_y == 0.0)); + else + xwidget_motion_notify (xv, xev->event_x, xev->event_y, + xev->root_x, xev->root_y, state, + xev->time); + + goto XI_OTHER; + } +#endif + if (found_valuator) + { +#ifdef USE_GTK + if (f && xg_event_is_for_scrollbar (f, event)) + *finish = X_EVENT_DROP; +#endif + 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 HAVE_XWIDGETS + struct xwidget_view *xvw; +#endif + +#ifdef XIPointerEmulated + /* Ignore emulated scroll events when XI2 native + scroll events are present. */ + if (((dpyinfo->xi2_version == 1 + && xev->detail >= 4 + && xev->detail <= 8) + || (dpyinfo->xi2_version >= 2)) + && xev->flags & XIPointerEmulated) + { + *finish = X_EVENT_DROP; + goto XI_OTHER; + } +#endif + +#ifdef HAVE_XWIDGETS + xvw = xwidget_view_from_window (xev->event); + if (xvw) + { + xwidget_button (xvw, xev->evtype == XI_ButtonPress, + lrint (xev->event_x), lrint (xev->event_y), + xev->detail, xev->mods.effective, xev->time); + + if (!EQ (selected_window, xvw->w) && (xev->detail < 4)) + { + inev.ie.kind = SELECT_WINDOW_EVENT; + inev.ie.frame_or_window = xvw->w; + } + + *finish = X_EVENT_DROP; + goto XI_OTHER; + } +#endif + + device = xi_device_from_id (dpyinfo, xev->deviceid); + + if (!device || !device->master_p) + goto XI_OTHER; + + 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); + } + + 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; + struct xi_device_t *device; + + device = xi_device_from_id (dpyinfo, xev->deviceid); + + if (!device || !device->master_p) + goto XI_OTHER; + +#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; +#ifdef XI_TouchBegin + case XI_TouchBegin: + { + struct xi_device_t *device; + bool menu_bar_p = false, tool_bar_p = false; +#ifdef HAVE_GTK3 + GdkRectangle test_rect; +#endif + device = xi_device_from_id (dpyinfo, xev->deviceid); + x_display_set_last_user_time (dpyinfo, xev->time); + + if (!device) + goto XI_OTHER; + + if (xi_find_touch_point (device, xev->detail)) + emacs_abort (); + + f = x_any_window_to_frame (dpyinfo, xev->event); + +#ifdef HAVE_GTK3 + menu_bar_p = (f && FRAME_X_OUTPUT (f)->menubar_widget + && xg_event_is_for_menubar (f, event)); + if (f && FRAME_X_OUTPUT (f)->toolbar_widget) + { + test_rect.x = xev->event_x; + test_rect.y = xev->event_y; + test_rect.width = 1; + test_rect.height = 1; + + tool_bar_p = gtk_widget_intersect (FRAME_X_OUTPUT (f)->toolbar_widget, + &test_rect, NULL); + } +#endif + + if (!menu_bar_p && !tool_bar_p) + { + if (f && device->direct_p) + { + *finish = X_EVENT_DROP; + x_catch_errors (dpyinfo->display); + XIAllowTouchEvents (dpyinfo->display, xev->deviceid, + xev->detail, xev->event, XIAcceptTouch); + if (!x_had_errors_p (dpyinfo->display)) + { + xi_link_touch_point (device, xev->detail, xev->event_x, + xev->event_y); + + inev.ie.kind = TOUCHSCREEN_BEGIN_EVENT; + inev.ie.timestamp = xev->time; + XSETFRAME (inev.ie.frame_or_window, f); + XSETINT (inev.ie.x, lrint (xev->event_x)); + XSETINT (inev.ie.y, lrint (xev->event_y)); + XSETINT (inev.ie.arg, xev->detail); + } + x_uncatch_errors_after_check (); + } +#ifndef HAVE_GTK3 + else + { + x_catch_errors (dpyinfo->display); + XIAllowTouchEvents (dpyinfo->display, xev->deviceid, + xev->detail, xev->event, XIRejectTouch); + x_uncatch_errors (); + } +#endif + } + else + { +#ifdef HAVE_GTK3 + 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_TouchUpdate: + { + struct xi_device_t *device; + struct xi_touch_point_t *touchpoint; + Lisp_Object arg = Qnil; + + device = xi_device_from_id (dpyinfo, xev->deviceid); + x_display_set_last_user_time (dpyinfo, xev->time); + + if (!device) + goto XI_OTHER; + + touchpoint = xi_find_touch_point (device, xev->detail); + + if (!touchpoint) + goto XI_OTHER; + + touchpoint->x = xev->event_x; + touchpoint->y = xev->event_y; + + f = x_any_window_to_frame (dpyinfo, xev->event); + + if (f && device->direct_p) + { + inev.ie.kind = TOUCHSCREEN_UPDATE_EVENT; + inev.ie.timestamp = xev->time; + XSETFRAME (inev.ie.frame_or_window, f); + + for (touchpoint = device->touchpoints; + touchpoint; touchpoint = touchpoint->next) + { + arg = Fcons (list3i (lrint (touchpoint->x), + lrint (touchpoint->y), + lrint (touchpoint->number)), + arg); + } + + inev.ie.arg = arg; + } + + goto XI_OTHER; + } + case XI_TouchEnd: + { + struct xi_device_t *device; + bool unlinked_p; + + device = xi_device_from_id (dpyinfo, xev->deviceid); + x_display_set_last_user_time (dpyinfo, xev->time); + + if (!device) + goto XI_OTHER; + + unlinked_p = xi_unlink_touch_point (xev->detail, device); + + if (unlinked_p) + { + f = x_any_window_to_frame (dpyinfo, xev->event); + + if (f && device->direct_p) + { + inev.ie.kind = TOUCHSCREEN_END_EVENT; + inev.ie.timestamp = xev->time; + XSETFRAME (inev.ie.frame_or_window, f); + XSETINT (inev.ie.x, lrint (xev->event_x)); + XSETINT (inev.ie.y, lrint (xev->event_y)); + XSETINT (inev.ie.arg, xev->detail); + } + } + + goto XI_OTHER; + } +#endif +#ifdef XI_GesturePinchBegin + case XI_GesturePinchBegin: + case XI_GesturePinchUpdate: + { +#ifdef HAVE_USABLE_XI_GESTURE_PINCH_EVENT + XIGesturePinchEvent *pev = (XIGesturePinchEvent *) xi_event; + struct xi_device_t *device = xi_device_from_id (dpyinfo, pev->deviceid); + + if (!device || !device->master_p) + goto XI_OTHER; + +#ifdef HAVE_XWIDGETS + struct xwidget_view *xvw = xwidget_view_from_window (pev->event); + + if (xvw) + { + *finish = X_EVENT_DROP; + xwidget_pinch (xvw, pev); + goto XI_OTHER; + } +#endif + + any = x_any_window_to_frame (dpyinfo, pev->event); + if (any) + { + inev.ie.kind = PINCH_EVENT; + inev.ie.modifiers = x_x_to_emacs_modifiers (FRAME_DISPLAY_INFO (any), + pev->mods.effective); + XSETINT (inev.ie.x, lrint (pev->event_x)); + XSETINT (inev.ie.y, lrint (pev->event_y)); + XSETFRAME (inev.ie.frame_or_window, any); + inev.ie.arg = list4 (make_float (pev->delta_x), + make_float (pev->delta_y), + make_float (pev->scale), + make_float (pev->delta_angle)); + } +#endif + /* Once again GTK seems to crash when confronted by + events it doesn't understand. */ + *finish = X_EVENT_DROP; + goto XI_OTHER; + } + case XI_GesturePinchEnd: + { +#if defined HAVE_XWIDGETS && HAVE_USABLE_XI_GESTURE_PINCH_EVENT + XIGesturePinchEvent *pev = (XIGesturePinchEvent *) xi_event; + struct xwidget_view *xvw = xwidget_view_from_window (pev->event); + + if (xvw) + xwidget_pinch (xvw, pev); +#endif + *finish = X_EVENT_DROP; + goto XI_OTHER; + } +#endif + 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: @@ -11534,9 +13349,26 @@ void frame_set_mouse_pixel_position (struct frame *f, int pix_x, int pix_y) { block_input (); +#ifdef HAVE_XINPUT2 + int deviceid; - XWarpPointer (FRAME_X_DISPLAY (f), None, FRAME_X_WINDOW (f), - 0, 0, 0, 0, pix_x, pix_y); + if (FRAME_DISPLAY_INFO (f)->supports_xi2) + { + XGrabServer (FRAME_X_DISPLAY (f)); + if (XIGetClientPointer (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + &deviceid)) + { + XIWarpPointer (FRAME_X_DISPLAY (f), + deviceid, None, + FRAME_X_WINDOW (f), + 0, 0, 0, 0, pix_x, pix_y); + } + XUngrabServer (FRAME_X_DISPLAY (f)); + } + else +#endif + XWarpPointer (FRAME_X_DISPLAY (f), None, FRAME_X_WINDOW (f), + 0, 0, 0, 0, pix_x, pix_y); unblock_input (); } @@ -11564,6 +13396,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 @@ -12123,6 +13962,10 @@ x_free_frame_resources (struct frame *f) xfree (f->shell_position); #else /* !USE_X_TOOLKIT */ +#ifdef HAVE_XWIDGETS + kill_frame_xwidget_views (f); +#endif + #ifdef USE_GTK xg_free_frame_widgets (f); #endif /* USE_GTK */ @@ -13029,6 +14872,63 @@ 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_GesturePinchBegin /* XInput 2.4 */ + int minor = 4; +#elif 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_XRANDR + int xrr_event_base, xrr_error_base; + bool xrr_ok = false; + xrr_ok = XRRQueryExtension (dpy, &xrr_event_base, &xrr_error_base); + if (xrr_ok) + { + XRRQueryVersion (dpy, &dpyinfo->xrandr_major_version, + &dpyinfo->xrandr_minor_version); + } +#endif + +#ifdef HAVE_XKB + int xkb_major, xkb_minor, xkb_op, xkb_event, xkb_error_code; + xkb_major = XkbMajorVersion; + xkb_minor = XkbMinorVersion; + + if (XkbLibraryVersion (&xkb_major, &xkb_minor) + && XkbQueryExtension (dpyinfo->display, &xkb_op, &xkb_event, + &xkb_error_code, &xkb_major, &xkb_minor)) + { + dpyinfo->supports_xkb = true; + 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: @@ -13461,6 +15361,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 @@ -13620,9 +15528,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 @@ -13679,7 +15590,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"); @@ -13779,4 +15690,10 @@ 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_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 de6ea50385d..a233e28dbeb 100644 --- a/src/xterm.h +++ b/src/xterm.h @@ -88,6 +88,10 @@ typedef GtkWidget *xt_or_gtk_widget; #include <X11/Xlib-xcb.h> #endif +#ifdef HAVE_XKB +#include <X11/XKBlib.h> +#endif + #include "dispextern.h" #include "termhooks.h" @@ -163,6 +167,39 @@ 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_touch_point_t +{ + struct xi_touch_point_t *next; + + int number; + double x, y; +}; + +struct xi_device_t +{ + int device_id; + int scroll_valuator_count; + int grab; + bool master_p; + bool direct_p; + + struct xi_scroll_valuator_t *valuators; + struct xi_touch_point_t *touchpoints; +}; +#endif + Status x_parse_color (struct frame *f, const char *color_name, XColor *color); @@ -474,6 +511,20 @@ 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 + bool supports_xkb; + XkbDescPtr xkb_desc; +#endif }; #ifdef HAVE_X_I18N @@ -481,6 +532,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; @@ -1108,6 +1164,7 @@ extern void x_mouse_leave (struct x_display_info *); extern int x_dispatch_event (XEvent *, Display *); #endif extern int x_x_to_emacs_modifiers (struct x_display_info *, int); +extern int x_emacs_to_x_modifiers (struct x_display_info *, intmax_t); #ifdef USE_CAIRO extern void x_cr_destroy_frame_context (struct frame *); extern void x_cr_update_surface_desired_size (struct frame *, int, int); @@ -1184,6 +1241,10 @@ extern void x_change_tool_bar_height (struct frame *, int); extern void x_implicitly_set_name (struct frame *, Lisp_Object, Lisp_Object); extern void x_set_scroll_bar_default_width (struct frame *); extern void x_set_scroll_bar_default_height (struct frame *); +#ifdef USE_LUCID +extern void xlw_monitor_dimensions_at_pos (Display *, Screen *, int, int, + int *, int *, int *, int *); +#endif /* Defined in xselect.c. */ diff --git a/src/xwidget.c b/src/xwidget.c index e4b42e6e0c6..36f216d9399 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -19,6 +19,8 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <config.h> +#include "buffer.h" +#include "coding.h" #include "xwidget.h" #include "lisp.h" @@ -30,15 +32,47 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "sysstdio.h" #include "termhooks.h" #include "window.h" +#include "process.h" /* Include xwidget bottom end headers. */ #ifdef USE_GTK #include <webkit2/webkit2.h> #include <JavaScriptCore/JavaScript.h> +#include <cairo.h> +#ifndef HAVE_PGTK +#include <X11/Xlib.h> +#else +#include <gtk/gtk.h> +#endif +#ifdef HAVE_XINPUT2 +#include <X11/extensions/XInput2.h> +#endif #elif defined NS_IMPL_COCOA #include "nsxwidget.h" #endif +#include <math.h> + +static Lisp_Object id_to_xwidget_map; +static Lisp_Object internal_xwidget_view_list; +static Lisp_Object internal_xwidget_list; +static uint32_t xwidget_counter = 0; + +#ifdef USE_GTK +#ifdef HAVE_X_WINDOWS +static Lisp_Object x_window_to_xwv_map; +#endif +static gboolean offscreen_damage_event (GtkWidget *, GdkEvent *, gpointer); +static void synthesize_focus_in_event (GtkWidget *); +static GdkDevice *find_suitable_keyboard (struct frame *); +static gboolean webkit_script_dialog_cb (WebKitWebView *, WebKitScriptDialog *, + gpointer); +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 * allocate_xwidget (void) { @@ -56,6 +90,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, @@ -64,18 +100,131 @@ static void webkit_javascript_finished_cb (GObject *, GAsyncResult *, gpointer); static gboolean webkit_download_cb (WebKitWebContext *, WebKitDownload *, gpointer); - +static GtkWidget *webkit_create_cb (WebKitWebView *, WebKitNavigationAction *, gpointer); static gboolean webkit_decide_policy_cb (WebKitWebView *, WebKitPolicyDecision *, WebKitPolicyDecisionType, gpointer); +static GtkWidget *find_widget_at_pos (GtkWidget *, int, int, int *, int *); +static gboolean run_file_chooser_cb (WebKitWebView *, + WebKitFileChooserRequest *, + gpointer); + +struct widget_search_data +{ + int x; + int y; + bool foundp; + bool first; + GtkWidget *data; +}; + +static void find_widget (GtkWidget *t, struct widget_search_data *); +static void mouse_target_changed (WebKitWebView *, WebKitHitTestResult *, guint, + gpointer); #endif +#ifdef HAVE_PGTK +static int +xw_forward_event_translate (GdkEvent *event, struct xwidget_view *xv, + struct xwidget *xw) +{ + GtkWidget *widget; + int new_x, new_y; + + switch (event->type) + { + case GDK_BUTTON_PRESS: + case GDK_BUTTON_RELEASE: + case GDK_2BUTTON_PRESS: + case GDK_3BUTTON_PRESS: + widget = find_widget_at_pos (xw->widgetwindow_osr, + lrint (event->button.x - xv->clip_left), + lrint (event->button.y - xv->clip_top), + &new_x, &new_y); + if (widget) + { + event->any.window = gtk_widget_get_window (widget); + event->button.x = new_x; + event->button.y = new_y; + return 1; + } + return 0; + case GDK_SCROLL: + widget = find_widget_at_pos (xw->widgetwindow_osr, + lrint (event->scroll.x - xv->clip_left), + lrint (event->scroll.y - xv->clip_top), + &new_x, &new_y); + if (widget) + { + event->any.window = gtk_widget_get_window (widget); + event->scroll.x = new_x; + event->scroll.y = new_y; + return 1; + } + return 0; + case GDK_MOTION_NOTIFY: + widget = find_widget_at_pos (xw->widgetwindow_osr, + lrint (event->motion.x - xv->clip_left), + lrint (event->motion.y - xv->clip_top), + &new_x, &new_y); + if (widget) + { + event->any.window = gtk_widget_get_window (widget); + event->motion.x = new_x; + event->motion.y = new_y; + return 1; + } + return 0; + case GDK_ENTER_NOTIFY: + case GDK_LEAVE_NOTIFY: + widget = find_widget_at_pos (xw->widgetwindow_osr, + lrint (event->crossing.x - xv->clip_left), + lrint (event->crossing.y - xv->clip_top), + &new_x, &new_y); + if (widget) + { + event->any.window = gtk_widget_get_window (widget); + event->crossing.x = new_x; + event->crossing.y = new_y; + return 1; + } + return 0; + default: + return 0; + } +} + +static gboolean +xw_forward_event_from_view (GtkWidget *widget, GdkEvent *event, + gpointer user_data) +{ + struct xwidget_view *xv = user_data; + struct xwidget *xw = XXWIDGET (xv->model); + GdkEvent *eventcopy; + bool translated_p; + + if (NILP (xw->buffer)) + return TRUE; + + eventcopy = gdk_event_copy (event); + translated_p = xw_forward_event_translate (eventcopy, xv, xw); + record_osr_embedder (xv); + + g_object_ref (eventcopy->any.window); + if (translated_p) + gtk_main_do_event (eventcopy); + gdk_event_free (eventcopy); + + /* Don't propagate this event further. */ + return TRUE; +} +#endif DEFUN ("make-xwidget", Fmake_xwidget, Smake_xwidget, - 5, 6, 0, + 4, 7, 0, doc: /* Make an xwidget of TYPE. If BUFFER is nil, use the current buffer. If BUFFER is a string and no such buffer exists, create it. @@ -83,10 +232,13 @@ TYPE is a symbol which can take one of the following values: - webkit -Returns the newly constructed xwidget, or nil if construction fails. */) +RELATED is nil, or an xwidget. When constructing a WebKit widget, it +will share the same settings and internal subprocess as RELATED. +Returns the newly constructed xwidget, or nil if construction +fails. */) (Lisp_Object type, Lisp_Object title, Lisp_Object width, Lisp_Object height, - Lisp_Object arguments, Lisp_Object buffer) + Lisp_Object arguments, Lisp_Object buffer, Lisp_Object related) { #ifdef USE_GTK if (!xg_gtk_initialized) @@ -96,6 +248,11 @@ Returns the newly constructed xwidget, or nil if construction fails. */) CHECK_FIXNAT (width); CHECK_FIXNAT (height); + if (!EQ (type, Qwebkit)) + error ("Bad xwidget type"); + + Frequire (Qxwidget, Qnil, Qnil); + struct xwidget *xw = allocate_xwidget (); Lisp_Object val; xw->type = type; @@ -106,15 +263,22 @@ Returns the newly constructed xwidget, or nil if construction fails. */) xw->width = XFIXNAT (width); xw->kill_without_query = false; XSETXWIDGET (val, xw); - Vxwidget_list = Fcons (val, Vxwidget_list); + internal_xwidget_list = Fcons (val, internal_xwidget_list); + Vxwidget_list = Fcopy_sequence (internal_xwidget_list); xw->plist = Qnil; + xw->xwidget_id = ++xwidget_counter; + xw->find_text = NULL; + + Fputhash (make_fixnum (xw->xwidget_id), val, id_to_xwidget_map); #ifdef USE_GTK xw->widgetwindow_osr = NULL; xw->widget_osr = NULL; + xw->hit_result = 0; if (EQ (xw->type, Qwebkit)) { block_input (); + WebKitSettings *settings; WebKitWebContext *webkit_context = webkit_web_context_get_default (); # if WEBKIT_CHECK_VERSION (2, 26, 0) @@ -125,24 +289,45 @@ Returns the newly constructed xwidget, or nil if construction fails. */) xw->widgetwindow_osr = gtk_offscreen_window_new (); gtk_window_resize (GTK_WINDOW (xw->widgetwindow_osr), xw->width, xw->height); + gtk_container_check_resize (GTK_CONTAINER (xw->widgetwindow_osr)); if (EQ (xw->type, Qwebkit)) { - xw->widget_osr = webkit_web_view_new (); - - /* 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); - } + WebKitWebView *related_view; + + if (NILP (related) + || !XWIDGETP (related) + || !EQ (XXWIDGET (related)->type, Qwebkit)) + { + 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. */ + catch_child_signal (); + } + else + { + related_view = WEBKIT_WEB_VIEW (XXWIDGET (related)->widget_osr); + xw->widget_osr = webkit_web_view_new_with_related_view (related_view); + } + + /* Enable the developer extras. */ + settings = webkit_web_view_get_settings (WEBKIT_WEB_VIEW (xw->widget_osr)); + g_object_set (G_OBJECT (settings), "enable-developer-extras", TRUE, NULL); + } gtk_widget_set_size_request (GTK_WIDGET (xw->widget_osr), xw->width, xw->height); + gtk_widget_queue_allocate (GTK_WIDGET (xw->widget_osr)); if (EQ (xw->type, Qwebkit)) { @@ -157,6 +342,16 @@ Returns the newly constructed xwidget, or nil if construction fails. */) gtk_widget_show (xw->widget_osr); gtk_widget_show (xw->widgetwindow_osr); +#if !defined HAVE_XINPUT2 && !defined HAVE_PGTK + 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. */ @@ -170,17 +365,33 @@ Returns the newly constructed xwidget, or nil if construction 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 (webkit_decide_policy_cb), xw); + + g_signal_connect (G_OBJECT (xw->widget_osr), + "mouse-target-changed", + G_CALLBACK (mouse_target_changed), + xw); + g_signal_connect (G_OBJECT (xw->widget_osr), + "create", + G_CALLBACK (webkit_create_cb), + xw); + g_signal_connect (G_OBJECT (xw->widget_osr), + "script-dialog", + G_CALLBACK (webkit_script_dialog_cb), + NULL); + g_signal_connect (G_OBJECT (xw->widget_osr), + "run-file-chooser", + G_CALLBACK (run_file_chooser_cb), + NULL); } + g_signal_connect (G_OBJECT (xw->widgetwindow_osr), "damage-event", + G_CALLBACK (offscreen_damage_event), xw); + unblock_input (); } #elif defined NS_IMPL_COCOA @@ -190,6 +401,214 @@ Returns the newly constructed xwidget, or nil if construction fails. */) return val; } +DEFUN ("xwidget-live-p", Fxwidget_live_p, Sxwidget_live_p, + 1, 1, 0, doc: /* Return t if OBJECT is an xwidget that has not been killed. +Value is nil if OBJECT is not an xwidget or if it has been killed. */) + (Lisp_Object object) +{ + return ((XWIDGETP (object) + && !NILP (XXWIDGET (object)->buffer)) + ? Qt : Qnil); +} + +#ifdef USE_GTK +static void +set_widget_if_text_view (GtkWidget *widget, void *data) +{ + GtkWidget **pointer = data; + + if (GTK_IS_TEXT_VIEW (widget)) + *pointer = widget; +} +#endif + +DEFUN ("xwidget-perform-lispy-event", + Fxwidget_perform_lispy_event, Sxwidget_perform_lispy_event, + 2, 3, 0, doc: /* Send a lispy event to XWIDGET. +EVENT should be the event that will be sent. FRAME should be the +frame which generated the event, and defaults to the selected frame. +On X11, modifier keys will not be processed if FRAME is nil and the +selected frame is not an X-Windows frame. */) + (Lisp_Object xwidget, Lisp_Object event, Lisp_Object frame) +{ + struct xwidget *xw; + struct frame *f = NULL; + int character = -1, keycode = -1; + int modifiers = 0; + +#ifdef USE_GTK + GdkEvent *xg_event; + GtkContainerClass *klass; + GtkWidget *widget; + GtkWidget *temp = NULL; +#ifdef HAVE_XINPUT2 + GdkWindow *embedder; + GdkWindow *osw; +#endif +#endif + + CHECK_LIVE_XWIDGET (xwidget); + xw = XXWIDGET (xwidget); + + if (!NILP (frame)) + f = decode_window_system_frame (frame); + else if (FRAME_WINDOW_P (SELECTED_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; + + block_input (); + 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); + unblock_input (); +#endif + widget = gtk_window_get_focus (GTK_WINDOW (xw->widgetwindow_osr)); + + if (!widget) + widget = xw->widget_osr; + + if (RANGED_FIXNUMP (0, event, INT_MAX)) + { + character = XFIXNUM (event); + + if (character < 32) + modifiers |= ctrl_modifier; + + modifiers |= character & meta_modifier; + modifiers |= character & hyper_modifier; + modifiers |= character & super_modifier; + modifiers |= character & shift_modifier; + modifiers |= character & ctrl_modifier; + + character = character & ~(1 << 21); + + if (character < 32) + character += '_'; + +#ifndef HAVE_PGTK + if (f) + modifiers = x_emacs_to_x_modifiers (FRAME_DISPLAY_INFO (f), modifiers); + else + modifiers = 0; +#else + if (f) + modifiers = pgtk_emacs_to_gtk_modifiers (FRAME_DISPLAY_INFO (f), modifiers); + else + modifiers = 0; +#endif + } + else if (SYMBOLP (event)) + { + Lisp_Object decoded = parse_modifiers (event); + Lisp_Object decoded_name = SYMBOL_NAME (XCAR (decoded)); + + int off = 0; + bool found = false; + + while (off < 256) + { + if (lispy_function_keys[off] + && !strcmp (lispy_function_keys[off], + SSDATA (decoded_name))) + { + found = true; + break; + } + ++off; + } + +#ifndef HAVE_PGTK + if (f) + modifiers = x_emacs_to_x_modifiers (FRAME_DISPLAY_INFO (f), + XFIXNUM (XCAR (XCDR (decoded)))); + else + modifiers = 0; +#else + if (f) + modifiers = pgtk_emacs_to_gtk_modifiers (FRAME_DISPLAY_INFO (f), + XFIXNUM (XCAR (XCDR (decoded)))); + else + modifiers = 0; +#endif + + if (found) + keycode = off + 0xff00; + } + + if (character == -1 && keycode == -1) + { +#ifdef HAVE_XINPUT2 + block_input (); + if (xw->embedder_view) + record_osr_embedder (xw->embedder_view); + else + gdk_offscreen_window_set_embedder (osw, NULL); + unblock_input (); +#endif + return Qnil; + } + + block_input (); + xg_event = gdk_event_new (GDK_KEY_PRESS); + xg_event->any.window = gtk_widget_get_window (xw->widget_osr); + g_object_ref (xg_event->any.window); + + if (character > -1) + keycode = gdk_unicode_to_keyval (character); + + xg_event->key.keyval = keycode; + xg_event->key.state = modifiers; + + if (keycode > -1) + { + /* WebKitGTK internals abuse follows. */ + if (WEBKIT_IS_WEB_VIEW (widget)) + { + /* WebKitGTK relies on an internal GtkTextView object to + "translate" keys such as backspace. We must find that + widget and activate its binding to this key if any. */ + klass = GTK_CONTAINER_CLASS (G_OBJECT_GET_CLASS (widget)); + + klass->forall (GTK_CONTAINER (xw->widget_osr), TRUE, + set_widget_if_text_view, &temp); + + if (GTK_IS_WIDGET (temp)) + { + if (!gtk_widget_get_realized (temp)) + gtk_widget_realize (temp); + + gtk_bindings_activate (G_OBJECT (temp), keycode, modifiers); + } + } + } + + if (f) + gdk_event_set_device (xg_event, + find_suitable_keyboard (SELECTED_FRAME ())); + + gtk_main_do_event (xg_event); + xg_event->type = GDK_KEY_RELEASE; + gtk_main_do_event (xg_event); + gdk_event_free (xg_event); + +#ifdef HAVE_XINPUT2 + if (xw->embedder_view) + record_osr_embedder (xw->embedder_view); + else + gdk_offscreen_window_set_embedder (osw, NULL); +#endif + unblock_input (); +#endif + + return Qnil; +} + DEFUN ("get-buffer-xwidgets", Fget_buffer_xwidgets, Sget_buffer_xwidgets, 1, 1, 0, doc: /* Return a list of xwidgets associated with BUFFER. @@ -206,7 +625,7 @@ BUFFER may be a buffer or the name of one. */) xw_list = Qnil; - for (tail = Vxwidget_list; CONSP (tail); tail = XCDR (tail)) + for (tail = internal_xwidget_list; CONSP (tail); tail = XCDR (tail)) { xw = XCAR (tail); if (XWIDGETP (xw) && EQ (Fxwidget_buffer (xw), buffer)) @@ -221,16 +640,871 @@ xwidget_hidden (struct xwidget_view *xv) return xv->hidden; } +struct xwidget * +xwidget_from_id (uint32_t id) +{ + Lisp_Object key = make_fixnum (id); + Lisp_Object xwidget = Fgethash (key, id_to_xwidget_map, Qnil); + + if (NILP (xwidget)) + emacs_abort (); + + return XXWIDGET (xwidget); +} + #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) +{ + struct xwidget *xw; + GdkWindow *window, *embedder; + + xw = XXWIDGET (view->model); + window = gtk_widget_get_window (xw->widgetwindow_osr); +#ifndef HAVE_PGTK + embedder = gtk_widget_get_window (FRAME_GTK_OUTER_WIDGET (view->frame)); +#else + embedder = gtk_widget_get_window (view->widget); +#endif + gdk_offscreen_window_set_embedder (window, embedder); + xw->embedder = view->frame; + xw->embedder_view = view; +} + +static struct xwidget * +find_xwidget_for_offscreen_window (GdkWindow *window) +{ + Lisp_Object tem; + struct xwidget *xw; + GdkWindow *w; + + for (tem = internal_xwidget_list; CONSP (tem); tem = XCDR (tem)) + { + if (XWIDGETP (XCAR (tem))) + { + xw = XXWIDGET (XCAR (tem)); + w = gtk_widget_get_window (xw->widgetwindow_osr); + + if (w == window) + return xw; + } + } + + return NULL; +} + +static void +from_embedder (GdkWindow *window, double x, double y, + gpointer x_out_ptr, gpointer y_out_ptr, + gpointer user_data) +{ + double *xout = x_out_ptr; + double *yout = y_out_ptr; +#ifndef HAVE_PGTK + struct xwidget *xw = find_xwidget_for_offscreen_window (window); + struct xwidget_view *xvw; + gint xoff, yoff; + + if (!xw) + emacs_abort (); + + xvw = xw->embedder_view; + + if (!xvw) + { + *xout = x; + *yout = y; + } + else + { + gtk_widget_translate_coordinates (FRAME_GTK_WIDGET (xvw->frame), + FRAME_GTK_OUTER_WIDGET (xvw->frame), + 0, 0, &xoff, &yoff); + + *xout = x - xvw->x - xoff; + *yout = y - xvw->y - yoff; + } +#else + *xout = x; + *yout = y; +#endif +} + +static void +to_embedder (GdkWindow *window, double x, double y, + gpointer x_out_ptr, gpointer y_out_ptr, + gpointer user_data) +{ + double *xout = x_out_ptr; + double *yout = y_out_ptr; +#ifndef HAVE_PGTK + struct xwidget *xw = find_xwidget_for_offscreen_window (window); + struct xwidget_view *xvw; + gint xoff, yoff; + + if (!xw) + emacs_abort (); + + xvw = xw->embedder_view; + + if (!xvw) + { + *xout = x; + *yout = y; + } + else + { + gtk_widget_translate_coordinates (FRAME_GTK_WIDGET (xvw->frame), + FRAME_GTK_OUTER_WIDGET (xvw->frame), + 0, 0, &xoff, &yoff); + + *xout = x + xvw->x + xoff; + *yout = y + xvw->y + yoff; + } +#else + *xout = x; + *yout = y; +#endif +} + +static GdkDevice * +find_suitable_pointer (struct frame *f) +{ + GdkSeat *seat = gdk_display_get_default_seat + (gtk_widget_get_display (FRAME_GTK_WIDGET (f))); + + if (!seat) + return NULL; + + return gdk_seat_get_pointer (seat); +} + +static GdkDevice * +find_suitable_keyboard (struct frame *f) +{ + GdkSeat *seat = gdk_display_get_default_seat + (gtk_widget_get_display (FRAME_GTK_WIDGET (f))); + + if (!seat) + return NULL; + + return gdk_seat_get_keyboard (seat); +} + +static void +find_widget_cb (GtkWidget *widget, void *user) +{ + find_widget (widget, user); +} + +static void +find_widget (GtkWidget *widget, + struct widget_search_data *data) +{ + GtkAllocation new_allocation; + GdkWindow *window; + int x_offset = 0; + int y_offset = 0; + + gtk_widget_get_allocation (widget, &new_allocation); + + if (gtk_widget_get_has_window (widget)) + { + new_allocation.x = 0; + new_allocation.y = 0; + } + + if (gtk_widget_get_parent (widget) && !data->first) + { + window = gtk_widget_get_window (widget); + while (window != gtk_widget_get_window (gtk_widget_get_parent (widget))) + { + gint tx, ty, twidth, theight; + + if (!window) + return; + + twidth = gdk_window_get_width (window); + theight = gdk_window_get_height (window); + + if (new_allocation.x < 0) + { + new_allocation.width += new_allocation.x; + new_allocation.x = 0; + } + + if (new_allocation.y < 0) + { + new_allocation.height += new_allocation.y; + new_allocation.y = 0; + } + + if (new_allocation.x + new_allocation.width > twidth) + new_allocation.width = twidth - new_allocation.x; + if (new_allocation.y + new_allocation.height > theight) + new_allocation.height = theight - new_allocation.y; + + gdk_window_get_position (window, &tx, &ty); + new_allocation.x += tx; + x_offset += tx; + new_allocation.y += ty; + y_offset += ty; + + window = gdk_window_get_parent (window); + } + } + + if ((data->x >= new_allocation.x) && (data->y >= new_allocation.y) && + (data->x < new_allocation.x + new_allocation.width) && + (data->y < new_allocation.y + new_allocation.height)) + { + /* First, check if the drag is in a valid drop site in one of + our children. */ + if (GTK_IS_CONTAINER (widget)) + { + struct widget_search_data new_data = *data; + + new_data.x -= x_offset; + new_data.y -= y_offset; + new_data.foundp = false; + new_data.first = false; + + gtk_container_forall (GTK_CONTAINER (widget), + find_widget_cb, &new_data); + + data->foundp = new_data.foundp; + if (data->foundp) + data->data = new_data.data; + } + + /* If not, and this widget is registered as a drop site, check + to emit "drag_motion" to check if we are actually in a drop + site. */ + if (!data->foundp) + { + data->foundp = true; + data->data = widget; + } + } +} + +static GtkWidget * +find_widget_at_pos (GtkWidget *w, int x, int y, + int *new_x, int *new_y) +{ + struct widget_search_data data; + + data.x = x; + data.y = y; + data.foundp = false; + data.first = true; + + find_widget (w, &data); + + if (data.foundp) + { + gtk_widget_translate_coordinates (w, data.data, x, + y, new_x, new_y); + return data.data; + } + + *new_x = x; + *new_y = y; + + return NULL; +} + +static Emacs_Cursor +cursor_for_hit (guint result, struct frame *frame) +{ + Emacs_Cursor cursor = FRAME_OUTPUT_DATA (frame)->nontext_cursor; + + if ((result & WEBKIT_HIT_TEST_RESULT_CONTEXT_EDITABLE) + || (result & WEBKIT_HIT_TEST_RESULT_CONTEXT_SELECTION) + || (result & WEBKIT_HIT_TEST_RESULT_CONTEXT_DOCUMENT)) + cursor = FRAME_X_OUTPUT (frame)->text_cursor; + + if (result & WEBKIT_HIT_TEST_RESULT_CONTEXT_SCROLLBAR) + cursor = FRAME_X_OUTPUT (frame)->vertical_drag_cursor; + + if (result & WEBKIT_HIT_TEST_RESULT_CONTEXT_LINK) + cursor = FRAME_X_OUTPUT (frame)->hand_cursor; + + return cursor; +} + +static void +define_cursors (struct xwidget *xw, WebKitHitTestResult *res) +{ + struct xwidget_view *xvw; +#ifdef HAVE_PGTK + GdkWindow *wdesc; +#endif + + xw->hit_result = webkit_hit_test_result_get_context (res); + + for (Lisp_Object tem = internal_xwidget_view_list; CONSP (tem); + tem = XCDR (tem)) + { + if (XWIDGET_VIEW_P (XCAR (tem))) + { + xvw = XXWIDGET_VIEW (XCAR (tem)); + + if (XXWIDGET (xvw->model) == xw) + { + xvw->cursor = cursor_for_hit (xw->hit_result, xvw->frame); +#ifdef HAVE_X_WINDOWS + if (xvw->wdesc != None) + XDefineCursor (xvw->dpy, xvw->wdesc, xvw->cursor); +#else + if (gtk_widget_get_realized (xvw->widget)) + { + wdesc = gtk_widget_get_window (xvw->widget); + gdk_window_set_cursor (wdesc, xvw->cursor); + } +#endif + } + } + } +} + +static void +mouse_target_changed (WebKitWebView *webview, + WebKitHitTestResult *hitresult, + guint modifiers, gpointer xw) +{ + define_cursors (xw, hitresult); +} + +static gboolean +run_file_chooser_cb (WebKitWebView *webview, + WebKitFileChooserRequest *request, + gpointer user_data) +{ + struct frame *f = SELECTED_FRAME (); + GtkFileChooserNative *chooser; + GtkFileFilter *filter; + bool select_multiple_p; + guint response; + GSList *filenames; + GSList *tem; + int i, len; + gchar **files; + + /* Return TRUE to prevent WebKit from showing the default script + dialog in the offscreen window, which runs a nested main loop + Emacs can't respond to, and as such can't pass X events to. */ + if (!FRAME_WINDOW_P (f)) + return TRUE; + + chooser = gtk_file_chooser_native_new ("Select file", + GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), + 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_native_dialog_run (GTK_NATIVE_DIALOG (chooser)); + + if (response != GTK_RESPONSE_ACCEPT) + { + gtk_native_dialog_destroy (GTK_NATIVE_DIALOG (chooser)); + webkit_file_chooser_request_cancel (request); + + return TRUE; + } + + filenames = gtk_file_chooser_get_filenames (GTK_FILE_CHOOSER (chooser)); + len = g_slist_length (filenames); + files = alloca (sizeof *files * (len + 1)); + + for (tem = filenames, i = 0; tem; tem = tem->next, ++i) + files[i] = tem->data; + files[len] = NULL; + + g_slist_free (filenames); + webkit_file_chooser_request_select_files (request, (const gchar **) files); + + for (i = 0; i < len; ++i) + g_free (files[i]); + + gtk_native_dialog_destroy (GTK_NATIVE_DIALOG (chooser)); + + return TRUE; +} + +#ifdef HAVE_X_WINDOWS + +static void +xwidget_button_1 (struct xwidget_view *view, + bool down_p, int x, int y, int button, + int modifier_state, Time time) +{ + GdkEvent *xg_event = gdk_event_new (down_p ? GDK_BUTTON_PRESS : GDK_BUTTON_RELEASE); + struct xwidget *model = XXWIDGET (view->model); + GtkWidget *target; + + /* X and Y should be relative to the origin of view->wdesc. */ + x += view->clip_left; + y += view->clip_top; + + target = find_widget_at_pos (model->widgetwindow_osr, x, y, &x, &y); + + if (!target) + target = model->widget_osr; + + xg_event->any.window = gtk_widget_get_window (target); + g_object_ref (xg_event->any.window); /* The window will be unrefed + later by gdk_event_free. */ + + xg_event->button.x = x; + xg_event->button.x_root = x; + xg_event->button.y = y; + xg_event->button.y_root = y; + xg_event->button.button = button; + xg_event->button.state = modifier_state; + xg_event->button.time = time; + xg_event->button.device = find_suitable_pointer (view->frame); + + gtk_main_do_event (xg_event); + gdk_event_free (xg_event); +} + +void +xwidget_button (struct xwidget_view *view, + bool down_p, int x, int y, int button, + int modifier_state, Time time) +{ + if (NILP (XXWIDGET (view->model)->buffer)) + return; + + record_osr_embedder (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); + GtkWidget *target; + + x += view->clip_left; + y += view->clip_top; + + target = find_widget_at_pos (model->widgetwindow_osr, x, y, &x, &y); + + if (!target) + target = model->widget_osr; + + xg_event->any.window = gtk_widget_get_window (target); + g_object_ref (xg_event->any.window); /* The window will be unrefed + later by gdk_event_free. */ + if (button == 4) + xg_event->scroll.direction = GDK_SCROLL_UP; + else if (button == 5) + xg_event->scroll.direction = GDK_SCROLL_DOWN; + else if (button == 6) + xg_event->scroll.direction = GDK_SCROLL_LEFT; + else + xg_event->scroll.direction = GDK_SCROLL_RIGHT; + + xg_event->scroll.device = find_suitable_pointer (view->frame); + + xg_event->scroll.x = x; + xg_event->scroll.x_root = x; + xg_event->scroll.y = y; + xg_event->scroll.y_root = y; + xg_event->scroll.state = modifier_state; + xg_event->scroll.time = time; + + xg_event->scroll.delta_x = 0; + xg_event->scroll.delta_y = 0; + + gtk_main_do_event (xg_event); + gdk_event_free (xg_event); + } +} + +#ifdef HAVE_XINPUT2 +void +xwidget_motion_notify (struct xwidget_view *view, + double x, double y, + double root_x, double root_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 + view->clip_left), + lrint (y + view->clip_top), + &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 = root_x; + xg_event->motion.y_root = root_y; + xg_event->motion.time = time; + xg_event->motion.state = state; + xg_event->motion.device = find_suitable_pointer (view->frame); + + 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, + bool stop_p) +{ + 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 + view->clip_left), + lrint (y + view->clip_top), + &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); + xg_event->scroll.is_stop = stop_p; + + g_object_ref (xg_event->any.window); + + gtk_main_do_event (xg_event); + gdk_event_free (xg_event); +} + +#ifdef HAVE_USABLE_XI_GESTURE_PINCH_EVENT +void +xwidget_pinch (struct xwidget_view *view, XIGesturePinchEvent *xev) +{ +#if GTK_CHECK_VERSION (3, 18, 0) + GdkEvent *xg_event; + GtkWidget *target; + struct xwidget *model = XXWIDGET (view->model); + int target_x, target_y; + double x = xev->event_x; + double y = xev->event_y; + + if (NILP (model->buffer)) + return; + + record_osr_embedder (view); + + target = find_widget_at_pos (model->widgetwindow_osr, + lrint (x + view->clip_left), + lrint (y + view->clip_top), + &target_x, &target_y); + + if (!target) + { + target_x = lrint (x); + target_y = lrint (y); + target = model->widget_osr; + } + + xg_event = gdk_event_new (GDK_TOUCHPAD_PINCH); + xg_event->any.window = gtk_widget_get_window (target); + xg_event->touchpad_pinch.x = target_x; + xg_event->touchpad_pinch.y = target_y; + xg_event->touchpad_pinch.dx = xev->delta_x; + xg_event->touchpad_pinch.dy = xev->delta_y; + xg_event->touchpad_pinch.angle_delta = xev->delta_angle; + xg_event->touchpad_pinch.scale = xev->scale; + xg_event->touchpad_pinch.x_root = xev->root_x; + xg_event->touchpad_pinch.y_root = xev->root_y; + xg_event->touchpad_pinch.state = xev->mods.effective; + xg_event->touchpad_pinch.n_fingers = 2; + + switch (xev->evtype) + { + case XI_GesturePinchBegin: + xg_event->touchpad_pinch.phase = GDK_TOUCHPAD_GESTURE_PHASE_BEGIN; + break; + case XI_GesturePinchUpdate: + xg_event->touchpad_pinch.phase = GDK_TOUCHPAD_GESTURE_PHASE_UPDATE; + break; + case XI_GesturePinchEnd: + xg_event->touchpad_pinch.phase = GDK_TOUCHPAD_GESTURE_PHASE_END; + break; + } + + gdk_event_set_device (xg_event, find_suitable_pointer (view->frame)); + + g_object_ref (xg_event->any.window); + gtk_main_do_event (xg_event); + gdk_event_free (xg_event); +#endif +} +#endif +#endif + +#ifdef HAVE_XINPUT2 +static GdkNotifyType +xi_translate_notify_detail (int detail) +{ + switch (detail) + { + case XINotifyInferior: + return GDK_NOTIFY_INFERIOR; + case XINotifyAncestor: + return GDK_NOTIFY_ANCESTOR; + case XINotifyVirtual: + return GDK_NOTIFY_VIRTUAL; + case XINotifyNonlinear: + return GDK_NOTIFY_NONLINEAR; + case XINotifyNonlinearVirtual: + return GDK_NOTIFY_NONLINEAR_VIRTUAL; + default: + emacs_abort (); + } +} +#endif + +void +xwidget_motion_or_crossing (struct xwidget_view *view, const XEvent *event) +{ + GdkEvent *xg_event; + struct xwidget *model = XXWIDGET (view->model); + int x; + int y; + GtkWidget *target; +#ifdef HAVE_XINPUT2 + XIEnterEvent *xev = NULL; +#endif + + if (NILP (model->buffer)) + return; + +#ifdef HAVE_XINPUT2 + if (event->type != GenericEvent) +#endif + { + xg_event = gdk_event_new (event->type == MotionNotify + ? GDK_MOTION_NOTIFY + : (event->type == LeaveNotify + ? GDK_LEAVE_NOTIFY + : GDK_ENTER_NOTIFY)); + target = find_widget_at_pos (model->widgetwindow_osr, + (event->type == MotionNotify + ? event->xmotion.x + view->clip_left + : event->xcrossing.x + view->clip_left), + (event->type == MotionNotify + ? event->xmotion.y + view->clip_top + : event->xcrossing.y + view->clip_top), + &x, &y); + } +#ifdef HAVE_XINPUT2 + else + { + eassert (event->xcookie.evtype == XI_Enter + || event->xcookie.evtype == XI_Leave); + + xev = (XIEnterEvent *) event->xcookie.data; + xg_event = gdk_event_new (event->type == XI_Enter + ? GDK_ENTER_NOTIFY + : GDK_LEAVE_NOTIFY); + target = find_widget_at_pos (model->widgetwindow_osr, + lrint (xev->event_x + view->clip_left), + lrint (xev->event_y + view->clip_top), + &x, &y); + } +#endif + + if (!target) + target = model->widget_osr; + + record_osr_embedder (view); + xg_event->any.window = gtk_widget_get_window (target); + g_object_ref (xg_event->any.window); /* The window will be unrefed + later by gdk_event_free. */ + + if (event->type == MotionNotify) + { + xg_event->motion.x = x; + xg_event->motion.y = y; + xg_event->motion.x_root = event->xmotion.x_root; + xg_event->motion.y_root = event->xmotion.y_root; + xg_event->motion.time = event->xmotion.time; + xg_event->motion.state = event->xmotion.state; + xg_event->motion.device = find_suitable_pointer (view->frame); + } +#ifdef HAVE_XINPUT2 + else if (event->type == GenericEvent) + { + xg_event->crossing.x = (gdouble) xev->event_x; + xg_event->crossing.y = (gdouble) xev->event_y; + xg_event->crossing.x_root = (gdouble) xev->root_x; + xg_event->crossing.y_root = (gdouble) xev->root_y; + xg_event->crossing.time = xev->time; + xg_event->crossing.focus = xev->focus; + xg_event->crossing.mode = xev->mode; + xg_event->crossing.detail = xi_translate_notify_detail (xev->detail); + xg_event->crossing.state = xev->mods.effective; + + if (xev->buttons.mask_len) + { + if (XIMaskIsSet (xev->buttons.mask, 1)) + xg_event->crossing.state |= GDK_BUTTON1_MASK; + if (XIMaskIsSet (xev->buttons.mask, 2)) + xg_event->crossing.state |= GDK_BUTTON2_MASK; + if (XIMaskIsSet (xev->buttons.mask, 3)) + xg_event->crossing.state |= GDK_BUTTON3_MASK; + } + + gdk_event_set_device (xg_event, find_suitable_pointer (view->frame)); + } +#endif + else + { + xg_event->crossing.detail = min (5, event->xcrossing.detail); + xg_event->crossing.time = event->xcrossing.time; + xg_event->crossing.x = x; + xg_event->crossing.y = y; + xg_event->crossing.x_root = event->xcrossing.x_root; + xg_event->crossing.y_root = event->xcrossing.y_root; + xg_event->crossing.focus = event->xcrossing.focus; + gdk_event_set_device (xg_event, find_suitable_pointer (view->frame)); + } + + gtk_main_do_event (xg_event); + gdk_event_free (xg_event); +} + +#endif /* HAVE_X_WINDOWS */ + +static void +synthesize_focus_in_event (GtkWidget *offscreen_window) +{ + GdkWindow *wnd; + GdkEvent *focus_event; + + if (!gtk_widget_get_realized (offscreen_window)) + gtk_widget_realize (offscreen_window); + + wnd = gtk_widget_get_window (offscreen_window); + + focus_event = gdk_event_new (GDK_FOCUS_CHANGE); + focus_event->focus_change.window = wnd; + focus_event->focus_change.in = TRUE; + + if (FRAME_WINDOW_P (SELECTED_FRAME ())) + gdk_event_set_device (focus_event, + find_suitable_pointer (SELECTED_FRAME ())); + + g_object_ref (wnd); + + gtk_main_do_event (focus_event); + gdk_event_free (focus_event); +} + +#ifdef HAVE_X_WINDOWS +struct xwidget_view * +xwidget_view_from_window (Window wdesc) +{ + Lisp_Object key = make_fixnum (wdesc); + Lisp_Object xwv = Fgethash (key, x_window_to_xwv_map, Qnil); + + if (NILP (xwv)) + return NULL; + + return XXWIDGET_VIEW (xwv); +} +#endif + static void xwidget_show_view (struct xwidget_view *xv) { xv->hidden = false; - gtk_widget_show (xv->widgetwindow); - gtk_fixed_move (GTK_FIXED (xv->emacswindow), - xv->widgetwindow, - xv->x + xv->clip_left, - xv->y + xv->clip_top); +#ifdef HAVE_X_WINDOWS + XMoveWindow (xv->dpy, xv->wdesc, + xv->x + xv->clip_left, + xv->y + xv->clip_top); + XMapWindow (xv->dpy, xv->wdesc); + XFlush (xv->dpy); +#else + gtk_fixed_move (GTK_FIXED (FRAME_GTK_WIDGET (xv->frame)), + xv->widget, xv->x + xv->clip_left, + xv->y + xv->clip_top); + gtk_widget_show_all (xv->widget); +#endif } /* Hide an xwidget view. */ @@ -238,28 +1512,115 @@ static void xwidget_hide_view (struct xwidget_view *xv) { xv->hidden = true; - gtk_fixed_move (GTK_FIXED (xv->emacswindow), xv->widgetwindow, - 10000, 10000); +#ifdef HAVE_X_WINDOWS + XUnmapWindow (xv->dpy, xv->wdesc); + XFlush (xv->dpy); +#else + gtk_widget_hide (xv->widget); +#endif +} + +#ifndef HAVE_PGTK +static void +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); + return; + } + + block_input (); + wnd = GTK_OFFSCREEN_WINDOW (w->widgetwindow_osr); + surface = gtk_offscreen_window_get_surface (wnd); + + cairo_save (xw->cr_context); + if (surface) + { + cairo_translate (xw->cr_context, -xw->clip_left, -xw->clip_top); + cairo_set_source_surface (xw->cr_context, surface, 0, 0); + cairo_set_operator (xw->cr_context, CAIRO_OPERATOR_SOURCE); + cairo_paint (xw->cr_context); + } + cairo_restore (xw->cr_context); + + unblock_input (); } +#else +static void +xwidget_view_draw_cb (GtkWidget *widget, cairo_t *cr, + gpointer data) +{ + struct xwidget_view *view = data; + struct xwidget *w = XXWIDGET (view->model); + GtkOffscreenWindow *wnd; + cairo_surface_t *surface; + + if (NILP (w->buffer)) + return; + + block_input (); + wnd = GTK_OFFSCREEN_WINDOW (w->widgetwindow_osr); + surface = gtk_offscreen_window_get_surface (wnd); + + cairo_save (cr); + if (surface) + { + cairo_translate (cr, -view->clip_left, + -view->clip_top); + cairo_set_source_surface (cr, surface, 0, 0); + cairo_set_operator (cr, CAIRO_OPERATOR_SOURCE); + cairo_paint (cr); + } + cairo_restore (cr); + + unblock_input (); +} +#endif /* When the off-screen webkit master view changes this signal is called. It copies the bitmap from the off-screen instance. */ static gboolean offscreen_damage_event (GtkWidget *widget, GdkEvent *event, - gpointer xv_widget) -{ - /* Queue a redraw of onscreen widget. - There is a guard against receiving an invalid widget, - which should only happen if we failed to remove the - specific signal handler for the damage event. */ - if (GTK_IS_WIDGET (xv_widget)) - gtk_widget_queue_draw (GTK_WIDGET (xv_widget)); - else - message ("Warning, offscreen_damage_event received invalid xv pointer:%p\n", - xv_widget); + gpointer xwidget) +{ + block_input (); + + for (Lisp_Object tail = internal_xwidget_view_list; CONSP (tail); + tail = XCDR (tail)) + { + if (XWIDGET_VIEW_P (XCAR (tail))) + { + struct xwidget_view *view = XXWIDGET_VIEW (XCAR (tail)); +#ifdef HAVE_X_WINDOWS + if (view->wdesc && XXWIDGET (view->model) == xwidget) + xv_do_draw (view, XXWIDGET (view->model)); +#else + gtk_widget_queue_draw (view->widget); +#endif + } + } + + unblock_input (); return FALSE; } + +#ifdef HAVE_X_WINDOWS +void +xwidget_expose (struct xwidget_view *xv) +{ + struct xwidget *xw = XXWIDGET (xv->model); + + xv_do_draw (xv, xw); +} +#endif #endif /* USE_GTK */ void @@ -313,22 +1674,121 @@ store_xwidget_js_callback_event (struct xwidget *xw, #ifdef USE_GTK +static void +store_xwidget_display_event (struct xwidget *xw, + struct xwidget *src) +{ + struct input_event evt; + 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 = list2 (val, src_val); + kbd_buffer_store_event (&evt); +} + +static void +webkit_ready_to_show (WebKitWebView *new_view, + gpointer user_data) +{ + 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)) + { + if (XWIDGETP (XCAR (tem))) + { + xw = XXWIDGET (XCAR (tem)); + + if (EQ (xw->type, Qwebkit) + && WEBKIT_WEB_VIEW (xw->widget_osr) == new_view) + { + /* 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 *xv) +{ + Lisp_Object related; + Lisp_Object xwidget; + GtkWidget *widget; + + XSETXWIDGET (related, xv); + xwidget = Fmake_xwidget (Qwebkit, Qnil, make_fixnum (0), + make_fixnum (0), Qnil, + build_string (" *detached xwidget buffer*"), + related); + + if (NILP (xwidget)) + return NULL; + + widget = XXWIDGET (xwidget)->widget_osr; + + g_signal_connect (G_OBJECT (widget), "ready-to-show", + G_CALLBACK (webkit_ready_to_show), + gtk_widget_get_window (xv->widgetwindow_osr)); + + return widget; +} + +static GtkWidget * +webkit_create_cb (WebKitWebView *webview, + WebKitNavigationAction *nav_action, + gpointer user_data) +{ + switch (webkit_navigation_action_get_navigation_type (nav_action)) + { + case WEBKIT_NAVIGATION_TYPE_OTHER: + return webkit_create_cb_1 (webview, user_data); + + case WEBKIT_NAVIGATION_TYPE_BACK_FORWARD: + case WEBKIT_NAVIGATION_TYPE_RELOAD: + case WEBKIT_NAVIGATION_TYPE_FORM_SUBMITTED: + case WEBKIT_NAVIGATION_TYPE_FORM_RESUBMITTED: + case WEBKIT_NAVIGATION_TYPE_LINK_CLICKED: + default: + return NULL; + } +} + void webkit_view_load_changed_cb (WebKitWebView *webkitwebview, WebKitLoadEvent load_event, gpointer data) { - switch (load_event) { - case WEBKIT_LOAD_FINISHED: + struct xwidget *xw = g_object_get_data (G_OBJECT (webkitwebview), + XG_XWIDGET); + + switch (load_event) { - struct xwidget *xw = g_object_get_data (G_OBJECT (webkitwebview), - XG_XWIDGET); - store_xwidget_event_string (xw, "load-changed", ""); + case WEBKIT_LOAD_FINISHED: + store_xwidget_event_string (xw, "load-changed", "load-finished"); + break; + case WEBKIT_LOAD_STARTED: + store_xwidget_event_string (xw, "load-changed", "load-started"); + break; + case WEBKIT_LOAD_REDIRECTED: + store_xwidget_event_string (xw, "load-changed", "load-redirected"); + break; + case WEBKIT_LOAD_COMMITTED: + store_xwidget_event_string (xw, "load-changed", "load-committed"); break; } - default: - break; - } } /* Recursively convert a JavaScript value to a Lisp value. */ @@ -419,8 +1879,8 @@ webkit_javascript_finished_cb (GObject *webview, if (!js_result) { - g_warning ("Error running javascript: %s", error->message); - g_error_free (error); + if (error) + g_error_free (error); return; } @@ -479,6 +1939,33 @@ webkit_decide_policy_cb (WebKitWebView *webView, break; } case WEBKIT_POLICY_DECISION_TYPE_NEW_WINDOW_ACTION: + { + WebKitNavigationPolicyDecision *navigation_decision = + WEBKIT_NAVIGATION_POLICY_DECISION (decision); + WebKitNavigationAction *navigation_action = + webkit_navigation_policy_decision_get_navigation_action (navigation_decision); + WebKitURIRequest *request = + webkit_navigation_action_get_request (navigation_action); + WebKitWebView *newview; + struct xwidget *xw = g_object_get_data (G_OBJECT (webView), XG_XWIDGET); + Lisp_Object val, new_xwidget; + + XSETXWIDGET (val, xw); + + new_xwidget = Fmake_xwidget (Qwebkit, Qnil, make_fixnum (0), + make_fixnum (0), Qnil, + build_string (" *detached xwidget buffer*"), + val); + + if (NILP (new_xwidget)) + return FALSE; + + newview = WEBKIT_WEB_VIEW (XXWIDGET (new_xwidget)->widget_osr); + webkit_web_view_load_request (newview, request); + + store_xwidget_display_event (XXWIDGET (new_xwidget), xw); + return TRUE; + } case WEBKIT_POLICY_DECISION_TYPE_NAVIGATION_ACTION: { WebKitNavigationPolicyDecision *navigation_decision = @@ -499,49 +1986,75 @@ webkit_decide_policy_cb (WebKitWebView *webView, } } - -/* For gtk3 offscreen rendered widgets. */ static gboolean -xwidget_osr_draw_cb (GtkWidget *widget, cairo_t *cr, gpointer data) +webkit_script_dialog_cb (WebKitWebView *webview, + WebKitScriptDialog *script_dialog, + gpointer user) { - struct xwidget *xw = g_object_get_data (G_OBJECT (widget), XG_XWIDGET); - struct xwidget_view *xv = g_object_get_data (G_OBJECT (widget), - XG_XWIDGET_VIEW); + struct frame *f = SELECTED_FRAME (); + WebKitScriptDialogType type; + GtkWidget *widget; + GtkWidget *dialog; + GtkWidget *entry; + GtkWidget *content_area; + GtkWidget *box; + GtkWidget *label; + const gchar *content; + const gchar *message; + gint result; + + /* Return TRUE to prevent WebKit from showing the default script + dialog in the offscreen window, which runs a nested main loop + Emacs can't respond to, and as such can't pass X events to. */ + if (!FRAME_WINDOW_P (f)) + return TRUE; + + type = webkit_script_dialog_get_dialog_type (script_dialog);; + widget = FRAME_GTK_OUTER_WIDGET (f); + content = webkit_script_dialog_get_message (script_dialog); + + if (type == WEBKIT_SCRIPT_DIALOG_ALERT) + dialog = gtk_dialog_new_with_buttons ("Alert", GTK_WINDOW (widget), + GTK_DIALOG_MODAL, + "Dismiss", 1, NULL); + else + dialog = gtk_dialog_new_with_buttons ("Question", GTK_WINDOW (widget), + GTK_DIALOG_MODAL, + "OK", 0, "Cancel", 1, NULL); - cairo_rectangle (cr, 0, 0, xv->clip_right, xv->clip_bottom); - cairo_clip (cr); + box = gtk_box_new (GTK_ORIENTATION_VERTICAL, 8); + label = gtk_label_new (content); + content_area = gtk_dialog_get_content_area (GTK_DIALOG (dialog)); + gtk_container_add (GTK_CONTAINER (content_area), box); - gtk_widget_draw (xw->widget_osr, cr); - return FALSE; -} + gtk_widget_show (box); + gtk_widget_show (label); -static gboolean -xwidget_osr_event_forward (GtkWidget *widget, GdkEvent *event, - gpointer user_data) -{ - /* Copy events that arrive at the outer widget to the offscreen widget. */ - struct xwidget *xw = g_object_get_data (G_OBJECT (widget), XG_XWIDGET); - GdkEvent *eventcopy = gdk_event_copy (event); - eventcopy->any.window = gtk_widget_get_window (xw->widget_osr); + gtk_box_pack_start (GTK_BOX (box), label, TRUE, TRUE, 0); - /* TODO: This might leak events. They should be deallocated later, - perhaps in xwgir_event_cb. */ - gtk_main_do_event (eventcopy); + if (type == WEBKIT_SCRIPT_DIALOG_PROMPT) + { + entry = gtk_entry_new (); + message = webkit_script_dialog_prompt_get_default_text (script_dialog); - /* Don't propagate this event further. */ - return TRUE; -} + gtk_widget_show (entry); + gtk_entry_set_text (GTK_ENTRY (entry), message); + gtk_box_pack_end (GTK_BOX (box), entry, TRUE, TRUE, 0); + } -static gboolean -xwidget_osr_event_set_embedder (GtkWidget *widget, GdkEvent *event, - gpointer data) -{ - struct xwidget_view *xv = data; - struct xwidget *xww = XXWIDGET (xv->model); - gdk_offscreen_window_set_embedder (gtk_widget_get_window - (xww->widgetwindow_osr), - gtk_widget_get_window (xv->widget)); - return FALSE; + result = gtk_dialog_run (GTK_DIALOG (dialog)); + + if (type == WEBKIT_SCRIPT_DIALOG_CONFIRM + || type == WEBKIT_SCRIPT_DIALOG_BEFORE_UNLOAD_CONFIRM) + webkit_script_dialog_confirm_set_confirmed (script_dialog, result == 0); + + if (type == WEBKIT_SCRIPT_DIALOG_PROMPT) + webkit_script_dialog_prompt_set_text (script_dialog, + gtk_entry_get_text (GTK_ENTRY (entry))); + + gtk_widget_destroy (GTK_WIDGET (dialog)); + + return TRUE; } #endif /* USE_GTK */ @@ -562,69 +2075,53 @@ xwidget_init_view (struct xwidget *xww, Lisp_Object val; XSETXWIDGET_VIEW (val, xv); - Vxwidget_view_list = Fcons (val, Vxwidget_view_list); + internal_xwidget_view_list = Fcons (val, internal_xwidget_view_list); + Vxwidget_view_list = Fcopy_sequence (internal_xwidget_view_list); XSETWINDOW (xv->w, s->w); XSETXWIDGET (xv->model, xww); -#ifdef USE_GTK - if (EQ (xww->type, Qwebkit)) - { - xv->widget = gtk_drawing_area_new (); - /* Expose event handling. */ - gtk_widget_set_app_paintable (xv->widget, TRUE); - gtk_widget_add_events (xv->widget, GDK_ALL_EVENTS_MASK); - - /* Draw the view on damage-event. */ - g_signal_connect (G_OBJECT (xww->widgetwindow_osr), "damage-event", - G_CALLBACK (offscreen_damage_event), xv->widget); - - if (EQ (xww->type, Qwebkit)) - { - g_signal_connect (G_OBJECT (xv->widget), "button-press-event", - G_CALLBACK (xwidget_osr_event_forward), NULL); - g_signal_connect (G_OBJECT (xv->widget), "button-release-event", - G_CALLBACK (xwidget_osr_event_forward), NULL); - g_signal_connect (G_OBJECT (xv->widget), "motion-notify-event", - G_CALLBACK (xwidget_osr_event_forward), NULL); - } - else - { - /* xwgir debug, orthogonal to forwarding. */ - g_signal_connect (G_OBJECT (xv->widget), "enter-notify-event", - G_CALLBACK (xwidget_osr_event_set_embedder), xv); - } - g_signal_connect (G_OBJECT (xv->widget), "draw", - G_CALLBACK (xwidget_osr_draw_cb), NULL); - } - - /* Widget realization. +#ifdef HAVE_X_WINDOWS + xv->dpy = FRAME_X_DISPLAY (s->f); - Make container widget first, and put the actual widget inside the - container later. Drawing should crop container window if necessary - to handle case where xwidget is partially obscured by other Emacs - windows. Other containers than gtk_fixed where explored, but - gtk_fixed had the most predictable behavior so far. */ + xv->x = x; + xv->y = y; - xv->emacswindow = FRAME_GTK_WIDGET (s->f); - xv->widgetwindow = gtk_fixed_new (); - gtk_widget_set_has_window (xv->widgetwindow, TRUE); - gtk_container_add (GTK_CONTAINER (xv->widgetwindow), xv->widget); + xv->clip_left = 0; + xv->clip_right = xww->width; + xv->clip_top = 0; + xv->clip_bottom = xww->height; + + xv->wdesc = None; + xv->frame = s->f; + xv->cursor = cursor_for_hit (xww->hit_result, s->f); + xv->just_resized = false; +#elif defined HAVE_PGTK + xv->dpyinfo = FRAME_DISPLAY_INFO (s->f); + xv->widget = gtk_drawing_area_new (); + gtk_widget_set_app_paintable (xv->widget, TRUE); + gtk_widget_add_events (xv->widget, GDK_ALL_EVENTS_MASK); + gtk_container_add (GTK_CONTAINER (FRAME_GTK_WIDGET (s->f)), + xv->widget); + + g_signal_connect (xv->widget, "draw", + G_CALLBACK (xwidget_view_draw_cb), xv); + g_signal_connect (xv->widget, "event", + G_CALLBACK (xw_forward_event_from_view), xv); - /* Store some xwidget data in the gtk widgets. */ - g_object_set_data (G_OBJECT (xv->widget), XG_FRAME_DATA, s->f); - g_object_set_data (G_OBJECT (xv->widget), XG_XWIDGET, xww); g_object_set_data (G_OBJECT (xv->widget), XG_XWIDGET_VIEW, xv); - g_object_set_data (G_OBJECT (xv->widgetwindow), XG_XWIDGET, xww); - g_object_set_data (G_OBJECT (xv->widgetwindow), XG_XWIDGET_VIEW, xv); - gtk_widget_set_size_request (GTK_WIDGET (xv->widget), xww->width, - xww->height); - gtk_widget_set_size_request (xv->widgetwindow, xww->width, xww->height); - gtk_fixed_put (GTK_FIXED (FRAME_GTK_WIDGET (s->f)), xv->widgetwindow, x, y); xv->x = x; xv->y = y; - gtk_widget_show_all (xv->widgetwindow); + + xv->clip_left = 0; + xv->clip_right = xww->width; + xv->clip_top = 0; + xv->clip_bottom = xww->height; + + 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); @@ -656,6 +2153,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) { @@ -678,21 +2177,10 @@ x_draw_xwidget_glyph_string (struct glyph_string *s) } #endif - window_box (s->w, TEXT_AREA, &text_area_x, &text_area_y, - &text_area_width, &text_area_height); + xv->area = s->area; - /* Resize xwidget webkit if its container window size is changed in - some ways, for example, a buffer became hidden in small split - window, then it can appear front in merged whole window. */ - if (EQ (xww->type, Qwebkit) - && (xww->width != text_area_width || xww->height != text_area_height)) - { - Lisp_Object xwl; - XSETXWIDGET (xwl, xww); - Fxwidget_resize (xwl, - make_int (text_area_width), - make_int (text_area_height)); - } + 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); clip_right = max (clip_left, @@ -711,15 +2199,96 @@ x_draw_xwidget_glyph_string (struct glyph_string *s) later. */ bool moved = (xv->x + xv->clip_left != x + clip_left || xv->y + xv->clip_top != y + clip_top); + +#ifdef HAVE_X_WINDOWS + bool wdesc_was_none = xv->wdesc == None; +#endif xv->x = x; xv->y = y; +#ifdef HAVE_X_WINDOWS + block_input (); + if (xv->wdesc == None) + { + Lisp_Object xvw; + XSETXWIDGET_VIEW (xvw, xv); + XSetWindowAttributes a; + a.event_mask = (ExposureMask | ButtonPressMask | ButtonReleaseMask + | PointerMotionMask | EnterWindowMask | LeaveWindowMask); + + if (clip_right - clip_left <= 0 + || clip_bottom - clip_top <= 0) + { + unblock_input (); + return; + } + + xv->wdesc = XCreateWindow (xv->dpy, FRAME_X_WINDOW (s->f), + x + clip_left, y + clip_top, + clip_right - clip_left, + 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); + XISetMask (m, XI_ButtonPress); + XISetMask (m, XI_ButtonRelease); + XISetMask (m, XI_Enter); + XISetMask (m, XI_Leave); +#ifdef XI_GesturePinchBegin + if (FRAME_DISPLAY_INFO (s->f)->xi2_version >= 4) + { + XISetMask (m, XI_GesturePinchBegin); + XISetMask (m, XI_GesturePinchUpdate); + XISetMask (m, XI_GesturePinchEnd); + } +#endif + 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, + FRAME_DISPLAY_INFO (s->f)->visual, + clip_right - clip_left, + clip_bottom - clip_top); + xv->cr_context = cairo_create (xv->cr_surface); + Fputhash (make_fixnum (xv->wdesc), xvw, x_window_to_xwv_map); + + moved = false; + } +#endif +#ifdef HAVE_PGTK + block_input (); +#endif + /* Has it moved? */ if (moved) { -#ifdef USE_GTK - gtk_fixed_move (GTK_FIXED (FRAME_GTK_WIDGET (s->f)), - xv->widgetwindow, x + clip_left, y + clip_top); +#ifdef HAVE_X_WINDOWS + XMoveResizeWindow (xv->dpy, xv->wdesc, x + clip_left, y + clip_top, + clip_right - clip_left, clip_bottom - clip_top); + XFlush (xv->dpy); + cairo_xlib_surface_set_size (xv->cr_surface, clip_right - clip_left, + clip_bottom - clip_top); +#elif defined HAVE_PGTK + gtk_widget_set_size_request (xv->widget, clip_right - clip_left, + clip_bottom - clip_top); + gtk_fixed_move (GTK_FIXED (FRAME_GTK_WIDGET (xv->frame)), + xv->widget, x + clip_left, y + clip_top); + gtk_widget_queue_allocate (xv->widget); #elif defined NS_IMPL_COCOA nsxwidget_move_view (xv, x + clip_left, y + clip_top); #endif @@ -730,15 +2299,38 @@ x_draw_xwidget_glyph_string (struct glyph_string *s) covers the entire frame. Clipping might have changed even if we haven't actually moved; try to figure out when we need to reclip for real. */ +#ifndef HAVE_PGTK if (xv->clip_right != clip_right || xv->clip_bottom != clip_bottom || xv->clip_top != clip_top || xv->clip_left != clip_left) +#endif { #ifdef USE_GTK - gtk_widget_set_size_request (xv->widgetwindow, clip_right - clip_left, - clip_bottom - clip_top); - gtk_fixed_move (GTK_FIXED (xv->widgetwindow), xv->widget, -clip_left, - -clip_top); +#ifdef HAVE_X_WINDOWS + if (!wdesc_was_none && !moved) + { + if (clip_right - clip_left <= 0 + || clip_bottom - clip_top <= 0) + { + XUnmapWindow (xv->dpy, xv->wdesc); + xv->hidden = true; + } + else + { + XResizeWindow (xv->dpy, xv->wdesc, clip_right - clip_left, + clip_bottom - clip_top); + } + XFlush (xv->dpy); + cairo_xlib_surface_set_size (xv->cr_surface, clip_right - clip_left, + clip_bottom - clip_top); + } +#else + gtk_widget_set_size_request (xv->widget, clip_right - clip_left, + clip_bottom - clip_top); + gtk_fixed_move (GTK_FIXED (FRAME_GTK_WIDGET (xv->frame)), + xv->widget, x + clip_left, y + clip_top); + gtk_widget_queue_allocate (xv->widget); +#endif #elif defined NS_IMPL_COCOA nsxwidget_resize_view (xv, clip_right - clip_left, clip_bottom - clip_top); @@ -755,37 +2347,45 @@ x_draw_xwidget_glyph_string (struct glyph_string *s) a redraw. It seems its possible to get out of sync with emacs redraws so emacs background sometimes shows up instead of the xwidgets background. It's just a visual glitch though. */ - if (!xwidget_hidden (xv)) + /* When xww->buffer is nil, that means the xwidget has been killed. */ + if (!NILP (xww->buffer)) { + if (!xwidget_hidden (xv)) + { #ifdef USE_GTK - gtk_widget_queue_draw (xv->widgetwindow); - gtk_widget_queue_draw (xv->widget); + gtk_widget_queue_draw (xww->widget_osr); #elif defined NS_IMPL_COCOA - nsxwidget_set_needsdisplay (xv); + nsxwidget_set_needsdisplay (xv); #endif + } } -} +#ifdef HAVE_X_WINDOWS + else + { + XSetWindowBackground (xv->dpy, xv->wdesc, + FRAME_BACKGROUND_PIXEL (s->f)); + } +#endif + +#if defined HAVE_XINPUT2 || defined HAVE_PGTK + record_osr_embedder (xv); + synthesize_focus_in_event (xww->widget_osr); +#endif -static bool -xwidget_is_web_view (struct xwidget *xw) -{ #ifdef USE_GTK - return xw->widget_osr != NULL && WEBKIT_IS_WEB_VIEW (xw->widget_osr); -#elif defined NS_IMPL_COCOA - return nsxwidget_is_web_view (xw); + unblock_input (); #endif } +#define CHECK_WEBKIT_WIDGET(xw) \ + if (NILP (xw->buffer) || !EQ (xw->type, Qwebkit)) \ + error ("Not a WebKit widget") + /* Macro that checks xwidget hold webkit web view first. */ #define WEBKIT_FN_INIT() \ - CHECK_XWIDGET (xwidget); \ + CHECK_LIVE_XWIDGET (xwidget); \ struct xwidget *xw = XXWIDGET (xwidget); \ - if (!xwidget_is_web_view (xw)) \ - { \ - fputs ("ERROR xw->widget_osr does not hold a webkit instance\n", \ - stdout); \ - return Qnil; \ - } + CHECK_WEBKIT_WIDGET (xw) DEFUN ("xwidget-webkit-uri", Fxwidget_webkit_uri, Sxwidget_webkit_uri, @@ -796,7 +2396,10 @@ DEFUN ("xwidget-webkit-uri", WEBKIT_FN_INIT (); #ifdef USE_GTK WebKitWebView *wkwv = WEBKIT_WEB_VIEW (xw->widget_osr); - return build_string (webkit_web_view_get_uri (wkwv)); + const gchar *uri = webkit_web_view_get_uri (wkwv); + if (!uri) + return build_string (""); + return build_string (uri); #elif defined NS_IMPL_COCOA return nsxwidget_webkit_uri (xw); #endif @@ -830,6 +2433,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 @@ -839,21 +2443,32 @@ DEFUN ("xwidget-webkit-goto-uri", DEFUN ("xwidget-webkit-goto-history", Fxwidget_webkit_goto_history, Sxwidget_webkit_goto_history, 2, 2, 0, - doc: /* Make the XWIDGET webkit load REL-POS (-1, 0, 1) page in browse history. */) + doc: /* Make the XWIDGET webkit the REL-POSth element in load history. + +If REL-POS is 0, the widget will be just reload the current element in +history. If REL-POS is more or less than 0, the widget will load the +REL-POSth element around the current spot in the load history. */) (Lisp_Object xwidget, Lisp_Object rel_pos) { WEBKIT_FN_INIT (); - /* Should be one of -1, 0, 1 */ - if (XFIXNUM (rel_pos) < -1 || XFIXNUM (rel_pos) > 1) - args_out_of_range_3 (rel_pos, make_fixnum (-1), make_fixnum (1)); + CHECK_FIXNUM (rel_pos); #ifdef USE_GTK WebKitWebView *wkwv = WEBKIT_WEB_VIEW (xw->widget_osr); - switch (XFIXNAT (rel_pos)) + WebKitBackForwardList *list; + WebKitBackForwardListItem *it; + + if (XFIXNUM (rel_pos) == 0) + webkit_web_view_reload (wkwv); + else { - case -1: webkit_web_view_go_back (wkwv); break; - case 0: webkit_web_view_reload (wkwv); break; - case 1: webkit_web_view_go_forward (wkwv); break; + list = webkit_web_view_get_back_forward_list (wkwv); + it = webkit_back_forward_list_get_nth_item (list, XFIXNUM (rel_pos)); + + if (!it) + error ("There is no item at this index"); + + webkit_web_view_go_to_back_forward_list_item (wkwv, it); } #elif defined NS_IMPL_COCOA nsxwidget_webkit_goto_history (xw, XFIXNAT (rel_pos)); @@ -946,7 +2561,7 @@ DEFUN ("xwidget-resize", Fxwidget_resize, Sxwidget_resize, 3, 3, 0, doc: /* Resize XWIDGET to NEW_WIDTH, NEW_HEIGHT. */ ) (Lisp_Object xwidget, Lisp_Object new_width, Lisp_Object new_height) { - CHECK_XWIDGET (xwidget); + CHECK_LIVE_XWIDGET (xwidget); int w = check_integer_range (new_width, 0, INT_MAX); int h = check_integer_range (new_height, 0, INT_MAX); struct xwidget *xw = XXWIDGET (xwidget); @@ -954,21 +2569,10 @@ DEFUN ("xwidget-resize", Fxwidget_resize, Sxwidget_resize, 3, 3, 0, xw->width = w; xw->height = h; - /* If there is an offscreen widget resize it first. */ -#ifdef USE_GTK - if (xw->widget_osr) - { - gtk_window_resize (GTK_WINDOW (xw->widgetwindow_osr), xw->width, - xw->height); - gtk_container_resize_children (GTK_CONTAINER (xw->widgetwindow_osr)); - gtk_widget_set_size_request (GTK_WIDGET (xw->widget_osr), xw->width, - xw->height); - } -#elif defined NS_IMPL_COCOA - nsxwidget_resize (xw); -#endif + block_input (); - for (Lisp_Object tail = Vxwidget_view_list; CONSP (tail); tail = XCDR (tail)) + for (Lisp_Object tail = internal_xwidget_view_list; CONSP (tail); + tail = XCDR (tail)) { if (XWIDGET_VIEW_P (XCAR (tail))) { @@ -976,15 +2580,33 @@ DEFUN ("xwidget-resize", Fxwidget_resize, Sxwidget_resize, 3, 3, 0, if (XXWIDGET (xv->model) == xw) { #ifdef USE_GTK - gtk_widget_set_size_request (GTK_WIDGET (xv->widget), xw->width, - xw->height); -#elif defined NS_IMPL_COCOA - nsxwidget_resize_view(xv, xw->width, xw->height); + 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) + { + gtk_window_resize (GTK_WINDOW (xw->widgetwindow_osr), xw->width, + xw->height); + gtk_widget_set_size_request (GTK_WIDGET (xw->widget_osr), xw->width, + xw->height); + + gtk_widget_queue_allocate (GTK_WIDGET (xw->widget_osr)); + } +#elif defined NS_IMPL_COCOA + nsxwidget_resize (xw); +#endif + unblock_input (); + return Qnil; } @@ -999,7 +2621,7 @@ This can be used to read the xwidget desired size, and resizes the Emacs allocated area accordingly. */) (Lisp_Object xwidget) { - CHECK_XWIDGET (xwidget); + CHECK_LIVE_XWIDGET (xwidget); #ifdef USE_GTK GtkRequisition requisition; gtk_widget_size_request (XXWIDGET (xwidget)->widget_osr, &requisition); @@ -1034,7 +2656,7 @@ DEFUN ("xwidget-info", Currently [TYPE TITLE WIDTH HEIGHT]. */) (Lisp_Object xwidget) { - CHECK_XWIDGET (xwidget); + CHECK_LIVE_XWIDGET (xwidget); struct xwidget *xw = XXWIDGET (xwidget); return CALLN (Fvector, xw->type, xw->title, make_fixed_natnum (xw->width), make_fixed_natnum (xw->height)); @@ -1083,19 +2705,39 @@ DEFUN ("delete-xwidget-view", { CHECK_XWIDGET_VIEW (xwidget_view); struct xwidget_view *xv = XXWIDGET_VIEW (xwidget_view); + + block_input (); #ifdef USE_GTK - gtk_widget_destroy (xv->widgetwindow); - /* xv->model still has signals pointing to the view. There can be - several views. Find the matching signals and delete them all. */ - g_signal_handlers_disconnect_matched (XXWIDGET (xv->model)->widgetwindow_osr, - G_SIGNAL_MATCH_DATA, - 0, 0, 0, 0, - xv->widget); + struct xwidget *xw = XXWIDGET (xv->model); + GdkWindow *w; +#ifdef HAVE_X_WINDOWS + if (xv->wdesc != None) + { + cairo_destroy (xv->cr_context); + cairo_surface_destroy (xv->cr_surface); + XDestroyWindow (xv->dpy, xv->wdesc); + Fremhash (make_fixnum (xv->wdesc), x_window_to_xwv_map); + } +#else + gtk_widget_destroy (xv->widget); +#endif + + if (xw->embedder_view == xv && !NILP (xw->buffer)) + { + w = gtk_widget_get_window (xw->widgetwindow_osr); + + XXWIDGET (xv->model)->embedder_view = NULL; + XXWIDGET (xv->model)->embedder = NULL; + + gdk_offscreen_window_set_embedder (w, NULL); + } #elif defined NS_IMPL_COCOA nsxwidget_delete_view (xv); #endif - Vxwidget_view_list = Fdelq (xwidget_view, Vxwidget_view_list); + internal_xwidget_view_list = Fdelq (xwidget_view, internal_xwidget_view_list); + Vxwidget_view_list = Fcopy_sequence (internal_xwidget_view_list); + unblock_input (); return Qnil; } @@ -1113,7 +2755,7 @@ Return nil if no association is found. */) window = Fselected_window (); CHECK_WINDOW (window); - for (Lisp_Object tail = Vxwidget_view_list; CONSP (tail); + for (Lisp_Object tail = internal_xwidget_view_list; CONSP (tail); tail = XCDR (tail)) { Lisp_Object xwidget_view = XCAR (tail); @@ -1131,7 +2773,7 @@ DEFUN ("xwidget-plist", doc: /* Return the plist of XWIDGET. */) (Lisp_Object xwidget) { - CHECK_XWIDGET (xwidget); + CHECK_LIVE_XWIDGET (xwidget); return XXWIDGET (xwidget)->plist; } @@ -1145,6 +2787,19 @@ DEFUN ("xwidget-buffer", return XXWIDGET (xwidget)->buffer; } +DEFUN ("set-xwidget-buffer", + Fset_xwidget_buffer, Sset_xwidget_buffer, + 2, 2, 0, + doc: /* Set XWIDGET's buffer to BUFFER. */) + (Lisp_Object xwidget, Lisp_Object buffer) +{ + CHECK_LIVE_XWIDGET (xwidget); + CHECK_BUFFER (buffer); + + XXWIDGET (xwidget)->buffer = buffer; + return Qnil; +} + DEFUN ("set-xwidget-plist", Fset_xwidget_plist, Sset_xwidget_plist, 2, 2, 0, @@ -1152,7 +2807,7 @@ DEFUN ("set-xwidget-plist", Returns PLIST. */) (Lisp_Object xwidget, Lisp_Object plist) { - CHECK_XWIDGET (xwidget); + CHECK_LIVE_XWIDGET (xwidget); CHECK_LIST (plist); XXWIDGET (xwidget)->plist = plist; @@ -1168,7 +2823,7 @@ exiting or killing a buffer if XWIDGET is running. This function returns FLAG. */) (Lisp_Object xwidget, Lisp_Object flag) { - CHECK_XWIDGET (xwidget); + CHECK_LIVE_XWIDGET (xwidget); XXWIDGET (xwidget)->kill_without_query = NILP (flag); return flag; } @@ -1179,16 +2834,414 @@ DEFUN ("xwidget-query-on-exit-flag", doc: /* Return the current value of the query-on-exit flag for XWIDGET. */) (Lisp_Object xwidget) { - CHECK_XWIDGET (xwidget); + CHECK_LIVE_XWIDGET (xwidget); return (XXWIDGET (xwidget)->kill_without_query ? Qnil : Qt); } +DEFUN ("xwidget-webkit-search", Fxwidget_webkit_search, Sxwidget_webkit_search, + 2, 5, 0, + doc: /* Begin an incremental search operation in an xwidget. +QUERY should be a string containing the text to search for. XWIDGET +should be a WebKit xwidget where the search will take place. When the +search operation is complete, callers should also call +`xwidget-webkit-finish-search' to complete the search operation. + +CASE-INSENSITIVE, when non-nil, will cause the search to ignore the +case of characters inside QUERY. BACKWARDS, when non-nil, will cause +the search to proceed towards the beginning of the widget's contents. +WRAP-AROUND, when nil, will cause the search to stop upon hitting the +end of the widget's contents. + +It is OK to call this function even when a search is already in +progress. In that case, the previous search query will be replaced +with QUERY. */) + (Lisp_Object query, Lisp_Object xwidget, Lisp_Object case_insensitive, + Lisp_Object backwards, Lisp_Object wrap_around) +{ +#ifdef USE_GTK + WebKitWebView *webview; + WebKitFindController *controller; + WebKitFindOptions opt; + struct xwidget *xw; + gchar *g_query; +#endif + + CHECK_STRING (query); + CHECK_LIVE_XWIDGET (xwidget); + +#ifdef USE_GTK + xw = XXWIDGET (xwidget); + CHECK_WEBKIT_WIDGET (xw); + + webview = WEBKIT_WEB_VIEW (xw->widget_osr); + query = ENCODE_UTF_8 (query); + opt = WEBKIT_FIND_OPTIONS_NONE; + g_query = xstrdup (SSDATA (query)); + + if (!NILP (case_insensitive)) + opt |= WEBKIT_FIND_OPTIONS_CASE_INSENSITIVE; + if (!NILP (backwards)) + opt |= WEBKIT_FIND_OPTIONS_BACKWARDS; + if (!NILP (wrap_around)) + opt |= WEBKIT_FIND_OPTIONS_WRAP_AROUND; + + if (xw->find_text) + xfree (xw->find_text); + xw->find_text = g_query; + + block_input (); + controller = webkit_web_view_get_find_controller (webview); + webkit_find_controller_search (controller, g_query, opt, G_MAXUINT); + unblock_input (); +#endif + + return Qnil; +} + +DEFUN ("xwidget-webkit-next-result", Fxwidget_webkit_next_result, + Sxwidget_webkit_next_result, 1, 1, 0, + doc: /* Show the next result matching the current search query. + +XWIDGET should be an xwidget that currently has a search query. +Before calling this function, you should start a search operation +using `xwidget-webkit-search'. */) + (Lisp_Object xwidget) +{ + struct xwidget *xw; +#ifdef USE_GTK + WebKitWebView *webview; + WebKitFindController *controller; +#endif + + CHECK_LIVE_XWIDGET (xwidget); + xw = XXWIDGET (xwidget); + CHECK_WEBKIT_WIDGET (xw); + + if (!xw->find_text) + error ("Widget has no ongoing search operation"); + +#ifdef USE_GTK + block_input (); + webview = WEBKIT_WEB_VIEW (xw->widget_osr); + controller = webkit_web_view_get_find_controller (webview); + webkit_find_controller_search_next (controller); + unblock_input (); +#endif + + return Qnil; +} + +DEFUN ("xwidget-webkit-previous-result", Fxwidget_webkit_previous_result, + Sxwidget_webkit_previous_result, 1, 1, 0, + doc: /* Show the previous result matching the current search query. + +XWIDGET should be an xwidget that currently has a search query. +Before calling this function, you should start a search operation +using `xwidget-webkit-search'. */) + (Lisp_Object xwidget) +{ + struct xwidget *xw; +#ifdef USE_GTK + WebKitWebView *webview; + WebKitFindController *controller; +#endif + + CHECK_LIVE_XWIDGET (xwidget); + xw = XXWIDGET (xwidget); + CHECK_WEBKIT_WIDGET (xw); + + if (!xw->find_text) + error ("Widget has no ongoing search operation"); + +#ifdef USE_GTK + block_input (); + webview = WEBKIT_WEB_VIEW (xw->widget_osr); + controller = webkit_web_view_get_find_controller (webview); + webkit_find_controller_search_previous (controller); + unblock_input (); +#endif + + return Qnil; +} + +DEFUN ("xwidget-webkit-finish-search", Fxwidget_webkit_finish_search, + Sxwidget_webkit_finish_search, 1, 1, 0, + doc: /* Finish XWIDGET's search operation. + +XWIDGET should be an xwidget that currently has a search query. +Before calling this function, you should start a search operation +using `xwidget-webkit-search'. */) + (Lisp_Object xwidget) +{ + struct xwidget *xw; +#ifdef USE_GTK + WebKitWebView *webview; + WebKitFindController *controller; +#endif + + CHECK_LIVE_XWIDGET (xwidget); + xw = XXWIDGET (xwidget); + CHECK_WEBKIT_WIDGET (xw); + + if (!xw->find_text) + error ("Widget has no ongoing search operation"); + +#ifdef USE_GTK + block_input (); + webview = WEBKIT_WEB_VIEW (xw->widget_osr); + controller = webkit_web_view_get_find_controller (webview); + webkit_find_controller_search_finish (controller); + + if (xw->find_text) + { + xfree (xw->find_text); + xw->find_text = NULL; + } + unblock_input (); +#endif + + 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, + doc: /* Make XWIDGET's WebKit widget render TEXT. +XWIDGET should be a WebKit xwidget, that will receive TEXT. TEXT +should be a string that will be displayed by XWIDGET as HTML markup. +BASE-URI should be a string containing a URI that is used to locate +resources with relative URLs, and if not specified, defaults +to "about:blank". */) + (Lisp_Object xwidget, Lisp_Object text, Lisp_Object base_uri) +{ + struct xwidget *xw; + WebKitWebView *webview; + char *data, *uri; + + CHECK_LIVE_XWIDGET (xwidget); + CHECK_STRING (text); + if (NILP (base_uri)) + base_uri = build_string ("about:blank"); + else + CHECK_STRING (base_uri); + + base_uri = ENCODE_UTF_8 (base_uri); + text = ENCODE_UTF_8 (text); + xw = XXWIDGET (xwidget); + CHECK_WEBKIT_WIDGET (xw); + + data = SSDATA (text); + uri = SSDATA (base_uri); + webview = WEBKIT_WEB_VIEW (xw->widget_osr); + + block_input (); + webkit_web_view_load_html (webview, data, uri); + unblock_input (); + + 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) { defsubr (&Smake_xwidget); defsubr (&Sxwidgetp); + defsubr (&Sxwidget_live_p); DEFSYM (Qxwidgetp, "xwidgetp"); + DEFSYM (Qxwidget_live_p, "xwidget-live-p"); defsubr (&Sxwidget_view_p); DEFSYM (Qxwidget_view_p, "xwidget-view-p"); defsubr (&Sxwidget_info); @@ -1215,6 +3268,20 @@ syms_of_xwidget (void) defsubr (&Sxwidget_plist); defsubr (&Sxwidget_buffer); defsubr (&Sset_xwidget_plist); + defsubr (&Sxwidget_perform_lispy_event); + defsubr (&Sxwidget_webkit_search); + defsubr (&Sxwidget_webkit_finish_search); + 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"); @@ -1228,14 +3295,29 @@ 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); + + id_to_xwidget_map = CALLN (Fmake_hash_table, QCtest, Qeq, + QCweakness, Qvalue); + staticpro (&id_to_xwidget_map); + + internal_xwidget_list = Qnil; + staticpro (&internal_xwidget_list); + internal_xwidget_view_list = Qnil; + staticpro (&internal_xwidget_view_list); + +#ifdef HAVE_X_WINDOWS + x_window_to_xwv_map = CALLN (Fmake_hash_table, QCtest, Qeq); + + staticpro (&x_window_to_xwv_map); +#endif } @@ -1276,7 +3358,7 @@ void xwidget_view_delete_all_in_window (struct window *w) { struct xwidget_view *xv = NULL; - for (Lisp_Object tail = Vxwidget_view_list; CONSP (tail); + for (Lisp_Object tail = internal_xwidget_view_list; CONSP (tail); tail = XCDR (tail)) { if (XWIDGET_VIEW_P (XCAR (tail))) @@ -1321,7 +3403,7 @@ lookup_xwidget (Lisp_Object spec) static void xwidget_start_redisplay (void) { - for (Lisp_Object tail = Vxwidget_view_list; CONSP (tail); + for (Lisp_Object tail = internal_xwidget_view_list; CONSP (tail); tail = XCDR (tail)) { if (XWIDGET_VIEW_P (XCAR (tail))) @@ -1374,25 +3456,22 @@ xwidget_end_redisplay (struct window *w, struct glyph_matrix *matrix) /* The only call to xwidget_end_redisplay is in dispnew. xwidget_end_redisplay (w->current_matrix); */ struct xwidget_view *xv - = xwidget_view_lookup (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 + = xwidget_view_lookup (xwidget_from_id (glyph->u.xwidget), w); + + /* 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 } } } - for (Lisp_Object tail = Vxwidget_view_list; CONSP (tail); + for (Lisp_Object tail = internal_xwidget_view_list; CONSP (tail); tail = XCDR (tail)) { if (XWIDGET_VIEW_P (XCAR (tail))) @@ -1424,6 +3503,80 @@ xwidget_end_redisplay (struct window *w, struct glyph_matrix *matrix) } } +#ifdef HAVE_X_WINDOWS +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); + } +} +#endif + +#ifndef NS_IMPL_COCOA +void +kill_frame_xwidget_views (struct frame *f) +{ + Lisp_Object rem = Qnil; + + for (Lisp_Object tail = internal_xwidget_view_list; CONSP (tail); + tail = XCDR (tail)) + { + if (XWIDGET_VIEW_P (XCAR (tail)) + && XXWIDGET_VIEW (XCAR (tail))->frame == f) + rem = Fcons (XCAR (tail), rem); + } + + for (; CONSP (rem); rem = XCDR (rem)) + Fdelete_xwidget_view (XCAR (rem)); +} +#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) @@ -1432,28 +3585,11 @@ kill_buffer_xwidgets (Lisp_Object buffer) for (tail = Fget_buffer_xwidgets (buffer); CONSP (tail); tail = XCDR (tail)) { xwidget = XCAR (tail); - Vxwidget_list = Fdelq (xwidget, Vxwidget_list); - /* TODO free the GTK things in xw. */ { - CHECK_XWIDGET (xwidget); + CHECK_LIVE_XWIDGET (xwidget); struct xwidget *xw = XXWIDGET (xwidget); -#ifdef USE_GTK - if (xw->widget_osr && xw->widgetwindow_osr) - { - gtk_widget_destroy (xw->widget_osr); - gtk_widget_destroy (xw->widgetwindow_osr); - } - 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); - } -#elif defined NS_IMPL_COCOA - nsxwidget_kill (xw); -#endif + + kill_xwidget (xw); } } } diff --git a/src/xwidget.h b/src/xwidget.h index 591f23489db..0c6ed1a3813 100644 --- a/src/xwidget.h +++ b/src/xwidget.h @@ -32,11 +32,21 @@ struct window; #if defined (USE_GTK) #include <gtk/gtk.h> +#ifndef HAVE_PGTK +#include <X11/Xlib.h> +#include "xterm.h" +#else +#include "pgtkterm.h" +#endif #elif defined (NS_IMPL_COCOA) && defined (__OBJC__) #import <AppKit/NSView.h> #import "nsxwidget.h" #endif +#ifdef HAVE_XINPUT2 +#include <X11/extensions/XInput2.h> +#endif + struct xwidget { union vectorlike_header header; @@ -59,11 +69,16 @@ struct xwidget int height; int width; + uint32_t xwidget_id; + char *find_text; #if defined (USE_GTK) /* For offscreen widgets, unused if not osr. */ GtkWidget *widget_osr; GtkWidget *widgetwindow_osr; + struct frame *embedder; + struct xwidget_view *embedder_view; + guint hit_result; #elif defined (NS_IMPL_COCOA) # ifdef __OBJC__ /* For offscreen widgets, unused if not osr. */ @@ -97,10 +112,22 @@ struct xwidget_view /* The "live" instance isn't drawn. */ bool hidden; + enum glyph_row_area area; + #if defined (USE_GTK) +#ifndef HAVE_PGTK + Display *dpy; + Window wdesc; +#else + struct pgtk_display_info *dpyinfo; GtkWidget *widget; - GtkWidget *widgetwindow; - GtkWidget *emacswindow; +#endif + Emacs_Cursor cursor; + struct frame *frame; + + cairo_surface_t *cr_surface; + cairo_t *cr_context; + int just_resized; #elif defined (NS_IMPL_COCOA) # ifdef __OBJC__ XvWindow *xvWindow; @@ -127,9 +154,16 @@ struct xwidget_view #define XXWIDGET(a) (eassert (XWIDGETP (a)), \ XUNTAG (a, Lisp_Vectorlike, struct xwidget)) +#define XWIDGET_LIVE_P(w) (!NILP ((w)->buffer)) + #define CHECK_XWIDGET(x) \ CHECK_TYPE (XWIDGETP (x), Qxwidgetp, x) +#define CHECK_LIVE_XWIDGET(x) \ + CHECK_TYPE ((XWIDGETP (x) \ + && XWIDGET_LIVE_P (XXWIDGET (x))), \ + Qxwidget_live_p, x) + /* Test for xwidget_view pseudovector. */ #define XWIDGET_VIEW_P(x) PSEUDOVECTORP (x, PVEC_XWIDGET_VIEW) #define XXWIDGET_VIEW(a) (eassert (XWIDGET_VIEW_P (a)), \ @@ -162,6 +196,32 @@ void store_xwidget_download_callback_event (struct xwidget *xw, void store_xwidget_js_callback_event (struct xwidget *xw, Lisp_Object proc, Lisp_Object argument); + +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); +#endif +#ifndef NS_IMPL_COCOA +extern void kill_frame_xwidget_views (struct frame *f); +#endif +#ifdef HAVE_X_WINDOWS +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, double, double, uint, Time); +extern void xwidget_scroll (struct xwidget_view *, double, double, + double, double, uint, Time, bool); +#ifdef HAVE_USABLE_XI_GESTURE_PINCH_EVENT +extern void xwidget_pinch (struct xwidget_view *, XIGesturePinchEvent *); +#endif +#endif +#endif #else INLINE_HEADER_BEGIN INLINE void syms_of_xwidget (void) {} diff --git a/test/Makefile.in b/test/Makefile.in index bb32ef672db..378a8fde7ed 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, @@ -77,9 +77,14 @@ EMACSOPT = --no-init-file --no-site-file --no-site-lisp -L "$(SEPCHAR)$(srcdir)" # Prevent any settings in the user environment causing problems. unexport EMACSDATA EMACSDOC EMACSPATH GREP_OPTIONS XDG_CONFIG_HOME -## To run tests under a debugger, set this to eg: "gdb --args". +# To run tests under a debugger, set this to eg: "gdb --args". GDB = +# Whether a timeout shall be given, writing possibly a core dump. +ifneq (${EMACS_TEST_TIMEOUT},) +TEST_TIMEOUT = timeout -s ABRT ${EMACS_TEST_TIMEOUT} +endif + # Set this to 'yes' to run the tests in an interactive instance. TEST_INTERACTIVE ?= no @@ -117,7 +122,7 @@ endif # and prevent locals to influence the text of the errors we expect to receive. emacs = LANG=C EMACSLOADPATH= \ EMACS_TEST_DIRECTORY=$(abspath $(srcdir)) \ - $(GDB) "$(EMACS)" $(MODULES_EMACSOPT) $(EMACSOPT) + $(GDB) $(TEST_TIMEOUT) "$(EMACS)" $(MODULES_EMACSOPT) $(EMACSOPT) # Set HOME to a nonexistent directory to prevent tests from accessing # it accidentally (e.g., popping up a gnupg dialog if ~/.authinfo.gpg @@ -167,7 +172,7 @@ lisp/net/tramp-tests.log \ : WRITE_LOG = 2>&1 | tee $@ endif ifdef EMACS_EMBA_CI -lisp/filenotify-tests.log lisp/net/tramp-tests.log src/emacs-module-tests.el \ +lisp/filenotify-tests.log lisp/net/tramp-tests.log src/emacs-module-tests.log \ : WRITE_LOG = 2>&1 | tee $@ endif @@ -178,8 +183,8 @@ testloadfile = $* endif %.log: %.elc - $(AM_V_at)${MKDIR_P} $(dir $@) - $(AM_V_GEN)HOME=$(TEST_HOME) $(emacs) \ + $(AM_V_GEN)${MKDIR_P} $(dir $@) + $(AM_V_at)HOME=$(TEST_HOME) $(emacs) \ -l ert ${ert_opts} -l $(testloadfile) \ $(TEST_RUN_ERT) @@ -247,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, \ @@ -283,8 +291,8 @@ FREE_SOURCE_1 = $(srcdir)/../lib/free.c # as source because those are not compiled with -fPIC. Therefore we # use only source files. $(test_module): $(test_module:${SO}=.c) ../src/emacs-module.h - $(AM_V_at)${MKDIR_P} $(dir $@) - $(AM_V_CCLD)$(CC) -shared $(CPPFLAGS) $(MODULE_CFLAGS) $(LDFLAGS) \ + $(AM_V_CCLD)${MKDIR_P} $(dir $@) + $(AM_V_at)$(CC) -shared $(CPPFLAGS) $(MODULE_CFLAGS) $(LDFLAGS) \ -o $@ $< $(LIBGMP) \ $(and $(GMP_H),$(srcdir)/../lib/mini-gmp-gnulib.c) \ $(FREE_SOURCE_$(REPLACE_FREE)) \ @@ -345,6 +353,7 @@ mostlyclean: clean: find . '(' -name '*.log' -o -name '*.log~' ')' $(FIND_DELETE) + find . '(' -name '*.xml' -a ! -path '*resources*' ')' $(FIND_DELETE) rm -f ${srcdir}/lisp/gnus/mml-sec-resources/random_seed rm -f $(test_module_dir)/*.o $(test_module_dir)/*.so \ $(test_module_dir)/*.dll @@ -362,3 +371,14 @@ maintainer-clean: distclean bootstrap-clean check-declare: $(emacs) --batch -l check-declare \ --eval '(check-declare-directory "$(srcdir)")' + +.PHONY: subdirs subdir-targets generate-test-jobs + +subdirs: + @: $(info $(SUBDIRS)) + +subdir-targets: + @: $(info $(SUBDIR_TARGETS)) + +generate-test-jobs: + @$(MAKE) -C infra generate-test-jobs SUBDIRS="$(SUBDIRS)" diff --git a/test/README b/test/README index a0961249cfa..2bd84b5f9b3 100644 --- a/test/README +++ b/test/README @@ -114,6 +114,9 @@ mode--only the names of the failed tests are listed. If the $EMACS_TEST_VERBOSE environment variable is set, the failure summaries will also include the data from the failing test. +If the $EMACS_TEST_JUNIT_REPORT environment variable is set to a file +name, a JUnit test report is generated under this name. + Some of the tests require a remote temporary directory (autorevert-tests.el, filenotify-tests.el, shadowfile-tests.el and tramp-tests.el). Per default, a mock-up connection method is used @@ -140,6 +143,11 @@ these test environments. $EMACS_HYDRA_CI indicates the hydra environment, and $EMACS_EMBA_CI indicates the emba environment, respectively. +If tests on these premises take too long, and it is needed to create a +core dump for further analysis, the environment variable +$EMACS_TEST_TIMEOUT could set a limit (in seconds) when this shall +happen. + (Also, see etc/compilation.txt for compilation mode font lock tests and etc/grep.txt for grep mode font lock tests.) diff --git a/test/data/image/black.gif b/test/data/image/black.gif Binary files differnew file mode 100644 index 00000000000..6ab623e367e --- /dev/null +++ b/test/data/image/black.gif diff --git a/test/data/image/black.webp b/test/data/image/black.webp Binary files differnew file mode 100644 index 00000000000..5dbe716415b --- /dev/null +++ b/test/data/image/black.webp diff --git a/test/infra/Dockerfile.emba b/test/infra/Dockerfile.emba index 71b4e76865f..aef68c6e81e 100644 --- a/test/infra/Dockerfile.emba +++ b/test/infra/Dockerfile.emba @@ -29,7 +29,7 @@ FROM debian:stretch as emacs-base RUN apt-get update && \ apt-get install -y --no-install-recommends -o=Dpkg::Use-Pty=0 \ libc-dev gcc g++ make autoconf automake libncurses-dev gnutls-dev \ - libdbus-1-dev libacl1-dev acl git texinfo \ + libdbus-1-dev libacl1-dev acl git texinfo gdb \ && rm -rf /var/lib/apt/lists/* FROM emacs-base as emacs-inotify @@ -72,14 +72,14 @@ RUN ./autogen.sh autoconf RUN ./configure --with-ns RUN make bootstrap -FROM emacs-base as emacs-native-comp-speed0 +FROM emacs-base as emacs-native-comp RUN apt-get update && \ apt-get install -y --no-install-recommends -o=Dpkg::Use-Pty=0 \ libgccjit-6-dev \ && rm -rf /var/lib/apt/lists/* -ARG make_bootstrap_params="" +FROM emacs-native-comp as emacs-native-comp-speed0 COPY . /checkout WORKDIR /checkout @@ -87,3 +87,19 @@ RUN ./autogen.sh autoconf RUN ./configure --with-native-compilation RUN make bootstrap -j2 \ NATIVE_FULL_AOT=1 BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 0)"' + +FROM emacs-native-comp as emacs-native-comp-speed1 + +COPY . /checkout +WORKDIR /checkout +RUN ./autogen.sh autoconf +RUN ./configure --with-native-compilation +RUN make bootstrap -j2 BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 1)"' + +FROM emacs-native-comp as emacs-native-comp-speed2 + +COPY . /checkout +WORKDIR /checkout +RUN ./autogen.sh autoconf +RUN ./configure --with-native-compilation +RUN make bootstrap -j2 diff --git a/test/infra/Makefile.in b/test/infra/Makefile.in new file mode 100644 index 00000000000..368be7392b2 --- /dev/null +++ b/test/infra/Makefile.in @@ -0,0 +1,100 @@ +### @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 <https://www.gnu.org/licenses/>. + +### 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: "-k -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: $(FILE) $(SUBDIR_TARGETS) + +$(FILE): + $(AM_V_GEN) + @echo "# Generated by \"make generate-test-jobs\", don't edit." >$(FILE) diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index b233c0fbc54..dd3f517e74a 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 <https://www.gnu.org/licenses/>. -# 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,8 +44,10 @@ workflow: variables: GIT_STRATEGY: fetch EMACS_EMBA_CI: 1 + EMACS_TEST_JUNIT_REPORT: junit-test-report.xml + 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 @@ -55,6 +57,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 @@ -67,31 +71,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/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} @@ -107,25 +86,31 @@ default: # TODO: with make -j4 several of the tests were failing, for # example shadowfile-tests, but passed without it. - 'export PWD=$(pwd)' - - 'docker run -i -e EMACS_EMBA_CI=${EMACS_EMBA_CI} --volumes-from $(docker ps -q -f "label=com.gitlab.gitlab-runner.job.id=${CI_JOB_ID}"):ro --name ${test_name} ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} /bin/bash -c "git fetch ${PWD} HEAD && echo checking out these updated files && git diff --name-only FETCH_HEAD && ( git diff --name-only FETCH_HEAD | xargs git checkout -f FETCH_HEAD ) && make -j4 && make ${make_params}"' + - 'docker run -i -e EMACS_EMBA_CI=${EMACS_EMBA_CI} -e EMACS_TEST_JUNIT_REPORT=${EMACS_TEST_JUNIT_REPORT} -e EMACS_TEST_TIMEOUT=${EMACS_TEST_TIMEOUT} -e EMACS_TEST_VERBOSE=${EMACS_TEST_VERBOSE} --volumes-from $(docker ps -q -f "label=com.gitlab.gitlab-runner.job.id=${CI_JOB_ID}"):ro --name ${test_name} ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} /bin/bash -c "git fetch ${PWD} HEAD && echo checking out these updated files && git diff --name-only FETCH_HEAD && ( git diff --name-only FETCH_HEAD | xargs git checkout -f FETCH_HEAD ) && make -j4 && make ${make_params}"' after_script: # - docker ps -a # - printenv # - test -n "$(docker ps -aq -f name=${test_name})" && ( docker export ${test_name} | tar -tvf - ) + # Prepare test artifacts. - test -n "$(docker ps -aq -f name=${test_name})" && docker cp ${test_name}:checkout/test ${test_name} - test -n "$(docker ps -aq -f name=${test_name})" && docker rm ${test_name} + - find ${test_name} ! \( -name "*.log" -o -name ${EMACS_TEST_JUNIT_REPORT} \) -type f -delete + # BusyBox find does not know -empty. + - find ${test_name} -type d -depth -exec rmdir {} + 2>/dev/null .build-template: + needs: [] rules: - if: '$CI_PIPELINE_SOURCE == "web"' when: always - changes: - - "**/Makefile.in" - - .gitlab-ci.yml + - "**.in" + - GNUmakefile - aclocal.m4 - autogen.sh - configure.ac - lib/*.{h,c} + - lib/malloc/*.{h,c} - lisp/emacs-lisp/*.el - src/*.{h,c} - test/infra/* @@ -134,7 +119,7 @@ default: - src/gfilenotify.c - src/kqueue.c # MS Windows - - "**/w32*" + - "**w32*" # GNUstep - lisp/term/ns-win.el - src/ns*.{h,m} @@ -145,32 +130,26 @@ default: - docker push ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} .test-template: - # Do not block later stages. - allow_failure: true - # 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 + when: always paths: - - "${test_name}/**/*.log" + - ${test_name}/ + reports: + junit: ${test_name}/${EMACS_TEST_JUNIT_REPORT} .gnustep-template: rules: - if: '$CI_PIPELINE_SOURCE == "web"' - if: '$CI_PIPELINE_SOURCE == "schedule"' changes: - - "**/Makefile.in" - - .gitlab-ci.yml - - configure.ac + - "**.in" - src/ns*.{h,m} - src/macfont.{h,m} - lisp/term/ns-win.el - - nextstep/**/* + - nextstep/** - test/infra/* .filenotify-gio-template: @@ -178,8 +157,7 @@ default: - if: '$CI_PIPELINE_SOURCE == "web"' - if: '$CI_PIPELINE_SOURCE == "schedule"' changes: - - "**/Makefile.in" - - .gitlab-ci.yml + - "**.in" - lisp/autorevert.el - lisp/filenotify.el - lisp/net/tramp-sh.el @@ -193,8 +171,7 @@ default: - if: '$CI_PIPELINE_SOURCE == "web"' - if: '$CI_PIPELINE_SOURCE == "schedule"' changes: - - "**/Makefile.in" - - .gitlab-ci.yml + - "**.in" - lisp/emacs-lisp/comp.el - lisp/emacs-lisp/comp-cstr.el - src/comp.{h,m} @@ -205,13 +182,11 @@ default: stages: - build-images -# - fast - normal - platform-images - platforms - native-comp-images - native-comp - - slow build-image-inotify: stage: build-images @@ -219,26 +194,22 @@ build-image-inotify: variables: target: emacs-inotify -# test-fast-inotify: -# stage: fast -# extends: [.job-template, .test-template] -# variables: -# target: emacs-inotify -# make_params: "-C test check" - -test-lisp-inotify: - stage: normal - extends: [.job-template, .test-template] - variables: - target: emacs-inotify - make_params: "-C test check-lisp" +include: '/test/infra/test-jobs.yml' -test-lisp-net-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-net" + make_params: check-expensive build-image-filenotify-gio: stage: platform-images @@ -246,80 +217,62 @@ build-image-filenotify-gio: variables: target: emacs-filenotify-gio -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] + needs: + - job: build-image-filenotify-gio + optional: true variables: target: emacs-filenotify-gio - make_params: "-k -C test autorevert-tests.log filenotify-tests.log" + # This is needed in order to get a JUnit test report. + make_params: '-k -C test check-expensive LOGFILES="lisp/autorevert-tests.log lisp/filenotify-tests.log"' + +build-image-gnustep: + stage: platform-images + extends: [.job-template, .build-template, .gnustep-template] + variables: + target: emacs-gnustep 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 -build-native-bootstrap-speed0: +build-native-comp-speed0: stage: native-comp-images extends: [.job-template, .build-template, .native-comp-template] variables: target: emacs-native-comp-speed0 -# build-native-bootstrap-speed0: -# # Test a full native bootstrap -# # Run for now only speed 0 to limit memory usage and compilation time. -# stage: native-comp-images -# # Uncomment the following to run it only when scheduled. -# # only: -# # - schedules -# script: -# - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev -# - ./autogen.sh autoconf -# - ./configure --with-native-compilation -# - make bootstrap NATIVE_FULL_AOT=1 BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 0)"' -j2 -# timeout: 8 hours - -# build-native-bootstrap-speed1: -# stage: native-comp-images -# script: -# - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev -# - ./autogen.sh autoconf -# - ./configure --with-native-compilation -# - make bootstrap BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 1)"' -# timeout: 8 hours +build-native-comp-speed1: + stage: native-comp-images + extends: [.job-template, .build-template, .native-comp-template] + variables: + target: emacs-native-comp-speed1 -# build-native-bootstrap-speed2: -# stage: native-comp-images -# script: -# - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev -# - ./autogen.sh autoconf -# - ./configure --with-native-compilation -# - make bootstrap -# timeout: 8 hours +build-native-comp-speed2: + stage: native-comp-images + extends: [.job-template, .build-template, .native-comp-template] + variables: + target: emacs-native-comp-speed2 -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"' +test-native-comp-speed0: + stage: native-comp + extends: [.job-template, .test-template, .native-comp-template] + needs: + - job: build-native-comp-speed0 + optional: true variables: - target: emacs-inotify - make_params: check-expensive + target: emacs-native-comp-speed0 + make_params: "-k -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..51707c181b1 --- /dev/null +++ b/test/infra/test-jobs.yml @@ -0,0 +1,545 @@ +# Generated by "make generate-test-jobs", don't edit. + +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: "-k -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: "-k -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: "-k -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: "-k -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: "-k -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: "-k -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: "-k -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: "-k -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: "-k -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: "-k -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: "-k -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: "-k -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: "-k -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: "-k -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: "-k -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: "-k -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: "-k -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: "-k -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: "-k -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: "-k -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: "-k -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: "-k -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: "-k -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: "-k -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: "-k -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: "-k -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: "-k -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: "-k -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: "-k -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: "-k -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: "-k -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: "-k -C test check-src" diff --git a/test/lisp/abbrev-tests.el b/test/lisp/abbrev-tests.el index 2dcfb1c309e..863806af7b3 100644 --- a/test/lisp/abbrev-tests.el +++ b/test/lisp/abbrev-tests.el @@ -28,6 +28,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'abbrev) (require 'seq) @@ -236,44 +237,41 @@ (ert-deftest read-write-abbrev-file-test () "Test reading and writing abbrevs from file." - (let ((temp-test-file (make-temp-file "ert-abbrev-test")) - (ert-test-abbrevs (setup-test-abbrev-table))) - (write-abbrev-file temp-test-file) - (clear-abbrev-table ert-test-abbrevs) - (should (abbrev-table-empty-p ert-test-abbrevs)) - (read-abbrev-file temp-test-file) - (should (equal "abbrev-ert-test" (abbrev-expansion "a-e-t" ert-test-abbrevs))) - (delete-file temp-test-file))) + (ert-with-temp-file temp-test-file + (let ((ert-test-abbrevs (setup-test-abbrev-table))) + (write-abbrev-file temp-test-file) + (clear-abbrev-table ert-test-abbrevs) + (should (abbrev-table-empty-p ert-test-abbrevs)) + (read-abbrev-file temp-test-file) + (should (equal "abbrev-ert-test" (abbrev-expansion "a-e-t" ert-test-abbrevs)))))) (ert-deftest read-write-abbrev-file-test-with-props () "Test reading and writing abbrevs from file." - (let ((temp-test-file (make-temp-file "ert-abbrev-test")) - (ert-test-abbrevs (setup-test-abbrev-table-with-props))) - (write-abbrev-file temp-test-file) - (clear-abbrev-table ert-test-abbrevs) - (should (abbrev-table-empty-p ert-test-abbrevs)) - (read-abbrev-file temp-test-file) - (should (equal "fooBar" (abbrev-expansion "fb" ert-test-abbrevs))) - (delete-file temp-test-file))) + (ert-with-temp-file temp-test-file + (let ((ert-test-abbrevs (setup-test-abbrev-table-with-props))) + (write-abbrev-file temp-test-file) + (clear-abbrev-table ert-test-abbrevs) + (should (abbrev-table-empty-p ert-test-abbrevs)) + (read-abbrev-file temp-test-file) + (should (equal "fooBar" (abbrev-expansion "fb" ert-test-abbrevs)))))) (ert-deftest abbrev-edit-save-to-file-test () "Test saving abbrev definitions in buffer to file." (defvar ert-save-test-table nil) - (let ((temp-test-file (make-temp-file "ert-abbrev-test")) - (ert-test-abbrevs (setup-test-abbrev-table))) - (with-temp-buffer - (goto-char (point-min)) - (insert "(ert-save-test-table)\n") - (insert "\n" "\"s-a-t\"\t" "0\t" "\"save-abbrevs-test\"\n") - (should (equal "abbrev-ert-test" - (abbrev-expansion "a-e-t" ert-test-abbrevs))) - ;; clears abbrev tables - (abbrev-edit-save-to-file temp-test-file) - (should-not (abbrev-expansion "a-e-t" ert-test-abbrevs)) - (read-abbrev-file temp-test-file) - (should (equal "save-abbrevs-test" - (abbrev-expansion "s-a-t" ert-save-test-table))) - (delete-file temp-test-file)))) + (ert-with-temp-file temp-test-file + (let ((ert-test-abbrevs (setup-test-abbrev-table))) + (with-temp-buffer + (goto-char (point-min)) + (insert "(ert-save-test-table)\n") + (insert "\n" "\"s-a-t\"\t" "0\t" "\"save-abbrevs-test\"\n") + (should (equal "abbrev-ert-test" + (abbrev-expansion "a-e-t" ert-test-abbrevs))) + ;; clears abbrev tables + (abbrev-edit-save-to-file temp-test-file) + (should-not (abbrev-expansion "a-e-t" ert-test-abbrevs)) + (read-abbrev-file temp-test-file) + (should (equal "save-abbrevs-test" + (abbrev-expansion "s-a-t" ert-save-test-table))))))) (ert-deftest inverse-add-abbrev-skips-trailing-nonword () "Test that adding an inverse abbrev skips trailing nonword characters." diff --git a/test/lisp/ansi-color-tests.el b/test/lisp/ansi-color-tests.el index 953fdff8933..14a14ca4f06 100644 --- a/test/lisp/ansi-color-tests.el +++ b/test/lisp/ansi-color-tests.el @@ -24,10 +24,12 @@ ;;; Code: (require 'ansi-color) +(eval-when-compile (require 'cl-lib)) (defvar ansi-color-tests--strings (let ((bright-yellow (face-foreground 'ansi-color-bright-yellow nil 'default)) - (yellow (face-foreground 'ansi-color-yellow nil 'default))) + (yellow (face-foreground 'ansi-color-yellow nil 'default)) + (custom-color "#87FFFF")) `(("Hello World" "Hello World") ("\e[33mHello World\e[0m" "Hello World" (:foreground ,yellow)) @@ -51,7 +53,25 @@ (ansi-color-bold (:foreground ,bright-yellow))) ("\e[1m\e[3m\e[5mbold italics blink\e[0m" "bold italics blink" (ansi-color-bold ansi-color-italic ansi-color-slow-blink)) - ("\e[10munrecognized\e[0m" "unrecognized")))) + ("\e[10munrecognized\e[0m" "unrecognized") + ("\e[38;5;3;1mHello World\e[0m" "Hello World" + (ansi-color-bold (:foreground ,yellow)) + (ansi-color-bold (:foreground ,bright-yellow))) + ("\e[48;5;123;1mHello World\e[0m" "Hello World" + (ansi-color-bold (:background ,custom-color))) + ("\e[48;2;135;255;255;1mHello World\e[0m" "Hello World" + (ansi-color-bold (:background ,custom-color)))))) + +(defun ansi-color-tests-equal-props (o1 o2) + "Return t if two Lisp objects have similar structure and contents. +While `equal-including-properties' compares text properties of +strings with `eq', this function compares them with `equal'." + (or (equal-including-properties o1 o2) + (and (stringp o1) + (equal o1 o2) + (cl-loop for i below (length o1) + always (equal (text-properties-at i o1) + (text-properties-at i o2)))))) (ert-deftest ansi-color-apply-on-region-test () (pcase-dolist (`(,input ,text ,face) ansi-color-tests--strings) @@ -83,6 +103,76 @@ (ansi-color-apply-on-region (point-min) (point-max) t) (should (equal (buffer-string) (car pair)))))) +(ert-deftest ansi-color-incomplete-sequences-test () + (let* ((strs (list "\e[" "2;31m Hello World " + "\e" "[108;5;12" "3m" "Greetings" + "\e[0m\e[35;6m" "Hello")) + (complete-str (apply #'concat strs)) + (filtered-str) + (propertized-str) + (ansi-color-apply-face-function + #'ansi-color-apply-text-property-face) + (ansi-filt (lambda (str) (ansi-color-filter-apply + (copy-sequence str)))) + (ansi-app (lambda (str) (ansi-color-apply + (copy-sequence str))))) + + (with-temp-buffer + (setq filtered-str + (replace-regexp-in-string "\e\\[.*?m" "" complete-str)) + (setq propertized-str (funcall ansi-app complete-str)) + + (should-not (ansi-color-tests-equal-props + filtered-str propertized-str)) + (should (equal filtered-str propertized-str))) + + ;; Tests for `ansi-color-filter-apply' + (with-temp-buffer + (should (equal-including-properties + filtered-str + (funcall ansi-filt complete-str)))) + + (with-temp-buffer + (should (equal-including-properties + filtered-str + (mapconcat ansi-filt strs "")))) + + ;; Tests for `ansi-color-filter-region' + (with-temp-buffer + (insert complete-str) + (ansi-color-filter-region (point-min) (point-max)) + (should (equal-including-properties + filtered-str (buffer-string)))) + + (with-temp-buffer + (dolist (str strs) + (let ((opoint (point))) + (insert str) + (ansi-color-filter-region opoint (point)))) + (should (equal-including-properties + filtered-str (buffer-string)))) + + ;; Test for `ansi-color-apply' + (with-temp-buffer + (should (ansi-color-tests-equal-props + propertized-str + (mapconcat ansi-app strs "")))) + + ;; Tests for `ansi-color-apply-on-region' + (with-temp-buffer + (insert complete-str) + (ansi-color-apply-on-region (point-min) (point-max)) + (should (ansi-color-tests-equal-props + propertized-str (buffer-string)))) + + (with-temp-buffer + (dolist (str strs) + (let ((opoint (point))) + (insert str) + (ansi-color-apply-on-region opoint (point)))) + (should (ansi-color-tests-equal-props + propertized-str (buffer-string)))))) + (provide 'ansi-color-tests) ;;; ansi-color-tests.el ends here diff --git a/test/lisp/auth-source-tests.el b/test/lisp/auth-source-tests.el index 5140970b0b6..34c68b421c9 100644 --- a/test/lisp/auth-source-tests.el +++ b/test/lisp/auth-source-tests.el @@ -27,6 +27,7 @@ ;;; Code: (require 'ert) +(eval-when-compile (require 'ert-x)) (require 'cl-lib) (require 'auth-source) (require 'secrets) @@ -277,34 +278,33 @@ "((:host \"a1\" :port \"a2\" :user \"a3\" :secret \"a4\") (:host \"b1\" :port \"b2\" :user \"b3\" :secret \"b4\") (:host \"c1\" :port \"c2\" :user \"c3\" :secret \"c4\"))" :host t :max 4) ("host b1, default max is 1" - "((:host \"b1\" :port \"b2\" :user \"b3\" :secret \"b4\"))" + "((:host \"b1\" :port \"b2\" :user \"b3\" :secret \"b4\"))" :host "b1") ("host b1, port b2, user b3, default max is 1" - "((:host \"b1\" :port \"b2\" :user \"b3\" :secret \"b4\"))" + "((:host \"b1\" :port \"b2\" :user \"b3\" :secret \"b4\"))" :host "b1" :port "b2" :user "b3") - )) - - (netrc-file (make-temp-file "auth-source-test" nil nil - (mapconcat 'identity entries "\n"))) - (auth-sources (list netrc-file)) - (auth-source-do-cache nil) - found found-as-string) - - (dolist (test tests) - (cl-destructuring-bind (testname needed &rest parameters) test - (setq found (apply #'auth-source-search parameters)) - (when (listp found) - (dolist (f found) - (setf f (plist-put f :secret - (let ((secret (plist-get f :secret))) - (if (functionp secret) - (funcall secret) - secret)))))) - - (setq found-as-string (format "%s: %S" testname found)) - ;; (message "With parameters %S found: [%s] needed: [%s]" parameters found-as-string needed) - (should (equal found-as-string (concat testname ": " needed))))) - (delete-file netrc-file))) + ))) + (ert-with-temp-file netrc-file + :text (mapconcat 'identity entries "\n") + (let ((auth-sources (list netrc-file)) + (auth-source-do-cache nil) + found found-as-string) + + (dolist (test tests) + (cl-destructuring-bind (testname needed &rest parameters) test + (setq found (apply #'auth-source-search parameters)) + (when (listp found) + (dolist (f found) + (setf f (plist-put f :secret + (let ((secret (plist-get f :secret))) + (if (functionp secret) + (funcall secret) + secret)))))) + + (setq found-as-string (format "%s: %S" testname found)) + ;; (message "With parameters %S found: [%s] needed: [%s]" + ;; parameters found-as-string needed) + (should (equal found-as-string (concat testname ": " needed))))))))) (ert-deftest auth-source-test-secrets-create-secret () (skip-unless secrets-enabled) @@ -360,77 +360,73 @@ (format "%s@%s" (plist-get auth-info :user) (plist-get auth-info :host)))))) (ert-deftest auth-source-test-netrc-create-secret () - (let* ((netrc-file (make-temp-file "auth-source-test")) - (auth-sources (list netrc-file)) - (auth-source-save-behavior t) - host auth-info auth-passwd) - (unwind-protect - (dolist (passwd '("foo" "" nil)) - ;; Redefine `read-*' in order to avoid interactive input. - (cl-letf (((symbol-function 'read-passwd) (lambda (_) passwd)) - ((symbol-function 'read-string) - (lambda (_prompt &optional _initial _history default - _inherit-input-method) - default))) - (setq host - (md5 (concat (prin1-to-string process-environment) passwd)) - auth-info - (car (auth-source-search - :max 1 :host host :require '(:user :secret) :create t)) - auth-passwd (plist-get auth-info :secret) - auth-passwd (if (functionp auth-passwd) - (funcall auth-passwd) - auth-passwd)) - (should (string-equal (plist-get auth-info :user) (user-login-name))) - (should (string-equal (plist-get auth-info :host) host)) - (should (equal auth-passwd passwd)) - (when (functionp (plist-get auth-info :save-function)) - (funcall (plist-get auth-info :save-function))) - - ;; Check, that the item has been created indeed. - (auth-source-forget+ :host t) - (setq auth-source-netrc-cache nil) - (setq auth-info (car (auth-source-search :host host)) - auth-passwd (plist-get auth-info :secret) - auth-passwd (if (functionp auth-passwd) - (funcall auth-passwd) - auth-passwd)) - (with-temp-buffer - (insert-file-contents netrc-file) - (if (zerop (length passwd)) - (progn - (should-not (plist-get auth-info :user)) - (should-not (plist-get auth-info :host)) - (should-not auth-passwd) - (should-not (search-forward host nil 'noerror))) - (should - (string-equal (plist-get auth-info :user) (user-login-name))) - (should (string-equal (plist-get auth-info :host) host)) - (should (string-equal auth-passwd passwd)) - (should (search-forward host nil 'noerror)))))) - - ;; Cleanup. - (delete-file netrc-file)))) + (ert-with-temp-file netrc-file + :suffix "auth-source-test" + (let* ((auth-sources (list netrc-file)) + (auth-source-save-behavior t) + host auth-info auth-passwd) + (dolist (passwd '("foo" "" nil)) + ;; Redefine `read-*' in order to avoid interactive input. + (cl-letf (((symbol-function 'read-passwd) (lambda (_) passwd)) + ((symbol-function 'read-string) + (lambda (_prompt &optional _initial _history default + _inherit-input-method) + default))) + (setq host + (md5 (concat (prin1-to-string process-environment) passwd)) + auth-info + (car (auth-source-search + :max 1 :host host :require '(:user :secret) :create t)) + auth-passwd (plist-get auth-info :secret) + auth-passwd (if (functionp auth-passwd) + (funcall auth-passwd) + auth-passwd)) + (should (string-equal (plist-get auth-info :user) (user-login-name))) + (should (string-equal (plist-get auth-info :host) host)) + (should (equal auth-passwd passwd)) + (when (functionp (plist-get auth-info :save-function)) + (funcall (plist-get auth-info :save-function))) + + ;; Check, that the item has been created indeed. + (auth-source-forget+ :host t) + (setq auth-source-netrc-cache nil) + (setq auth-info (car (auth-source-search :host host)) + auth-passwd (plist-get auth-info :secret) + auth-passwd (if (functionp auth-passwd) + (funcall auth-passwd) + auth-passwd)) + (with-temp-buffer + (insert-file-contents netrc-file) + (if (zerop (length passwd)) + (progn + (should-not (plist-get auth-info :user)) + (should-not (plist-get auth-info :host)) + (should-not auth-passwd) + (should-not (search-forward host nil 'noerror))) + (should + (string-equal (plist-get auth-info :user) (user-login-name))) + (should (string-equal (plist-get auth-info :host) host)) + (should (string-equal auth-passwd passwd)) + (should (search-forward host nil 'noerror))))))))) (ert-deftest auth-source-delete () - (let* ((netrc-file (make-temp-file "auth-source-test" nil nil "\ + (ert-with-temp-file netrc-file + :suffix "auth-source-test" :text "\ machine a1 port a2 user a3 password a4 machine b1 port b2 user b3 password b4 -machine c1 port c2 user c3 password c4\n")) - (auth-sources (list netrc-file)) - (auth-source-do-cache nil) - (expected '((:host "a1" :port "a2" :user "a3" :secret "a4"))) - (parameters '(:max 1 :host t))) - (unwind-protect - (let ((found (apply #'auth-source-delete parameters))) - (dolist (f found) - (let ((s (plist-get f :secret))) - (setf f (plist-put f :secret - (if (functionp s) (funcall s) s))))) - ;; Note: The netrc backend doesn't delete anything, so - ;; this is actually the same as `auth-source-search'. - (should (equal found expected))) - (delete-file netrc-file)))) +machine c1 port c2 user c3 password c4\n" + (let* ((auth-sources (list netrc-file)) + (auth-source-do-cache nil) + (expected '((:host "a1" :port "a2" :user "a3" :secret "a4"))) + (parameters '(:max 1 :host t)) + (found (apply #'auth-source-delete parameters))) + (dolist (f found) + (let ((s (plist-get f :secret))) + (setf f (plist-put f :secret + (if (functionp s) (funcall s) s))))) + ;; Note: The netrc backend doesn't delete anything, so + ;; this is actually the same as `auth-source-search'. + (should (equal found expected))))) (provide 'auth-source-tests) ;;; auth-source-tests.el ends here diff --git a/test/lisp/autoinsert-tests.el b/test/lisp/autoinsert-tests.el index 7ec4bf63791..b264323ca15 100644 --- a/test/lisp/autoinsert-tests.el +++ b/test/lisp/autoinsert-tests.el @@ -28,6 +28,7 @@ (require 'autoinsert) (require 'ert) +(require 'ert-x) (ert-deftest autoinsert-tests-auto-insert-skeleton () (let ((auto-insert-alist '((text-mode nil "f" _ "oo"))) @@ -39,16 +40,14 @@ (should (equal (point) (+ (point-min) 1)))))) (ert-deftest autoinsert-tests-auto-insert-file () - (let ((temp-file (make-temp-file "autoinsert-tests" nil nil "foo"))) - (unwind-protect - (let ((auto-insert-alist `((text-mode . ,temp-file))) - (auto-insert-query nil)) - (with-temp-buffer - (text-mode) - (auto-insert) - (should (equal (buffer-string) "foo")))) - (when (file-exists-p temp-file) - (delete-file temp-file))))) + (ert-with-temp-file temp-file + :text "foo" + (let ((auto-insert-alist `((text-mode . ,temp-file))) + (auto-insert-query nil)) + (with-temp-buffer + (text-mode) + (auto-insert) + (should (equal (buffer-string) "foo")))))) (ert-deftest autoinsert-tests-auto-insert-function () (let ((auto-insert-alist '((text-mode . (lambda () (insert "foo"))))) diff --git a/test/lisp/autorevert-tests.el b/test/lisp/autorevert-tests.el index 7dce39810ab..2508b6a499f 100644 --- a/test/lisp/autorevert-tests.el +++ b/test/lisp/autorevert-tests.el @@ -127,7 +127,7 @@ This expects `auto-revert--messages' to be bound by `ert-with-message-capture' before calling." ;; Remote files do not cooperate well with timers. So we count ourselves. (let ((ct (current-time))) - (while (and (< (float-time (time-subtract (current-time) ct)) + (while (and (< (float-time (time-subtract nil ct)) (auto-revert--timeout)) (null (string-match (format-message @@ -167,49 +167,48 @@ This expects `auto-revert--messages' to be bound by (defun auto-revert-tests--write-file (text file time-delta &optional append) (write-region text nil file append 'no-message) - (set-file-times file (time-subtract (current-time) time-delta))) + (set-file-times file (time-subtract nil time-delta))) (ert-deftest auto-revert-test00-auto-revert-mode () "Check autorevert for a file." ;; `auto-revert-buffers' runs every 5". And we must wait, until the ;; file has been reverted. (with-auto-revert-test - (let ((tmpfile (make-temp-file "auto-revert-test")) - (times '(60 30 15)) - buf) - (unwind-protect - (progn - (auto-revert-tests--write-file "any text" tmpfile (pop times)) - (setq buf (find-file-noselect tmpfile)) - (with-current-buffer buf - (ert-with-message-capture auto-revert--messages - (should (string-equal (buffer-string) "any text")) - ;; `buffer-stale--default-function' checks for - ;; `verify-visited-file-modtime'. We must ensure that it - ;; returns nil. - (auto-revert-mode 1) - (should auto-revert-mode) - - (auto-revert-tests--write-file "another text" tmpfile (pop times)) - - ;; Check, that the buffer has been reverted. - (auto-revert--wait-for-revert buf)) - (should (string-match "another text" (buffer-string))) - - ;; When the buffer is modified, it shall not be reverted. - (ert-with-message-capture auto-revert--messages - (set-buffer-modified-p t) - (auto-revert-tests--write-file "any text" tmpfile (pop times)) - - ;; Check, that the buffer hasn't been reverted. - (auto-revert--wait-for-revert buf)) - (should-not (string-match "any text" (buffer-string))))) - - ;; Exit. - (ignore-errors - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf)) - (ignore-errors (delete-file tmpfile)))))) + (ert-with-temp-file tmpfile + (let ((times '(60 30 15)) + buf) + (unwind-protect + (progn + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + (setq buf (find-file-noselect tmpfile)) + (with-current-buffer buf + (ert-with-message-capture auto-revert--messages + (should (string-equal (buffer-string) "any text")) + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that it + ;; returns nil. + (auto-revert-mode 1) + (should auto-revert-mode) + + (auto-revert-tests--write-file "another text" tmpfile (pop times)) + + ;; Check, that the buffer has been reverted. + (auto-revert--wait-for-revert buf)) + (should (string-match "another text" (buffer-string))) + + ;; When the buffer is modified, it shall not be reverted. + (ert-with-message-capture auto-revert--messages + (set-buffer-modified-p t) + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + + ;; Check, that the buffer hasn't been reverted. + (auto-revert--wait-for-revert buf)) + (should-not (string-match "any text" (buffer-string))))) + + ;; Exit. + (ignore-errors + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf))))))) (auto-revert--deftest-remote auto-revert-test00-auto-revert-mode "Check autorevert for a remote file.") @@ -219,63 +218,61 @@ This expects `auto-revert--messages' to be bound by "Check autorevert for several files at once." (skip-unless (executable-find "cp" (file-remote-p temporary-file-directory))) - (with-auto-revert-test - (let* ((cp (executable-find "cp" (file-remote-p temporary-file-directory))) - (tmpdir1 (make-temp-file "auto-revert-test" 'dir)) - (tmpdir2 (make-temp-file "auto-revert-test" 'dir)) - (tmpfile1 - (make-temp-file (expand-file-name "auto-revert-test" tmpdir1))) - (tmpfile2 - (make-temp-file (expand-file-name "auto-revert-test" tmpdir1))) - (times '(120 60 30 15)) - buf1 buf2) - (unwind-protect - (ert-with-message-capture auto-revert--messages - (auto-revert-tests--write-file "any text" tmpfile1 (pop times)) - (setq buf1 (find-file-noselect tmpfile1)) - (auto-revert-tests--write-file "any text" tmpfile2 (pop times)) - (setq buf2 (find-file-noselect tmpfile2)) - - (dolist (buf (list buf1 buf2)) - (with-current-buffer buf - (should (string-equal (buffer-string) "any text")) - ;; `buffer-stale--default-function' checks for - ;; `verify-visited-file-modtime'. We must ensure that - ;; it returns nil. - (auto-revert-mode 1) - (should auto-revert-mode))) - - ;; Modify files. We wait for a second, in order to have - ;; another timestamp. - (auto-revert-tests--write-file - "another text" - (expand-file-name (file-name-nondirectory tmpfile1) tmpdir2) - (pop times)) - (auto-revert-tests--write-file - "another text" - (expand-file-name (file-name-nondirectory tmpfile2) tmpdir2) - (pop times)) - ;;(copy-directory tmpdir2 tmpdir1 nil 'copy-contents) - ;; Strange, that `copy-directory' does not work as expected. - ;; The following shell command is not portable on all - ;; platforms, unfortunately. - (shell-command - (format "%s -f %s/* %s" - cp (file-local-name tmpdir2) (file-local-name tmpdir1))) - - ;; Check, that the buffers have been reverted. - (dolist (buf (list buf1 buf2)) - (with-current-buffer buf - (auto-revert--wait-for-revert buf) - (should (string-match "another text" (buffer-string)))))) - - ;; Exit. - (ignore-errors - (dolist (buf (list buf1 buf2)) - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf))) - (ignore-errors (delete-directory tmpdir1 'recursive)) - (ignore-errors (delete-directory tmpdir2 'recursive)))))) + (ert-with-temp-directory tmpdir1 + (ert-with-temp-directory tmpdir2 + (ert-with-temp-file tmpfile1 + :prefix (expand-file-name "auto-revert-test" tmpdir1) + (ert-with-temp-file tmpfile2 + :prefix (expand-file-name "auto-revert-test" tmpdir1) + (with-auto-revert-test + (let* ((cp (executable-find "cp" (file-remote-p temporary-file-directory))) + (times '(120 60 30 15)) + buf1 buf2) + (unwind-protect + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "any text" tmpfile1 (pop times)) + (setq buf1 (find-file-noselect tmpfile1)) + (auto-revert-tests--write-file "any text" tmpfile2 (pop times)) + (setq buf2 (find-file-noselect tmpfile2)) + + (dolist (buf (list buf1 buf2)) + (with-current-buffer buf + (should (string-equal (buffer-string) "any text")) + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that + ;; it returns nil. + (auto-revert-mode 1) + (should auto-revert-mode))) + + ;; Modify files. We wait for a second, in order to have + ;; another timestamp. + (auto-revert-tests--write-file + "another text" + (expand-file-name (file-name-nondirectory tmpfile1) tmpdir2) + (pop times)) + (auto-revert-tests--write-file + "another text" + (expand-file-name (file-name-nondirectory tmpfile2) tmpdir2) + (pop times)) + ;;(copy-directory tmpdir2 tmpdir1 nil 'copy-contents) + ;; Strange, that `copy-directory' does not work as expected. + ;; The following shell command is not portable on all + ;; platforms, unfortunately. + (shell-command + (format "%s -f %s/* %s" + cp (file-local-name tmpdir2) (file-local-name tmpdir1))) + + ;; Check, that the buffers have been reverted. + (dolist (buf (list buf1 buf2)) + (with-current-buffer buf + (auto-revert--wait-for-revert buf) + (should (string-match "another text" (buffer-string)))))) + + ;; Exit. + (ignore-errors + (dolist (buf (list buf1 buf2)) + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf))))))))))) (auto-revert--deftest-remote auto-revert-test01-auto-revert-several-files "Check autorevert for several remote files at once.") @@ -284,80 +281,79 @@ This expects `auto-revert--messages' to be bound by (ert-deftest auto-revert-test02-auto-revert-deleted-file () "Check autorevert for a deleted file." ;; Repeated unpredictable failures, bug#32645. - ;; Unlikely to be hydra-specific? -; (skip-unless (not (getenv "EMACS_HYDRA_CI"))) :tags '(:unstable) + ;; Unlikely to be hydra-specific? + ;; (skip-unless (not (getenv "EMACS_HYDRA_CI"))) (with-auto-revert-test - (let ((tmpfile (make-temp-file "auto-revert-test")) - ;; Try to catch bug#32645. - (auto-revert-debug (getenv "EMACS_HYDRA_CI")) - (file-notify-debug (getenv "EMACS_HYDRA_CI")) - (times '(120 60 30 15)) - buf desc) - (unwind-protect - (progn - (auto-revert-tests--write-file "any text" tmpfile (pop times)) - (setq buf (find-file-noselect tmpfile)) - (with-current-buffer buf - (should-not - (file-notify-valid-p auto-revert-notify-watch-descriptor)) - (should (string-equal (buffer-string) "any text")) - ;; `buffer-stale--default-function' checks for - ;; `verify-visited-file-modtime'. We must ensure that - ;; it returns nil. - (auto-revert-mode 1) - (should auto-revert-mode) - (setq desc auto-revert-notify-watch-descriptor) - - ;; Remove file while reverting. We simulate this by - ;; modifying `before-revert-hook'. - (add-hook - 'before-revert-hook - (lambda () - (when auto-revert-debug - (message "%s deleted" buffer-file-name)) - (delete-file buffer-file-name)) - nil t) - - (ert-with-message-capture auto-revert--messages - (auto-revert-tests--write-file "another text" tmpfile (pop times)) - (auto-revert--wait-for-revert buf)) - ;; Check, that the buffer hasn't been reverted. File - ;; notification should be disabled, falling back to - ;; polling. - (should (string-match "any text" (buffer-string))) - ;; With w32notify, and on emba, the `stopped' events are not sent. - (or (eq file-notify--library 'w32notify) - (getenv "EMACS_EMBA_CI") - (should-not - (file-notify-valid-p auto-revert-notify-watch-descriptor))) - - ;; Once the file has been recreated, the buffer shall be - ;; reverted. - (kill-local-variable 'before-revert-hook) - (ert-with-message-capture auto-revert--messages - (auto-revert-tests--write-file "another text" tmpfile (pop times)) - (auto-revert--wait-for-revert buf)) - ;; Check, that the buffer has been reverted. - (should (string-match "another text" (buffer-string))) - ;; When file notification is used, it must be reenabled - ;; after recreation of the file. We cannot expect that - ;; the descriptor is the same, so we just check the - ;; existence. - (should (eq (null desc) (null auto-revert-notify-watch-descriptor))) - - ;; An empty file shall still be reverted. - (ert-with-message-capture auto-revert--messages - (auto-revert-tests--write-file "" tmpfile (pop times)) - (auto-revert--wait-for-revert buf)) - ;; Check, that the buffer has been reverted. - (should (string-equal "" (buffer-string))))) - - ;; Exit. - (ignore-errors - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf)) - (ignore-errors (delete-file tmpfile)))))) + (ert-with-temp-file tmpfile + (let (;; Try to catch bug#32645. + (auto-revert-debug (getenv "EMACS_HYDRA_CI")) + (file-notify-debug (getenv "EMACS_HYDRA_CI")) + (times '(120 60 30 15)) + buf desc) + (unwind-protect + (progn + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + (setq buf (find-file-noselect tmpfile)) + (with-current-buffer buf + (should-not + (file-notify-valid-p auto-revert-notify-watch-descriptor)) + (should (string-equal (buffer-string) "any text")) + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that + ;; it returns nil. + (auto-revert-mode 1) + (should auto-revert-mode) + (setq desc auto-revert-notify-watch-descriptor) + + ;; Remove file while reverting. We simulate this by + ;; modifying `before-revert-hook'. + (add-hook + 'before-revert-hook + (lambda () + (when auto-revert-debug + (message "%s deleted" buffer-file-name)) + (delete-file buffer-file-name)) + nil t) + + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "another text" tmpfile (pop times)) + (auto-revert--wait-for-revert buf)) + ;; Check, that the buffer hasn't been reverted. File + ;; notification should be disabled, falling back to + ;; polling. + (should (string-match "any text" (buffer-string))) + ;; With w32notify, and on emba, the `stopped' events are not sent. + (or (eq file-notify--library 'w32notify) + (getenv "EMACS_EMBA_CI") + (should-not + (file-notify-valid-p auto-revert-notify-watch-descriptor))) + + ;; Once the file has been recreated, the buffer shall be + ;; reverted. + (kill-local-variable 'before-revert-hook) + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "another text" tmpfile (pop times)) + (auto-revert--wait-for-revert buf)) + ;; Check, that the buffer has been reverted. + (should (string-match "another text" (buffer-string))) + ;; When file notification is used, it must be reenabled + ;; after recreation of the file. We cannot expect that + ;; the descriptor is the same, so we just check the + ;; existence. + (should (eq (null desc) (null auto-revert-notify-watch-descriptor))) + + ;; An empty file shall still be reverted. + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "" tmpfile (pop times)) + (auto-revert--wait-for-revert buf)) + ;; Check, that the buffer has been reverted. + (should (string-equal "" (buffer-string))))) + + ;; Exit. + (ignore-errors + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf))))))) (auto-revert--deftest-remote auto-revert-test02-auto-revert-deleted-file "Check autorevert for a deleted remote file.") @@ -366,34 +362,33 @@ This expects `auto-revert--messages' to be bound by "Check autorevert tail mode." ;; `auto-revert-buffers' runs every 5". And we must wait, until the ;; file has been reverted. - (let ((tmpfile (make-temp-file "auto-revert-test")) - (times '(30 15)) - buf) - (unwind-protect - (ert-with-message-capture auto-revert--messages - (auto-revert-tests--write-file "any text" tmpfile (pop times)) - (setq buf (find-file-noselect tmpfile)) - (with-current-buffer buf - ;; `buffer-stale--default-function' checks for - ;; `verify-visited-file-modtime'. We must ensure that it - ;; returns nil. - (auto-revert-tail-mode 1) - (should auto-revert-tail-mode) - (erase-buffer) - (insert "modified text\n") - (set-buffer-modified-p nil) - - ;; Modify file. - (auto-revert-tests--write-file "another text" tmpfile (pop times) 'append) - - ;; Check, that the buffer has been reverted. - (auto-revert--wait-for-revert buf) - (should - (string-match "modified text\nanother text" (buffer-string))))) - - ;; Exit. - (ignore-errors (kill-buffer buf)) - (ignore-errors (delete-file tmpfile))))) + (ert-with-temp-file tmpfile + (let ((times '(30 15)) + buf) + (unwind-protect + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + (setq buf (find-file-noselect tmpfile)) + (with-current-buffer buf + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that it + ;; returns nil. + (auto-revert-tail-mode 1) + (should auto-revert-tail-mode) + (erase-buffer) + (insert "modified text\n") + (set-buffer-modified-p nil) + + ;; Modify file. + (auto-revert-tests--write-file "another text" tmpfile (pop times) 'append) + + ;; Check, that the buffer has been reverted. + (auto-revert--wait-for-revert buf) + (should + (string-match "modified text\nanother text" (buffer-string))))) + + ;; Exit. + (ignore-errors (kill-buffer buf)))))) (auto-revert--deftest-remote auto-revert-test03-auto-revert-tail-mode "Check remote autorevert tail mode.") @@ -403,46 +398,45 @@ This expects `auto-revert--messages' to be bound by ;; `auto-revert-buffers' runs every 5". And we must wait, until the ;; file has been reverted. (with-auto-revert-test - (let* ((tmpfile (make-temp-file "auto-revert-test")) - (name (file-name-nondirectory tmpfile)) - (times '(30)) - buf) - (unwind-protect - (progn - (setq buf (dired-noselect temporary-file-directory)) - (with-current-buffer buf - ;; `buffer-stale--default-function' checks for - ;; `verify-visited-file-modtime'. We must ensure that it - ;; returns nil. - (auto-revert-mode 1) - (should auto-revert-mode) - (should - (string-match name (substring-no-properties (buffer-string)))) - - (ert-with-message-capture auto-revert--messages - ;; Delete file. - (delete-file tmpfile) - (auto-revert--wait-for-revert buf)) - ;; Check, that the buffer has been reverted. - (should-not - (string-match name (substring-no-properties (buffer-string)))) - - (ert-with-message-capture auto-revert--messages - ;; Make dired buffer modified. Check, that the buffer has - ;; been still reverted. - (set-buffer-modified-p t) - (auto-revert-tests--write-file "any text" tmpfile (pop times)) - - (auto-revert--wait-for-revert buf)) - ;; Check, that the buffer has been reverted. - (should - (string-match name (substring-no-properties (buffer-string)))))) - - ;; Exit. - (ignore-errors - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf)) - (ignore-errors (delete-file tmpfile)))))) + (ert-with-temp-file tmpfile + (let* ((name (file-name-nondirectory tmpfile)) + (times '(30)) + buf) + (unwind-protect + (progn + (setq buf (dired-noselect temporary-file-directory)) + (with-current-buffer buf + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that it + ;; returns nil. + (auto-revert-mode 1) + (should auto-revert-mode) + (should + (string-match name (substring-no-properties (buffer-string)))) + + (ert-with-message-capture auto-revert--messages + ;; Delete file. + (delete-file tmpfile) + (auto-revert--wait-for-revert buf)) + ;; Check, that the buffer has been reverted. + (should-not + (string-match name (substring-no-properties (buffer-string)))) + + (ert-with-message-capture auto-revert--messages + ;; Make dired buffer modified. Check, that the buffer has + ;; been still reverted. + (set-buffer-modified-p t) + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + + (auto-revert--wait-for-revert buf)) + ;; Check, that the buffer has been reverted. + (should + (string-match name (substring-no-properties (buffer-string)))))) + + ;; Exit. + (ignore-errors + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf))))))) (auto-revert--deftest-remote auto-revert-test04-auto-revert-mode-dired "Check remote autorevert for dired.") @@ -459,7 +453,7 @@ This expects `auto-revert--messages' to be bound by (defun auto-revert-test--wait-for (pred max-wait) "Wait until PRED is true, or MAX-WAIT seconds elapsed." (let ((ct (current-time))) - (while (and (< (float-time (time-subtract (current-time) ct)) max-wait) + (while (and (< (float-time (time-subtract nil ct)) max-wait) (not (funcall pred))) (read-event nil nil 0.1)))) @@ -485,99 +479,84 @@ This expects `auto-revert--messages' to be bound by (skip-unless (or file-notify--library (file-remote-p temporary-file-directory))) (with-auto-revert-test - (let* ((auto-revert-use-notify t) - (auto-revert-avoid-polling t) - (auto-revert-debug (getenv "EMACS_EMBA_CI")) - (file-notify-debug (getenv "EMACS_EMBA_CI")) - (was-in-global-auto-revert-mode global-auto-revert-mode) - (file-1 (make-temp-file "global-auto-revert-test-1")) - (file-2 (make-temp-file "global-auto-revert-test-2")) - (file-3 (make-temp-file "global-auto-revert-test-3")) - (file-2b (concat file-2 "-b")) - require-final-newline buf-1 buf-2 buf-3) - (unwind-protect - (progn - (setq buf-1 (find-file-noselect file-1)) - (auto-revert-test--instrument-kill-buffer-hook buf-1) - (setq buf-2 (find-file-noselect file-2)) - (auto-revert-test--instrument-kill-buffer-hook buf-2) - (auto-revert-test--write-file "1-a" file-1) - (should (equal (auto-revert-test--buffer-string buf-1) "")) - - (global-auto-revert-mode 1) ; Turn it on. - - (should (buffer-local-value - 'auto-revert-notify-watch-descriptor buf-1)) - (should (buffer-local-value - 'auto-revert-notify-watch-descriptor buf-2)) - - ;; buf-1 should have been reverted immediately when the mode - ;; was enabled. - (should (equal (auto-revert-test--buffer-string buf-1) "1-a")) - - ;; Alter a file. - (auto-revert-test--write-file "2-a" file-2) - ;; Allow for some time to handle notification events. - (auto-revert-test--wait-for-buffer-text buf-2 "2-a" 1) - (should (equal (auto-revert-test--buffer-string buf-2) "2-a")) - - ;; Visit a file, and modify it on disk. - (setq buf-3 (find-file-noselect file-3)) - (auto-revert-test--instrument-kill-buffer-hook buf-3) - ;; Newly opened buffers won't be use notification until the - ;; first poll cycle; wait for it. - (auto-revert-test--wait-for - (lambda () (buffer-local-value - 'auto-revert-notify-watch-descriptor buf-3)) - (auto-revert--timeout)) - (should (buffer-local-value - 'auto-revert-notify-watch-descriptor buf-3)) - (auto-revert-test--write-file "3-a" file-3) - (auto-revert-test--wait-for-buffer-text buf-3 "3-a" 1) - (should (equal (auto-revert-test--buffer-string buf-3) "3-a")) - - ;; Delete a visited file, and re-create it with new contents. - (when auto-revert-debug (message "Hallo0")) - (delete-file file-1) - (when auto-revert-debug (message "Hallo1")) - (should (equal (auto-revert-test--buffer-string buf-1) "1-a")) - (when auto-revert-debug (message "Hallo2")) - (auto-revert-test--write-file "1-b" file-1) - (when auto-revert-debug (message "Hallo3")) - (auto-revert-test--wait-for-buffer-text - buf-1 "1-b" (auto-revert--timeout)) - ;; On emba, `buf-1' is a killed buffer. - (when auto-revert-debug - (message - "Hallo4 %s %s %s %s %s %s %s" - buf-1 (buffer-name buf-1) (buffer-live-p buf-1) - file-1 (get-file-buffer file-1) - (buffer-name (get-file-buffer file-1)) - (buffer-live-p (get-file-buffer file-1))) - (with-current-buffer buf-1 - (message "Hallo5\n%s" (buffer-local-variables)))) - (should (buffer-local-value - 'auto-revert-notify-watch-descriptor buf-1)) - (when auto-revert-debug (message "Hallo6")) - - ;; Write a buffer to a new file, then modify the new file on disk. - (with-current-buffer buf-2 - (write-file file-2b)) - (should (equal (auto-revert-test--buffer-string buf-2) "2-a")) - (auto-revert-test--write-file "2-b" file-2b) - (auto-revert-test--wait-for-buffer-text - buf-2 "2-b" (auto-revert--timeout)) - (should (buffer-local-value - 'auto-revert-notify-watch-descriptor buf-2))) - - ;; Clean up. - (unless was-in-global-auto-revert-mode - (global-auto-revert-mode 0)) ; Turn it off. - (dolist (buf (list buf-1 buf-2 buf-3)) - (with-current-buffer buf (setq-local kill-buffer-hook nil)) - (ignore-errors (kill-buffer buf))) - (dolist (file (list file-1 file-2 file-2b file-3)) - (ignore-errors (delete-file file))))))) + (ert-with-temp-file file-1 + (ert-with-temp-file file-2 + (ert-with-temp-file file-3 + (let* ((auto-revert-use-notify t) + (auto-revert-avoid-polling t) + (was-in-global-auto-revert-mode global-auto-revert-mode) + (file-2b (concat file-2 "-b")) + require-final-newline buf-1 buf-2 buf-3) + (unwind-protect + (progn + (setq buf-1 (find-file-noselect file-1)) + (auto-revert-test--instrument-kill-buffer-hook buf-1) + (setq buf-2 (find-file-noselect file-2)) + (auto-revert-test--instrument-kill-buffer-hook buf-2) + (auto-revert-test--write-file "1-a" file-1) + (should (equal (auto-revert-test--buffer-string buf-1) "")) + + (global-auto-revert-mode 1) ; Turn it on. + + (should (buffer-local-value + 'auto-revert-notify-watch-descriptor buf-1)) + (should (buffer-local-value + 'auto-revert-notify-watch-descriptor buf-2)) + + ;; buf-1 should have been reverted immediately when the mode + ;; was enabled. + (should (equal (auto-revert-test--buffer-string buf-1) "1-a")) + + ;; Alter a file. + (auto-revert-test--write-file "2-a" file-2) + ;; Allow for some time to handle notification events. + (auto-revert-test--wait-for-buffer-text buf-2 "2-a" 1) + (should (equal (auto-revert-test--buffer-string buf-2) "2-a")) + + ;; Visit a file, and modify it on disk. + (setq buf-3 (find-file-noselect file-3)) + (auto-revert-test--instrument-kill-buffer-hook buf-3) + ;; Newly opened buffers won't be use notification until the + ;; first poll cycle; wait for it. + (auto-revert-test--wait-for + (lambda () (buffer-local-value + 'auto-revert-notify-watch-descriptor buf-3)) + (auto-revert--timeout)) + (should (buffer-local-value + 'auto-revert-notify-watch-descriptor buf-3)) + (auto-revert-test--write-file "3-a" file-3) + (auto-revert-test--wait-for-buffer-text buf-3 "3-a" 1) + (should (equal (auto-revert-test--buffer-string buf-3) "3-a")) + + ;; Delete a visited file, and re-create it with new contents. + (delete-file file-1) + (should (equal (auto-revert-test--buffer-string buf-1) "1-a")) + (auto-revert-test--write-file "1-b" file-1) + ;; Since the file is deleted, it needs at least + ;; `autorevert-interval' to recognize the new file, + ;; while polling. So increase the timeout. + (auto-revert-test--wait-for-buffer-text + buf-1 "1-b" (* 2 (auto-revert--timeout))) + (should (buffer-local-value + 'auto-revert-notify-watch-descriptor buf-1)) + + ;; Write a buffer to a new file, then modify the new file on disk. + (with-current-buffer buf-2 + (write-file file-2b)) + (should (equal (auto-revert-test--buffer-string buf-2) "2-a")) + (auto-revert-test--write-file "2-b" file-2b) + (auto-revert-test--wait-for-buffer-text + buf-2 "2-b" (auto-revert--timeout)) + (should (buffer-local-value + 'auto-revert-notify-watch-descriptor buf-2))) + + ;; Clean up. + (unless was-in-global-auto-revert-mode + (global-auto-revert-mode 0)) ; Turn it off. + (dolist (buf (list buf-1 buf-2 buf-3)) + (with-current-buffer buf (setq-local kill-buffer-hook nil)) + (ignore-errors (kill-buffer buf))) + (ignore-errors (delete-file file-2b))))))))) (auto-revert--deftest-remote auto-revert-test05-global-notify "Test `global-auto-revert-mode' without polling for remote buffers.") @@ -587,31 +566,30 @@ This expects `auto-revert--messages' to be bound by (skip-unless (or file-notify--library (file-remote-p temporary-file-directory))) (with-auto-revert-test - (let* ((auto-revert-use-notify t) - (file-1 (make-temp-file "auto-revert-test")) - (file-2 (concat file-1 "-2")) - require-final-newline buf) - (unwind-protect - (progn - (setq buf (find-file-noselect file-1)) - (with-current-buffer buf - (insert "A") - (save-buffer) + (ert-with-temp-file file-1 + (let* ((auto-revert-use-notify t) + (file-2 (concat file-1 "-2")) + require-final-newline buf) + (unwind-protect + (progn + (setq buf (find-file-noselect file-1)) + (with-current-buffer buf + (insert "A") + (save-buffer) - (auto-revert-mode 1) + (auto-revert-mode 1) - (insert "B") - (write-file file-2) + (insert "B") + (write-file file-2) - (auto-revert-test--write-file "C" file-2) - (auto-revert-test--wait-for-buffer-text - buf "C" (auto-revert--timeout)) - (should (equal (buffer-string) "C")))) + (auto-revert-test--write-file "C" file-2) + (auto-revert-test--wait-for-buffer-text + buf "C" (auto-revert--timeout)) + (should (equal (buffer-string) "C")))) - ;; Clean up. - (ignore-errors (kill-buffer buf)) - (ignore-errors (delete-file file-1)) - (ignore-errors (delete-file file-2)))))) + ;; Clean up. + (ignore-errors (kill-buffer buf)) + (ignore-errors (delete-file file-2))))))) (auto-revert--deftest-remote auto-revert-test06-write-file "Test `write-file' in `auto-revert-mode' for remote buffers.") @@ -620,82 +598,81 @@ This expects `auto-revert--messages' to be bound by (ert-deftest auto-revert-test07-auto-revert-several-buffers () "Check autorevert for several buffers visiting the same file." ;; (with-auto-revert-test - (let ((auto-revert-use-notify t) - (tmpfile (make-temp-file "auto-revert-test")) - (times '(120 60 30 15)) - (num-buffers 10) - require-final-newline buffers) - - (unwind-protect - ;; Check indirect buffers. - (ert-with-message-capture auto-revert--messages - (auto-revert-tests--write-file "any text" tmpfile (pop times)) - (push (find-file-noselect tmpfile) buffers) - (with-current-buffer (car buffers) - (should (string-equal (buffer-string) "any text")) - ;; `buffer-stale--default-function' checks for - ;; `verify-visited-file-modtime'. We must ensure that - ;; it returns nil. - (auto-revert-mode 1) - (should auto-revert-mode)) - - (dotimes (i num-buffers) - (push (make-indirect-buffer - (car buffers) - (format "%s-%d" (buffer-file-name (car buffers)) i) - 'clone) - buffers)) - (setq buffers (nreverse buffers)) - (dolist (buf buffers) - (with-current-buffer buf - (should (string-equal (buffer-string) "any text")) - (should auto-revert-mode))) - - (auto-revert-tests--write-file "another text" tmpfile (pop times)) - ;; Check, that the buffer has been reverted. - (auto-revert--wait-for-revert (car buffers)) - (dolist (buf buffers) - (with-current-buffer buf - (should (string-equal (buffer-string) "another text"))))) - - ;; Exit. - (ignore-errors - (dolist (buf buffers) - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf))) - (setq buffers nil) - (ignore-errors (delete-file tmpfile))) - - ;; Check direct buffers. - (unwind-protect - (ert-with-message-capture auto-revert--messages - (auto-revert-tests--write-file "any text" tmpfile (pop times)) - - (dotimes (i num-buffers) - (push (generate-new-buffer - (format "%s-%d" (file-name-nondirectory tmpfile) i)) - buffers)) - (setq buffers (nreverse buffers)) - (dolist (buf buffers) - (with-current-buffer buf - (insert-file-contents tmpfile 'visit) - (should (string-equal (buffer-string) "any text")) - (auto-revert-mode 1) - (should auto-revert-mode))) - - (auto-revert-tests--write-file "another text" tmpfile (pop times)) - ;; Check, that the buffers have been reverted. - (dolist (buf buffers) - (auto-revert--wait-for-revert buf) - (with-current-buffer buf - (should (string-equal (buffer-string) "another text"))))) - - ;; Exit. - (ignore-errors - (dolist (buf buffers) - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf))) - (ignore-errors (delete-file tmpfile)))));) + (ert-with-temp-file tmpfile + (let ((auto-revert-use-notify t) + (times '(120 60 30 15)) + (num-buffers 10) + require-final-newline buffers) + + (unwind-protect + ;; Check indirect buffers. + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + (push (find-file-noselect tmpfile) buffers) + (with-current-buffer (car buffers) + (should (string-equal (buffer-string) "any text")) + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that + ;; it returns nil. + (auto-revert-mode 1) + (should auto-revert-mode)) + + (dotimes (i num-buffers) + (push (make-indirect-buffer + (car buffers) + (format "%s-%d" (buffer-file-name (car buffers)) i) + 'clone) + buffers)) + (setq buffers (nreverse buffers)) + (dolist (buf buffers) + (with-current-buffer buf + (should (string-equal (buffer-string) "any text")) + (should auto-revert-mode))) + + (auto-revert-tests--write-file "another text" tmpfile (pop times)) + ;; Check, that the buffer has been reverted. + (auto-revert--wait-for-revert (car buffers)) + (dolist (buf buffers) + (with-current-buffer buf + (should (string-equal (buffer-string) "another text"))))) + + ;; Exit. + (ignore-errors + (dolist (buf buffers) + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf))) + (setq buffers nil) + (ignore-errors (delete-file tmpfile))) + + ;; Check direct buffers. + (unwind-protect + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + + (dotimes (i num-buffers) + (push (generate-new-buffer + (format "%s-%d" (file-name-nondirectory tmpfile) i)) + buffers)) + (setq buffers (nreverse buffers)) + (dolist (buf buffers) + (with-current-buffer buf + (insert-file-contents tmpfile 'visit) + (should (string-equal (buffer-string) "any text")) + (auto-revert-mode 1) + (should auto-revert-mode))) + + (auto-revert-tests--write-file "another text" tmpfile (pop times)) + ;; Check, that the buffers have been reverted. + (dolist (buf buffers) + (auto-revert--wait-for-revert buf) + (with-current-buffer buf + (should (string-equal (buffer-string) "another text"))))) + + ;; Exit. + (ignore-errors + (dolist (buf buffers) + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf)))))));) (auto-revert--deftest-remote auto-revert-test07-auto-revert-several-buffers "Check autorevert for several buffers visiting the same remote file.") diff --git a/test/lisp/bookmark-tests.el b/test/lisp/bookmark-tests.el index 9c33a27288a..dc2dec68ee3 100644 --- a/test/lisp/bookmark-tests.el +++ b/test/lisp/bookmark-tests.el @@ -371,16 +371,14 @@ Same as `with-bookmark-test' but also sets a temporary `bookmark-default-file', evaluates BODY, and then runs the test that saves and then loads the bookmark file." `(with-bookmark-test - (let ((file (make-temp-file "bookmark-tests-"))) - (unwind-protect - (let ((bookmark-default-file file) - (old-alist bookmark-alist)) - ,@body - (bookmark-save nil file t) - (setq bookmark-alist nil) - (bookmark-load file nil t) - (should (equal bookmark-alist old-alist))) - (delete-file file))))) + (ert-with-temp-file file + (let ((bookmark-default-file file) + (old-alist bookmark-alist)) + ,@body + (bookmark-save nil file t) + (setq bookmark-alist nil) + (bookmark-load file nil t) + (should (equal bookmark-alist old-alist)))))) (defvar bookmark-tests-non-ascii-data (concat "Здра́вствуйте!" "中文,普通话,汉语" "åäöøñ" diff --git a/test/lisp/buff-menu-tests.el b/test/lisp/buff-menu-tests.el index 18c988656d3..b223a643083 100644 --- a/test/lisp/buff-menu-tests.el +++ b/test/lisp/buff-menu-tests.el @@ -24,19 +24,20 @@ ;;; Code: (require 'ert) +(eval-when-compile (require 'ert-x)) (ert-deftest buff-menu-24962 () "Test for https://debbugs.gnu.org/24962 ." - (let* ((file (make-temp-file "foo")) - (buf (find-file file))) - (unwind-protect - (progn - (rename-buffer " foo") - (list-buffers) - (with-current-buffer "*Buffer List*" - (should (string= " foo" (buffer-name (Buffer-menu-buffer)))))) - (and (buffer-live-p buf) (kill-buffer buf)) - (and (file-exists-p file) (delete-file file))))) + (ert-with-temp-file file + :suffix "foo" + (let ((buf (find-file file))) + (unwind-protect + (progn + (rename-buffer " foo") + (list-buffers) + (with-current-buffer "*Buffer List*" + (should (string= " foo" (buffer-name (Buffer-menu-buffer)))))) + (and (buffer-live-p buf) (kill-buffer buf)))))) (provide 'buff-menu-tests) diff --git a/test/lisp/button-tests.el b/test/lisp/button-tests.el index 2f5ad795df2..a88387e0259 100644 --- a/test/lisp/button-tests.el +++ b/test/lisp/button-tests.el @@ -21,11 +21,9 @@ (require 'ert) -(defvar button-tests--map - (let ((map (make-sparse-keymap))) - (define-key map "x" #'ignore) - map) - "Keymap for testing command substitution.") +(defvar-keymap button-tests--map + :doc "Keymap for testing command substitution." + "x" #'ignore) (ert-deftest button-at () "Test `button-at' behavior." diff --git a/test/lisp/calc/calc-tests.el b/test/lisp/calc/calc-tests.el index 8a78a068242..3eb6b34c132 100644 --- a/test/lisp/calc/calc-tests.el +++ b/test/lisp/calc/calc-tests.el @@ -810,6 +810,12 @@ An existing calc stack is reused, otherwise a new one is created." (should (equal (calcFunc-test6 3) (* (* 3 2) (- 3 1)))) (should (equal (calcFunc-test7 3) (* 3 2)))) +(ert-deftest calc-nth-root () + ;; bug#51209 + (let* ((calc-display-working-message nil) + (x (calc-tests--calc-to-number (math-pow 8 '(frac 1 6))))) + (should (< (abs (- x (sqrt 2.0))) 1.0e-10)))) + (provide 'calc-tests) ;;; calc-tests.el ends here diff --git a/test/lisp/calendar/icalendar-tests.el b/test/lisp/calendar/icalendar-tests.el index a1853ff3d4e..1551922028c 100644 --- a/test/lisp/calendar/icalendar-tests.el +++ b/test/lisp/calendar/icalendar-tests.el @@ -698,17 +698,18 @@ and ISO style input data must use english month names." "Actually perform export test. Argument INPUT input diary string. Argument EXPECTED-OUTPUT expected iCalendar result string." - (let ((temp-file (make-temp-file "icalendar-tests-ics"))) + (ert-with-temp-file temp-file + :suffix "icalendar-tests-ics" (unwind-protect - (progn - (with-temp-buffer - (insert input) - (icalendar-export-region (point-min) (point-max) temp-file)) - (save-excursion - (find-file temp-file) - (goto-char (point-min)) - (cond (expected-output - (should (re-search-forward "^\\s-*BEGIN:VCALENDAR + (progn + (with-temp-buffer + (insert input) + (icalendar-export-region (point-min) (point-max) temp-file)) + (save-excursion + (find-file temp-file) + (goto-char (point-min)) + (cond (expected-output + (should (re-search-forward "^\\s-*BEGIN:VCALENDAR PRODID:-//Emacs//NONSGML icalendar.el//EN VERSION:2.0 BEGIN:VEVENT @@ -717,23 +718,22 @@ UID:emacs[0-9]+ END:VEVENT END:VCALENDAR \\s-*$" - nil t)) - (should (string-match - (concat "^\\s-*" - (regexp-quote (buffer-substring-no-properties - (match-beginning 1) (match-end 1))) - "\\s-*$") - expected-output))) - (t - (should (re-search-forward "^\\s-*BEGIN:VCALENDAR + nil t)) + (should (string-match + (concat "^\\s-*" + (regexp-quote (buffer-substring-no-properties + (match-beginning 1) (match-end 1))) + "\\s-*$") + expected-output))) + (t + (should (re-search-forward "^\\s-*BEGIN:VCALENDAR PRODID:-//Emacs//NONSGML icalendar.el//EN VERSION:2.0 END:VCALENDAR \\s-*$" - nil t)))))) + nil t)))))) ;; cleanup!! - (kill-buffer (find-buffer-visiting temp-file)) - (delete-file temp-file)))) + (kill-buffer (find-buffer-visiting temp-file))))) (ert-deftest icalendar-export-ordinary-no-time () "Perform export test." @@ -1031,7 +1031,8 @@ During import test the timezone is set to Central European Time." (defun icalendar-tests--do-test-import (expected-output) "Actually perform import test. Argument EXPECTED-OUTPUT file containing expected diary string." - (let ((temp-file (make-temp-file "icalendar-test-diary"))) + (ert-with-temp-file temp-file + :suffix "icalendar-test-diary" ;; Test the Catch-the-mysterious-coding-header logic below. ;; Ruby-mode adds an after-save-hook which inserts the header! ;; (save-excursion @@ -1061,8 +1062,7 @@ Argument EXPECTED-OUTPUT file containing expected diary string." (let ((result (buffer-substring-no-properties (point-min) (point-max)))) (should (string= expected-output result))) - (kill-buffer (find-buffer-visiting temp-file)) - (delete-file temp-file)))) + (kill-buffer (find-buffer-visiting temp-file))))) (ert-deftest icalendar-import-non-recurring () "Perform standard import tests." @@ -1240,35 +1240,33 @@ Argument INPUT icalendar event string." (defun icalendar-tests--do-test-cycle () "Actually perform import/export cycle test." - (let ((temp-diary (make-temp-file "icalendar-test-diary")) - (temp-ics (make-temp-file "icalendar-test-ics")) - (org-input (buffer-substring-no-properties (point-min) (point-max)))) - - (unwind-protect - (progn - ;; step 1: import - (icalendar-import-buffer temp-diary t t) - - ;; step 2: export what was just imported - (save-excursion - (find-file temp-diary) - (icalendar-export-region (point-min) (point-max) temp-ics)) - - ;; compare the output of step 2 with the input of step 1 - (save-excursion - (find-file temp-ics) - (goto-char (point-min)) - ;;(when (re-search-forward "\nUID:.*\n" nil t) - ;;(replace-match "\n")) - (let ((cycled (buffer-substring-no-properties (point-min) (point-max)))) - (should (string= org-input cycled))))) - ;; clean up - (kill-buffer (find-buffer-visiting temp-diary)) - (with-current-buffer (find-buffer-visiting temp-ics) - (set-buffer-modified-p nil) - (kill-buffer (current-buffer))) - (delete-file temp-diary) - (delete-file temp-ics)))) + (ert-with-temp-file temp-diary + (ert-with-temp-file temp-ics + (let ((org-input (buffer-substring-no-properties (point-min) (point-max)))) + + (unwind-protect + (progn + ;; step 1: import + (icalendar-import-buffer temp-diary t t) + + ;; step 2: export what was just imported + (save-excursion + (find-file temp-diary) + (icalendar-export-region (point-min) (point-max) temp-ics)) + + ;; compare the output of step 2 with the input of step 1 + (save-excursion + (find-file temp-ics) + (goto-char (point-min)) + ;;(when (re-search-forward "\nUID:.*\n" nil t) + ;;(replace-match "\n")) + (let ((cycled (buffer-substring-no-properties (point-min) (point-max)))) + (should (string= org-input cycled))))) + ;; clean up + (kill-buffer (find-buffer-visiting temp-diary)) + (with-current-buffer (find-buffer-visiting temp-ics) + (set-buffer-modified-p nil) + (kill-buffer (current-buffer)))))))) (ert-deftest icalendar-cycle () "Perform cycling tests. @@ -1635,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/calendar/time-date-tests.el b/test/lisp/calendar/time-date-tests.el index 4568947c0b3..ed842e34fd6 100644 --- a/test/lisp/calendar/time-date-tests.el +++ b/test/lisp/calendar/time-date-tests.el @@ -41,6 +41,13 @@ (encode-time-value 1 2 3 4 3)) '(1 2 3 4)))) +(ert-deftest test-date-to-time () + (should (equal (format-time-string "%F %T" (date-to-time "2021-12-04")) + "2021-12-04 00:00:00"))) + +(ert-deftest test-days-between () + (should (equal (days-between "2021-10-22" "2020-09-29") 388))) + (ert-deftest test-leap-year () (should-not (date-leap-year-p 1999)) (should-not (date-leap-year-p 1900)) @@ -48,13 +55,13 @@ (should (date-leap-year-p 2004))) (ert-deftest test-days-to-time () - (should (equal (days-to-time 0) '(0 0))) - (should (equal (days-to-time 1) '(1 20864))) - (should (equal (days-to-time 999) '(1317 2688))) - (should (equal (days-to-time 0.0) '(0 0 0 0))) - (should (equal (days-to-time 0.5) '(0 43200 0 0))) - (should (equal (days-to-time 1.0) '(1 20864 0 0))) - (should (equal (days-to-time 999.0) '(1317 2688 0 0)))) + (should (time-equal-p (days-to-time 0) '(0 0))) + (should (time-equal-p (days-to-time 1) '(1 20864))) + (should (time-equal-p (days-to-time 999) '(1317 2688))) + (should (time-equal-p (days-to-time 0.0) '(0 0 0 0))) + (should (time-equal-p (days-to-time 0.5) '(0 43200 0 0))) + (should (time-equal-p (days-to-time 1.0) '(1 20864 0 0))) + (should (time-equal-p (days-to-time 999.0) '(1317 2688 0 0)))) (ert-deftest test-seconds-to-string () (should (equal (seconds-to-string 0) "0s")) @@ -163,7 +170,8 @@ (ert-deftest test-time-since () (should (time-equal-p 0 (time-since nil))) - (should (= (cadr (time-since (time-subtract (current-time) 1))) 1))) + (should (time-equal-p 1 (time-convert (time-since (time-subtract nil 1)) + 'integer)))) (ert-deftest test-time-decoded-period () (should (equal (decoded-time-period '(nil nil 1 nil nil nil nil nil nil)) diff --git a/test/lisp/calendar/todo-mode-tests.el b/test/lisp/calendar/todo-mode-tests.el index 9b5d990b9bd..79978a2041f 100644 --- a/test/lisp/calendar/todo-mode-tests.el +++ b/test/lisp/calendar/todo-mode-tests.el @@ -37,25 +37,24 @@ (defmacro with-todo-test (&rest body) "Set up an isolated `todo-mode' test environment." (declare (debug (body))) - `(let* ((todo-test-home (make-temp-file "todo-test-home-" t)) - ;; Since we change HOME, clear this to avoid a conflict - ;; e.g. if Emacs runs within the user's home directory. - (abbreviated-home-dir nil) - (process-environment (cons (format "HOME=%s" todo-test-home) - process-environment)) - (todo-directory (ert-resource-directory)) - (todo-default-todo-file (todo-short-file-name - (car (funcall todo-files-function))))) - (unwind-protect - (progn ,@body) - ;; Restore pre-test-run state of test files. - (dolist (f (directory-files todo-directory)) - (let ((buf (get-file-buffer f))) - (when buf - (with-current-buffer buf - (restore-buffer-modified-p nil) - (kill-buffer))))) - (delete-directory todo-test-home t)))) + `(ert-with-temp-directory todo-test-home + (let* (;; Since we change HOME, clear this to avoid a conflict + ;; e.g. if Emacs runs within the user's home directory. + (abbreviated-home-dir nil) + (process-environment (cons (format "HOME=%s" todo-test-home) + process-environment)) + (todo-directory (ert-resource-directory)) + (todo-default-todo-file (todo-short-file-name + (car (funcall todo-files-function))))) + (unwind-protect + (progn ,@body) + ;; Restore pre-test-run state of test files. + (dolist (f (directory-files todo-directory)) + (let ((buf (get-file-buffer f))) + (when buf + (with-current-buffer buf + (restore-buffer-modified-p nil) + (kill-buffer))))))))) (defun todo-test--show (num &optional archive) "Display category NUM of test todo file. diff --git a/test/lisp/cedet/semantic/bovine/gcc-tests.el b/test/lisp/cedet/semantic/bovine/gcc-tests.el index d049f95b4cd..04a02ec03bd 100644 --- a/test/lisp/cedet/semantic/bovine/gcc-tests.el +++ b/test/lisp/cedet/semantic/bovine/gcc-tests.el @@ -127,8 +127,9 @@ gcc version 2.95.2 19991024 (release)" ;; Some macOS machines run llvm when you type gcc. (!) ;; We can't even check if it's a symlink; it's a binary placed in ;; "/usr/bin/gcc". So check the output and just skip this test if - ;; it says "Apple LLVM". - (unless (string-match "Apple LLVM" (car semantic-gcc-test-strings)) + ;; it looks like that's the case. + (unless (string-match "Apple \\(LLVM\\|clang\\)\\|Xcode\\.app" + (car semantic-gcc-test-strings)) (semantic-gcc-test-output-parser)))) ;;; gcc-tests.el ends here diff --git a/test/lisp/cedet/srecode/fields-tests.el b/test/lisp/cedet/srecode/fields-tests.el index 5f634a5e4ce..3c66f219bd6 100644 --- a/test/lisp/cedet/srecode/fields-tests.el +++ b/test/lisp/cedet/srecode/fields-tests.el @@ -57,8 +57,7 @@ It is filled with some text." (end-of-line) (forward-word -1) - (setq f (srecode-field "Test" - :name "TEST" + (setq f (srecode-field :name "TEST" :start 6 :end 8)) @@ -99,19 +98,17 @@ It is filled with some text." (reg nil) (fields (list - (srecode-field "Test1" :name "TEST-1" :start 5 :end 10) - (srecode-field "Test2" :name "TEST-2" :start 15 :end 20) - (srecode-field "Test3" :name "TEST-3" :start 25 :end 30) + (srecode-field :name "TEST-1" :start 5 :end 10) + (srecode-field :name "TEST-2" :start 15 :end 20) + (srecode-field :name "TEST-3" :start 25 :end 30) - (srecode-field "Test4" :name "TEST-4" :start 35 :end 35)) - )) + (srecode-field :name "TEST-4" :start 35 :end 35)))) (when (not (= (length srecode-field-archive) 4)) (error "Region Test: Found %d fields. Expected 4" (length srecode-field-archive))) - (setq reg (srecode-template-inserted-region "REG" - :start 4 + (setq reg (srecode-template-inserted-region :start 4 :end 40)) (srecode-overlaid-activate reg) @@ -183,10 +180,10 @@ It is filled with some text." ;; Test variable linkage. (let* ((srecode-field-archive nil) - (f1 (srecode-field "Test1" :name "TEST" :start 6 :end 8)) - (f2 (srecode-field "Test2" :name "TEST" :start 28 :end 30)) - (f3 (srecode-field "Test3" :name "NOTTEST" :start 35 :end 40)) - (reg (srecode-template-inserted-region "REG" :start 4 :end 40))) + (f1 (srecode-field :name "TEST" :start 6 :end 8)) + (f2 (srecode-field :name "TEST" :start 28 :end 30)) + (f3 (srecode-field :name "NOTTEST" :start 35 :end 40)) + (reg (srecode-template-inserted-region :start 4 :end 40))) (srecode-overlaid-activate reg) (when (not (string= (srecode-overlaid-text f1) diff --git a/test/lisp/comint-tests.el b/test/lisp/comint-tests.el index e1bac81a185..0bd5c1e9d15 100644 --- a/test/lisp/comint-tests.el +++ b/test/lisp/comint-tests.el @@ -43,6 +43,7 @@ "PIN for user:" ; Bug#35523 "Password (again):" "Enter password:" + "(user@host) Password: " ; openssh-8.6p1 "Current password:" ; "passwd" (to change password) in Debian. "Enter encryption key: " ; ccrypt "Enter decryption key: " ; ccrypt diff --git a/test/lisp/custom-tests.el b/test/lisp/custom-tests.el index f4c43b0a148..769db6ceab4 100644 --- a/test/lisp/custom-tests.el +++ b/test/lisp/custom-tests.el @@ -25,20 +25,9 @@ (require 'wid-edit) (require 'cus-edit) -(defmacro custom-tests--with-temp-dir (&rest body) - "Eval BODY with `temporary-file-directory' bound to a fresh directory. -Ensure the directory is recursively deleted after the fact." - (declare (debug t) (indent 0)) - (let ((dir (make-symbol "dir"))) - `(let ((,dir (file-name-as-directory (make-temp-file "custom-tests-" t)))) - (unwind-protect - (let ((temporary-file-directory ,dir)) - ,@body) - (delete-directory ,dir t))))) - (ert-deftest custom-theme--load-path () "Test `custom-theme--load-path' behavior." - (custom-tests--with-temp-dir + (ert-with-temp-directory temporary-file-directory ;; Path is empty. (let ((custom-theme-load-path ())) (should (null (custom-theme--load-path)))) @@ -50,28 +39,28 @@ Ensure the directory is recursively deleted after the fact." (should (null (custom-theme--load-path)))) ;; Path comprises existing file. - (let* ((file (make-temp-file "file")) - (custom-theme-load-path (list file))) - (should (file-exists-p file)) - (should (not (file-directory-p file))) - (should (null (custom-theme--load-path)))) + (ert-with-temp-file file + (let* ((custom-theme-load-path (list file))) + (should (file-exists-p file)) + (should (not (file-directory-p file))) + (should (null (custom-theme--load-path))))) ;; Path comprises existing directory. - (let* ((dir (make-temp-file "dir" t)) - (custom-theme-load-path (list dir))) - (should (file-directory-p dir)) - (should (equal (custom-theme--load-path) custom-theme-load-path))) + (ert-with-temp-directory dir + (let* ((custom-theme-load-path (list dir))) + (should (file-directory-p dir)) + (should (equal (custom-theme--load-path) custom-theme-load-path)))) ;; Expand `custom-theme-directory' path element. (let ((custom-theme-load-path '(custom-theme-directory))) (let ((custom-theme-directory (make-temp-name temporary-file-directory))) (should (not (file-exists-p custom-theme-directory))) (should (null (custom-theme--load-path)))) - (let ((custom-theme-directory (make-temp-file "file"))) + (ert-with-temp-file custom-theme-directory (should (file-exists-p custom-theme-directory)) (should (not (file-directory-p custom-theme-directory))) (should (null (custom-theme--load-path)))) - (let ((custom-theme-directory (make-temp-file "dir" t))) + (ert-with-temp-directory custom-theme-directory (should (file-directory-p custom-theme-directory)) (should (equal (custom-theme--load-path) (list custom-theme-directory))))) @@ -97,7 +86,7 @@ Ensure the directory is recursively deleted after the fact." (ert-deftest custom-tests-require-theme () "Test `require-theme'." (require 'warnings) - (custom-tests--with-temp-dir + (ert-with-temp-directory temporary-file-directory (let* ((default-directory temporary-file-directory) (custom-theme-load-path (list default-directory)) (load-path ())) diff --git a/test/lisp/dired-aux-tests.el b/test/lisp/dired-aux-tests.el index d5940ed8ca7..69fc95ba552 100644 --- a/test/lisp/dired-aux-tests.el +++ b/test/lisp/dired-aux-tests.el @@ -19,26 +19,25 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'dired-aux) (eval-when-compile (require 'cl-lib)) (ert-deftest dired-test-bug27496 () "Test for https://debbugs.gnu.org/27496 ." (skip-unless (executable-find shell-file-name)) - (let* ((foo (make-temp-file "foo")) - (files (list foo))) - (unwind-protect - (cl-letf (((symbol-function 'read-char-from-minibuffer) 'error)) - (dired temporary-file-directory) - (dired-goto-file foo) - ;; `dired-do-shell-command' returns nil on success. - (should-error (dired-do-shell-command "ls ? ./?" nil files)) - (should-error (dired-do-shell-command "ls ./? ?" nil files)) - (should-not (dired-do-shell-command "ls ? ?" nil files)) - (should-error (dired-do-shell-command "ls * ./*" nil files)) - (should-not (dired-do-shell-command "ls * *" nil files)) - (should-not (dired-do-shell-command "ls ? ./`?`" nil files))) - (delete-file foo)))) + (ert-with-temp-file foo + (let* ((files (list foo))) + (cl-letf (((symbol-function 'read-char-from-minibuffer) 'error)) + (dired temporary-file-directory) + (dired-goto-file foo) + ;; `dired-do-shell-command' returns nil on success. + (should-error (dired-do-shell-command "ls ? ./?" nil files)) + (should-error (dired-do-shell-command "ls ./? ?" nil files)) + (should-not (dired-do-shell-command "ls ? ?" nil files)) + (should-error (dired-do-shell-command "ls * ./*" nil files)) + (should-not (dired-do-shell-command "ls * *" nil files)) + (should-not (dired-do-shell-command "ls ? ./`?`" nil files)))))) ;; Auxiliary macro for `dired-test-bug28834': it binds ;; `dired-create-destination-dirs' to CREATE-DIRS and execute BODY. @@ -47,28 +46,25 @@ (defmacro with-dired-bug28834-test (create-dirs yes-or-no &rest body) (declare (debug (form symbolp body))) (let ((foo (make-symbol "foo"))) - `(let* ((,foo (make-temp-file "foo" 'dir)) - (dired-create-destination-dirs ,create-dirs)) - (setq from (make-temp-file "from")) - (setq to-cp - (expand-file-name - "foo-cp" (file-name-as-directory (expand-file-name "bar" ,foo)))) - (setq to-mv - (expand-file-name - "foo-mv" (file-name-as-directory (expand-file-name "qux" ,foo)))) - (unwind-protect - (if ,yes-or-no - (cl-letf (((symbol-function 'yes-or-no-p) - (lambda (_prompt) (eq ,yes-or-no 'yes)))) - ,@body) - ,@body) - ;; clean up - (delete-directory ,foo 'recursive) - (delete-file from))))) + `(ert-with-temp-directory ,foo + (ert-with-temp-file from + (let* ((dired-create-destination-dirs ,create-dirs)) + (setq to-cp + (expand-file-name + "foo-cp" (file-name-as-directory (expand-file-name "bar" ,foo)))) + (setq to-mv + (expand-file-name + "foo-mv" (file-name-as-directory (expand-file-name "qux" ,foo)))) + (unwind-protect + (if ,yes-or-no + (cl-letf (((symbol-function 'yes-or-no-p) + (lambda (_prompt) (eq ,yes-or-no 'yes)))) + ,@body) + ,@body))))))) (ert-deftest dired-test-bug28834 () "test for https://debbugs.gnu.org/28834 ." - (let (from to-cp to-mv) + (let (to-cp to-mv) ;; `dired-create-destination-dirs' set to 'always. (with-dired-bug28834-test 'always nil diff --git a/test/lisp/dired-resources/insert-directory/test_dir/bar b/test/lisp/dired-resources/insert-directory/test_dir/bar new file mode 100644 index 00000000000..e69de29bb2d --- /dev/null +++ b/test/lisp/dired-resources/insert-directory/test_dir/bar diff --git a/test/lisp/dired-resources/insert-directory/test_dir/foo b/test/lisp/dired-resources/insert-directory/test_dir/foo new file mode 100644 index 00000000000..e69de29bb2d --- /dev/null +++ b/test/lisp/dired-resources/insert-directory/test_dir/foo diff --git a/test/lisp/dired-resources/insert-directory/test_dir_other/bar b/test/lisp/dired-resources/insert-directory/test_dir_other/bar new file mode 100644 index 00000000000..e69de29bb2d --- /dev/null +++ b/test/lisp/dired-resources/insert-directory/test_dir_other/bar diff --git a/test/lisp/dired-resources/insert-directory/test_dir_other/foo b/test/lisp/dired-resources/insert-directory/test_dir_other/foo new file mode 100644 index 00000000000..e69de29bb2d --- /dev/null +++ b/test/lisp/dired-resources/insert-directory/test_dir_other/foo diff --git a/test/lisp/dired-tests.el b/test/lisp/dired-tests.el index 83f7dc3cac7..1c4f37bd327 100644 --- a/test/lisp/dired-tests.el +++ b/test/lisp/dired-tests.el @@ -19,6 +19,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'dired) (ert-deftest dired-autoload () @@ -141,116 +142,113 @@ (ert-deftest dired-test-bug27243-01 () "Test for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27243#5 ." - (let* ((test-dir (file-name-as-directory (make-temp-file "test-dir-" t))) - (save-pos (lambda () - (with-current-buffer (car (dired-buffers-for-dir test-dir)) - (dired-save-positions)))) - (dired-auto-revert-buffer t) buffers) - ;; On MS-Windows, get rid of 8+3 short names in test-dir, if the - ;; corresponding long file names exist, otherwise such names trip - ;; dired-buffers-for-dir. - (if (eq system-type 'windows-nt) - (setq test-dir (file-truename test-dir))) - (should-not (dired-buffers-for-dir test-dir)) - (with-current-buffer (find-file-noselect test-dir) - (make-directory "test-subdir")) - (message "Saved pos: %S" (funcall save-pos)) - ;; Point must be at end-of-buffer. - (with-current-buffer (car (dired-buffers-for-dir test-dir)) - (should (eobp))) - (push (dired test-dir) buffers) - (message "Saved pos: %S" (funcall save-pos)) - ;; Previous dired call shouldn't create a new buffer: must visit the one - ;; created by `find-file-noselect' above. - (should (eq 1 (length (dired-buffers-for-dir test-dir)))) - (unwind-protect - (let ((buf (current-buffer)) - (pt1 (point)) - (test-file (concat (file-name-as-directory "test-subdir") - "test-file"))) - (message "Saved pos: %S" (funcall save-pos)) - (write-region "Test" nil test-file nil 'silent nil 'excl) - (message "Saved pos: %S" (funcall save-pos)) - ;; Sanity check: point should now be on the subdirectory. - (should (equal (dired-file-name-at-point) - (concat test-dir (file-name-as-directory "test-subdir")))) - (message "Saved pos: %S" (funcall save-pos)) - (push (dired-find-file) buffers) - (let ((pt2 (point))) ; Point is on test-file. - (pop-to-buffer-same-window buf) - ;; Sanity check: point should now be back on the subdirectory. - (should (eq (point) pt1)) + (ert-with-temp-directory test-dir + (let* ((save-pos (lambda () + (with-current-buffer (car (dired-buffers-for-dir test-dir)) + (dired-save-positions)))) + (dired-auto-revert-buffer t) buffers) + ;; On MS-Windows, get rid of 8+3 short names in test-dir, if the + ;; corresponding long file names exist, otherwise such names trip + ;; dired-buffers-for-dir. + (if (eq system-type 'windows-nt) + (setq test-dir (file-truename test-dir))) + (should-not (dired-buffers-for-dir test-dir)) + (with-current-buffer (find-file-noselect test-dir) + (make-directory "test-subdir")) + (message "Saved pos: %S" (funcall save-pos)) + ;; Point must be at end-of-buffer. + (with-current-buffer (car (dired-buffers-for-dir test-dir)) + (should (eobp))) + (push (dired test-dir) buffers) + (message "Saved pos: %S" (funcall save-pos)) + ;; Previous dired call shouldn't create a new buffer: must visit the one + ;; created by `find-file-noselect' above. + (should (eq 1 (length (dired-buffers-for-dir test-dir)))) + (unwind-protect + (let ((buf (current-buffer)) + (pt1 (point)) + (test-file (concat (file-name-as-directory "test-subdir") + "test-file"))) + (message "Saved pos: %S" (funcall save-pos)) + (write-region "Test" nil test-file nil 'silent nil 'excl) + (message "Saved pos: %S" (funcall save-pos)) + ;; Sanity check: point should now be on the subdirectory. + (should (equal (dired-file-name-at-point) + (concat test-dir (file-name-as-directory "test-subdir")))) + (message "Saved pos: %S" (funcall save-pos)) (push (dired-find-file) buffers) - (should (eq (point) pt2)))) - (dolist (buf buffers) - (when (buffer-live-p buf) (kill-buffer buf))) - (delete-directory test-dir t)))) + (let ((pt2 (point))) ; Point is on test-file. + (pop-to-buffer-same-window buf) + ;; Sanity check: point should now be back on the subdirectory. + (should (eq (point) pt1)) + (push (dired-find-file) buffers) + (should (eq (point) pt2)))) + (dolist (buf buffers) + (when (buffer-live-p buf) (kill-buffer buf))))))) (ert-deftest dired-test-bug27243-02 () "Test for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27243#28 ." - (let ((test-dir (make-temp-file "test-dir-" t)) - (dired-auto-revert-buffer t) buffers) - ;; On MS-Windows, get rid of 8+3 short names in test-dir, if the - ;; corresponding long file names exist, otherwise such names trip - ;; string comparisons below. - (if (eq system-type 'windows-nt) - (setq test-dir (file-truename test-dir))) - (with-current-buffer (find-file-noselect test-dir) - (make-directory "test-subdir")) - (push (dired test-dir) buffers) - (unwind-protect - (let ((buf (current-buffer)) - (pt1 (point)) - (test-file (concat (file-name-as-directory "test-subdir") - "test-file"))) - (write-region "Test" nil test-file nil 'silent nil 'excl) - ;; Sanity check: point should now be on the subdirectory. - (should (equal (dired-file-name-at-point) - (concat (file-name-as-directory test-dir) - (file-name-as-directory "test-subdir")))) - (push (dired-find-file) buffers) - ;; Point is on test-file. - (switch-to-buffer buf) - ;; Sanity check: point should now be back on the subdirectory. - (should (eq (point) pt1)) - (push (dired test-dir) buffers) - (should (eq (point) pt1))) - (dolist (buf buffers) - (when (buffer-live-p buf) (kill-buffer buf))) - (delete-directory test-dir t)))) + (ert-with-temp-directory test-dir + (let ((dired-auto-revert-buffer t) buffers) + ;; On MS-Windows, get rid of 8+3 short names in test-dir, if the + ;; corresponding long file names exist, otherwise such names trip + ;; string comparisons below. + (if (eq system-type 'windows-nt) + (setq test-dir (file-truename test-dir))) + (with-current-buffer (find-file-noselect test-dir) + (make-directory "test-subdir")) + (push (dired test-dir) buffers) + (unwind-protect + (let ((buf (current-buffer)) + (pt1 (point)) + (test-file (concat (file-name-as-directory "test-subdir") + "test-file"))) + (write-region "Test" nil test-file nil 'silent nil 'excl) + ;; Sanity check: point should now be on the subdirectory. + (should (equal (dired-file-name-at-point) + (concat (file-name-as-directory test-dir) + (file-name-as-directory "test-subdir")))) + (push (dired-find-file) buffers) + ;; Point is on test-file. + (switch-to-buffer buf) + ;; Sanity check: point should now be back on the subdirectory. + (should (eq (point) pt1)) + (push (dired test-dir) buffers) + (should (eq (point) pt1))) + (dolist (buf buffers) + (when (buffer-live-p buf) (kill-buffer buf))))))) (ert-deftest dired-test-bug27243-03 () "Test for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27243#61 ." - (let ((test-dir (make-temp-file "test-dir-" t)) - (dired-auto-revert-buffer t) - allbufs) - (unwind-protect - (progn - (with-current-buffer (find-file-noselect test-dir) - (push (current-buffer) allbufs) - (make-directory "test-subdir1") - (make-directory "test-subdir2") - (let ((test-file1 "test-file1") - (test-file2 "test-file2")) - (with-current-buffer (find-file-noselect "test-subdir1") - (push (current-buffer) allbufs) - (write-region "Test1" nil test-file1 nil 'silent nil 'excl)) - (with-current-buffer (find-file-noselect "test-subdir2") - (push (current-buffer) allbufs) - (write-region "Test2" nil test-file2 nil 'silent nil 'excl)))) - ;; Call find-file with a wild card and test point in each file. - (let ((buffers (find-file (concat (file-name-as-directory test-dir) - "*") - t))) - (dolist (buf buffers) - (let ((pt (with-current-buffer buf (point)))) - (switch-to-buffer (find-file-noselect test-dir)) - (find-file (buffer-name buf)) - (should (equal (point) pt)))) - (append buffers allbufs))) - (dolist (buf allbufs) - (when (buffer-live-p buf) (kill-buffer buf))) - (delete-directory test-dir t)))) + (ert-with-temp-directory test-dir + (let ((dired-auto-revert-buffer t) + allbufs) + (unwind-protect + (progn + (with-current-buffer (find-file-noselect test-dir) + (push (current-buffer) allbufs) + (make-directory "test-subdir1") + (make-directory "test-subdir2") + (let ((test-file1 "test-file1") + (test-file2 "test-file2")) + (with-current-buffer (find-file-noselect "test-subdir1") + (push (current-buffer) allbufs) + (write-region "Test1" nil test-file1 nil 'silent nil 'excl)) + (with-current-buffer (find-file-noselect "test-subdir2") + (push (current-buffer) allbufs) + (write-region "Test2" nil test-file2 nil 'silent nil 'excl)))) + ;; Call find-file with a wild card and test point in each file. + (let ((buffers (find-file (concat (file-name-as-directory test-dir) + "*") + t))) + (dolist (buf buffers) + (let ((pt (with-current-buffer buf (point)))) + (switch-to-buffer (find-file-noselect test-dir)) + (find-file (buffer-name buf)) + (should (equal (point) pt)))) + (append buffers allbufs))) + (dolist (buf allbufs) + (when (buffer-live-p buf) (kill-buffer buf))))))) (ert-deftest dired-test-bug7131 () "Test for https://debbugs.gnu.org/7131 ." @@ -274,22 +272,21 @@ ;; ls-lisp-tests.el and em-ls-tests.el. (skip-unless (and (not (featurep 'ls-lisp)) (not (featurep 'eshell)))) - (let* ((dir (make-temp-file "bug27631" 'dir)) - (dir1 (expand-file-name "dir1" dir)) - (dir2 (expand-file-name "dir2" dir)) - (default-directory dir) - buf) - (unwind-protect - (progn - (make-directory dir1) - (make-directory dir2) - (with-temp-file (expand-file-name "a.txt" dir1)) - (with-temp-file (expand-file-name "b.txt" dir2)) - (setq buf (dired (expand-file-name "dir*/*.txt" dir))) - (dired-toggle-marks) - (should (cdr (dired-get-marked-files)))) - (delete-directory dir 'recursive) - (when (buffer-live-p buf) (kill-buffer buf))))) + (ert-with-temp-directory dir + (let* ((dir1 (expand-file-name "dir1" dir)) + (dir2 (expand-file-name "dir2" dir)) + (default-directory dir) + buf) + (unwind-protect + (progn + (make-directory dir1) + (make-directory dir2) + (with-temp-file (expand-file-name "a.txt" dir1)) + (with-temp-file (expand-file-name "b.txt" dir2)) + (setq buf (dired (expand-file-name "dir*/*.txt" dir))) + (dired-toggle-marks) + (should (cdr (dired-get-marked-files)))) + (when (buffer-live-p buf) (kill-buffer buf)))))) (ert-deftest dired-test-bug27899 () "Test for https://debbugs.gnu.org/27899 ." @@ -310,72 +307,69 @@ (ert-deftest dired-test-bug27968 () "Test for https://debbugs.gnu.org/27968 ." - (let* ((top-dir (make-temp-file "top-dir" t)) - (subdir (expand-file-name "subdir" top-dir)) - (header-len-fn (lambda () - (save-excursion - (goto-char 1) - (forward-line 1) - (- (point-at-eol) (point))))) - orig-len len diff pos line-nb) - (make-directory subdir 'parents) - (unwind-protect - (with-current-buffer (dired-noselect subdir) - (setq orig-len (funcall header-len-fn) - pos (point) - line-nb (line-number-at-pos)) - ;; Bug arises when the header line changes its length; this may - ;; happen if the used space has changed: for instance, with the - ;; creation of additional files. - (make-directory "subdir" t) - (dired-revert) - ;; Change the header line. - (save-excursion - (goto-char 1) - (forward-line 1) - (let ((inhibit-read-only t) - (new-header " test-bug27968")) - (delete-region (point) (point-at-eol)) - (when (= orig-len (length new-header)) - ;; Wow lucky guy! I must buy lottery today. - (setq new-header (concat new-header " :-)"))) - (insert new-header))) - (setq len (funcall header-len-fn) - diff (- len orig-len)) - (should-not (zerop diff)) ; Header length has changed. - ;; If diff > 0, then the point moves back. - ;; If diff < 0, then the point moves forward. - ;; If diff = 0, then the point doesn't move. - ;; Sometimes this point movement causes - ;; line-nb != (line-number-at-pos pos), so that we get - ;; an unexpected file at point if we store buffer points. - ;; Note that the line number before/after revert - ;; doesn't change. - (should (= line-nb - (line-number-at-pos) - (line-number-at-pos (+ pos diff)))) - ;; After revert, the point must be in 'subdir' line. - (should (equal "subdir" (dired-get-filename 'local t)))) - (delete-directory top-dir t)))) + (ert-with-temp-directory top-dir + (let* ((subdir (expand-file-name "subdir" top-dir)) + (header-len-fn (lambda () + (save-excursion + (goto-char 1) + (forward-line 1) + (- (point-at-eol) (point))))) + orig-len len diff pos line-nb) + (make-directory subdir 'parents) + (with-current-buffer (dired-noselect subdir) + (setq orig-len (funcall header-len-fn) + pos (point) + line-nb (line-number-at-pos)) + ;; Bug arises when the header line changes its length; this may + ;; happen if the used space has changed: for instance, with the + ;; creation of additional files. + (make-directory "subdir" t) + (dired-revert) + ;; Change the header line. + (save-excursion + (goto-char 1) + (forward-line 1) + (let ((inhibit-read-only t) + (new-header " test-bug27968")) + (delete-region (point) (point-at-eol)) + (when (= orig-len (length new-header)) + ;; Wow lucky guy! I must buy lottery today. + (setq new-header (concat new-header " :-)"))) + (insert new-header))) + (setq len (funcall header-len-fn) + diff (- len orig-len)) + (should-not (zerop diff)) ; Header length has changed. + ;; If diff > 0, then the point moves back. + ;; If diff < 0, then the point moves forward. + ;; If diff = 0, then the point doesn't move. + ;; Sometimes this point movement causes + ;; line-nb != (line-number-at-pos pos), so that we get + ;; an unexpected file at point if we store buffer points. + ;; Note that the line number before/after revert + ;; doesn't change. + (should (= line-nb + (line-number-at-pos) + (line-number-at-pos (+ pos diff)))) + ;; After revert, the point must be in 'subdir' line. + (should (equal "subdir" (dired-get-filename 'local t))))))) (defmacro dired-test-with-temp-dirs (just-empty-dirs &rest body) "Helper macro for Bug#27940 test." (declare (indent 1) (debug body)) (let ((dir (make-symbol "dir"))) - `(let* ((,dir (make-temp-file "bug27940" t)) - (dired-deletion-confirmer (lambda (_) "yes")) ; Suppress prompts. - (inhibit-message t) - (default-directory ,dir)) - (dotimes (i 5) (make-directory (format "empty-dir-%d" i))) - (unless ,just-empty-dirs - (dotimes (i 5) (make-directory (format "non-empty-%d/foo" i) 'parents))) - (make-directory "zeta-empty-dir") - (unwind-protect - (progn - ,@body) - (delete-directory ,dir t) - (kill-buffer (current-buffer)))))) + `(ert-with-temp-directory ,dir + (let* ((dired-deletion-confirmer (lambda (_) "yes")) ; Suppress prompts. + (inhibit-message t) + (default-directory ,dir)) + (dotimes (i 5) (make-directory (format "empty-dir-%d" i))) + (unless ,just-empty-dirs + (dotimes (i 5) (make-directory (format "non-empty-%d/foo" i) 'parents))) + (make-directory "zeta-empty-dir") + (unwind-protect + (progn + ,@body) + (kill-buffer (current-buffer))))))) (ert-deftest dired-test-bug27940 () "Test for https://debbugs.gnu.org/27940 ." @@ -517,5 +511,92 @@ (when (file-directory-p testdir) (delete-directory testdir t))))) +;; `dired-insert-directory' output tests. +(let* ((data-dir "insert-directory") + (test-dir (file-name-as-directory + (ert-resource-file + (concat data-dir "/test_dir")))) + (test-dir-other (file-name-as-directory + (ert-resource-file + (concat data-dir "/test_dir_other")))) + (test-files `(,test-dir "foo" "bar")) ;expected files to be found + ;; Free space test data for `insert-directory'. + ;; Meaning: (path free-space-bytes-to-stub expected-free-space-string) + (free-data `((,test-dir 10 "available 10 B") + (,test-dir-other 100 "available 100 B") + (:default 999 "available 999 B")))) + + (defun files-tests--look-up-free-data (path) + "Look up free space test data, with a default for unspecified paths." + (let ((path (file-name-as-directory path))) + (cdr (or (assoc path free-data) + (assoc :default free-data))))) + + (defun files-tests--make-file-system-info-stub (&optional static-path) + "Return a stub for `file-system-info' using dynamic or static test data. +If that data should be static, pass STATIC-PATH to choose which +path's data to use." + (lambda (path) + (let* ((path (cond (static-path) + ;; file-system-info knows how to handle ".", so we + ;; do the same thing + ((equal "." path) default-directory) + (path))) + (return-size + ;; It is always defined but this silences the byte-compiler: + (when (fboundp 'files-tests--look-up-free-data) + (car (files-tests--look-up-free-data path))))) + (list return-size return-size return-size)))) + + (defun files-tests--insert-directory-output (dir &optional _verbose) + "Run `insert-directory' and return its output." + (with-current-buffer-window "files-tests--insert-directory" nil nil + (let ((dired-free-space 'separate)) + (dired-insert-directory dir "-l" nil nil t)) + (buffer-substring-no-properties (point-min) (point-max)))) + + (ert-deftest files-tests-insert-directory-shows-files () + "Verify `insert-directory' reports the files in the directory." + ;; It is always defined but this silences the byte-compiler: + (when (fboundp 'files-tests--insert-directory-output) + (let* ((test-dir (car test-files)) + (files (cdr test-files)) + (output (files-tests--insert-directory-output test-dir))) + (dolist (file files) + (should (string-match-p file output)))))) + + (defun files-tests--insert-directory-shows-given-free (dir &optional + info-func) + "Run `insert-directory' and verify it reports the correct available space. +Stub `file-system-info' to ensure the available space is consistent, +either with the given stub function or a default one using test data." + ;; It is always defined but this silences the byte-compiler: + (when (and (fboundp 'files-tests--make-file-system-info-stub) + (fboundp 'files-tests--look-up-free-data) + (fboundp 'files-tests--insert-directory-output)) + (cl-letf (((symbol-function 'file-system-info) + (or info-func + (files-tests--make-file-system-info-stub)))) + (should (string-match-p (cadr + (files-tests--look-up-free-data dir)) + (files-tests--insert-directory-output dir t)))))) + + (ert-deftest files-tests-insert-directory-shows-free () + "Test that verbose `insert-directory' shows the correct available space." + ;; It is always defined but this silences the byte-compiler: + (when (and (fboundp 'files-tests--insert-directory-shows-given-free) + (fboundp 'files-tests--make-file-system-info-stub)) + (files-tests--insert-directory-shows-given-free + test-dir + (files-tests--make-file-system-info-stub test-dir)))) + + (ert-deftest files-tests-bug-50630 () + "Verify verbose `insert-directory' shows free space of the target directory. +The current directory at call time should not affect the result (Bug#50630)." + ;; It is always defined but this silences the byte-compiler: + (when (fboundp 'files-tests--insert-directory-shows-given-free) + (let ((default-directory test-dir-other)) + (files-tests--insert-directory-shows-given-free test-dir))))) + (provide 'dired-tests) ;;; dired-tests.el ends here diff --git a/test/lisp/dired-x-tests.el b/test/lisp/dired-x-tests.el index d00815e543c..69c88c060a1 100644 --- a/test/lisp/dired-x-tests.el +++ b/test/lisp/dired-x-tests.el @@ -19,6 +19,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'dired-x) @@ -31,23 +32,20 @@ (append (copy-sequence dirs) (delete "c" (copy-sequence files))) #'string<)) - (dir (make-temp-file "Bug25942" 'dir)) (extension "c")) - (unwind-protect - (progn - (dolist (d dirs) - (make-directory (expand-file-name d dir))) - (dolist (f files) - (write-region nil nil (expand-file-name f dir))) - (dired dir) - (dired-mark-extension extension) - (should (equal '("bar.c" "foo.c") - (sort (dired-get-marked-files 'local) #'string<))) - (dired-unmark-all-marks) - (dired-mark-suffix extension) - (should (equal all-but-c - (sort (dired-get-marked-files 'local) #'string<)))) - (delete-directory dir 'recursive)))) + (ert-with-temp-directory dir + (dolist (d dirs) + (make-directory (expand-file-name d dir))) + (dolist (f files) + (write-region nil nil (expand-file-name f dir))) + (dired dir) + (dired-mark-extension extension) + (should (equal '("bar.c" "foo.c") + (sort (dired-get-marked-files 'local) #'string<))) + (dired-unmark-all-marks) + (dired-mark-suffix extension) + (should (equal all-but-c + (sort (dired-get-marked-files 'local) #'string<)))))) (ert-deftest dired-guess-default () (let ((dired-guess-shell-alist-user nil) @@ -62,5 +60,15 @@ (should (equal (dired-guess-default '("/tmp/foo.png" "/tmp/foo.txt")) nil)))) +(ert-deftest dired-x--string-to-number () + (should (= (dired-x--string-to-number "2.4K") 2457.6)) + (should (= (dired-x--string-to-number "2400") 2400)) + (should (= (dired-x--string-to-number "123.4M") 129394278.4)) + (should (= (dired-x--string-to-number "123.40000M") 129394278.4)) + (should (= (dired-x--string-to-number "4.134") 4134)) + (should (= (dired-x--string-to-number "4,134") 4134)) + (should (= (dired-x--string-to-number "4 134") 4134)) + (should (= (dired-x--string-to-number "41,52,134") 4152134))) + (provide 'dired-x-tests) ;;; dired-x-tests.el ends here diff --git a/test/lisp/edmacro-tests.el b/test/lisp/edmacro-tests.el new file mode 100644 index 00000000000..974f506a367 --- /dev/null +++ b/test/lisp/edmacro-tests.el @@ -0,0 +1,47 @@ +;;; edmacro-tests.el --- Tests for edmacro.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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'edmacro) + +(ert-deftest edmacro-test-edmacro-parse-keys () + (should (equal (edmacro-parse-keys "") "")) + (should (equal (edmacro-parse-keys "x") "x")) + (should (equal (edmacro-parse-keys "C-a") "\C-a")) + + ;; comments + (should (equal (edmacro-parse-keys ";; foobar") "")) + (should (equal (edmacro-parse-keys ";;;") "")) + (should (equal (edmacro-parse-keys "; ; ;") ";;;")) + (should (equal (edmacro-parse-keys "REM foobar") "")) + (should (equal (edmacro-parse-keys "x ;; foobar") "x")) + (should (equal (edmacro-parse-keys "x REM foobar") "x")) + (should (equal (edmacro-parse-keys "<<goto-line>>") + [134217848 103 111 116 111 45 108 105 110 101 13])) + + ;; repetitions + (should (equal (edmacro-parse-keys "3*x") "xxx")) + (should (equal (edmacro-parse-keys "3*C-m") "\C-m\C-m\C-m")) + (should (equal (edmacro-parse-keys "10*foo") "foofoofoofoofoofoofoofoofoofoo"))) + +;;; edmacro-tests.el ends here diff --git a/test/lisp/electric-tests.el b/test/lisp/electric-tests.el index f59f9d9ccac..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) @@ -176,7 +176,7 @@ The buffer's contents should %s: expected-string expected-point bindings - (modes '(quote (ruby-mode js-mode python-mode))) + (modes '(quote (ruby-mode js-mode python-mode c-mode))) (test-in-comments t) (test-in-strings t) (test-in-code t) @@ -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 @@ -428,7 +428,9 @@ baz\"\"" :bindings '((electric-pair-skip-whitespace . chomp)) :test-in-strings nil :test-in-code nil - :test-in-comments t) + :test-in-comments t + :fixture-fn (lambda () (when (eq major-mode 'c-mode) + (c-toggle-comment-style -1)))) (define-electric-pair-test whitespace-skipping-for-quotes-not-outside " \" \"" "\"-----" :expected-string "\"\" \" \"" @@ -548,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}\\{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 a6e224b3d2c..a442eb473be 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -640,6 +640,58 @@ inner loops respectively." (f (list (lambda (x) (setq a x))))) (funcall (car f) 3) (list a b)) + + (cond) + (mapcar (lambda (x) (cond ((= x 0)))) '(0 1)) + + ;; These expressions give different results in lexbind and dynbind modes, + ;; but in each the compiler and interpreter should agree! + ;; (They look much the same but come in pairs exercising both the + ;; `let' and `let*' paths.) + (let ((f (lambda (x) + (lambda () + (let ((g (lambda () x))) + (let ((x 'a)) + (list x (funcall g)))))))) + (funcall (funcall f 'b))) + (let ((f (lambda (x) + (lambda () + (let ((g (lambda () x))) + (let* ((x 'a)) + (list x (funcall g)))))))) + (funcall (funcall f 'b))) + (let ((f (lambda (x) + (lambda () + (let ((g (lambda () x))) + (setq x (list x x)) + (let ((x 'a)) + (list x (funcall g)))))))) + (funcall (funcall f 'b))) + (let ((f (lambda (x) + (lambda () + (let ((g (lambda () x))) + (setq x (list x x)) + (let* ((x 'a)) + (list x (funcall g)))))))) + (funcall (funcall f 'b))) + (let ((f (lambda (x) + (let ((g (lambda () x)) + (h (lambda () (setq x (list x x))))) + (let ((x 'a)) + (list x (funcall g) (funcall h))))))) + (funcall (funcall f 'b))) + (let ((f (lambda (x) + (let ((g (lambda () x)) + (h (lambda () (setq x (list x x))))) + (let* ((x 'a)) + (list x (funcall g) (funcall h))))))) + (funcall (funcall f 'b))) + + ;; Test constant-propagation of access to captured variables. + (let* ((x 2) + (f (lambda () + (let ((y x)) (list y 3 y))))) + (funcall f)) ) "List of expressions for cross-testing interpreted and compiled code.") @@ -690,24 +742,19 @@ byte-compiled. Run with dynamic binding." (defun test-byte-comp-compile-and-load (compile &rest forms) (declare (indent 1)) - (let ((elfile nil) - (elcfile nil)) - (unwind-protect - (progn - (setf elfile (make-temp-file "test-bytecomp" nil ".el")) - (when compile - (setf elcfile (make-temp-file "test-bytecomp" nil ".elc"))) - (with-temp-buffer - (dolist (form forms) - (print form (current-buffer))) - (write-region (point-min) (point-max) elfile nil 'silent)) - (if compile - (let ((byte-compile-dest-file-function - (lambda (e) elcfile))) - (byte-compile-file elfile))) - (load elfile nil 'nomessage)) - (when elfile (delete-file elfile)) - (when elcfile (delete-file elcfile))))) + (ert-with-temp-file elfile + :suffix ".el" + (ert-with-temp-file elcfile + :suffix ".elc" + (with-temp-buffer + (dolist (form forms) + (print form (current-buffer))) + (write-region (point-min) (point-max) elfile nil 'silent)) + (if compile + (let ((byte-compile-dest-file-function + (lambda (e) elcfile))) + (byte-compile-file elfile))) + (load elfile nil 'nomessage)))) (ert-deftest test-byte-comp-macro-expansion () (test-byte-comp-compile-and-load t @@ -810,8 +857,7 @@ byte-compiled. Run with dynamic binding." (byte-compile-file ,(ert-resource-file file)) (ert-info ((buffer-string) :prefix "buffer: ") (,(if reverse 'should-not 'should) - (re-search-forward ,(string-replace " " "[ \n]+" re-warning) - nil t)))))) + (re-search-forward ,re-warning nil t)))))) (bytecomp--define-warning-file-test "error-lexical-var-with-add-hook.el" "add-hook.*lexical var") @@ -939,7 +985,7 @@ byte-compiled. Run with dynamic binding." (bytecomp--define-warning-file-test "warn-wide-docstring-defun.el" - "wider than .* characters") + "Warning: docstring wider than .* characters") (bytecomp--define-warning-file-test "warn-wide-docstring-defvar.el" @@ -958,6 +1004,10 @@ byte-compiled. Run with dynamic binding." "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) @@ -1013,10 +1063,9 @@ byte-compiled. Run with dynamic binding." (defmacro bytecomp-tests--with-temp-file (file-name-var &rest body) (declare (indent 1)) (cl-check-type file-name-var symbol) - `(let ((,file-name-var (make-temp-file "emacs"))) + `(ert-with-temp-file ,file-name-var (unwind-protect (progn ,@body) - (delete-file ,file-name-var) (let ((elc (concat ,file-name-var ".elc"))) (if (file-exists-p elc) (delete-file elc)))))) @@ -1243,25 +1292,25 @@ literals (Bug#20852)." (ert-deftest bytecomp-tests--not-writable-directory () "Test that byte compilation works if the output directory isn't writable (Bug#44631)." - (let ((directory (make-temp-file "bytecomp-tests-" :directory))) - (unwind-protect - (let* ((input-file (expand-file-name "test.el" directory)) - (output-file (expand-file-name "test.elc" directory)) - (byte-compile-dest-file-function - (lambda (_) output-file)) - (byte-compile-error-on-warn t)) - (write-region "" nil input-file nil nil nil 'excl) - (write-region "" nil output-file nil nil nil 'excl) - (set-file-modes input-file #o400) - (set-file-modes output-file #o200) - (set-file-modes directory #o500) - (should (byte-compile-file input-file)) - (should (file-regular-p output-file)) - (should (cl-plusp (file-attribute-size - (file-attributes output-file))))) - (with-demoted-errors "Error cleaning up directory: %s" - (set-file-modes directory #o700) - (delete-directory directory :recursive))))) + (ert-with-temp-directory directory + (let* ((input-file (expand-file-name "test.el" directory)) + (output-file (expand-file-name "test.elc" directory)) + (byte-compile-dest-file-function + (lambda (_) output-file)) + (byte-compile-error-on-warn t)) + (unwind-protect + (progn + (write-region "" nil input-file nil nil nil 'excl) + (write-region "" nil output-file nil nil nil 'excl) + (set-file-modes input-file #o400) + (set-file-modes output-file #o200) + (set-file-modes directory #o500) + (should (byte-compile-file input-file)) + (should (file-regular-p output-file)) + (should (cl-plusp (file-attribute-size + (file-attributes output-file))))) + ;; Allow the directory to be deleted. + (set-file-modes directory #o777))))) (ert-deftest bytecomp-tests--dest-mountpoint () "Test that byte compilation works if the destination file is a @@ -1273,56 +1322,53 @@ mountpoint (Bug#44631)." (skip-unless (not (file-remote-p bwrap))) (skip-unless (file-executable-p emacs)) (skip-unless (not (file-remote-p emacs))) - (let ((directory (make-temp-file "bytecomp-tests-" :directory))) - (unwind-protect - (let* ((input-file (expand-file-name "test.el" directory)) - (output-file (expand-file-name "test.elc" directory)) - (unquoted-file (file-name-unquote output-file)) - (byte-compile-dest-file-function - (lambda (_) output-file)) - (byte-compile-error-on-warn t)) - (should-not (file-remote-p input-file)) - (should-not (file-remote-p output-file)) - (write-region "" nil input-file nil nil nil 'excl) - (write-region "" nil output-file nil nil nil 'excl) - (set-file-modes input-file #o400) - (set-file-modes output-file #o200) - (set-file-modes directory #o500) - (with-temp-buffer - (let ((status (call-process - bwrap nil t nil - "--ro-bind" "/" "/" - "--bind" unquoted-file unquoted-file - emacs "--quick" "--batch" "--load=bytecomp" - (format "--eval=%S" - `(setq byte-compile-dest-file-function - (lambda (_) ,output-file) - byte-compile-error-on-warn t)) - "--funcall=batch-byte-compile" input-file))) - (unless (eql status 0) - (ert-fail `((status . ,status) - (output . ,(buffer-string))))))) - (should (file-regular-p output-file)) - (should (cl-plusp (file-attribute-size - (file-attributes output-file))))) - (with-demoted-errors "Error cleaning up directory: %s" - (set-file-modes directory #o700) - (delete-directory directory :recursive)))))) + (ert-with-temp-directory directory + (let* ((input-file (expand-file-name "test.el" directory)) + (output-file (expand-file-name "test.elc" directory)) + (unquoted-file (file-name-unquote output-file)) + (byte-compile-dest-file-function + (lambda (_) output-file)) + (byte-compile-error-on-warn t)) + (should-not (file-remote-p input-file)) + (should-not (file-remote-p output-file)) + (write-region "" nil input-file nil nil nil 'excl) + (write-region "" nil output-file nil nil nil 'excl) + (unwind-protect + (progn + (set-file-modes input-file #o400) + (set-file-modes output-file #o200) + (set-file-modes directory #o500) + (with-temp-buffer + (let ((status (call-process + bwrap nil t nil + "--ro-bind" "/" "/" + "--bind" unquoted-file unquoted-file + emacs "--quick" "--batch" "--load=bytecomp" + (format "--eval=%S" + `(setq byte-compile-dest-file-function + (lambda (_) ,output-file) + byte-compile-error-on-warn t)) + "--funcall=batch-byte-compile" input-file))) + (unless (eql status 0) + (ert-fail `((status . ,status) + (output . ,(buffer-string))))))) + (should (file-regular-p output-file)) + (should (cl-plusp (file-attribute-size + (file-attributes output-file))))) + ;; Allow the directory to be deleted. + (set-file-modes directory #o777)))))) (ert-deftest bytecomp-tests--target-file-no-directory () "Check that Bug#45287 is fixed." - (let ((directory (make-temp-file "bytecomp-tests-" :directory))) - (unwind-protect - (let* ((default-directory directory) - (byte-compile-dest-file-function (lambda (_) "test.elc")) - (byte-compile-error-on-warn t)) - (write-region "" nil "test.el" nil nil nil 'excl) - (should (byte-compile-file "test.el")) - (should (file-regular-p "test.elc")) - (should (cl-plusp (file-attribute-size - (file-attributes "test.elc"))))) - (with-demoted-errors "Error cleaning up directory: %s" - (delete-directory directory :recursive))))) + (ert-with-temp-directory directory + (let* ((default-directory directory) + (byte-compile-dest-file-function (lambda (_) "test.elc")) + (byte-compile-error-on-warn t)) + (write-region "" nil "test.el" nil nil nil 'excl) + (should (byte-compile-file "test.el")) + (should (file-regular-p "test.elc")) + (should (cl-plusp (file-attribute-size + (file-attributes "test.elc"))))))) (defun bytecomp-tests--get-vars () (list (ignore-errors (symbol-value 'bytecomp-tests--var1)) diff --git a/test/lisp/emacs-lisp/cconv-tests.el b/test/lisp/emacs-lisp/cconv-tests.el index 4290571735e..479afe12c0d 100644 --- a/test/lisp/emacs-lisp/cconv-tests.el +++ b/test/lisp/emacs-lisp/cconv-tests.el @@ -23,6 +23,7 @@ (require 'ert) (require 'cl-lib) +(require 'generator) (ert-deftest cconv-tests-lambda-:documentation () "Docstring for lambda can be specified with :documentation." @@ -83,9 +84,6 @@ (iter-yield 'cl-iter-defun-result)) (ert-deftest cconv-tests-cl-iter-defun-:documentation () "Docstring for cl-iter-defun can be specified with :documentation." - ;; FIXME: See Bug#28557. - :tags '(:unstable) - :expected-result :failed (should (string= (documentation 'cconv-tests-cl-iter-defun) "cl-iter-defun documentation")) (should (eq (iter-next (cconv-tests-cl-iter-defun)) @@ -96,17 +94,12 @@ (iter-yield 'iter-defun-result)) (ert-deftest cconv-tests-iter-defun-:documentation () "Docstring for iter-defun can be specified with :documentation." - ;; FIXME: See Bug#28557. - :tags '(:unstable) - :expected-result :failed (should (string= (documentation 'cconv-tests-iter-defun) "iter-defun documentation")) (should (eq (iter-next (cconv-tests-iter-defun)) 'iter-defun-result))) (ert-deftest cconv-tests-iter-lambda-:documentation () "Docstring for iter-lambda can be specified with :documentation." - ;; FIXME: See Bug#28557. - :expected-result :failed (let ((iter-fun (iter-lambda () (:documentation (concat "iter-lambda" " documentation")) @@ -116,13 +109,11 @@ (ert-deftest cconv-tests-cl-function-:documentation () "Docstring for cl-function can be specified with :documentation." - ;; FIXME: See Bug#28557. - :expected-result :failed (let ((fun (cl-function (lambda (&key arg) (:documentation (concat "cl-function" " documentation")) (list arg 'cl-function-result))))) - (should (string= (documentation fun) "cl-function documentation")) + (should (string-match "\\`cl-function documentation$" (documentation fun))) (should (equal (funcall fun :arg t) '(t cl-function-result))))) (ert-deftest cconv-tests-function-:documentation () @@ -142,8 +133,6 @@ (+ 1 n)) (ert-deftest cconv-tests-cl-defgeneric-:documentation () "Docstring for cl-defgeneric can be specified with :documentation." - ;; FIXME: See Bug#28557. - :expected-result :failed (let ((descr (describe-function 'cconv-tests-cl-defgeneric))) (set-text-properties 0 (length descr) nil descr) (should (string-match-p "cl-defgeneric documentation" descr)) @@ -205,5 +194,157 @@ nil 99) 42))) +(defun cconv-tests--intern-all (x) + "Intern all symbols in X." + (cond ((symbolp x) (intern (symbol-name x))) + ((consp x) (cons (cconv-tests--intern-all (car x)) + (cconv-tests--intern-all (cdr x)))) + ;; Assume we don't need to deal with vectors etc. + (t x))) + +(ert-deftest cconv-closure-convert-remap-var () + ;; Verify that we correctly remap shadowed lambda-lifted variables. + + ;; We intern all symbols for ease of comparison; this works because + ;; the `cconv-closure-convert' result should contain no pair of + ;; distinct symbols having the same name. + + ;; Sanity check: captured variable, no lambda-lifting or shadowing: + (should (equal (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + #'(lambda () x)))) + '#'(lambda (x) + (internal-make-closure + nil (x) nil + (internal-get-closed-var 0))))) + + ;; Basic case: + (should (equal (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + (let ((f #'(lambda () x))) + (let ((x 'b)) + (list x (funcall f))))))) + '#'(lambda (x) + (let ((f #'(lambda (x) x))) + (let ((x 'b) + (closed-x x)) + (list x (funcall f closed-x))))))) + (should (equal (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + (let ((f #'(lambda () x))) + (let* ((x 'b)) + (list x (funcall f))))))) + '#'(lambda (x) + (let ((f #'(lambda (x) x))) + (let* ((closed-x x) + (x 'b)) + (list x (funcall f closed-x))))))) + + ;; With the lambda-lifted shadowed variable also being captured: + (should (equal + (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + #'(lambda () + (let ((f #'(lambda () x))) + (let ((x 'a)) + (list x (funcall f)))))))) + '#'(lambda (x) + (internal-make-closure + nil (x) nil + (let ((f #'(lambda (x) x))) + (let ((x 'a) + (closed-x (internal-get-closed-var 0))) + (list x (funcall f closed-x)))))))) + (should (equal + (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + #'(lambda () + (let ((f #'(lambda () x))) + (let* ((x 'a)) + (list x (funcall f)))))))) + '#'(lambda (x) + (internal-make-closure + nil (x) nil + (let ((f #'(lambda (x) x))) + (let* ((closed-x (internal-get-closed-var 0)) + (x 'a)) + (list x (funcall f closed-x)))))))) + ;; With lambda-lifted shadowed variable also being mutably captured: + (should (equal + (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + #'(lambda () + (let ((f #'(lambda () x))) + (setq x x) + (let ((x 'a)) + (list x (funcall f)))))))) + '#'(lambda (x) + (let ((x (list x))) + (internal-make-closure + nil (x) nil + (let ((f #'(lambda (x) (car-safe x)))) + (setcar (internal-get-closed-var 0) + (car-safe (internal-get-closed-var 0))) + (let ((x 'a) + (closed-x (internal-get-closed-var 0))) + (list x (funcall f closed-x))))))))) + (should (equal + (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + #'(lambda () + (let ((f #'(lambda () x))) + (setq x x) + (let* ((x 'a)) + (list x (funcall f)))))))) + '#'(lambda (x) + (let ((x (list x))) + (internal-make-closure + nil (x) nil + (let ((f #'(lambda (x) (car-safe x)))) + (setcar (internal-get-closed-var 0) + (car-safe (internal-get-closed-var 0))) + (let* ((closed-x (internal-get-closed-var 0)) + (x 'a)) + (list x (funcall f closed-x))))))))) + ;; Lambda-lifted variable that isn't actually captured where it is shadowed: + (should (equal + (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + (let ((g #'(lambda () x)) + (h #'(lambda () (setq x x)))) + (let ((x 'b)) + (list x (funcall g) (funcall h))))))) + '#'(lambda (x) + (let ((x (list x))) + (let ((g #'(lambda (x) (car-safe x))) + (h #'(lambda (x) (setcar x (car-safe x))))) + (let ((x 'b) + (closed-x x)) + (list x (funcall g closed-x) (funcall h closed-x)))))))) + (should (equal + (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + (let ((g #'(lambda () x)) + (h #'(lambda () (setq x x)))) + (let* ((x 'b)) + (list x (funcall g) (funcall h))))))) + '#'(lambda (x) + (let ((x (list x))) + (let ((g #'(lambda (x) (car-safe x))) + (h #'(lambda (x) (setcar x (car-safe x))))) + (let* ((closed-x x) + (x 'b)) + (list x (funcall g closed-x) (funcall h closed-x)))))))) + ) + (provide 'cconv-tests) ;;; cconv-tests.el ends here diff --git a/test/lisp/emacs-lisp/check-declare-tests.el b/test/lisp/emacs-lisp/check-declare-tests.el index 276530fb4d3..5c9d847e34a 100644 --- a/test/lisp/emacs-lisp/check-declare-tests.el +++ b/test/lisp/emacs-lisp/check-declare-tests.el @@ -28,6 +28,7 @@ (require 'check-declare) (require 'ert) +(require 'ert-x) (eval-when-compile (require 'subr-x)) (ert-deftest check-declare-tests-locate () @@ -36,62 +37,53 @@ (string-prefix-p "ext:" (check-declare-locate "ext:foo" "")))) (ert-deftest check-declare-tests-scan () - (let ((file (make-temp-file "check-declare-tests-"))) - (unwind-protect - (progn - (with-temp-file file - (insert - (string-join - '(";; foo comment" - "(declare-function ring-insert \"ring\" (ring item))" - "(let ((foo 'code)) foo)") - "\n"))) - (let ((res (check-declare-scan file))) - (should (= (length res) 1)) - (pcase-let ((`((,fnfile ,fn ,arglist ,fileonly)) res)) - (should (string-match-p "ring" fnfile)) - (should (equal "ring-insert" fn)) - (should (equal '(ring item) arglist)) - (should-not fileonly)))) - (delete-file file)))) + (ert-with-temp-file file + (with-temp-file file + (insert + (string-join + '(";; foo comment" + "(declare-function ring-insert \"ring\" (ring item))" + "(let ((foo 'code)) foo)") + "\n"))) + (let ((res (check-declare-scan file))) + (should (= (length res) 1)) + (pcase-let ((`((,fnfile ,fn ,arglist ,fileonly)) res)) + (should (string-match-p "ring" fnfile)) + (should (equal "ring-insert" fn)) + (should (equal '(ring item) arglist)) + (should-not fileonly))))) (ert-deftest check-declare-tests-verify () - (let ((file (make-temp-file "check-declare-tests-"))) - (unwind-protect - (progn - (with-temp-file file - (insert - (string-join - '(";; foo comment" - "(defun foo-fun ())" - "(defun ring-insert (ring item)" - "\"Insert onto ring RING the item ITEM.\"" - "nil)") - "\n"))) - (should-not - (check-declare-verify - file '(("foo.el" "ring-insert" (ring item)))))) - (delete-file file)))) + (ert-with-temp-file file + (with-temp-file file + (insert + (string-join + '(";; foo comment" + "(defun foo-fun ())" + "(defun ring-insert (ring item)" + "\"Insert onto ring RING the item ITEM.\"" + "nil)") + "\n"))) + (should-not + (check-declare-verify + file '(("foo.el" "ring-insert" (ring item))))))) (ert-deftest check-declare-tests-verify-mismatch () - (let ((file (make-temp-file "check-declare-tests-"))) - (unwind-protect - (progn - (with-temp-file file - (insert - (string-join - '(";; foo comment" - "(defun foo-fun ())" - "(defun ring-insert (ring)" - "\"Insert onto ring RING the item ITEM.\"" - "nil)") - "\n"))) - (should - (equal - (check-declare-verify - file '(("foo.el" "ring-insert" (ring item)))) - '(("foo.el" "ring-insert" "arglist mismatch"))))) - (delete-file file)))) + (ert-with-temp-file file + (with-temp-file file + (insert + (string-join + '(";; foo comment" + "(defun foo-fun ())" + "(defun ring-insert (ring)" + "\"Insert onto ring RING the item ITEM.\"" + "nil)") + "\n"))) + (should + (equal + (check-declare-verify + file '(("foo.el" "ring-insert" (ring item)))) + '(("foo.el" "ring-insert" "arglist mismatch")))))) (ert-deftest check-declare-tests-sort () (should-not (check-declare-sort '())) diff --git a/test/lisp/emacs-lisp/cl-generic-tests.el b/test/lisp/emacs-lisp/cl-generic-tests.el index dd7511e9afe..9c285a9facf 100644 --- a/test/lisp/emacs-lisp/cl-generic-tests.el +++ b/test/lisp/emacs-lisp/cl-generic-tests.el @@ -200,9 +200,14 @@ (fmakunbound 'cl--generic-1) (cl-defgeneric cl--generic-1 (x y)) (cl-defmethod cl--generic-1 ((x t) y) - (list x y (cl-next-method-p))) + (list x y + (with-suppressed-warnings ((obsolete cl-next-method-p)) + (cl-next-method-p)))) (cl-defmethod cl--generic-1 ((_x (eql 4)) _y) - (cl-list* "quatre" (cl-next-method-p) (cl-call-next-method))) + (cl-list* "quatre" + (with-suppressed-warnings ((obsolete cl-next-method-p)) + (cl-next-method-p)) + (cl-call-next-method))) (should (equal (cl--generic-1 4 5) '("quatre" t 4 5 nil)))) (ert-deftest cl-generic-test-12-context () diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el index a132d736383..a0facc81dbe 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)))) @@ -558,4 +551,9 @@ (should cl-old-struct-compat-mode) (cl-old-struct-compat-mode (if saved 1 -1)))) +(ert-deftest cl-constantly () + (should (equal (mapcar (cl-constantly 3) '(a b c d)) + '(3 3 3 3)))) + + ;;; cl-lib-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index f4e2e46a019..ced2cc10f30 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))) @@ -637,17 +637,26 @@ collection clause." (/ 1 (logand n 1)) (arith-error (len3 (cdr xs) (1+ n))) (:success (len3 (cdr xs) (+ n k)))) - n))) + n)) + + ;; Tail calls in `cond'. + (len4 (xs n) + (cond (xs (cond (nil 'nevertrue) + ((len4 (cdr xs) (1+ n))))) + (t n)))) (should (equal (len nil 0) 0)) (should (equal (len2 nil 0) 0)) (should (equal (len3 nil 0) 0)) + (should (equal (len4 nil 0) 0)) (should (equal (len list-42 0) 42)) (should (equal (len2 list-42 0) 42)) (should (equal (len3 list-42 0) 42)) + (should (equal (len4 list-42 0) 42)) ;; Should not bump into stack depth limits. (should (equal (len list-42k 0) 42000)) (should (equal (len2 list-42k 0) 42000)) - (should (equal (len3 list-42k 0) 42000)))) + (should (equal (len3 list-42k 0) 42000)) + (should (equal (len4 list-42k 0) 42000)))) ;; Check that non-recursive functions are handled more efficiently. (should (pcase (macroexpand '(cl-labels ((f (x) (+ x 1))) (f 5))) @@ -657,11 +666,32 @@ collection clause." (should (pcase (macroexpand '(cl-labels ((len (xs n) (if xs (len (cdr xs) (1+ n)) n))) #'len)) - (`(function (lambda (,_ ,_) . ,_)) t)))) + (`(function (lambda (,_ ,_) . ,_)) t))) + + ;; Verify that there is no tail position inside dynamic variable bindings. + (defvar dyn-var) + (let ((dyn-var 'a)) + (cl-labels ((f (x) (if x + dyn-var + (let ((dyn-var 'b)) + (f dyn-var))))) + (should (equal (f nil) 'b)))) + + ;; Control: same as above but with lexical binding. + (let ((lex-var 'a)) + (cl-labels ((f (x) (if x + lex-var + (let ((lex-var 'b)) + (f lex-var))))) + (should (equal (f nil) 'a))))) (ert-deftest cl-macs--progv () - (should (= (cl-progv '(test test) '(1 2) test) 2)) - (should (equal (cl-progv '(test1 test2) '(1 2) (list test1 test2)) + (defvar cl-macs--test) + (defvar cl-macs--test1) + (defvar cl-macs--test2) + (should (= (cl-progv '(cl-macs--test cl-macs--test) '(1 2) cl-macs--test) 2)) + (should (equal (cl-progv '(cl-macs--test1 cl-macs--test2) '(1 2) + (list cl-macs--test1 cl-macs--test2)) '(1 2)))) ;;; cl-macs-tests.el ends here diff --git a/test/lisp/emacs-lisp/derived-tests.el b/test/lisp/emacs-lisp/derived-tests.el index 9c8e6c33b4c..2647b86826a 100644 --- a/test/lisp/emacs-lisp/derived-tests.el +++ b/test/lisp/emacs-lisp/derived-tests.el @@ -24,13 +24,13 @@ (define-derived-mode derived-tests--parent-mode prog-mode "P" :after-hook (let ((f (let ((x "S")) (lambda () x)))) - (insert (format "AFP=%s " (let ((x "D")) (funcall f))))) + (insert (format "AFP=%s " (let ((x "D")) x (funcall f))))) (insert "PB ")) (define-derived-mode derived-tests--child-mode derived-tests--parent-mode "C" :after-hook (let ((f (let ((x "S")) (lambda () x)))) - (insert (format "AFC=%s " (let ((x "D")) (funcall f))))) + (insert (format "AFC=%s " (let ((x "D")) x (funcall f))))) (insert "CB ")) (ert-deftest derived-tests-after-hook-lexical () diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el index f8fa223da4c..3ab5ac6a9ad 100644 --- a/test/lisp/emacs-lisp/edebug-tests.el +++ b/test/lisp/emacs-lisp/edebug-tests.el @@ -53,22 +53,20 @@ Since `should' failures which happen inside `post-command-hook' will be trapped by the command loop, this preserves them until we get back to the top level.") -(defvar edebug-tests-keymap - (let ((map (make-sparse-keymap))) - (define-key map "@" 'edebug-tests-call-instrumented-func) - (define-key map "C-u" 'universal-argument) - (define-key map "C-p" 'previous-line) - (define-key map "C-n" 'next-line) - (define-key map "C-b" 'backward-char) - (define-key map "C-a" 'move-beginning-of-line) - (define-key map "C-e" 'move-end-of-line) - (define-key map "C-k" 'kill-line) - (define-key map "M-x" 'execute-extended-command) - (define-key map "C-M-x" 'eval-defun) - (define-key map "C-x X b" 'edebug-set-breakpoint) - (define-key map "C-x X w" 'edebug-where) - map) - "Keys used by the keyboard macros in Edebug's tests.") +(defvar-keymap edebug-tests-keymap + :doc "Keys used by the keyboard macros in Edebug's tests." + "@" 'edebug-tests-call-instrumented-func + "C-u" 'universal-argument + "C-p" 'previous-line + "C-n" 'next-line + "C-b" 'backward-char + "C-a" 'move-beginning-of-line + "C-e" 'move-end-of-line + "C-k" 'kill-line + "M-x" 'execute-extended-command + "C-M-x" 'eval-defun + "C-x X b" 'edebug-set-breakpoint + "C-x X w" 'edebug-where) ;;; Macros for defining tests: @@ -107,27 +105,27 @@ back to the top level.") "Set up the environment for an Edebug test BODY, run it, and clean up." (declare (debug (body))) `(edebug-tests-with-default-config - (let ((edebug-tests-failure-in-post-command nil) - (edebug-tests-temp-file (make-temp-file "edebug-tests-" nil ".el")) - (find-file-suppress-same-file-warnings t)) - (edebug-tests-setup-code-file edebug-tests-temp-file) - (ert-with-message-capture - edebug-tests-messages - (unwind-protect - (with-current-buffer (find-file edebug-tests-temp-file) - (read-only-mode) - (setq lexical-binding t) - (eval-buffer) - ,@body - (when edebug-tests-failure-in-post-command - (signal (car edebug-tests-failure-in-post-command) - (cdr edebug-tests-failure-in-post-command)))) - (unload-feature 'edebug-test-code) - (with-current-buffer (find-file-noselect edebug-tests-temp-file) - (set-buffer-modified-p nil)) - (ignore-errors (kill-buffer (find-file-noselect - edebug-tests-temp-file))) - (ignore-errors (delete-file edebug-tests-temp-file))))))) + (ert-with-temp-file edebug-tests-temp-file + :suffix ".el" + (let ((edebug-tests-failure-in-post-command nil) + (find-file-suppress-same-file-warnings t)) + (edebug-tests-setup-code-file edebug-tests-temp-file) + (ert-with-message-capture + edebug-tests-messages + (unwind-protect + (with-current-buffer (find-file edebug-tests-temp-file) + (read-only-mode) + (setq lexical-binding t) + (eval-buffer) + ,@body + (when edebug-tests-failure-in-post-command + (signal (car edebug-tests-failure-in-post-command) + (cdr edebug-tests-failure-in-post-command)))) + (unload-feature 'edebug-test-code) + (with-current-buffer (find-file-noselect edebug-tests-temp-file) + (set-buffer-modified-p nil)) + (ignore-errors (kill-buffer (find-file-noselect + edebug-tests-temp-file))))))))) ;; The following macro and its support functions implement an extension ;; to keyboard macros to allow interleaving of keyboard macro @@ -860,7 +858,8 @@ test and possibly others should be updated." (let ((inhibit-read-only t)) (delete-region (point-min) (point-max)) (insert "`1")) - (edebug-eval-defun nil) + (with-suppressed-warnings ((obsolete edebug-eval-defun)) + (edebug-eval-defun nil)) ;; `eval-defun' outputs its message to the echo area in a rather ;; funny way, so the "1" and the " (#o1, #x1, ?\C-a)" end up placed ;; there in separate pieces (via `print' rather than via `message'). @@ -870,7 +869,8 @@ test and possibly others should be updated." (setq edebug-initial-mode 'go) ;; In Bug#23651 Edebug would hang reading `1. - (edebug-eval-defun t))) + (with-suppressed-warnings ((obsolete edebug-eval-defun)) + (edebug-eval-defun t)))) (ert-deftest edebug-tests-trivial-comma () "Edebug can read a trivial comma expression (Bug#23651)." @@ -879,7 +879,8 @@ test and possibly others should be updated." (delete-region (point-min) (point-max)) (insert ",1") (read-only-mode) - (should-error (edebug-eval-defun t)))) + (with-suppressed-warnings ((obsolete edebug-eval-defun)) + (should-error (edebug-eval-defun t))))) (ert-deftest edebug-tests-circular-read-syntax () "Edebug can instrument code using circular read object syntax (Bug#23660)." diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el index d1da066dc45..a5349b95582 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el @@ -55,6 +55,7 @@ ;;; Code: (require 'eieio) +(require 'eieio-compat) (require 'ert) (defvar eieio-test-method-order-list nil @@ -85,37 +86,40 @@ (defclass eitest-B-base2 () ()) (defclass eitest-B (eitest-B-base1 eitest-B-base2) ()) -(defmethod eitest-F :BEFORE ((_p eitest-B-base1)) - (eieio-test-method-store :BEFORE 'eitest-B-base1)) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete call-next-method) + (obsolete next-method-p)) + (defmethod eitest-F :BEFORE ((_p eitest-B-base1)) + (eieio-test-method-store :BEFORE 'eitest-B-base1)) -(defmethod eitest-F :BEFORE ((_p eitest-B-base2)) - (eieio-test-method-store :BEFORE 'eitest-B-base2)) + (defmethod eitest-F :BEFORE ((_p eitest-B-base2)) + (eieio-test-method-store :BEFORE 'eitest-B-base2)) -(defmethod eitest-F :BEFORE ((_p eitest-B)) - (eieio-test-method-store :BEFORE 'eitest-B)) + (defmethod eitest-F :BEFORE ((_p eitest-B)) + (eieio-test-method-store :BEFORE 'eitest-B)) -(defmethod eitest-F ((_p eitest-B)) - (eieio-test-method-store :PRIMARY 'eitest-B) - (call-next-method)) - -(defmethod eitest-F ((_p eitest-B-base1)) - (eieio-test-method-store :PRIMARY 'eitest-B-base1) - (call-next-method)) + (defmethod eitest-F ((_p eitest-B)) + (eieio-test-method-store :PRIMARY 'eitest-B) + (call-next-method)) -(defmethod eitest-F ((_p eitest-B-base2)) - (eieio-test-method-store :PRIMARY 'eitest-B-base2) - (when (next-method-p) + (defmethod eitest-F ((_p eitest-B-base1)) + (eieio-test-method-store :PRIMARY 'eitest-B-base1) (call-next-method)) - ) -(defmethod eitest-F :AFTER ((_p eitest-B-base1)) - (eieio-test-method-store :AFTER 'eitest-B-base1)) + (defmethod eitest-F ((_p eitest-B-base2)) + (eieio-test-method-store :PRIMARY 'eitest-B-base2) + (when (next-method-p) + (call-next-method))) -(defmethod eitest-F :AFTER ((_p eitest-B-base2)) - (eieio-test-method-store :AFTER 'eitest-B-base2)) + (defmethod eitest-F :AFTER ((_p eitest-B-base1)) + (eieio-test-method-store :AFTER 'eitest-B-base1)) -(defmethod eitest-F :AFTER ((_p eitest-B)) - (eieio-test-method-store :AFTER 'eitest-B)) + (defmethod eitest-F :AFTER ((_p eitest-B-base2)) + (eieio-test-method-store :AFTER 'eitest-B-base2)) + + (defmethod eitest-F :AFTER ((_p eitest-B)) + (eieio-test-method-store :AFTER 'eitest-B))) (ert-deftest eieio-test-method-order-list-3 () (let ((eieio-test-method-order-list nil) @@ -138,9 +142,11 @@ ;;; Test static invocation ;; -(defmethod eitest-H :STATIC ((_class eitest-A)) - "No need to do work in here." - 'moose) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod eitest-H :STATIC ((_class eitest-A)) + "No need to do work in here." + 'moose)) (ert-deftest eieio-test-method-order-list-4 () ;; Both of these situations should succeed. @@ -149,17 +155,19 @@ ;;; Return value from :PRIMARY ;; -(defmethod eitest-I :BEFORE ((_a eitest-A)) - (eieio-test-method-store :BEFORE 'eitest-A) - ":before") +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod eitest-I :BEFORE ((_a eitest-A)) + (eieio-test-method-store :BEFORE 'eitest-A) + ":before") -(defmethod eitest-I :PRIMARY ((_a eitest-A)) - (eieio-test-method-store :PRIMARY 'eitest-A) - ":primary") + (defmethod eitest-I :PRIMARY ((_a eitest-A)) + (eieio-test-method-store :PRIMARY 'eitest-A) + ":primary") -(defmethod eitest-I :AFTER ((_a eitest-A)) - (eieio-test-method-store :AFTER 'eitest-A) - ":after") + (defmethod eitest-I :AFTER ((_a eitest-A)) + (eieio-test-method-store :AFTER 'eitest-A) + ":after")) (ert-deftest eieio-test-method-order-list-5 () (let ((eieio-test-method-order-list nil) @@ -175,16 +183,18 @@ (defclass C-base2 () ()) (defclass C (C-base1 C-base2) ()) -;; Just use the obsolete name once, to make sure it also works. -(defmethod constructor :STATIC ((_p C-base1) &rest _args) - (eieio-test-method-store :STATIC 'C-base1) - (if (next-method-p) (call-next-method)) - ) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete next-method-p) + (obsolete call-next-method)) + ;; Just use the obsolete name once, to make sure it also works. + (defmethod constructor :STATIC ((_p C-base1) &rest _args) + (eieio-test-method-store :STATIC 'C-base1) + (if (next-method-p) (call-next-method))) -(defmethod make-instance :STATIC ((_p C-base2) &rest _args) - (eieio-test-method-store :STATIC 'C-base2) - (if (next-method-p) (call-next-method)) - ) + (defmethod make-instance :STATIC ((_p C-base2) &rest _args) + (eieio-test-method-store :STATIC 'C-base2) + (if (next-method-p) (call-next-method)))) (cl-defmethod make-instance ((_p (subclass C)) &rest _args) (eieio-test-method-store :STATIC 'C) @@ -215,29 +225,32 @@ (defclass D-base2 (D-base0) () :method-invocation-order :depth-first) (defclass D (D-base1 D-base2) () :method-invocation-order :depth-first) -(defmethod eitest-F ((_p D)) - "D" - (eieio-test-method-store :PRIMARY 'D) - (call-next-method)) - -(defmethod eitest-F ((_p D-base0)) - "D-base0" - (eieio-test-method-store :PRIMARY 'D-base0) - ;; This should have no next - ;; (when (next-method-p) (call-next-method)) - ) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete call-next-method) + (obsolete next-method-p)) + (defmethod eitest-F ((_p D)) + "D" + (eieio-test-method-store :PRIMARY 'D) + (call-next-method)) -(defmethod eitest-F ((_p D-base1)) - "D-base1" - (eieio-test-method-store :PRIMARY 'D-base1) - (call-next-method)) + (defmethod eitest-F ((_p D-base0)) + "D-base0" + (eieio-test-method-store :PRIMARY 'D-base0) + ;; This should have no next + ;; (when (next-method-p) (call-next-method)) + ) -(defmethod eitest-F ((_p D-base2)) - "D-base2" - (eieio-test-method-store :PRIMARY 'D-base2) - (when (next-method-p) + (defmethod eitest-F ((_p D-base1)) + "D-base1" + (eieio-test-method-store :PRIMARY 'D-base1) (call-next-method)) - ) + + (defmethod eitest-F ((_p D-base2)) + "D-base2" + (eieio-test-method-store :PRIMARY 'D-base2) + (when (next-method-p) + (call-next-method)))) (ert-deftest eieio-test-method-order-list-7 () (let ((eieio-test-method-order-list nil) @@ -258,25 +271,28 @@ (defclass E-base2 (E-base0) () :method-invocation-order :breadth-first) (defclass E (E-base1 E-base2) () :method-invocation-order :breadth-first) -(defmethod eitest-F ((_p E)) - (eieio-test-method-store :PRIMARY 'E) - (call-next-method)) - -(defmethod eitest-F ((_p E-base0)) - (eieio-test-method-store :PRIMARY 'E-base0) - ;; This should have no next - ;; (when (next-method-p) (call-next-method)) - ) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete next-method-p) + (obsolete call-next-method)) + (defmethod eitest-F ((_p E)) + (eieio-test-method-store :PRIMARY 'E) + (call-next-method)) -(defmethod eitest-F ((_p E-base1)) - (eieio-test-method-store :PRIMARY 'E-base1) - (call-next-method)) + (defmethod eitest-F ((_p E-base0)) + (eieio-test-method-store :PRIMARY 'E-base0) + ;; This should have no next + ;; (when (next-method-p) (call-next-method)) + ) -(defmethod eitest-F ((_p E-base2)) - (eieio-test-method-store :PRIMARY 'E-base2) - (when (next-method-p) + (defmethod eitest-F ((_p E-base1)) + (eieio-test-method-store :PRIMARY 'E-base1) (call-next-method)) - ) + + (defmethod eitest-F ((_p E-base2)) + (eieio-test-method-store :PRIMARY 'E-base2) + (when (next-method-p) + (call-next-method)))) (ert-deftest eieio-test-method-order-list-8 () (let ((eieio-test-method-order-list nil) @@ -295,24 +311,32 @@ (defclass eitest-Ja () ()) -(defmethod initialize-instance :after ((_this eitest-Ja) &rest _slots) - ;(message "+Ja") - ;; FIXME: Using next-method-p in an after-method is invalid! - (when (next-method-p) - (call-next-method)) - ;(message "-Ja") - ) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete next-method-p) + (obsolete call-next-method)) + (defmethod initialize-instance :after ((_this eitest-Ja) &rest _slots) + ;;(message "+Ja") + ;; FIXME: Using next-method-p in an after-method is invalid! + (when (next-method-p) + (call-next-method)) + ;;(message "-Ja") + )) (defclass eitest-Jb () ()) -(defmethod initialize-instance :after ((_this eitest-Jb) &rest _slots) - ;(message "+Jb") - ;; FIXME: Using next-method-p in an after-method is invalid! - (when (next-method-p) - (call-next-method)) - ;(message "-Jb") - ) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete next-method-p) + (obsolete call-next-method)) + (defmethod initialize-instance :after ((_this eitest-Jb) &rest _slots) + ;;(message "+Jb") + ;; FIXME: Using next-method-p in an after-method is invalid! + (when (next-method-p) + (call-next-method)) + ;;(message "-Jb") + )) (defclass eitest-Jc (eitest-Jb) ()) @@ -320,12 +344,16 @@ (defclass eitest-Jd (eitest-Jc eitest-Ja) ()) -(defmethod initialize-instance ((_this eitest-Jd) &rest _slots) - ;(message "+Jd") - (when (next-method-p) - (call-next-method)) - ;(message "-Jd") - ) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete next-method-p) + (obsolete call-next-method)) + (defmethod initialize-instance ((_this eitest-Jd) &rest _slots) + ;;(message "+Jd") + (when (next-method-p) + (call-next-method)) + ;;(message "-Jd") + )) (ert-deftest eieio-test-method-order-list-9 () (should (eitest-Jd))) @@ -345,32 +373,36 @@ (defclass CNM-2 (CNM-1-1 CNM-1-2) ()) -(defmethod CNM-M ((this CNM-0) args) - (push (cons 'CNM-0 (copy-sequence args)) - eieio-test-call-next-method-arguments) - (when (next-method-p) - (call-next-method - this (cons 'CNM-0 args)))) - -(defmethod CNM-M ((this CNM-1-1) args) - (push (cons 'CNM-1-1 (copy-sequence args)) - eieio-test-call-next-method-arguments) - (when (next-method-p) - (call-next-method - this (cons 'CNM-1-1 args)))) - -(defmethod CNM-M ((_this CNM-1-2) args) - (push (cons 'CNM-1-2 (copy-sequence args)) - eieio-test-call-next-method-arguments) - (when (next-method-p) - (call-next-method))) - -(defmethod CNM-M ((this CNM-2) args) - (push (cons 'CNM-2 (copy-sequence args)) - eieio-test-call-next-method-arguments) - (when (next-method-p) - (call-next-method - this (cons 'CNM-2 args)))) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete next-method-p) + (obsolete call-next-method)) + (defmethod CNM-M ((this CNM-0) args) + (push (cons 'CNM-0 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method + this (cons 'CNM-0 args)))) + + (defmethod CNM-M ((this CNM-1-1) args) + (push (cons 'CNM-1-1 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method + this (cons 'CNM-1-1 args)))) + + (defmethod CNM-M ((_this CNM-1-2) args) + (push (cons 'CNM-1-2 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method))) + + (defmethod CNM-M ((this CNM-2) args) + (push (cons 'CNM-2 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method + this (cons 'CNM-2 args))))) (ert-deftest eieio-test-method-order-list-10 () (let ((eieio-test-call-next-method-arguments nil)) diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el index fd044ff3734..d1183b81c6c 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el @@ -99,7 +99,7 @@ This is usually a symbol that starts with `:'." (defclass persist-simple (eieio-persistent) ((slot1 :initarg :slot1 :type symbol - :initform moose) + :initform 'moose) (slot2 :initarg :slot2 :initform "foo") (slot3 :initform 2)) diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el index 9eb7fb02230..abb12e68333 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el @@ -27,18 +27,24 @@ (require 'ert) (require 'eieio) (require 'eieio-base) +(require 'eieio-compat) (require 'eieio-opt) (eval-when-compile (require 'cl-lib)) +;; Silence byte-compiler. +(eval-when-compile + (dolist (slot '(:a :b ooga-booga :derived-value missing-slot)) + (cl-pushnew slot eieio--known-slot-names))) + ;;; Code: ;; Set up some test classes (defclass class-a () ((water :initarg :water - :initform h20 + :initform 'h20 :type symbol :documentation "Detail about water.") - (classslot :initform penguin + (classslot :initform 'penguin :type symbol :documentation "A class allocated slot." :allocation :class) @@ -50,6 +56,9 @@ ) "Class A.") +;; Silence compiler warning about `water' not being a class-allocated slot. +(defclass eieio-tests--dummy () ((water :allocation :class))) + (defclass class-b () ((land :initform "Sc" :type string @@ -61,40 +70,41 @@ :documentation "Detail about amphibian on land and water.")) "Class A and B combined.") -(defclass class-c () - ((slot-1 :initarg :moose - :initform moose - :type symbol - :allocation :instance - :documentation "First slot testing slot arguments." - :custom symbol - :label "Wild Animal" - :group borg - :protection :public) - (slot-2 :initarg :penguin - :initform "penguin" - :type string - :allocation :instance - :documentation "Second slot testing slot arguments." - :custom string - :label "Wild bird" - :group vorlon - :accessor get-slot-2 - :protection :private) - (slot-3 :initarg :emu - :initform emu - :type symbol - :allocation :class - :documentation "Third slot test class allocated accessor" - :custom symbol - :label "Fuzz" - :group tokra - :accessor get-slot-3 - :protection :private) - ) - (:custom-groups (foo)) - "A class for testing slot arguments." - ) +(with-no-warnings ; FIXME: Make more specific. + (defclass class-c () + ((slot-1 :initarg :moose + :initform 'moose + :type symbol + :allocation :instance + :documentation "First slot testing slot arguments." + :custom symbol + :label "Wild Animal" + :group borg + :protection :public) + (slot-2 :initarg :penguin + :initform "penguin" + :type string + :allocation :instance + :documentation "Second slot testing slot arguments." + :custom string + :label "Wild bird" + :group vorlon + :accessor get-slot-2 + :protection :private) + (slot-3 :initarg :emu + :initform 'emu + :type symbol + :allocation :class + :documentation "Third slot test class allocated accessor" + :custom symbol + :label "Fuzz" + :group tokra + :accessor get-slot-3 + :protection :private) + ) + (:custom-groups (foo)) + "A class for testing slot arguments." + )) (defclass class-subc (class-c) ((slot-1 ;; :initform moose - don't override this @@ -132,21 +142,25 @@ ;; (error "invalid-slot-type thrown when eieio-error-unsupported-class-tags is nil") ;; ))) +;; Silence byte-compiler. +(declare-function eitest-subordinate--eieio-childp nil) +(declare-function class-alloc-initarg--eieio-childp nil) (ert-deftest eieio-test-01-mix-alloc-initarg () ;; Only run this test if the message framework thingy works. - (when (and (message "foo") (string= "foo" (current-message))) + (skip-unless (and (message "foo") (string= "foo" (current-message)))) - ;; Defining this class should generate a warning(!) message that - ;; you should not mix :initarg with class allocated slots. + ;; Defining this class should generate a warning(!) message that + ;; you should not mix :initarg with class allocated slots. + (with-no-warnings ; FIXME: Make more specific. (defclass class-alloc-initarg () ((throwwarning :initarg :throwwarning - :allocation :class)) - "Throw a warning mixing allocation class and an initarg.") + :allocation :class)) + "Throw a warning mixing allocation class and an initarg.")) - ;; Check that message is there - (should (current-message)) - (should (string-match "Class allocated slots do not need :initarg" - (current-message))))) + ;; Check that message is there + (should (current-message)) + (should (string-match "Class allocated slots do not need :initarg" + (current-message)))) (defclass abstract-class () ((some-slot :initarg :some-slot @@ -160,30 +174,33 @@ ;; error (should-error (abstract-class))) -(defgeneric generic1 () "First generic function.") +(with-suppressed-warnings ((obsolete defgeneric)) + (defgeneric generic1 () "First generic function.")) (ert-deftest eieio-test-03-generics () - (defun anormalfunction () "A plain function for error testing." nil) - (should-error - (progn - (defgeneric anormalfunction () - "Attempt to turn it into a generic."))) - - ;; Check that generic-p works - (should (generic-p 'generic1)) - - (defmethod generic1 ((c class-a)) - "Method on generic1." - 'monkey) - - (defmethod generic1 (not-an-object) - "Method generic1 that can take a non-object." - not-an-object) - - (let ((ans-obj (generic1 (class-a))) - (ans-num (generic1 666))) - (should (eq ans-obj 'monkey)) - (should (eq ans-num 666)))) + (with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defun anormalfunction () "A plain function for error testing." nil) + (should-error + (progn + (defgeneric anormalfunction () + "Attempt to turn it into a generic."))) + + ;; Check that generic-p works + (should (generic-p 'generic1)) + + (defmethod generic1 ((_c class-a)) + "Method on generic1." + 'monkey) + + (defmethod generic1 (not-an-object) + "Method generic1 that can take a non-object." + not-an-object) + + (let ((ans-obj (generic1 (class-a))) + (ans-num (generic1 666))) + (should (eq ans-obj 'monkey)) + (should (eq ans-num 666))))) (defclass static-method-class () ((some-slot :initform nil @@ -191,12 +208,17 @@ :documentation "A slot.")) :documentation "A class used for testing static methods.") -(defmethod static-method-class-method :STATIC ((c static-method-class) value) - "Test static methods. +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod static-method-class-method :STATIC ((c static-method-class) value) + "Test static methods. Argument C is the class bound to this static method." - (if (eieio-object-p c) (setq c (eieio-object-class c))) - (oset-default c some-slot value)) + (if (eieio-object-p c) (setq c (eieio-object-class c))) + (oset-default c some-slot value))) +;; Silence byte-compiler. +(declare-function static-method-class-2 nil) +(declare-function static-method-class-2--eieio-childp nil) (ert-deftest eieio-test-04-static-method () ;; Call static method on a class and see if it worked (static-method-class-method 'static-method-class 'class) @@ -209,11 +231,13 @@ Argument C is the class bound to this static method." () "A second class after the previous for static methods.") - (defmethod static-method-class-method :STATIC ((c static-method-class-2) value) - "Test static methods. + (with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod static-method-class-method :STATIC ((c static-method-class-2) value) + "Test static methods. Argument C is the class bound to this static method." - (if (eieio-object-p c) (setq c (eieio-object-class c))) - (oset-default c some-slot (intern (concat "moose-" (symbol-name value))))) + (if (eieio-object-p c) (setq c (eieio-object-class c))) + (oset-default c some-slot (intern (concat "moose-" (symbol-name value)))))) (static-method-class-method 'static-method-class-2 'class) (should (eq (oref-default 'static-method-class-2 some-slot) 'moose-class)) @@ -240,64 +264,71 @@ Argument C is the class bound to this static method." (should (make-instance 'class-a :water 'cho)) (should (make-instance 'class-b))) -(defmethod class-cn ((a class-a)) - "Try calling `call-next-method' when there isn't one. +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod class-cn ((_a class-a)) + "Try calling `call-next-method' when there isn't one. Argument A is object of type symbol `class-a'." - (call-next-method)) + (with-suppressed-warnings ((obsolete call-next-method)) + (call-next-method))) -(defmethod no-next-method ((a class-a) &rest args) - "Override signal throwing for variable `class-a'. + (defmethod no-next-method ((_a class-a) &rest _args) + "Override signal throwing for variable `class-a'. Argument A is the object of class variable `class-a'." - 'moose) + 'moose)) (ert-deftest eieio-test-08-call-next-method () ;; Play with call-next-method (should (eq (class-cn eitest-ab) 'moose))) -(defmethod no-applicable-method ((b class-b) method &rest args) - "No need. +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod no-applicable-method ((_b class-b) _method &rest _args) + "No need. Argument B is for booger. METHOD is the method that was attempting to be called." - 'moose) + 'moose)) (ert-deftest eieio-test-09-no-applicable-method () ;; Non-existing methods. (should (eq (class-cn eitest-b) 'moose))) -(defmethod class-fun ((a class-a)) - "Fun with class A." - 'moose) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod class-fun ((_a class-a)) + "Fun with class A." + 'moose) -(defmethod class-fun ((b class-b)) - "Fun with class B." - (error "Class B fun should not be called") - ) + (defmethod class-fun ((_b class-b)) + "Fun with class B." + (error "Class B fun should not be called")) -(defmethod class-fun-foo ((b class-b)) - "Foo Fun with class B." - 'moose) + (defmethod class-fun-foo ((_b class-b)) + "Foo Fun with class B." + 'moose) -(defmethod class-fun2 ((a class-a)) - "More fun with class A." - 'moose) + (defmethod class-fun2 ((_a class-a)) + "More fun with class A." + 'moose) -(defmethod class-fun2 ((b class-b)) - "More fun with class B." - (error "Class B fun2 should not be called") - ) + (defmethod class-fun2 ((_b class-b)) + "More fun with class B." + (error "Class B fun2 should not be called")) -(defmethod class-fun2 ((ab class-ab)) - "More fun with class AB." - (call-next-method)) + (defmethod class-fun2 ((_ab class-ab)) + "More fun with class AB." + (with-suppressed-warnings ((obsolete call-next-method)) + (call-next-method))) -;; How about if B is the only slot? -(defmethod class-fun3 ((b class-b)) - "Even More fun with class B." - 'moose) + ;; How about if B is the only slot? + (defmethod class-fun3 ((_b class-b)) + "Even More fun with class B." + 'moose) -(defmethod class-fun3 ((ab class-ab)) - "Even More fun with class AB." - (call-next-method)) + (defmethod class-fun3 ((_ab class-ab)) + "Even More fun with class AB." + (with-suppressed-warnings ((obsolete call-next-method)) + (call-next-method)))) (ert-deftest eieio-test-10-multiple-inheritance () ;; play with methods and mi @@ -314,20 +345,22 @@ METHOD is the method that was attempting to be called." (defvar class-fun-value-seq '()) -(defmethod class-fun-value :BEFORE ((a class-a)) - "Return `before', and push `before' in `class-fun-value-seq'." - (push 'before class-fun-value-seq) - 'before) - -(defmethod class-fun-value :PRIMARY ((a class-a)) - "Return `primary', and push `primary' in `class-fun-value-seq'." - (push 'primary class-fun-value-seq) - 'primary) - -(defmethod class-fun-value :AFTER ((a class-a)) - "Return `after', and push `after' in `class-fun-value-seq'." - (push 'after class-fun-value-seq) - 'after) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod class-fun-value :BEFORE ((_a class-a)) + "Return `before', and push `before' in `class-fun-value-seq'." + (push 'before class-fun-value-seq) + 'before) + + (defmethod class-fun-value :PRIMARY ((_a class-a)) + "Return `primary', and push `primary' in `class-fun-value-seq'." + (push 'primary class-fun-value-seq) + 'primary) + + (defmethod class-fun-value :AFTER ((_a class-a)) + "Return `after', and push `after' in `class-fun-value-seq'." + (push 'after class-fun-value-seq) + 'after)) (ert-deftest eieio-test-12-generic-function-call () ;; Test value of a generic function call @@ -343,20 +376,23 @@ METHOD is the method that was attempting to be called." ;; (ert-deftest eieio-test-13-init-methods () - (defmethod initialize-instance ((a class-a) &rest slots) - "Initialize the slots of class-a." - (call-next-method) - (if (/= (oref a test-tag) 1) - (error "shared-initialize test failed.")) - (oset a test-tag 2)) - - (defmethod shared-initialize ((a class-a) &rest slots) - "Shared initialize method for class-a." - (call-next-method) - (oset a test-tag 1)) - - (let ((ca (class-a))) - (should (= (oref ca test-tag) 2)))) + (with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete call-next-method)) + (defmethod initialize-instance ((a class-a) &rest _slots) + "Initialize the slots of class-a." + (call-next-method) + (if (/= (oref a test-tag) 1) + (error "shared-initialize test failed.")) + (oset a test-tag 2)) + + (defmethod shared-initialize ((a class-a) &rest _slots) + "Shared initialize method for class-a." + (call-next-method) + (oset a test-tag 1)) + + (let ((ca (class-a))) + (should (= (oref ca test-tag) 2))))) ;;; Perform slot testing @@ -368,10 +404,11 @@ METHOD is the method that was attempting to be called." (should (oref eitest-ab amphibian))) (ert-deftest eieio-test-15-slot-missing () - - (defmethod slot-missing ((ab class-ab) &rest foo) - "If a slot in AB is unbound, return something cool. FOO." - 'moose) + (with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod slot-missing ((_ab class-ab) &rest _foo) + "If a slot in AB is unbound, return something cool. FOO." + 'moose)) (should (eq (oref eitest-ab ooga-booga) 'moose)) (should-error (oref eitest-a ooga-booga) :type 'invalid-slot-name)) @@ -391,17 +428,20 @@ METHOD is the method that was attempting to be called." (defclass virtual-slot-class () ((base-value :initarg :base-value)) "Class has real slot :base-value and simulated slot :derived-value.") -(defmethod slot-missing ((vsc virtual-slot-class) - slot-name operation &optional new-value) - "Simulate virtual slot derived-value." - (cond - ((or (eq slot-name :derived-value) - (eq slot-name 'derived-value)) - (with-slots (base-value) vsc - (if (eq operation 'oref) - (+ base-value 1) - (setq base-value (- new-value 1))))) - (t (call-next-method)))) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod slot-missing ((vsc virtual-slot-class) + slot-name operation &optional new-value) + "Simulate virtual slot derived-value." + (cond + ((or (eq slot-name :derived-value) + (eq slot-name 'derived-value)) + (with-slots (base-value) vsc + (if (eq operation 'oref) + (+ base-value 1) + (setq base-value (- new-value 1))))) + (t (with-suppressed-warnings ((obsolete call-next-method)) + (call-next-method)))))) (ert-deftest eieio-test-17-virtual-slot () (setq eitest-vsca (virtual-slot-class :base-value 1)) @@ -424,35 +464,37 @@ METHOD is the method that was attempting to be called." (should (= (oref eitest-vscb :derived-value) 5))) (ert-deftest eieio-test-18-slot-unbound () - - (defmethod slot-unbound ((a class-a) &rest foo) - "If a slot in A is unbound, ignore FOO." - 'moose) - - (should (eq (oref eitest-a water) 'moose)) - - ;; Check if oset of unbound works - (oset eitest-a water 'moose) - (should (eq (oref eitest-a water) 'moose)) - - ;; oref/oref-default comparison - (should-not (eq (oref eitest-a water) (oref-default eitest-a water))) - - ;; oset-default -> oref/oref-default comparison - (oset-default (eieio-object-class eitest-a) water 'moose) - (should (eq (oref eitest-a water) (oref-default eitest-a water))) - - ;; After setting 'water to 'moose, make sure a new object has - ;; the right stuff. - (oset-default (eieio-object-class eitest-a) water 'penguin) - (should (eq (oref (class-a) water) 'penguin)) - - ;; Revert the above - (defmethod slot-unbound ((a class-a) &rest foo) - "If a slot in A is unbound, ignore FOO." - ;; Disable the old slot-unbound so we can run this test - ;; more than once - (call-next-method))) + (with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod slot-unbound ((_a class-a) &rest _foo) + "If a slot in A is unbound, ignore FOO." + 'moose) + + (should (eq (oref eitest-a water) 'moose)) + + ;; Check if oset of unbound works + (oset eitest-a water 'moose) + (should (eq (oref eitest-a water) 'moose)) + + ;; oref/oref-default comparison + (should-not (eq (oref eitest-a water) (oref-default eitest-a water))) + + ;; oset-default -> oref/oref-default comparison + (oset-default (eieio-object-class eitest-a) water 'moose) + (should (eq (oref eitest-a water) (oref-default eitest-a water))) + + ;; After setting 'water to 'moose, make sure a new object has + ;; the right stuff. + (oset-default (eieio-object-class eitest-a) water 'penguin) + (should (eq (oref (class-a) water) 'penguin)) + + ;; Revert the above + (defmethod slot-unbound ((_a class-a) &rest _foo) + "If a slot in A is unbound, ignore FOO." + ;; Disable the old slot-unbound so we can run this test + ;; more than once + (with-suppressed-warnings ((obsolete call-next-method)) + (call-next-method))))) (ert-deftest eieio-test-19-slot-type-checking () ;; Slot type checking @@ -489,7 +531,7 @@ METHOD is the method that was attempting to be called." (defclass inittest nil ((staticval :initform 1) - (symval :initform eieio-test-permuting-value) + (symval :initform 'eieio-test-permuting-value) (evalval :initform (symbol-value 'eieio-test-permuting-value)) (evalnow :initform (symbol-value 'eieio-test-permuting-value) :allocation :class) @@ -506,8 +548,10 @@ METHOD is the method that was attempting to be called." (should (eq (oref eitest-pvinit evalval) 2)) (should (eq (oref eitest-pvinit evalnow) 1))) +;; Silence byte-compiler. (defvar eitest-tests nil) - +(declare-function eitest-superior nil) +(declare-function eitest-superior--eieio-childp nil) (ert-deftest eieio-test-22-init-forms-dont-match-runnable () ;; Init forms with types that don't match the runnable. (defclass eitest-subordinate nil @@ -515,7 +559,7 @@ METHOD is the method that was attempting to be called." "Test class that will be a calculated value.") (defclass eitest-superior nil - ((sub :initform (eitest-subordinate) + ((sub :initform (funcall #'eitest-subordinate) :type eitest-subordinate)) "A class with an initform that creates a class.") @@ -555,7 +599,10 @@ METHOD is the method that was attempting to be called." (should-not (cl-typep listooa '(list-of class-b))) (should-not (cl-typep listoob '(list-of class-a))))) +;; Silence byte-compiler. (defvar eitest-t1 nil) +(declare-function eieio-tests-initform-not-evaluated-when-initarg-is-present nil) +(declare-function eieio-tests-initform-not-evaluated-when-initarg-is-present--eieio-childp nil) (ert-deftest eieio-test-25-slot-tests () (setq eitest-t1 (class-c)) ;; Slot initialization @@ -617,12 +664,14 @@ METHOD is the method that was attempting to be called." () "Protection testing baseclass.") -(defmethod prot0-slot-2 ((s2 prot-0)) - "Try to access slot-2 from this class which doesn't have it. +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod prot0-slot-2 ((s2 prot-0)) + "Try to access slot-2 from this class which doesn't have it. The object S2 passed in will be of class prot-1, which does have the slot. This could be allowed, and currently is in EIEIO. Needed by the eieio persistent base class." - (oref s2 slot-2)) + (oref s2 slot-2))) (defclass prot-1 (prot-0) ((slot-1 :initarg :slot-1 @@ -640,26 +689,28 @@ Needed by the eieio persistent base class." nil "A class for testing the :protection option.") -(defmethod prot1-slot-2 ((s2 prot-1)) - "Try to access slot-2 in S2." - (oref s2 slot-2)) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod prot1-slot-2 ((s2 prot-1)) + "Try to access slot-2 in S2." + (oref s2 slot-2)) -(defmethod prot1-slot-2 ((s2 prot-2)) - "Try to access slot-2 in S2." - (oref s2 slot-2)) + (defmethod prot1-slot-2 ((s2 prot-2)) + "Try to access slot-2 in S2." + (oref s2 slot-2)) -(defmethod prot1-slot-3-only ((s2 prot-1)) - "Try to access slot-3 in S2. + (defmethod prot1-slot-3-only ((s2 prot-1)) + "Try to access slot-3 in S2. Do not override for `prot-2'." - (oref s2 slot-3)) + (oref s2 slot-3)) -(defmethod prot1-slot-3 ((s2 prot-1)) - "Try to access slot-3 in S2." - (oref s2 slot-3)) + (defmethod prot1-slot-3 ((s2 prot-1)) + "Try to access slot-3 in S2." + (oref s2 slot-3)) -(defmethod prot1-slot-3 ((s2 prot-2)) - "Try to access slot-3 in S2." - (oref s2 slot-3)) + (defmethod prot1-slot-3 ((s2 prot-2)) + "Try to access slot-3 in S2." + (oref s2 slot-3))) (defvar eitest-p1 nil) (defvar eitest-p2 nil) @@ -729,7 +780,7 @@ Do not override for `prot-2'." (should (eq (oref eitest-II3 slot3) 'penguin))) (defclass slotattr-base () - ((initform :initform init) + ((initform :initform 'init) (type :type list) (initarg :initarg :initarg) (protection :protection :private) @@ -744,7 +795,7 @@ Do not override for `prot-2'." Subclasses to override slot attributes.") (defclass slotattr-ok (slotattr-base) - ((initform :initform no-init) + ((initform :initform 'no-init) (initarg :initarg :initblarg) (custom :custom string :label "One String" @@ -778,28 +829,29 @@ Subclasses to override slot attributes.") (let ((obj (slotattr-ok))) (should (eq (oref obj initform) 'no-init)))) -(defclass slotattr-class-base () - ((initform :allocation :class - :initform init) - (type :allocation :class - :type list) - (initarg :allocation :class - :initarg :initarg) - (protection :allocation :class - :protection :private) - (custom :allocation :class - :custom (repeat string) - :label "Custom Strings" - :group moose) - (docstring :allocation :class - :documentation - "Replace the doc-string for this property.") - ) - "Baseclass we will attempt to subclass. -Subclasses to override slot attributes.") +(with-no-warnings ; FIXME: Make more specific. + (defclass slotattr-class-base () + ((initform :allocation :class + :initform 'init) + (type :allocation :class + :type list) + (initarg :allocation :class + :initarg :initarg) + (protection :allocation :class + :protection :private) + (custom :allocation :class + :custom (repeat string) + :label "Custom Strings" + :group moose) + (docstring :allocation :class + :documentation + "Replace the doc-string for this property.") + ) + "Baseclass we will attempt to subclass. +Subclasses to override slot attributes.")) (defclass slotattr-class-ok (slotattr-class-base) - ((initform :initform no-init) + ((initform :initform 'no-init) (initarg :initarg :initblarg) (custom :custom string :label "One String" @@ -861,7 +913,7 @@ Subclasses to override slot attributes.") (should (setq eitest-CLONETEST2 (clone eitest-CLONETEST1)))) (defclass IT (eieio-instance-tracker) - ((tracking-symbol :initform IT-list) + ((tracking-symbol :initform 'IT-list) (slot1 :initform 'die)) "Instance Tracker test object.") @@ -914,13 +966,20 @@ Subclasses to override slot attributes.") (defclass eieio--testing () ()) -(defmethod constructor :static ((_x eieio--testing) newname &rest _args) - (list newname 2)) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod constructor :static ((_x eieio--testing) newname &rest _args) + (list newname 2))) (ert-deftest eieio-test-37-obsolete-name-in-constructor () ;; FIXME repeated intermittent failures on hydra and elsewhere (bug#24503). :tags '(:unstable) - (should (equal (eieio--testing "toto") '("toto" 2)))) + ;; Disable byte-compiler "Warning: Obsolete name arg "toto" to + ;; constructor eieio--testing". This could be made more specific + ;; with changes to `with-suppressed-warnings', but it's not worth + ;; the hassle for just this one test. + (with-no-warnings + (should (equal (eieio--testing "toto") '("toto" 2))))) (ert-deftest eieio-autoload () "Tests to see whether reftex-auc has been autoloaded" @@ -969,6 +1028,21 @@ Subclasses to override slot attributes.") (should (eieio-instance-inheritor-slot-boundp C :b)) (should-not (eieio-instance-inheritor-slot-boundp C :c)))) +;;;; Interaction with defstruct + +(cl-defstruct eieio-test--struct a b (c nil :read-only t)) + +(ert-deftest eieio-test-defstruct-slot-value () + (let ((x (make-eieio-test--struct :a 'A :b 'B :c 'C))) + (should (eq (eieio-test--struct-a x) + (slot-value x 'a))) + (should (eq (eieio-test--struct-b x) + (slot-value x 'b))) + (should (eq (eieio-test--struct-c x) + (slot-value x 'c))) + (setf (slot-value x 'a) 1) + (should (eq (eieio-test--struct-a x) 1)) + (should-error (setf (slot-value x 'c) 3) :type 'eieio-read-only))) (provide 'eieio-tests) diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el index a18664bba3b..e2b41297ade 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. @@ -494,6 +495,12 @@ This macro is used to test if macroexpansion in `should' works." (should (equal (ert-select-tests '(tag b) (list test)) (list test))) (should (equal (ert-select-tests '(tag c) (list test)) '())))) +(ert-deftest ert-test-select-undefined () + (let* ((symbol (make-symbol "ert-not-a-test")) + (data (should-error (ert-select-tests symbol t) + :type 'ert-test-unbound))) + (should (eq (cadr data) symbol)))) + ;;; Tests for utility functions. (ert-deftest ert-test-parse-keys-and-body () @@ -519,17 +526,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 +559,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)) @@ -695,49 +765,40 @@ This macro is used to test if macroexpansion in `should' works." (should (equal (ert--abbreviate-string "bar" 0 t) ""))) (ert-deftest ert-test-explain-equal-string-properties () - (should - (equal (ert--explain-equal-including-properties #("foo" 0 1 (a b)) - "foo") - '(char 0 "f" - (different-properties-for-key a (different-atoms b nil)) - context-before "" - context-after "oo"))) - (should (equal (ert--explain-equal-including-properties + (should-not (ert--explain-equal-including-properties-rec "foo" "foo")) + (should-not (ert--explain-equal-including-properties-rec + #("foo" 0 3 (a b)) + (propertize "foo" 'a 'b))) + (should-not (ert--explain-equal-including-properties-rec + #("foo" 0 3 (a b c d)) + (propertize "foo" 'a 'b 'c 'd))) + (should-not (ert--explain-equal-including-properties-rec + #("foo" 0 3 (a (t))) + (propertize "foo" 'a (list t)))) + + (should (equal (ert--explain-equal-including-properties-rec + #("foo" 0 3 (a b c e)) + (propertize "foo" 'a 'b 'c 'd)) + '(char 0 "f" (different-properties-for-key c (different-atoms e d)) + context-before "" + context-after "oo"))) + (should (equal (ert--explain-equal-including-properties-rec + #("foo" 0 1 (a b)) + "foo") + '(char 0 "f" + (different-properties-for-key a (different-atoms b nil)) + context-before "" + context-after "oo"))) + (should (equal (ert--explain-equal-including-properties-rec #("foo" 1 3 (a b)) #("goo" 0 1 (c d))) '(array-elt 0 (different-atoms (?f "#x66" "?f") (?g "#x67" "?g"))))) - (should - (equal (ert--explain-equal-including-properties - #("foo" 0 1 (a b c d) 1 3 (a b)) - #("foo" 0 1 (c d a b) 1 2 (a foo))) - '(char 1 "o" (different-properties-for-key a (different-atoms b foo)) - context-before "f" context-after "o")))) - -(ert-deftest ert-test-equal-including-properties () - (should (equal-including-properties "foo" "foo")) - (should (ert-equal-including-properties "foo" "foo")) - - (should (equal-including-properties #("foo" 0 3 (a b)) - (propertize "foo" 'a 'b))) - (should (ert-equal-including-properties #("foo" 0 3 (a b)) - (propertize "foo" 'a 'b))) - - (should (equal-including-properties #("foo" 0 3 (a b c d)) - (propertize "foo" 'a 'b 'c 'd))) - (should (ert-equal-including-properties #("foo" 0 3 (a b c d)) - (propertize "foo" 'a 'b 'c 'd))) - - (should-not (equal-including-properties #("foo" 0 3 (a b c e)) - (propertize "foo" 'a 'b 'c 'd))) - (should-not (ert-equal-including-properties #("foo" 0 3 (a b c e)) - (propertize "foo" 'a 'b 'c 'd))) - - ;; This is bug 6581. - (should-not (equal-including-properties #("foo" 0 3 (a (t))) - (propertize "foo" 'a (list t)))) - (should (ert-equal-including-properties #("foo" 0 3 (a (t))) - (propertize "foo" 'a (list t))))) + (should (equal (ert--explain-equal-including-properties-rec + #("foo" 0 1 (a b c d) 1 3 (a b)) + #("foo" 0 1 (c d a b) 1 2 (a foo))) + '(char 1 "o" (different-properties-for-key a (different-atoms b foo)) + context-before "f" context-after "o")))) (ert-deftest ert-test-stats-set-test-and-result () (let* ((test-1 (make-ert-test :name 'test-1 diff --git a/test/lisp/emacs-lisp/ert-x-tests.el b/test/lisp/emacs-lisp/ert-x-tests.el index 9f40a18d343..7106b7abc0c 100644 --- a/test/lisp/emacs-lisp/ert-x-tests.el +++ b/test/lisp/emacs-lisp/ert-x-tests.el @@ -90,10 +90,10 @@ "foo baz"))) (ert-deftest ert-propertized-string () - (should (ert-equal-including-properties + (should (equal-including-properties (ert-propertized-string "a" '(a b) "b" '(c t) "cd") #("abcd" 1 2 (a b) 2 4 (c t)))) - (should (ert-equal-including-properties + (should (equal-including-properties (ert-propertized-string "foo " '(face italic) "bar" " baz" nil " quux") #("foo bar baz quux" 4 11 (face italic))))) @@ -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 <passing-test> <failing-test> " @@ -152,21 +156,19 @@ "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, " "1 skipped")))) (with-current-buffer buffer-name (font-lock-mode 0) - (should (ert-equal-including-properties + (should (equal-including-properties (ert-filter-string (buffer-string) '("Started at:\\(.*\\)$" 1) '("Finished at:\\(.*\\)$" 1)) @@ -175,7 +177,7 @@ ;; pretend we are. (let ((noninteractive nil)) (font-lock-mode 1)) - (should (ert-equal-including-properties + (should (equal-including-properties (ert-filter-string (buffer-string) '("Started at:\\(.*\\)$" 1) '("Finished at:\\(.*\\)$" 1)) @@ -271,6 +273,62 @@ desired effect." (cl-loop for x in '(0 1 2 3 4 t) do (should (equal (c x) (lisp x)))))) +(ert-deftest ert-x-tests--with-temp-file-generate-suffix () + (should (equal (ert--with-temp-file-generate-suffix "foo.el") "-foo")) + (should (equal (ert--with-temp-file-generate-suffix "foo-test.el") "-foo")) + (should (equal (ert--with-temp-file-generate-suffix "foo-tests.el") "-foo")) + (should (equal (ert--with-temp-file-generate-suffix "foo-bar-baz.el") + "-foo-bar-baz")) + (should (equal (ert--with-temp-file-generate-suffix "/foo/bar/baz.el") + "-baz"))) + +(ert-deftest ert-x-tests-with-temp-file () + (let (saved) + (ert-with-temp-file fil + (setq saved fil) + (should (file-exists-p fil)) + (should (file-regular-p fil))) + (should-not (file-exists-p saved)))) + +(ert-deftest ert-x-tests-with-temp-file/handle-error () + (let (saved) + (ignore-errors + (ert-with-temp-file fil + (setq saved fil) + (error "foo"))) + (should-not (file-exists-p saved)))) + +(ert-deftest ert-x-tests-with-temp-file/prefix-and-suffix-kwarg () + (ert-with-temp-file fil + :prefix "foo" + :suffix "bar" + (should (string-match "foo.*bar" fil)))) + +(ert-deftest ert-x-tests-with-temp-file/text-kwarg () + (ert-with-temp-file fil + :text "foobar3" + (let ((buf (find-file-noselect fil))) + (unwind-protect + (with-current-buffer buf + (should (equal (buffer-string) "foobar3"))) + (kill-buffer buf))))) + +(ert-deftest ert-x-tests-with-temp-file/unknown-kwarg-signals-error () + (should-error + (ert-with-temp-file fil :foo "foo" nil))) + +(ert-deftest ert-x-tests-with-temp-directory () + (let (saved) + (ert-with-temp-directory dir + (setq saved dir) + (should (file-exists-p dir)) + (should (file-directory-p dir)) + (should (equal dir (file-name-as-directory dir)))) + (should-not (file-exists-p saved)))) + +(ert-deftest ert-x-tests-with-temp-directory/text-signals-error () + (should-error + (ert-with-temp-directory dir :text "foo" nil))) (provide 'ert-x-tests) diff --git a/test/lisp/emacs-lisp/generator-tests.el b/test/lisp/emacs-lisp/generator-tests.el index c81d3d09e7d..1d2aa7ab374 100644 --- a/test/lisp/emacs-lisp/generator-tests.el +++ b/test/lisp/emacs-lisp/generator-tests.el @@ -74,7 +74,7 @@ identical output." (cps-testcase cps-prog1-b (prog1 1)) (cps-testcase cps-prog1-c (prog2 1 2 3)) (cps-testcase cps-quote (progn 'hello)) -(cps-testcase cps-function (progn #'hello)) +(cps-testcase cps-function (progn #'message)) (cps-testcase cps-and-fail (and 1 nil 2)) (cps-testcase cps-and-succeed (and 1 2 3)) @@ -85,9 +85,9 @@ identical output." (cps-testcase cps-or-empty (or)) (cps-testcase cps-let* (let* ((i 10)) i)) -(cps-testcase cps-let*-shadow-empty (let* ((i 10)) (let (i) i))) +(cps-testcase cps-let*-shadow-empty (let* ((i 10)) i (let ((i nil)) i))) (cps-testcase cps-let (let ((i 10)) i)) -(cps-testcase cps-let-shadow-empty (let ((i 10)) (let (i) i))) +(cps-testcase cps-let-shadow-empty (let ((i 10)) i (let ((i nil)) i))) (cps-testcase cps-let-novars (let nil 42)) (cps-testcase cps-let*-novars (let* nil 42)) @@ -95,7 +95,7 @@ identical output." (let ((a 5) (b 6)) (let ((a b) (b a)) (list a b)))) (cps-testcase cps-let*-parallel - (let* ((a 5) (b 6)) (let* ((a b) (b a)) (list a b)))) + (let* ((a 5) (b 6)) a (let* ((a b) (b a)) (list a b)))) (cps-testcase cps-while-dynamic (setq *cps-test-i* 0) @@ -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) @@ -307,6 +307,7 @@ identical output." (1+ it))))))) -2))) +(defun generator-tests-edebug ()) ; silence byte-compiler (ert-deftest generator-tests-edebug () "Check that Bug#40434 is fixed." (with-temp-buffer diff --git a/test/lisp/emacs-lisp/gv-tests.el b/test/lisp/emacs-lisp/gv-tests.el index b9850eca8b9..6ee274ae10f 100644 --- a/test/lisp/emacs-lisp/gv-tests.el +++ b/test/lisp/emacs-lisp/gv-tests.el @@ -21,22 +21,21 @@ (require 'edebug) (require 'ert) +(require 'ert-x) (eval-when-compile (require 'cl-lib)) (cl-defmacro gv-tests--in-temp-dir ((elvar elcvar) (&rest filebody) &rest body) (declare (indent 2)) - `(let ((default-directory (make-temp-file "gv-test" t))) - (unwind-protect - (let ((,elvar "gv-test-deffoo.el") - (,elcvar "gv-test-deffoo.elc")) - (with-temp-file ,elvar - (insert ";; -*- lexical-binding: t; -*-\n") - (dolist (form ',filebody) - (pp form (current-buffer)))) - ,@body) - (delete-directory default-directory t)))) + `(ert-with-temp-directory default-directory + (let ((,elvar "gv-test-deffoo.el") + (,elcvar "gv-test-deffoo.elc")) + (with-temp-file ,elvar + (insert ";; -*- lexical-binding: t; -*-\n") + (dolist (form ',filebody) + (pp form (current-buffer)))) + ,@body))) (ert-deftest gv-define-expander-in-file () (gv-tests--in-temp-dir (el elc) 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..7f4d50c5958 100644 --- a/test/lisp/emacs-lisp/lisp-tests.el +++ b/test/lisp/emacs-lisp/lisp-tests.el @@ -213,6 +213,7 @@ (should-error (forward-sexp)))) ;; FIXME: Shouldn't be an error. ;; Test some core Elisp rules. +(defvar c-e-x) (ert-deftest core-elisp-tests-1-defvar-in-let () "Test some core Elisp rules." (with-temp-buffer @@ -235,7 +236,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 +325,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/macroexp-resources/m1.el b/test/lisp/emacs-lisp/macroexp-resources/m1.el index 96b5f7091af..3c0594fb166 100644 --- a/test/lisp/emacs-lisp/macroexp-resources/m1.el +++ b/test/lisp/emacs-lisp/macroexp-resources/m1.el @@ -5,23 +5,23 @@ ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: -;; - ;;; Code: (defconst macroexp--m1-tests-filename (macroexp-file-name)) diff --git a/test/lisp/emacs-lisp/macroexp-resources/m2.el b/test/lisp/emacs-lisp/macroexp-resources/m2.el index 4f2b96d8ca0..85eae3b9dcf 100644 --- a/test/lisp/emacs-lisp/macroexp-resources/m2.el +++ b/test/lisp/emacs-lisp/macroexp-resources/m2.el @@ -5,23 +5,23 @@ ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: -;; - ;;; Code: (defconst macroexp--m2-tests-filename (macroexp-file-name)) diff --git a/test/lisp/emacs-lisp/macroexp-resources/vk.el b/test/lisp/emacs-lisp/macroexp-resources/vk.el new file mode 100644 index 00000000000..2dee1306a2d --- /dev/null +++ b/test/lisp/emacs-lisp/macroexp-resources/vk.el @@ -0,0 +1,130 @@ +;;; vk.el --- test code for macroexp-tests -*- 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 <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'macroexp) + +(defmacro vk-variable-kind (var) + (if (macroexp--dynamic-variable-p var) ''dyn ''lex)) + +(defvar vk-a 1) +(defconst vk-b 2) +(defvar vk-c) + +(defun vk-f1 (x) + (defvar vk-u1) + (let ((vk-a 10) + (vk-b 20) + (vk-c 30) + (vk-u1 40) + (y 50)) + (ignore vk-a vk-b vk-c vk-u1 x y) + (list + (vk-variable-kind vk-a) ; dyn + (vk-variable-kind vk-b) ; dyn + (vk-variable-kind vk-c) ; dyn + (vk-variable-kind vk-u1) ; dyn + (vk-variable-kind x) ; lex + (vk-variable-kind y)))) ; lex + +(eval-and-compile + (defvar vk-u2) + (defun vk-f2 (x) + (defvar vk-v2) + (let ((vk-u2 11) + (vk-v2 12) + (y 13)) + (ignore vk-u2 vk-v2 x y) + (list + (vk-variable-kind vk-u2) ; dyn + (vk-variable-kind vk-v2) ; dyn + (vk-variable-kind x) ; lex + (vk-variable-kind y))))) ; lex + +(eval-when-compile + (defvar vk-u3) + (defun vk-f3 (x) + (defvar vk-v3) + (let ((vk-a 23) + (vk-b 24) + (vk-u3 25) + (vk-v3 26) + (y 27)) + (ignore vk-a vk-b vk-u3 vk-v3 x y) + (list + (vk-variable-kind vk-a) ; dyn + (vk-variable-kind vk-b) ; dyn + (vk-variable-kind vk-u3) ; dyn + (vk-variable-kind vk-v3) ; dyn + (vk-variable-kind x) ; lex + (vk-variable-kind y))))) ; lex + +(defconst vk-val3 (eval-when-compile (vk-f3 0))) + +(defconst vk-f4 '(lambda (x) + (defvar vk-v4) + (let ((vk-v4 31) + (y 32)) + (ignore vk-v4 x y) + (list + (vk-variable-kind vk-a) ; dyn + (vk-variable-kind vk-b) ; dyn + (vk-variable-kind vk-v4) ; dyn + (vk-variable-kind x) ; dyn + (vk-variable-kind y))))) ; dyn + +(defconst vk-f5 '(closure (t) (x) + (defvar vk-v5) + (let ((vk-v5 41) + (y 42)) + (ignore vk-v5 x y) + (list + (vk-variable-kind vk-a) ; dyn + (vk-variable-kind vk-b) ; dyn + (vk-variable-kind vk-v5) ; dyn + (vk-variable-kind x) ; lex + (vk-variable-kind y))))) ; lex + +(defun vk-f6 () + (eval '(progn + (defvar vk-v6) + (let ((vk-v6 51) + (y 52)) + (ignore vk-v6 y) + (list + (vk-variable-kind vk-a) ; dyn + (vk-variable-kind vk-b) ; dyn + (vk-variable-kind vk-v6) ; dyn + (vk-variable-kind vk-y)))))) ; dyn + +(defun vk-f7 () + (eval '(progn + (defvar vk-v7) + (let ((vk-v7 51) + (y 52)) + (ignore vk-v7 y) + (list + (vk-variable-kind vk-a) ; dyn + (vk-variable-kind vk-b) ; dyn + (vk-variable-kind vk-v7) ; dyn + (vk-variable-kind vk-y)))) ; lex + t)) + +(provide 'vk) diff --git a/test/lisp/emacs-lisp/macroexp-tests.el b/test/lisp/emacs-lisp/macroexp-tests.el index 89d3882d1da..fb2211b1770 100644 --- a/test/lisp/emacs-lisp/macroexp-tests.el +++ b/test/lisp/emacs-lisp/macroexp-tests.el @@ -5,25 +5,28 @@ ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: -;; - ;;; Code: +(require 'macroexp) +(require 'ert-x) + (ert-deftest macroexp--tests-fgrep () (should (equal (macroexp--fgrep '((x) (y)) '([x] z ((u)))) '((x)))) @@ -67,6 +70,58 @@ (should (equal "m1.el" (file-name-nondirectory macroexp--m1-tests-comp-filename))))) +(defun macroexp-tests--run-emacs (&rest args) + "Run Emacs in batch mode with ARGS, return output." + (let ((emacs (expand-file-name invocation-name invocation-directory))) + (with-temp-buffer + (let ((res (apply #'call-process emacs nil t nil + "-Q" "--batch" args)) + (output (buffer-string))) + (unless (equal res 0) + (message "%s" output) + (error "Inferior Emacs exited with status %S" res)) + output)))) + +(defun macroexp-tests--eval-in-subprocess (file expr) + (let ((output (macroexp-tests--run-emacs + "-l" file (format "--eval=(print %S)" expr)))) + (car (read-from-string output)))) + +(defun macroexp-tests--byte-compile-in-subprocess (file) + "Byte-compile FILE using a subprocess to avoid contaminating the lisp state." + (let ((output (macroexp-tests--run-emacs "-f" "batch-byte-compile" file))) + (when output + (message "%s" output)))) + +(ert-deftest macroexp--tests-dynamic-variable-p () + "Test `macroexp--dynamic-variable-p'." + (let* ((vk-el (ert-resource-file "vk.el")) + (vk-elc (concat vk-el "c")) + (expr '(list (vk-f1 0) + (vk-f2 0) + vk-val3 + (funcall vk-f4 0) + (funcall vk-f5 0) + (vk-f6) + (vk-f7)))) + ;; We compile and run the test in separate processes for complete + ;; isolation between test cases. + (should (equal (macroexp-tests--eval-in-subprocess vk-el expr) + '((dyn dyn dyn dyn lex lex) + (dyn dyn lex lex) + (dyn dyn dyn dyn lex lex) + (dyn dyn dyn dyn dyn) + (dyn dyn dyn lex lex) + (dyn dyn dyn dyn) + (dyn dyn dyn lex)))) + (macroexp-tests--byte-compile-in-subprocess vk-el) + (should (equal (macroexp-tests--eval-in-subprocess vk-elc expr) + '((dyn dyn dyn dyn lex lex) + (dyn dyn lex lex) + (dyn dyn dyn dyn lex lex) + (dyn dyn dyn dyn dyn) + (dyn dyn dyn lex lex) + (dyn dyn dyn dyn) + (dyn dyn dyn lex)))))) -(provide 'macroexp-tests) ;;; macroexp-tests.el ends here diff --git a/test/lisp/emacs-lisp/multisession-tests.el b/test/lisp/emacs-lisp/multisession-tests.el new file mode 100644 index 00000000000..17457d9be2f --- /dev/null +++ b/test/lisp/emacs-lisp/multisession-tests.el @@ -0,0 +1,207 @@ +;;; multisession-tests.el --- Tests for multisession.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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'multisession) +(require 'ert) +(require 'ert-x) +(require 'cl-lib) + +(declare-function sqlite-close "sqlite.c") + +(ert-deftest multi-test-sqlite-simple () + (skip-unless (sqlite-available-p)) + (ert-with-temp-file dir + :directory t + (let ((user-init-file "/tmp/foo.el") + (multisession-storage 'sqlite) + (multisession-directory dir)) + (unwind-protect + (progn + (define-multisession-variable multisession--foo 0 + "" + :synchronized t) + (should (= (multisession-value multisession--foo) 0)) + (cl-incf (multisession-value multisession--foo)) + (should (= (multisession-value multisession--foo) 1)) + (call-process + (concat invocation-directory invocation-name) + nil t nil + "-Q" "-batch" + "--eval" (prin1-to-string + `(progn + (require 'multisession) + (let ((multisession-directory ,dir) + (multisession-storage 'sqlite) + (user-init-file "/tmp/foo.el")) + (define-multisession-variable multisession--foo 0 + "" + :synchronized t) + (cl-incf (multisession-value multisession--foo)))))) + (should (= (multisession-value multisession--foo) 2))) + (sqlite-close multisession--db) + (setq multisession--db nil))))) + +(ert-deftest multi-test-sqlite-busy () + (skip-unless (sqlite-available-p)) + (ert-with-temp-file dir + :directory t + (let ((user-init-file "/tmp/foo.el") + (multisession-directory dir) + (multisession-storage 'sqlite) + proc) + (unwind-protect + (progn + (define-multisession-variable multisession--bar 0 + "" + :synchronized t) + (should (= (multisession-value multisession--bar) 0)) + (cl-incf (multisession-value multisession--bar)) + (should (= (multisession-value multisession--bar) 1)) + (setq proc + (start-process + "other-emacs" + nil + (concat invocation-directory invocation-name) + "-Q" "-batch" + "--eval" (prin1-to-string + `(progn + (require 'multisession) + (let ((multisession-directory ,dir) + (multisession-storage 'sqlite) + (user-init-file "/tmp/bar.el")) + (define-multisession-variable multisession--bar 0 + "" :synchronized t) + (dotimes (i 100) + (cl-incf (multisession-value multisession--bar)))))))) + (while (process-live-p proc) + (ignore-error 'sqlite-locked-error + (message "multisession--bar %s" (multisession-value multisession--bar)) + ;;(cl-incf (multisession-value multisession--bar)) + ) + (sleep-for 0.1)) + (message "multisession--bar ends up as %s" (multisession-value multisession--bar)) + (should (< (multisession-value multisession--bar) 1003))) + (sqlite-close multisession--db) + (setq multisession--db nil))))) + +(ert-deftest multi-test-files-simple () + (ert-with-temp-file dir + :directory t + (let ((user-init-file "/tmp/sfoo.el") + (multisession-storage 'files) + (multisession-directory dir)) + (define-multisession-variable multisession--sfoo 0 + "" + :synchronized t) + (should (= (multisession-value multisession--sfoo) 0)) + (cl-incf (multisession-value multisession--sfoo)) + (should (= (multisession-value multisession--sfoo) 1)) + ;; On Windows and Haiku, we don't have sub-second resolution, so + ;; let some time pass to make the "later" logic work. + (when (memq system-type '(windows-nt haiku)) + (sleep-for 0.6)) + (call-process + (concat invocation-directory invocation-name) + nil t nil + "-Q" "-batch" + "--eval" (prin1-to-string + `(progn + (require 'multisession) + (let ((multisession-directory ,dir) + (multisession-storage 'files) + (user-init-file "/tmp/sfoo.el")) + (define-multisession-variable multisession--sfoo 0 + "" + :synchronized t) + (cl-incf (multisession-value multisession--sfoo)))))) + (should (= (multisession-value multisession--sfoo) 2))))) + +(ert-deftest multi-test-files-busy () + (skip-unless (sqlite-available-p)) + (ert-with-temp-file dir + :directory t + (let ((user-init-file "/tmp/foo.el") + (multisession-storage 'files) + (multisession-directory dir) + proc) + (define-multisession-variable multisession--sbar 0 + "" + :synchronized t) + (should (= (multisession-value multisession--sbar) 0)) + (cl-incf (multisession-value multisession--sbar)) + (should (= (multisession-value multisession--sbar) 1)) + (setq proc + (start-process + "other-emacs" + nil + (concat invocation-directory invocation-name) + "-Q" "-batch" + "--eval" (prin1-to-string + `(progn + (require 'multisession) + (let ((multisession-directory ,dir) + (multisession-storage 'files) + (user-init-file "/tmp/sbar.el")) + (define-multisession-variable multisession--sbar 0 + "" :synchronized t) + (dotimes (i 100) + (cl-incf (multisession-value multisession--sbar)))))))) + (while (process-live-p proc) + (message "multisession--sbar %s" (multisession-value multisession--sbar)) + ;;(cl-incf (multisession-value multisession--sbar)) + (sleep-for 0.1)) + (message "multisession--sbar ends up as %s" (multisession-value multisession--sbar)) + (should (< (multisession-value multisession--sbar) 200))))) + +(ert-deftest multi-test-files-some-values () + (ert-with-temp-file dir + :directory t + (let ((user-init-file "/tmp/sfoo.el") + (multisession-storage 'files) + (multisession-directory dir)) + (define-multisession-variable multisession--foo1 nil) + (should (eq (multisession-value multisession--foo1) nil)) + (setf (multisession-value multisession--foo1) nil) + (should (eq (multisession-value multisession--foo1) nil)) + (setf (multisession-value multisession--foo1) t) + (should (eq (multisession-value multisession--foo1) t)) + + (define-multisession-variable multisession--foo2 t) + (setf (multisession-value multisession--foo2) nil) + (should (eq (multisession-value multisession--foo2) nil)) + (setf (multisession-value multisession--foo2) t) + (should (eq (multisession-value multisession--foo2) t)) + + (define-multisession-variable multisession--foo3 t) + (should-error (setf (multisession-value multisession--foo3) (make-marker))) + + (let ((string (with-temp-buffer + (set-buffer-multibyte nil) + (insert 0 1 2) + (buffer-string)))) + (should-not (multibyte-string-p string)) + (define-multisession-variable multisession--foo4 nil) + (setf (multisession-value multisession--foo4) string) + (should (equal (multisession-value multisession--foo4) string)))))) + +;;; multisession-tests.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin-aux.el b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin-aux.el new file mode 100644 index 00000000000..724f88ec9ea --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin-aux.el @@ -0,0 +1,12 @@ +;;; macro-builtin-aux.el --- laksd -*- lexical-binding: t; -*- + +;; Author: Artur Malabarba <emacs@endlessparentheses.com> + +;;; Code: + +(defun macro-builtin-aux-1 ( &rest forms) + "Description" + `(progn ,@forms)) + +(provide 'macro-builtin-aux) +;;; macro-builtin-aux.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin.el b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin.el new file mode 100644 index 00000000000..828968a0576 --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin.el @@ -0,0 +1,21 @@ +;;; macro-builtin.el --- laksd -*- lexical-binding: t; -*- + +;; Author: Artur Malabarba <emacs@endlessparentheses.com> +;; Keywords: tools +;; Version: 1.0 + +;;; Code: + +(require 'macro-builtin-aux) + +(defmacro macro-builtin-1 ( &rest forms) + "Description" + `(progn ,@forms)) + +(defun macro-builtin-func () + "" + (macro-builtin-1 'a 'b) + (macro-builtin-aux-1 'a 'b)) + +(provide 'macro-builtin) +;;; macro-builtin.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin-aux.el b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin-aux.el new file mode 100644 index 00000000000..9f257d9d22c --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin-aux.el @@ -0,0 +1,16 @@ +;;; macro-builtin-aux.el --- laksd -*- lexical-binding: t; -*- + +;; Author: Artur Malabarba <emacs@endlessparentheses.com> + +;;; Code: + +(defmacro macro-builtin-aux-1 ( &rest forms) + "Description" + `(progn ,@forms)) + +(defmacro macro-builtin-aux-3 ( &rest _) + "Description" + 90) + +(provide 'macro-builtin-aux) +;;; macro-builtin-aux.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin.el b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin.el new file mode 100644 index 00000000000..5d241c082d0 --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin.el @@ -0,0 +1,30 @@ +;;; macro-builtin.el --- laksd -*- lexical-binding: t; -*- + +;; Author: Artur Malabarba <emacs@endlessparentheses.com> +;; Keywords: tools +;; Version: 2.0 + +;;; Code: + +(require 'macro-builtin-aux) + +(defmacro macro-builtin-1 ( &rest forms) + "Description" + `(progn ,(cadr (car forms)))) + + +(defun macro-builtin-func () + "" + (list (macro-builtin-1 '1 'b) + (macro-builtin-aux-1 'a 'b))) + +(defmacro macro-builtin-3 (&rest _) + "Description" + 10) + +(defun macro-builtin-10-and-90 () + "" + (list (macro-builtin-3 haha) (macro-builtin-aux-3 hehe))) + +(provide 'macro-builtin) +;;; macro-builtin.el ends here diff --git a/test/lisp/emacs-lisp/package-tests.el b/test/lisp/emacs-lisp/package-tests.el index 1fd93bc1be7..efa9f834110 100644 --- a/test/lisp/emacs-lisp/package-tests.el +++ b/test/lisp/emacs-lisp/package-tests.el @@ -115,57 +115,55 @@ &rest body) "Set up temporary locations and variables for testing." (declare (indent 1) (debug (([&rest form]) body))) - `(let* ((package-test-user-dir (make-temp-file "pkg-test-user-dir-" t)) - (process-environment (cons (format "HOME=%s" package-test-user-dir) - process-environment)) - (package-user-dir package-test-user-dir) - (package-gnupghome-dir (expand-file-name "gnupg" package-user-dir)) - (package-archives `(("gnu" . ,(or ,location package-test-data-dir)))) - (default-directory package-test-file-dir) - abbreviated-home-dir - package--initialized - package-alist - ,@(if update-news - '(package-update-news-on-upload t) - (list (cl-gensym))) - ,@(if upload-base - '((package-test-archive-upload-base (make-temp-file "pkg-archive-base-" t)) - (package-archive-upload-base package-test-archive-upload-base)) - (list (cl-gensym)))) ;; Dummy value so `let' doesn't try to bind nil - (let ((buf (get-buffer "*Packages*"))) - (when (buffer-live-p buf) - (kill-buffer buf))) - (unwind-protect - (progn - ,(if basedir `(cd ,basedir)) - (unless (file-directory-p package-user-dir) - (mkdir package-user-dir)) - (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest _) t)) - ((symbol-function 'y-or-n-p) (lambda (&rest _) t))) - ,@(when install - `((package-initialize) - (package-refresh-contents) - (mapc 'package-install ,install))) - (with-temp-buffer - ,(if file - `(insert-file-contents ,file)) - ,@body))) - - (when ,upload-base - (dolist (f '("archive-contents" - "simple-single-1.3.el" - "simple-single-1.4.el" - "simple-single-readme.txt")) - (ignore-errors - (delete-file - (expand-file-name f package-test-archive-upload-base)))) - (delete-directory package-test-archive-upload-base)) - (when (file-directory-p package-test-user-dir) - (delete-directory package-test-user-dir t)) - - (when (and (boundp 'package-test-archive-upload-base) - (file-directory-p package-test-archive-upload-base)) - (delete-directory package-test-archive-upload-base t))))) + `(ert-with-temp-directory package-test-user-dir + (let* ((process-environment (cons (format "HOME=%s" package-test-user-dir) + process-environment)) + (package-user-dir package-test-user-dir) + (package-gnupghome-dir (expand-file-name "gnupg" package-user-dir)) + (package-archives `(("gnu" . ,(or ,location package-test-data-dir)))) + (default-directory package-test-file-dir) + abbreviated-home-dir + package--initialized + package-alist + ,@(if update-news + '(package-update-news-on-upload t) + (list (cl-gensym))) + ,@(if upload-base + '((package-test-archive-upload-base (make-temp-file "pkg-archive-base-" t)) + (package-archive-upload-base package-test-archive-upload-base)) + (list (cl-gensym)))) ;; Dummy value so `let' doesn't try to bind nil + (let ((buf (get-buffer "*Packages*"))) + (when (buffer-live-p buf) + (kill-buffer buf))) + (unwind-protect + (progn + ,(if basedir `(cd ,basedir)) + (unless (file-directory-p package-user-dir) + (mkdir package-user-dir)) + (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest _) t)) + ((symbol-function 'y-or-n-p) (lambda (&rest _) t))) + ,@(when install + `((package-initialize) + (package-refresh-contents) + (mapc 'package-install ,install))) + (with-temp-buffer + ,(if file + `(insert-file-contents ,file)) + ,@body))) + + (when ,upload-base + (dolist (f '("archive-contents" + "simple-single-1.3.el" + "simple-single-1.4.el" + "simple-single-readme.txt")) + (ignore-errors + (delete-file + (expand-file-name f package-test-archive-upload-base)))) + (delete-directory package-test-archive-upload-base)) + + (when (and (boundp 'package-test-archive-upload-base) + (file-directory-p package-test-archive-upload-base)) + (delete-directory package-test-archive-upload-base t)))))) (defmacro with-fake-help-buffer (&rest body) "Execute BODY in a temp buffer which is treated as the \"*Help*\" buffer." @@ -342,9 +340,13 @@ but with a different end of line convention (bug#48137)." (declare-function macro-problem-func "macro-problem" ()) (declare-function macro-problem-10-and-90 "macro-problem" ()) +(declare-function macro-builtin-func "macro-builtin" ()) +(declare-function macro-builtin-10-and-90 "macro-builtin" ()) (ert-deftest package-test-macro-compilation () - "Install a package which includes a dependency." + "\"Activation has to be done before compilation, so that if we're + upgrading and macros have changed we load the new definitions + before compiling.\" -- package.el" (with-package-test (:basedir (ert-resource-directory)) (package-install-file (expand-file-name "macro-problem-package-1.0/")) (require 'macro-problem) @@ -357,6 +359,32 @@ but with a different end of line convention (bug#48137)." ;; `macro-problem-10-and-90' depends on an entirely new macro from `macro-aux'. (should (equal (macro-problem-10-and-90) '(10 90))))) +(ert-deftest package-test-macro-compilation-gz () + "Built-in's can be superseded as well." + (with-package-test (:basedir (ert-resource-directory)) + (let ((dir (expand-file-name "macro-builtin-package-1.0"))) + (unwind-protect + (let ((load-path load-path)) + (add-to-list 'load-path (directory-file-name dir)) + (byte-recompile-directory dir 0 t) + (mapc (lambda (f) (call-process "gzip" nil nil nil f)) + (directory-files-recursively dir "\\`[^\\.].*\\.el\\'")) + (require 'macro-builtin) + (should (member (expand-file-name "macro-builtin-aux.elc" dir) + (mapcar #'car load-history))) + ;; `macro-builtin-func' uses a macro from `macro-aux'. + (should (equal (macro-builtin-func) '(progn a b))) + (package-install-file (expand-file-name "macro-builtin-package-2.0/")) + ;; After upgrading, `macro-builtin-func' depends on a new version + ;; of the macro from `macro-builtin-aux'. + (should (equal (macro-builtin-func) '(1 b))) + ;; `macro-builtin-10-and-90' depends on an entirely new macro from `macro-aux'. + (should (equal (macro-builtin-10-and-90) '(10 90)))) + (mapc #'delete-file + (directory-files-recursively dir "\\`[^\\.].*\\.elc\\'")) + (mapc (lambda (f) (call-process "gunzip" nil nil nil f)) + (directory-files-recursively dir "\\`[^\\.].*\\.el\\.gz\\'")))))) + (ert-deftest package-test-install-two-dependencies () "Install a package which includes a dependency." (with-package-test () @@ -685,25 +713,23 @@ but with a different end of line convention (bug#48137)." (defvar epg-config--program-alist) ; Silence byte-compiler. (ert-deftest package-test-signed () "Test verifying package signature." - (skip-unless (let ((homedir (make-temp-file "package-test" t))) - (unwind-protect - (let ((process-environment - (cons (concat "HOME=" homedir) - process-environment))) - (require 'epg-config) - (defvar epg-config--program-alist) - (epg-find-configuration - 'OpenPGP nil - ;; By default we require gpg2 2.1+ due to some - ;; practical problems with pinentry. But this - ;; test works fine with 2.0 as well. - (let ((prog-alist (copy-tree epg-config--program-alist))) - (setf (alist-get "gpg2" - (alist-get 'OpenPGP prog-alist) - nil nil #'equal) - "2.0") - prog-alist))) - (delete-directory homedir t)))) + (skip-unless (ert-with-temp-directory homedir + (let ((process-environment + (cons (concat "HOME=" homedir) + process-environment))) + (require 'epg-config) + (defvar epg-config--program-alist) + (epg-find-configuration + 'OpenPGP nil + ;; By default we require gpg2 2.1+ due to some + ;; practical problems with pinentry. But this + ;; test works fine with 2.0 as well. + (let ((prog-alist (copy-tree epg-config--program-alist))) + (setf (alist-get "gpg2" + (alist-get 'OpenPGP prog-alist) + nil nil #'equal) + "2.0") + prog-alist))))) (let* ((keyring (expand-file-name "key.pub" package-test-data-dir)) (package-test-data-dir (ert-resource-file "signed"))) (with-package-test () diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el index 7ad01e7aef7..40ae9809b5f 100644 --- a/test/lisp/emacs-lisp/pcase-tests.el +++ b/test/lisp/emacs-lisp/pcase-tests.el @@ -107,8 +107,11 @@ (should (equal (pcase 1 ((cl-type (integer 0 2)) 'integer-0<=n<=2)) 'integer-0<=n<=2)) - (should-error (pcase 1 - ((cl-type notatype) 'integer)))) + (should-error + ;; Avoid error at compile time due to compiler macro. + (eval '(pcase 1 + ((cl-type notatype) 'integer)) + t))) (ert-deftest pcase-tests-setq () (should (equal (let (a b) diff --git a/test/lisp/emacs-lisp/pp-resources/code-formats.erts b/test/lisp/emacs-lisp/pp-resources/code-formats.erts new file mode 100644 index 00000000000..2b2001d0964 --- /dev/null +++ b/test/lisp/emacs-lisp/pp-resources/code-formats.erts @@ -0,0 +1,124 @@ +Code: + (lambda () + (emacs-lisp-mode) + (let ((code (read (current-buffer)))) + (erase-buffer) + (pp-emacs-lisp-code code) + (untabify (point-min) (point-max)))) + +Name: code-formats1 + +=-= +(defun foo (bar) + "Yes." + (let ((a 1) + (b 2)) + (zot 1 2 (funcall bar 2)))) +=-=-= + + +Name: code-formats2 + +=-= +(defun pp-emacs-lisp-code (sexp) + "Insert SEXP into the current buffer, formatted as Emacs Lisp code." + (require 'edebug) + (let ((start (point)) + (standard-output (current-buffer))) + (pp--insert-lisp sexp) + (insert "\n") + (goto-char start) + (indent-sexp))) +=-=-= + + +Name: code-formats3 + +=-= +(defun foo (bar) + "Yes." + (let ((a 1) + (b 2)) + (zot-zot-zot-zot-zot-zot 1 2 (funcall + bar-bar-bar-bar-bar-bar-bar-bar-bar-bar + 2)))) +=-=-= + + +Name: code-formats4 + +=-= +(defun foo (bar) + "Yes." + (let ((a 1) + (b 2) + foo bar zotfoo bar zotfoo bar zotfoo bar zotfoo bar zotfoo bar zotfoo + bar zot) + (zot 1 2 (funcall bar 2)))) +=-=-= + + +Name: code-formats5 + +=-= +(defgroup pp () + "Pretty printer for Emacs Lisp." + :prefix "pp-" + :group 'lisp) +=-=-= + +Name: code-formats6 + +=-= +(defcustom pp-escape-newlines t + "Value of `print-escape-newlines' used by pp-* functions." + :type 'boolean + :group 'pp) +=-=-= + +Name: code-formats7 + +=-= +(defun pp (object &optional stream) + (princ (pp-to-string object) (or stream standard-output))) +=-=-= + + +Name: code-formats8 + +=-= +(defun pp-eval-expression (expression) + "Evaluate EXPRESSION and pretty-print its value. +Also add the value to the front of the list in the variable `values'." + (interactive (list (read--expression "Eval: "))) + (message "Evaluating...") + (let ((result (eval expression lexical-binding))) + (values--store-value result) + (pp-display-expression result "*Pp Eval Output*"))) +=-=-= + +Name: code-formats9 + +=-= +(lambda () + (interactive) + 1) +=-=-= + + +Name: code-formats10 + +=-= +(funcall foo (concat "zot" (if (length> site 0) site + "bar") + "+" + (string-replace " " "+" query))) +=-=-= + + +Name: code-formats11 + +=-= +(lambda () + [(foo bar) (foo bar)]) +=-=-= diff --git a/test/lisp/emacs-lisp/pp-tests.el b/test/lisp/emacs-lisp/pp-tests.el index b04030cc432..4cae1a73775 100644 --- a/test/lisp/emacs-lisp/pp-tests.el +++ b/test/lisp/emacs-lisp/pp-tests.el @@ -20,6 +20,7 @@ ;;; Code: (require 'pp) +(require 'ert-x) (ert-deftest pp-print-quote () (should (string= (pp-to-string 'quote) "quote")) @@ -32,4 +33,7 @@ (should (string= (pp-to-string '(quotefoo)) "(quotefoo)\n")) (should (string= (pp-to-string '(a b)) "(a b)\n"))) +(ert-deftest test-indentation () + (ert-test-erts-file (ert-resource-file "code-formats.erts"))) + ;;; pp-tests.el ends here. 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/rmc-tests.el b/test/lisp/emacs-lisp/rmc-tests.el index 9d8f3d48014..c1e838d051e 100644 --- a/test/lisp/emacs-lisp/rmc-tests.el +++ b/test/lisp/emacs-lisp/rmc-tests.el @@ -22,14 +22,42 @@ ;;; Commentary: -;; - ;;; Code: (require 'ert) (require 'rmc) +(require 'cl-lib) (eval-when-compile (require 'cl-lib)) +(ert-deftest test-rmc--add-key-description () + (cl-letf (((symbol-function 'display-supports-face-attributes-p) (lambda (_ _) t))) + (should (equal (rmc--add-key-description '(?y "yes")) + '(?y . "yes"))) + (should (equal (rmc--add-key-description '(?n "foo")) + '(?n . "n foo"))) + (should (equal (rmc--add-key-description '(?\s "foo bar")) + `(?\s . "SPC foo bar"))))) + +(ert-deftest test-rmc--add-key-description/with-attributes () + (cl-letf (((symbol-function 'display-supports-face-attributes-p) (lambda (_ _) t))) + (should (equal-including-properties + (rmc--add-key-description '(?y "yes")) + `(?y . ,(concat (propertize "y" 'face 'read-multiple-choice-face) "es")))) + (should (equal-including-properties + (rmc--add-key-description '(?n "foo")) + `(?n . ,(concat (propertize "n" 'face 'read-multiple-choice-face) " foo")))) + (should (equal-including-properties + (rmc--add-key-description '(?\s "foo bar")) + `(?\s . ,(concat (propertize "SPC" 'face 'read-multiple-choice-face) " foo bar")))))) + +(ert-deftest test-rmc--add-key-description/non-graphical-display () + (cl-letf (((symbol-function 'display-supports-face-attributes-p) (lambda (_ _) nil))) + (should (equal-including-properties + (rmc--add-key-description '(?y "yes")) + '(?y . "[Y]es"))) + (should (equal-including-properties + (rmc--add-key-description '(?n "foo")) + `(?n . ,(concat (propertize "n" 'face 'help-key-binding) " foo")))))) (ert-deftest test-read-multiple-choice () (dolist (char '(?y ?n)) @@ -38,6 +66,5 @@ (should (equal (list char str) (read-multiple-choice "Do it? " '((?y "yes") (?n "no")))))))) - (provide 'rmc-tests) ;;; rmc-tests.el ends here diff --git a/test/lisp/emacs-lisp/seq-tests.el b/test/lisp/emacs-lisp/seq-tests.el index 8dc0b93b5af..4b940af81f1 100644 --- a/test/lisp/emacs-lisp/seq-tests.el +++ b/test/lisp/emacs-lisp/seq-tests.el @@ -173,16 +173,18 @@ Evaluate BODY for each created sequence. (should (seq-find #'null '(1 2 3) 'sentinel))) (ert-deftest test-seq-contains () - (with-test-sequences (seq '(3 4 5 6)) - (should (seq-contains seq 3)) - (should-not (seq-contains seq 7))) - (with-test-sequences (seq '()) - (should-not (seq-contains seq 3)) - (should-not (seq-contains seq nil)))) + (with-suppressed-warnings ((obsolete seq-contains)) + (with-test-sequences (seq '(3 4 5 6)) + (should (seq-contains seq 3)) + (should-not (seq-contains seq 7))) + (with-test-sequences (seq '()) + (should-not (seq-contains seq 3)) + (should-not (seq-contains seq nil))))) (ert-deftest test-seq-contains-should-return-the-elt () - (with-test-sequences (seq '(3 4 5 6)) - (should (= 5 (seq-contains seq 5))))) + (with-suppressed-warnings ((obsolete seq-contains)) + (with-test-sequences (seq '(3 4 5 6)) + (should (= 5 (seq-contains seq 5)))))) (ert-deftest test-seq-contains-p () (with-test-sequences (seq '(3 4 5 6)) @@ -404,7 +406,7 @@ Evaluate BODY for each created sequence. (let ((seq '(1 (2 (3 (4)))))) (seq-let (_ (_ (_ (a)))) seq (should (= a 4)))) - (let (seq) + (let ((seq nil)) (seq-let (a b c) seq (should (null a)) (should (null b)) @@ -428,7 +430,7 @@ Evaluate BODY for each created sequence. (seq '(1 (2 (3 (4)))))) (seq-setq (_ (_ (_ (a)))) seq) (should (= a 4))) - (let (seq a b c) + (let ((seq nil) a b c) (seq-setq (a b c) seq) (should (null a)) (should (null b)) diff --git a/test/lisp/emacs-lisp/subr-x-tests.el b/test/lisp/emacs-lisp/subr-x-tests.el index 1d19496ba44..821b6770ba0 100644 --- a/test/lisp/emacs-lisp/subr-x-tests.el +++ b/test/lisp/emacs-lisp/subr-x-tests.el @@ -169,13 +169,13 @@ "no") "no")) (should (equal - (let (z) + (let ((z nil)) (if-let* (z (a 1) (b 2) (c 3)) "yes" "no")) "no")) (should (equal - (let (d) + (let ((d nil)) (if-let* ((a 1) (b 2) (c 3) d) "yes" "no")) @@ -191,7 +191,7 @@ (ert-deftest subr-x-test-if-let*-and-laziness-is-preserved () "Test `if-let' respects `and' laziness." - (let (a-called b-called c-called) + (let ((a-called nil) (b-called nil) c-called) (should (equal (if-let* ((a nil) (b (setq b-called t)) @@ -199,7 +199,7 @@ "yes" (list a-called b-called c-called)) (list nil nil nil)))) - (let (a-called b-called c-called) + (let ((a-called nil) (b-called nil) c-called) (should (equal (if-let* ((a (setq a-called t)) (b nil) @@ -207,12 +207,12 @@ "yes" (list a-called b-called c-called)) (list t nil nil)))) - (let (a-called b-called c-called) + (let ((a-called nil) (b-called nil) c-called) (should (equal (if-let* ((a (setq a-called t)) - (b (setq b-called t)) - (c nil) - (d (setq c-called t))) + (b (setq b-called t)) + (c nil) + (d (setq c-called t))) "yes" (list a-called b-called c-called)) (list t t nil))))) @@ -329,12 +329,12 @@ "no") nil)) (should (equal - (let (z) + (let ((z nil)) (when-let* (z (a 1) (b 2) (c 3)) "no")) nil)) (should (equal - (let (d) + (let ((d nil)) (when-let* ((a 1) (b 2) (c 3) d) "no")) nil))) @@ -348,7 +348,7 @@ (ert-deftest subr-x-test-when-let*-and-laziness-is-preserved () "Test `when-let' respects `and' laziness." - (let (a-called b-called c-called) + (let ((a-called nil) (b-called nil) (c-called nil)) (should (equal (progn (when-let* ((a nil) @@ -357,7 +357,7 @@ "yes") (list a-called b-called c-called)) (list nil nil nil)))) - (let (a-called b-called c-called) + (let ((a-called nil) (b-called nil) (c-called nil)) (should (equal (progn (when-let* ((a (setq a-called t)) @@ -366,7 +366,7 @@ "yes") (list a-called b-called c-called)) (list t nil nil)))) - (let (a-called b-called c-called) + (let ((a-called nil) (b-called nil) (c-called nil)) (should (equal (progn (when-let* ((a (setq a-called t)) @@ -638,5 +638,79 @@ (should (equal (string-chop-newline "foo\nbar\n") "foo\nbar")) (should (equal (string-chop-newline "foo\nbar") "foo\nbar"))) +(ert-deftest subr-ensure-empty-lines () + (should + (equal + (with-temp-buffer + (insert "foo") + (goto-char (point-min)) + (ensure-empty-lines 2) + (buffer-string)) + "\n\nfoo")) + (should + (equal + (with-temp-buffer + (insert "foo") + (ensure-empty-lines 2) + (buffer-string)) + "foo\n\n\n")) + (should + (equal + (with-temp-buffer + (insert "foo\n") + (ensure-empty-lines 2) + (buffer-string)) + "foo\n\n\n")) + (should + (equal + (with-temp-buffer + (insert "foo\n\n\n\n\n") + (ensure-empty-lines 2) + (buffer-string)) + "foo\n\n\n")) + (should + (equal + (with-temp-buffer + (insert "foo\n\n\n") + (ensure-empty-lines 0) + (buffer-string)) + "foo\n"))) + +(ert-deftest subr-x-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))))) + +(ert-deftest subr-x-named-let () + (let ((funs ())) + (named-let loop + ((rest '(1 42 3)) + (sum 0)) + (when rest + ;; Here, we make sure that the variables are distinct in every + ;; iteration, since a naive tail-call optimization would tend to end up + ;; with a single `sum' variable being shared by all the closures. + (push (lambda () sum) funs) + ;; Here we add a dummy `sum' variable which shadows the `sum' iteration + ;; variable since a naive tail-call optimization could also trip here + ;; thinking it can `(setq sum ...)' to set the iteration + ;; variable's value. + (let ((sum sum)) + (loop (cdr rest) (+ sum (car rest)))))) + (should (equal (mapcar #'funcall funs) '(43 1 0))))) + (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/emacs-lisp/testcover-tests.el b/test/lisp/emacs-lisp/testcover-tests.el index 7854e33e77d..a7e055a28b1 100644 --- a/test/lisp/emacs-lisp/testcover-tests.el +++ b/test/lisp/emacs-lisp/testcover-tests.el @@ -45,34 +45,34 @@ testcases.el. This can be used to create test cases if Testcover is working correctly on a code sample. OPTARGS are optional arguments for `testcover-start'." (interactive "r") - (let ((tempfile (make-temp-file "testcover-tests-" nil ".el")) - (find-file-suppress-same-file-warnings t) - (code (buffer-substring beg end)) - (marked-up-code)) - (unwind-protect - (progn - (with-temp-file tempfile - (insert code)) - (save-current-buffer - (let ((buf (find-file-noselect tempfile))) - (set-buffer buf) - (apply 'testcover-start (cons tempfile optargs)) - (testcover-mark-all buf) - (dolist (overlay (overlays-in (point-min) (point-max))) - (let ((ov-face (overlay-get overlay 'face))) - (goto-char (overlay-end overlay)) - (cond - ((eq ov-face 'testcover-nohits) (insert "!!!")) - ((eq ov-face 'testcover-1value) (insert "%%%")) - (t nil)))) - (setq marked-up-code (buffer-string))) - (set-buffer-modified-p nil))) - (ignore-errors (kill-buffer (find-file-noselect tempfile))) - (ignore-errors (delete-file tempfile))) - - ;; Now replace the original code with the marked up code. - (delete-region beg end) - (insert marked-up-code)))) + (ert-with-temp-file tempfile + :suffix ".el" + (let ((find-file-suppress-same-file-warnings t) + (code (buffer-substring beg end)) + (marked-up-code)) + (unwind-protect + (progn + (with-temp-file tempfile + (insert code)) + (save-current-buffer + (let ((buf (find-file-noselect tempfile))) + (set-buffer buf) + (apply 'testcover-start (cons tempfile optargs)) + (testcover-mark-all buf) + (dolist (overlay (overlays-in (point-min) (point-max))) + (let ((ov-face (overlay-get overlay 'face))) + (goto-char (overlay-end overlay)) + (cond + ((eq ov-face 'testcover-nohits) (insert "!!!")) + ((eq ov-face 'testcover-1value) (insert "%%%")) + (t nil)))) + (setq marked-up-code (buffer-string))) + (set-buffer-modified-p nil))) + (ignore-errors (kill-buffer (find-file-noselect tempfile)))) + + ;; Now replace the original code with the marked up code. + (delete-region beg end) + (insert marked-up-code))))) (eval-and-compile (defun testcover-tests-unmarkup-region (beg end) @@ -99,32 +99,32 @@ arguments for `testcover-start'." (eval-and-compile (defun testcover-tests-run-test-case (marked-up-code) "Test the operation of Testcover on the string MARKED-UP-CODE." - (let ((tempfile (make-temp-file "testcover-tests-" nil ".el")) - (find-file-suppress-same-file-warnings t)) - (unwind-protect - (progn - (with-temp-file tempfile - (insert marked-up-code)) - ;; Remove the marks and mark the code up again. The original - ;; and recreated versions should match. - (save-current-buffer - (set-buffer (find-file-noselect tempfile)) - ;; Fail the test if the debugger tries to become active, - ;; which can happen if Testcover fails to attach itself - ;; correctly. Note that this will prevent debugging - ;; these tests using Edebug. - (cl-letf (((symbol-function #'edebug-default-enter) - (lambda (&rest _args) - (ert-fail "Debugger invoked during test run")))) - (dolist (byte-compile '(t nil)) - (testcover-tests-unmarkup-region (point-min) (point-max)) - (unwind-protect - (testcover-tests-markup-region (point-min) (point-max) byte-compile) - (set-buffer-modified-p nil)) - (should (string= marked-up-code - (buffer-string))))))) - (ignore-errors (kill-buffer (find-file-noselect tempfile))) - (ignore-errors (delete-file tempfile)))))) + (ert-with-temp-file tempfile + :suffix ".el" + (let ((find-file-suppress-same-file-warnings t)) + (unwind-protect + (progn + (with-temp-file tempfile + (insert marked-up-code)) + ;; Remove the marks and mark the code up again. The original + ;; and recreated versions should match. + (save-current-buffer + (set-buffer (find-file-noselect tempfile)) + ;; Fail the test if the debugger tries to become active, + ;; which can happen if Testcover fails to attach itself + ;; correctly. Note that this will prevent debugging + ;; these tests using Edebug. + (cl-letf (((symbol-function #'edebug-default-enter) + (lambda (&rest _args) + (ert-fail "Debugger invoked during test run")))) + (dolist (byte-compile '(t nil)) + (testcover-tests-unmarkup-region (point-min) (point-max)) + (unwind-protect + (testcover-tests-markup-region (point-min) (point-max) byte-compile) + (set-buffer-modified-p nil)) + (should (string= marked-up-code + (buffer-string))))))) + (ignore-errors (kill-buffer (find-file-noselect tempfile)))))))) ;; Convert test case file to ert-defmethod. diff --git a/test/lisp/emacs-lisp/timer-tests.el b/test/lisp/emacs-lisp/timer-tests.el index 7856c217f9e..0f5b1a71868 100644 --- a/test/lisp/emacs-lisp/timer-tests.el +++ b/test/lisp/emacs-lisp/timer-tests.el @@ -37,7 +37,8 @@ (ert-deftest timer-tests-debug-timer-check () ;; This function exists only if --enable-checking. (skip-unless (fboundp 'debug-timer-check)) - (should (debug-timer-check))) + (when (fboundp 'debug-timer-check) ; silence byte-compiler + (should (debug-timer-check)))) (ert-deftest timer-test-multiple-of-time () (should (time-equal-p diff --git a/test/lisp/emulation/viper-tests.el b/test/lisp/emulation/viper-tests.el index 0d999763b61..b8efc87ab70 100644 --- a/test/lisp/emulation/viper-tests.el +++ b/test/lisp/emulation/viper-tests.el @@ -21,7 +21,8 @@ ;;; Code: - +(require 'ert) +(require 'ert-x) (require 'viper) (defun viper-test-undo-kmacro (kmacro) @@ -30,47 +31,42 @@ This function makes as many attempts as possible to clean up after itself, although it will leave a buffer called *viper-test-buffer* if it fails (this is deliberate!)." - (let ( - ;; Viper just turns itself off during batch use. - (noninteractive nil) - ;; Switch off start up message or it will chew the key presses. - (viper-inhibit-startup-message 't) - ;; Select an expert-level for the same reason. - (viper-expert-level 5) - ;; viper loads this even with -q so make sure it's empty! - (viper-custom-file-name (make-temp-file "viper-tests" nil ".elc")) - (before-buffer (current-buffer))) - (unwind-protect - (progn - ;; viper-mode is essentially global, so set it here. - (viper-mode) - ;; We must switch to buffer because we are using a keyboard macro - ;; which appears to not go to the current-buffer but what ever is - ;; currently taking keyboard events. We use a named buffer because - ;; then we can see what it in it if it all goes wrong. - (switch-to-buffer - (get-buffer-create - "*viper-test-buffer*")) - (erase-buffer) - ;; The new buffer fails to enter vi state so set it. - (viper-change-state-to-vi) - ;; Run the macro. - (execute-kbd-macro kmacro) - (let ((rtn - (buffer-substring-no-properties - (point-min) - (point-max)))) - ;; Kill the buffer iff the macro succeeds. - (kill-buffer) - rtn)) - ;; Switch everything off and restore the buffer. - (toggle-viper-mode) - (delete-file viper-custom-file-name) - (switch-to-buffer before-buffer)))) - -(ert-deftest viper-test-go () - "Test that this file is running." - (should t)) + (ert-with-temp-file viper-custom-file-name + ;; viper loads this even with -q so make sure it's empty! + :prefix "emacs-viper-tests" :suffix ".elc" + (let (;; Viper just turns itself off during batch use. + (noninteractive nil) + ;; Switch off start up message or it will chew the key presses. + (viper-inhibit-startup-message 't) + ;; Select an expert-level for the same reason. + (viper-expert-level 5) + (before-buffer (current-buffer))) + (unwind-protect + (progn + ;; viper-mode is essentially global, so set it here. + (viper-mode) + ;; We must switch to buffer because we are using a keyboard macro + ;; which appears to not go to the current-buffer but what ever is + ;; currently taking keyboard events. We use a named buffer because + ;; then we can see what it in it if it all goes wrong. + (switch-to-buffer + (get-buffer-create + "*viper-test-buffer*")) + (erase-buffer) + ;; The new buffer fails to enter vi state so set it. + (viper-change-state-to-vi) + ;; Run the macro. + (execute-kbd-macro kmacro) + (let ((rtn + (buffer-substring-no-properties + (point-min) + (point-max)))) + ;; Kill the buffer iff the macro succeeds. + (kill-buffer) + rtn)) + ;; Switch everything off and restore the buffer. + (toggle-viper-mode) + (switch-to-buffer before-buffer))))) (ert-deftest viper-test-fix () "Test that the viper kmacro fixture is working." diff --git a/test/lisp/epg-tests.el b/test/lisp/epg-tests.el index 741574f0adf..1384221c491 100644 --- a/test/lisp/epg-tests.el +++ b/test/lisp/epg-tests.el @@ -58,48 +58,45 @@ (cl-defmacro with-epg-tests ((&optional &key require-passphrase require-public-key require-secret-key) - &rest body) + &rest body) "Set up temporary locations and variables for testing." (declare (indent 1) (debug (sexp body))) - `(let* ((epg-tests-home-directory (make-temp-file "epg-tests-homedir" t)) - (process-environment - (append - (list "GPG_AGENT_INFO" - (format "GNUPGHOME=%s" epg-tests-home-directory)) - process-environment))) - (unwind-protect - ;; GNUPGHOME is needed to find a usable gpg, so we can't - ;; check whether to skip any earlier (Bug#23561). - (let ((epg-config (or (epg-tests-find-usable-gpg-configuration - ,require-passphrase ,require-public-key) - (ert-skip "No usable gpg config"))) - (context (epg-make-context 'OpenPGP))) - (setf (epg-context-program context) - (alist-get 'program epg-config)) - (setf (epg-context-home-directory context) - epg-tests-home-directory) - ,(if require-passphrase - '(with-temp-file (expand-file-name - "gpg-agent.conf" epg-tests-home-directory) - (insert "pinentry-program " - (ert-resource-file "dummy-pinentry") - "\n") - (epg-context-set-passphrase-callback - context - #'epg-tests-passphrase-callback))) - ,(if require-public-key - '(epg-import-keys-from-file - context - (ert-resource-file "pubkey.asc"))) - ,(if require-secret-key - '(epg-import-keys-from-file - context - (ert-resource-file "seckey.asc"))) - (with-temp-buffer - (setq-local epg-tests-context context) - ,@body)) - (when (file-directory-p epg-tests-home-directory) - (delete-directory epg-tests-home-directory t))))) + `(ert-with-temp-directory epg-tests-home-directory + (let* ((process-environment + (append + (list "GPG_AGENT_INFO" + (format "GNUPGHOME=%s" epg-tests-home-directory)) + process-environment))) + ;; GNUPGHOME is needed to find a usable gpg, so we can't + ;; check whether to skip any earlier (Bug#23561). + (let ((epg-config (or (epg-tests-find-usable-gpg-configuration + ,require-passphrase ,require-public-key) + (ert-skip "No usable gpg config"))) + (context (epg-make-context 'OpenPGP))) + (setf (epg-context-program context) + (alist-get 'program epg-config)) + (setf (epg-context-home-directory context) + epg-tests-home-directory) + ,(if require-passphrase + '(with-temp-file (expand-file-name + "gpg-agent.conf" epg-tests-home-directory) + (insert "pinentry-program " + (ert-resource-file "dummy-pinentry") + "\n") + (epg-context-set-passphrase-callback + context + #'epg-tests-passphrase-callback))) + ,(if require-public-key + '(epg-import-keys-from-file + context + (ert-resource-file "pubkey.asc"))) + ,(if require-secret-key + '(epg-import-keys-from-file + context + (ert-resource-file "seckey.asc"))) + (with-temp-buffer + (setq-local epg-tests-context context) + ,@body))))) (ert-deftest epg-decrypt-1 () :expected-result (if (getenv "EMACS_HYDRA_CI") :failed :passed) ; fixme diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index 6ed26f68289..b2dbc1012de 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -228,4 +228,75 @@ (kill-buffer "*erc-protocol*") (should-not erc-debug-irc-protocol))) + +;; The point of this test is to ensure output is handled identically +;; regardless of whether a command handler is summoned. + +(ert-deftest erc-process-input-line () + (let (erc-server-last-sent-time + erc-server-flood-queue + (orig-erc-cmd-MSG (symbol-function 'erc-cmd-MSG)) + (erc-default-recipients '("#chan")) + calls) + (with-temp-buffer + (cl-letf (((symbol-function 'erc-cmd-MSG) + (lambda (line) + (push line calls) + (funcall orig-erc-cmd-MSG line))) + ((symbol-function 'erc-server-buffer) + (lambda () (current-buffer))) + ((symbol-function 'erc-server-process-alive) + (lambda () t)) + ((symbol-function 'erc-server-send-queue) + #'ignore)) + + (ert-info ("Dispatch to user command handler") + + (ert-info ("Baseline") + (erc-process-input-line "/msg #chan hi\n") + (should (equal (pop calls) " #chan hi")) + (should (equal (pop erc-server-flood-queue) + '("PRIVMSG #chan :hi\r\n" . utf-8)))) + + (ert-info ("Quote preserves line intact") + (erc-process-input-line "/QUOTE FAKE foo bar\n") + (should (equal (pop erc-server-flood-queue) + '("FAKE foo bar\r\n" . utf-8)))) + + (ert-info ("Unknown command respected") + (erc-process-input-line "/FAKE foo bar\n") + (should (equal (pop erc-server-flood-queue) + '("FAKE foo bar\r\n" . utf-8)))) + + (ert-info ("Spaces preserved") + (erc-process-input-line "/msg #chan hi you\n") + (should (equal (pop calls) " #chan hi you")) + (should (equal (pop erc-server-flood-queue) + '("PRIVMSG #chan :hi you\r\n" . utf-8)))) + + (ert-info ("Empty line honored") + (erc-process-input-line "/msg #chan\n") + (should (equal (pop calls) " #chan")) + (should (equal (pop erc-server-flood-queue) + '("PRIVMSG #chan :\r\n" . utf-8))))) + + (ert-info ("Implicit cmd via `erc-send-input-line-function'") + + (ert-info ("Baseline") + (erc-process-input-line "hi") + (should (equal (pop erc-server-flood-queue) + '("PRIVMSG #chan :hi\r\n" . utf-8)))) + + (ert-info ("Spaces preserved") + (erc-process-input-line "hi you") + (should (equal (pop erc-server-flood-queue) + '("PRIVMSG #chan :hi you\r\n" . utf-8)))) + + (ert-info ("Empty line transmitted without injected-space kludge") + (erc-process-input-line "") + (should (equal (pop erc-server-flood-queue) + '("PRIVMSG #chan :\r\n" . utf-8)))) + + (should-not calls)))))) + ;;; erc-tests.el ends here diff --git a/test/lisp/eshell/em-hist-tests.el b/test/lisp/eshell/em-hist-tests.el index 31967a61c3c..5bc5690675d 100644 --- a/test/lisp/eshell/em-hist-tests.el +++ b/test/lisp/eshell/em-hist-tests.el @@ -20,19 +20,18 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'em-hist) (ert-deftest eshell-write-readonly-history () "Test that having read-only strings in history is okay." - (let ((histfile (make-temp-file "eshell-history")) - (eshell-history-ring (make-ring 2))) - (ring-insert eshell-history-ring - (propertize "echo foo" 'read-only t)) - (ring-insert eshell-history-ring - (propertize "echo bar" 'read-only t)) - (unwind-protect - (eshell-write-history histfile) - (delete-file histfile)))) + (ert-with-temp-file histfile + (let ((eshell-history-ring (make-ring 2))) + (ring-insert eshell-history-ring + (propertize "echo foo" 'read-only t)) + (ring-insert eshell-history-ring + (propertize "echo bar" 'read-only t)) + (eshell-write-history histfile)))) (provide 'em-hist-test) diff --git a/test/lisp/eshell/em-ls-tests.el b/test/lisp/eshell/em-ls-tests.el index 5d1742b76fd..3ea11ab2de1 100644 --- a/test/lisp/eshell/em-ls-tests.el +++ b/test/lisp/eshell/em-ls-tests.el @@ -25,30 +25,30 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'em-ls) (require 'dired) (ert-deftest em-ls-test-bug27631 () "Test for https://debbugs.gnu.org/27631 ." - (let* ((dir (make-temp-file "bug27631" 'dir)) - (dir1 (expand-file-name "dir1" dir)) - (dir2 (expand-file-name "dir2" dir)) - (default-directory dir) - (orig eshell-ls-use-in-dired) - buf) - (unwind-protect - (progn - (customize-set-value 'eshell-ls-use-in-dired t) - (make-directory dir1) - (make-directory dir2) - (with-temp-file (expand-file-name "a.txt" dir1)) - (with-temp-file (expand-file-name "b.txt" dir2)) - (setq buf (dired (expand-file-name "dir*/*.txt" dir))) - (dired-toggle-marks) - (should (cdr (dired-get-marked-files)))) - (customize-set-variable 'eshell-ls-use-in-dired orig) - (delete-directory dir 'recursive) - (when (buffer-live-p buf) (kill-buffer buf))))) + (ert-with-temp-directory dir + (let* ((dir1 (expand-file-name "dir1" dir)) + (dir2 (expand-file-name "dir2" dir)) + (default-directory dir) + (orig eshell-ls-use-in-dired) + buf) + (unwind-protect + (progn + (customize-set-value 'eshell-ls-use-in-dired t) + (make-directory dir1) + (make-directory dir2) + (with-temp-file (expand-file-name "a.txt" dir1)) + (with-temp-file (expand-file-name "b.txt" dir2)) + (setq buf (dired (expand-file-name "dir*/*.txt" dir))) + (dired-toggle-marks) + (should (cdr (dired-get-marked-files)))) + (customize-set-variable 'eshell-ls-use-in-dired orig) + (when (buffer-live-p buf) (kill-buffer buf)))))) (ert-deftest em-ls-test-bug27817 () "Test for https://debbugs.gnu.org/27817 ." diff --git a/test/lisp/eshell/eshell-tests.el b/test/lisp/eshell/eshell-tests.el index a460f45bf13..0974784ef4c 100644 --- a/test/lisp/eshell/eshell-tests.el +++ b/test/lisp/eshell/eshell-tests.el @@ -26,23 +26,23 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'esh-mode) (require 'eshell) (defmacro with-temp-eshell (&rest body) "Evaluate BODY in a temporary Eshell buffer." - `(let* ((eshell-directory-name (make-temp-file "eshell" t)) - ;; We want no history file, so prevent Eshell from falling - ;; back on $HISTFILE. - (process-environment (cons "HISTFILE" process-environment)) - (eshell-history-file-name nil) - (eshell-buffer (eshell t))) - (unwind-protect - (with-current-buffer eshell-buffer - ,@body) - (let (kill-buffer-query-functions) - (kill-buffer eshell-buffer) - (delete-directory eshell-directory-name t))))) + `(ert-with-temp-directory eshell-directory-name + (let* (;; We want no history file, so prevent Eshell from falling + ;; back on $HISTFILE. + (process-environment (cons "HISTFILE" process-environment)) + (eshell-history-file-name nil) + (eshell-buffer (eshell t))) + (unwind-protect + (with-current-buffer eshell-buffer + ,@body) + (let (kill-buffer-query-functions) + (kill-buffer eshell-buffer)))))) (defun eshell-insert-command (text &optional func) "Insert a command at the end of the buffer." @@ -65,11 +65,9 @@ (defun eshell-test-command-result (command) "Like `eshell-command-result', but not using HOME." - (let ((eshell-directory-name (make-temp-file "eshell" t)) - (eshell-history-file-name nil)) - (unwind-protect - (eshell-command-result command) - (delete-directory eshell-directory-name t)))) + (ert-with-temp-directory eshell-directory-name + (let ((eshell-history-file-name nil)) + (eshell-command-result command)))) ;;; Tests: diff --git a/test/lisp/ffap-tests.el b/test/lisp/ffap-tests.el index f8113bffc1a..df5c264baad 100644 --- a/test/lisp/ffap-tests.el +++ b/test/lisp/ffap-tests.el @@ -25,30 +25,29 @@ (require 'cl-lib) (require 'ert) +(require 'ert-x) (require 'ffap) (ert-deftest ffap-tests-25243 () "Test for https://debbugs.gnu.org/25243 ." - (let ((file (make-temp-file "test-Bug#25243"))) - (unwind-protect - (with-temp-file file - (let ((str "diff --git b/lisp/ffap.el a/lisp/ffap.el + (ert-with-temp-file file + :suffix "-bug25243" + (let ((str "diff --git b/lisp/ffap.el a/lisp/ffap.el index 3d7cebadcf..ad4b70d737 100644 --- b/lisp/ffap.el +++ a/lisp/ffap.el @@ -203,6 +203,9 @@ ffap-foo-at-bar-prefix ")) - (transient-mark-mode 1) - (when (natnump ffap-max-region-length) - (insert - (concat - str - (make-string ffap-max-region-length #xa) - (format "%s ENDS HERE" file))) - (call-interactively 'mark-whole-buffer) - (should (equal "" (ffap-string-at-point))) - (should (equal '(1 1) ffap-string-at-point-region))))) - (and (file-exists-p file) (delete-file file))))) + (transient-mark-mode 1) + (when (natnump ffap-max-region-length) + (insert + (concat + str + (make-string ffap-max-region-length #xa) + (format "%s ENDS HERE" file))) + (call-interactively 'mark-whole-buffer) + (should (equal "" (ffap-string-at-point))) + (should (equal '(1 1) ffap-string-at-point-region)))))) (ert-deftest ffap-gopher-at-point () (with-temp-buffer @@ -133,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/filenotify-tests.el b/test/lisp/filenotify-tests.el index 9be515ab176..0fe72f278dc 100644 --- a/test/lisp/filenotify-tests.el +++ b/test/lisp/filenotify-tests.el @@ -162,9 +162,7 @@ Return nil when any other file notification watch is still active." (defun file-notify--test-cleanup () "Cleanup after a test." - (file-notify-rm-watch file-notify--test-desc) - (file-notify-rm-watch file-notify--test-desc1) - (file-notify-rm-watch file-notify--test-desc2) + (file-notify-rm-all-watches) (ignore-errors (delete-file (file-newest-backup file-notify--test-tmpfile))) @@ -421,7 +419,7 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; This test is inspired by Bug#26126 and Bug#26127. (ert-deftest file-notify-test02-rm-watch () - "Check `file-notify-rm-watch'." + "Check `file-notify-rm-watch' and `file-notify-rm-all-watches'." (skip-unless (file-notify--test-local-enabled)) (unwind-protect @@ -517,6 +515,31 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (file-notify--test-cleanup-p)))) ;; Cleanup. + (file-notify--test-cleanup)) + + (unwind-protect + ;; Check `file-notify-rm-all-watches'. + (progn + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) + file-notify--test-tmpfile1 (file-notify--test-make-temp-name)) + (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) + (write-region "any text" nil file-notify--test-tmpfile1 nil 'no-message) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile '(change) #'ignore))) + (should + (setq file-notify--test-desc1 + (file-notify-add-watch + file-notify--test-tmpfile1 '(change) #'ignore))) + (file-notify-rm-all-watches) + (delete-file file-notify--test-tmpfile) + (delete-file file-notify--test-tmpfile1) + + ;; The environment shall be cleaned up. + (file-notify--test-cleanup-p)) + + ;; Cleanup. (file-notify--test-cleanup))) (file-notify--deftest-remote file-notify-test02-rm-watch diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el index 9547ac2b695..462048802f0 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." @@ -176,15 +176,14 @@ form.") ;; If called interactively, environment variable ;; $EMACS_TEST_DIRECTORY does not exist. (skip-unless (file-exists-p files-test-bug-18141-file)) - (let ((tempfile (make-temp-file "files-test-bug-18141" nil ".gz"))) - (unwind-protect - (progn - (copy-file files-test-bug-18141-file tempfile t) - (with-current-buffer (find-file-noselect tempfile) - (set-buffer-modified-p t) - (save-buffer) - (should (eq buffer-file-coding-system 'iso-2022-7bit-unix)))) - (delete-file tempfile)))) + (ert-with-temp-file tempfile + :prefix "emacs-test-files-bug-18141" + :suffix ".gz" + (copy-file files-test-bug-18141-file tempfile t) + (with-current-buffer (find-file-noselect tempfile) + (set-buffer-modified-p t) + (save-buffer) + (should (eq buffer-file-coding-system 'iso-2022-7bit-unix))))) (ert-deftest files-tests-make-temp-file-empty-prefix () "Test make-temp-file with an empty prefix." @@ -283,22 +282,20 @@ If we are in a directory named `~', the default value should not be $HOME." (cl-letf (((symbol-function 'completing-read) (lambda (_prompt _coll &optional _pred _req init _hist def _) - (or def init))) - (dir (make-temp-file "read-file-name-test" t))) - (unwind-protect - (let ((subdir (expand-file-name "./~/" dir))) - (make-directory subdir t) - (with-temp-buffer - (setq default-directory subdir) - (should-not (equal - (expand-file-name (read-file-name "File: ")) - (expand-file-name "~/"))) - ;; Don't overquote either! - (setq default-directory (concat "/:" subdir)) - (should-not (equal - (expand-file-name (read-file-name "File: ")) - (concat "/:/:" subdir))))) - (delete-directory dir 'recursive)))) + (or def init)))) + (ert-with-temp-directory dir + (let ((subdir (expand-file-name "./~/" dir))) + (make-directory subdir t) + (with-temp-buffer + (setq default-directory subdir) + (should-not (equal + (expand-file-name (read-file-name "File: ")) + (expand-file-name "~/"))) + ;; Don't overquote either! + (setq default-directory (concat "/:" subdir)) + (should-not (equal + (expand-file-name (read-file-name "File: ")) + (concat "/:/:" subdir)))))))) (ert-deftest files-tests-file-name-non-special-quote-unquote () (let (;; Just in case it is quoted, who knows. @@ -341,14 +338,6 @@ be $HOME." (progn ,@body) (advice-remove #',symbol ,function))))) -(defmacro files-tests--with-temp-file (name &rest body) - (declare (indent 1) (debug (symbolp body))) - (cl-check-type name symbol) - `(let ((,name (make-temp-file "emacs"))) - (unwind-protect - (progn ,@body) - (delete-file ,name)))) - (ert-deftest files-tests-file-name-non-special--buffers () "Check that Bug#25951 is fixed. We call `verify-visited-file-modtime' on a buffer visiting a file @@ -357,7 +346,7 @@ the buffer current and a nil argument, second passing the buffer object explicitly. In both cases no error should be raised and the `file-name-non-special' handler for quoted file names should be invoked with the right arguments." - (files-tests--with-temp-file temp-file-name + (ert-with-temp-file temp-file-name (with-temp-buffer (let* ((buffer-visiting-file (current-buffer)) (actual-args ()) @@ -476,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. @@ -1239,26 +1237,26 @@ works as expected if the default directory is quoted." (insert-directory-wildcard-in-dir-p (car path-res))))))) (ert-deftest files-tests-make-directory () - (let* ((dir (make-temp-file "files-mkdir-test" t)) - (dirname (file-name-as-directory dir)) - (file (concat dirname "file")) - (subdir1 (concat dirname "subdir1")) - (subdir2 (concat dirname "subdir2")) - (a/b (concat dirname "a/b"))) - (write-region "" nil file) - (should-error (make-directory "/")) - (should-not (make-directory "/" t)) - (should-error (make-directory dir)) - (should-not (make-directory dir t)) - (should-error (make-directory dirname)) - (should-not (make-directory dirname t)) - (should-error (make-directory file)) - (should-error (make-directory file t)) - (should-not (make-directory subdir1)) - (should-not (make-directory subdir2 t)) - (should-error (make-directory a/b)) - (should-not (make-directory a/b t)) - (delete-directory dir 'recursive))) + (ert-with-temp-directory dir + (let* ((dirname (file-name-as-directory dir)) + (file (concat dirname "file")) + (subdir1 (concat dirname "subdir1")) + (subdir2 (concat dirname "subdir2")) + (a/b (concat dirname "a/b"))) + (write-region "" nil file) + (should-error (make-directory "/")) + (should-not (make-directory "/" t)) + (should-error (make-directory dir)) + (should-not (make-directory dir t)) + (should-error (make-directory dirname)) + (should-not (make-directory dirname t)) + (should-error (make-directory file)) + (should-error (make-directory file t)) + (should-not (make-directory subdir1)) + (should-not (make-directory subdir2 t)) + (should-error (make-directory a/b)) + (should-not (make-directory a/b t)) + (delete-directory dir 'recursive)))) (ert-deftest files-tests-file-modes-symbolic-to-number () (let ((alist (list (cons "a=rwx" #o777) @@ -1318,7 +1316,7 @@ name (Bug#28412)." (set-buffer-modified-p t) (should-error (save-buffer) :type 'error)) ;; Then a buffer visiting a file: should save normally. - (files-tests--with-temp-file temp-file-name + (ert-with-temp-file temp-file-name (with-current-buffer (find-file-noselect temp-file-name) (setq write-contents-functions nil) (insert "p") @@ -1326,21 +1324,21 @@ name (Bug#28412)." (should (eq (buffer-size) 1)))))) (ert-deftest files-tests-copy-directory () - (let* ((dir (make-temp-file "files-mkdir-test" t)) - (dirname (file-name-as-directory dir)) - (source (concat dirname "source")) - (dest (concat dirname "dest/new/directory/")) - (file (concat (file-name-as-directory source) "file")) - (source2 (concat dirname "source2")) - (dest2 (concat dirname "dest/new2"))) - (make-directory source) - (write-region "" nil file) - (copy-directory source dest t t t) - (should (file-exists-p (concat dest "file"))) - (make-directory (concat (file-name-as-directory source2) "a") t) - (copy-directory source2 dest2) - (should (file-directory-p (concat (file-name-as-directory dest2) "a"))) - (delete-directory dir 'recursive))) + (ert-with-temp-directory dir + (let* ((dirname (file-name-as-directory dir)) + (source (concat dirname "source")) + (dest (concat dirname "dest/new/directory/")) + (file (concat (file-name-as-directory source) "file")) + (source2 (concat dirname "source2")) + (dest2 (concat dirname "dest/new2"))) + (make-directory source) + (write-region "" nil file) + (copy-directory source dest t t t) + (should (file-exists-p (concat dest "file"))) + (make-directory (concat (file-name-as-directory source2) "a") t) + (copy-directory source2 dest2) + (should (file-directory-p (concat (file-name-as-directory dest2) "a"))) + (delete-directory dir 'recursive)))) (ert-deftest files-tests-abbreviate-file-name-homedir () ;; Check homedir abbreviation. @@ -1392,43 +1390,40 @@ See <https://debbugs.gnu.org/19657#20>." (ert-deftest files-tests-executable-find () "Test that `executable-find' works also with a relative or remote PATH. See <https://debbugs.gnu.org/35241>." - (let ((tmpfile (make-temp-file "files-test" nil (car exec-suffixes)))) - (unwind-protect - (progn - (set-file-modes tmpfile #o777) - (let ((exec-path `(,temporary-file-directory))) - (should - (equal tmpfile - (executable-find (file-name-nondirectory tmpfile))))) - ;; An empty element of `exec-path' means `default-directory'. - (let ((default-directory temporary-file-directory) - (exec-path nil)) - (should - (equal tmpfile - (executable-find (file-name-nondirectory tmpfile))))) - ;; The remote file name shall be quoted, and handled like a - ;; non-existing directory. - (let ((default-directory "/ssh::") - (exec-path (append exec-path `("." ,temporary-file-directory)))) - (should - (equal tmpfile - (executable-find (file-name-nondirectory tmpfile)))))) - (delete-file tmpfile)))) + (ert-with-temp-file tmpfile + :suffix (car exec-suffixes) + (set-file-modes tmpfile #o755) + (let ((exec-path `(,temporary-file-directory))) + (should + (equal tmpfile + (executable-find (file-name-nondirectory tmpfile))))) + ;; An empty element of `exec-path' means `default-directory'. + (let ((default-directory temporary-file-directory) + (exec-path nil)) + (should + (equal tmpfile + (executable-find (file-name-nondirectory tmpfile))))) + ;; The remote file name shall be quoted, and handled like a + ;; non-existing directory. + (let ((default-directory "/ssh::") + (exec-path (append exec-path `("." ,temporary-file-directory)))) + (should + (equal tmpfile + (executable-find (file-name-nondirectory tmpfile))))))) (ert-deftest files-tests-dont-rewrite-precious-files () "Test that `file-precious-flag' forces files to be saved by renaming only, rather than modified in-place." - (let* ((temp-file-name (make-temp-file "files-tests")) - (advice (lambda (_start _end filename &rest _r) - (should-not (string= filename temp-file-name))))) - (unwind-protect - (with-current-buffer (find-file-noselect temp-file-name) - (advice-add #'write-region :before advice) - (setq-local file-precious-flag t) - (insert "foobar") - (should (null (save-buffer)))) - (ignore-errors (advice-remove #'write-region advice)) - (ignore-errors (delete-file temp-file-name))))) + (ert-with-temp-file temp-file-name + (let* ((advice (lambda (_start _end filename &rest _r) + (should-not (string= filename temp-file-name))))) + (unwind-protect + (with-current-buffer (find-file-noselect temp-file-name) + (advice-add #'write-region :before advice) + (setq-local file-precious-flag t) + (insert "foobar") + (should (null (save-buffer)))) + (ignore-errors (advice-remove #'write-region advice)))))) (ert-deftest files-test-file-size-human-readable () (should (equal (file-size-human-readable 13) "13")) @@ -1542,26 +1537,32 @@ The door of all subtleties! (ert-deftest files-tests-revert-buffer () "Test that revert-buffer is successful." - (files-tests--with-temp-file temp-file-name + (ert-with-temp-file temp-file-name (with-temp-buffer (insert files-tests-lao) - (write-file temp-file-name) - (erase-buffer) - (insert files-tests-tzu) - (revert-buffer t t t) + ;; Disable lock files, since that barfs in + ;; userlock--check-content-unchanged on MS-Windows. + (let (create-lockfiles) + (write-file temp-file-name) + (erase-buffer) + (insert files-tests-tzu) + (revert-buffer t t t)) (should (compare-strings files-tests-lao nil nil (buffer-substring (point-min) (point-max)) nil nil))))) (ert-deftest files-tests-revert-buffer-with-fine-grain () "Test that revert-buffer-with-fine-grain is successful." - (files-tests--with-temp-file temp-file-name + (ert-with-temp-file temp-file-name (with-temp-buffer (insert files-tests-lao) - (write-file temp-file-name) - (erase-buffer) - (insert files-tests-tzu) - (should (revert-buffer-with-fine-grain t t)) + ;; Disable lock files, since that barfs in + ;; userlock--check-content-unchanged on MS-Windows. + (let (create-lockfiles) + (write-file temp-file-name) + (erase-buffer) + (insert files-tests-tzu) + (should (revert-buffer-with-fine-grain t t))) (should (compare-strings files-tests-lao nil nil (buffer-substring (point-min) (point-max)) nil nil))))) @@ -1584,6 +1585,14 @@ The door of all subtleties! (should-error (file-name-with-extension "Jack" ".")) (should-error (file-name-with-extension "/is/a/directory/" "css"))) +(ert-deftest files-tests-file-name-base () + (should (equal (file-name-base "") "")) + (should (equal (file-name-base "/foo/") "")) + (should (equal (file-name-base "/foo") "foo")) + (should (equal (file-name-base "/foo/bar") "bar")) + (should (equal (file-name-base "foo") "foo")) + (should (equal (file-name-base "foo/bar") "bar"))) + (ert-deftest files-test-dir-locals-auto-mode-alist () "Test an `auto-mode-alist' entry in `.dir-locals.el'" (find-file (ert-resource-file "whatever.quux")) @@ -1611,40 +1620,39 @@ on BUF-1 and BUF-2 after the `save-some-buffers' call. The test is repeated with `save-some-buffers-default-predicate' let-bound to PRED and passing nil as second arg of `save-some-buffers'." - (let* ((dir (make-temp-file "testdir" 'dir)) - (file-1 (expand-file-name "subdir-1/file.foo" dir)) - (file-2 (expand-file-name "subdir-2/file.bar" dir)) - (inhibit-message t) - buf-1 buf-2) - (unwind-protect - (progn - (make-empty-file file-1 'parens) - (make-empty-file file-2 'parens) - (setq buf-1 (find-file file-1) - buf-2 (find-file file-2)) - (dolist (buf (list buf-1 buf-2)) - (with-current-buffer buf (insert "foobar\n"))) - ;; Run the test. - (with-current-buffer buf-1 - (let ((save-some-buffers-default-predicate def-pred-bind)) - (save-some-buffers t pred)) - (should (eq exp-1 (buffer-modified-p buf-1))) - (should (eq exp-2 (buffer-modified-p buf-2)))) - ;; Set both buffers as modified to run another test. - (dolist (buf (list buf-1 buf-2)) - (with-current-buffer buf (set-buffer-modified-p t))) - ;; The result of this test must be identical as the previous one. - (with-current-buffer buf-1 - (let ((save-some-buffers-default-predicate (or pred def-pred-bind))) - (save-some-buffers t nil)) - (should (eq exp-1 (buffer-modified-p buf-1))) - (should (eq exp-2 (buffer-modified-p buf-2))))) - ;; Clean up. - (dolist (buf (list buf-1 buf-2)) - (with-current-buffer buf - (set-buffer-modified-p nil) - (kill-buffer buf))) - (delete-directory dir 'recursive)))) + (ert-with-temp-directory dir + (let* ((file-1 (expand-file-name "subdir-1/file.foo" dir)) + (file-2 (expand-file-name "subdir-2/file.bar" dir)) + (inhibit-message t) + buf-1 buf-2) + (unwind-protect + (progn + (make-empty-file file-1 'parens) + (make-empty-file file-2 'parens) + (setq buf-1 (find-file file-1) + buf-2 (find-file file-2)) + (dolist (buf (list buf-1 buf-2)) + (with-current-buffer buf (insert "foobar\n"))) + ;; Run the test. + (with-current-buffer buf-1 + (let ((save-some-buffers-default-predicate def-pred-bind)) + (save-some-buffers t pred)) + (should (eq exp-1 (buffer-modified-p buf-1))) + (should (eq exp-2 (buffer-modified-p buf-2)))) + ;; Set both buffers as modified to run another test. + (dolist (buf (list buf-1 buf-2)) + (with-current-buffer buf (set-buffer-modified-p t))) + ;; The result of this test must be identical as the previous one. + (with-current-buffer buf-1 + (let ((save-some-buffers-default-predicate (or pred def-pred-bind))) + (save-some-buffers t nil)) + (should (eq exp-1 (buffer-modified-p buf-1))) + (should (eq exp-2 (buffer-modified-p buf-2))))) + ;; Clean up. + (dolist (buf (list buf-1 buf-2)) + (with-current-buffer buf + (set-buffer-modified-p nil) + (kill-buffer buf))))))) (ert-deftest files-tests-save-some-buffers () "Test `save-some-buffers'. @@ -1807,6 +1815,12 @@ Prompt users for any modified buffer with `buffer-offer-save' non-nil." ;; `save-some-buffers-default-predicate' (i.e. the 2nd element) is ignored. (nil save-some-buffers-root ,nb-might-save)))))) +(ert-deftest test-file-name-split () + (should (equal (file-name-split "foo/bar") '("foo" "bar"))) + (should (equal (file-name-split "/foo/bar") '("" "foo" "bar"))) + (should (equal (file-name-split "/foo/bar/zot") '("" "foo" "bar" "zot"))) + (should (equal (file-name-split "/foo/bar/") '("" "foo" "bar" ""))) + (should (equal (file-name-split "foo/bar/") '("foo" "bar" "")))) (provide 'files-tests) ;;; files-tests.el ends here diff --git a/test/lisp/format-spec-tests.el b/test/lisp/format-spec-tests.el index ff2abdeaad5..3c6fa540fe8 100644 --- a/test/lisp/format-spec-tests.el +++ b/test/lisp/format-spec-tests.el @@ -56,7 +56,7 @@ (ert-deftest format-spec-do-flags-truncate () "Test `format-spec--do-flags' truncation." - (let (flags) + (let ((flags nil)) (should (equal (format-spec--do-flags "" flags nil 0) "")) (should (equal (format-spec--do-flags "" flags nil 1) "")) (should (equal (format-spec--do-flags "a" flags nil 0) "")) @@ -75,7 +75,7 @@ (ert-deftest format-spec-do-flags-pad () "Test `format-spec--do-flags' padding." - (let (flags) + (let ((flags nil)) (should (equal (format-spec--do-flags "" flags 0 nil) "")) (should (equal (format-spec--do-flags "" flags 1 nil) " ")) (should (equal (format-spec--do-flags "a" flags 0 nil) "a")) diff --git a/test/lisp/gnus/gnus-group-tests.el b/test/lisp/gnus/gnus-group-tests.el new file mode 100644 index 00000000000..ee1e01be4b2 --- /dev/null +++ b/test/lisp/gnus/gnus-group-tests.el @@ -0,0 +1,52 @@ +;;; gnus-group-tests.el --- Tests for gnus-group.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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'gnus-group) +(require 'ert) + +(ert-deftest gnus-short-group-name () + (map-apply + (lambda (input expected) + (should (string-equal (gnus-short-group-name input) expected))) + '(("nnimap+email@example.com:archives/2020/03" . "email@example:a/2/03") + ("nndiary+diary:birthdays" . "diary:birthdays") + ("nnimap+email@example.com:test" . "email@example:test") + ("nnimap+email@example.com:234" . "email@example:234") + + ;; This is a very aggressive shortening of the left hand side. + ("nnimap+email@banana.salesman.example.com:234" . "email@banana:234") + ("nntp+some.where.edu:soc.motss" . "some:s.motss") + ("nntp+news.gmane.org:gmane.emacs.gnus.general" . "news:g.e.g.general") + ("nntp+news.gnus.org:gmane.text.docbook.apps" . "news:g.t.d.apps") + + ;; nnimap groups. + ("nnimap+email@example.com:[Invoices]/Bananas" . "email@example:I/Bananas") + ("nnimap+email@banana.salesman.example.com:[Invoices]/Bananas" + . "email@banana:I/Bananas") + + ;; The "n" from "nnspool" is perhaps not optimal. + ("nnspool+alt.binaries.pictures.furniture" . "n.b.p.furniture")))) + +;;; gnus-group-tests.el ends here diff --git a/test/lisp/gnus/gnus-icalendar-tests.el b/test/lisp/gnus/gnus-icalendar-tests.el index 90c3a34a5c0..1206a976f6e 100644 --- a/test/lisp/gnus/gnus-icalendar-tests.el +++ b/test/lisp/gnus/gnus-icalendar-tests.el @@ -216,7 +216,7 @@ RRULE:FREQ=WEEKLY;BYDAY=FR,MO,TH,TU,WE DTSTAMP:20200915T120627Z ORGANIZER;CN=anon@anoncompany.com:mailto:anon@anoncompany.com UID:7b6g3m7iftuo90ei4ul00feqn_R20200915T120000@google.com -ATTENDEE;CUTYPE=INDIVIDUAL;ROLE=REQ-PARTICIPANT;PARTSTAT=ACCEPTED;RSVP=TRUE +ATTENDEE;CUTYPE=INDIVIDUAL;PARTSTAT=ACCEPTED;RSVP=TRUE ;CN=participant@anoncompany.com;X-NUM-GUESTS=0:mailto:participant@anoncompany.com CREATED:20200325T095723Z DESCRIPTION:Coffee talk diff --git a/test/lisp/help-fns-tests.el b/test/lisp/help-fns-tests.el index 513a0c2daea..24a42290a3f 100644 --- a/test/lisp/help-fns-tests.el +++ b/test/lisp/help-fns-tests.el @@ -148,7 +148,7 @@ Return first line of the output of (describe-function-1 FUNC)." (ert-deftest help-fns-test-describe-keymap/value () (describe-keymap minibuffer-local-must-match-map) (with-current-buffer "*Help*" - (should (looking-at "^key")))) + (should (looking-at "\nKey")))) (ert-deftest help-fns-test-describe-keymap/not-keymap () (should-error (describe-keymap nil)) @@ -158,7 +158,7 @@ Return first line of the output of (describe-function-1 FUNC)." (let ((foobar minibuffer-local-must-match-map)) (describe-keymap foobar) (with-current-buffer "*Help*" - (should (looking-at "^key"))))) + (should (looking-at "\nKey"))))) (ert-deftest help-fns-test-describe-keymap/dynamically-bound-no-file () (setq help-fns-test--describe-keymap-foo minibuffer-local-must-match-map) diff --git a/test/lisp/help-tests.el b/test/lisp/help-tests.el index 871417da3d2..65b329c1cd6 100644 --- a/test/lisp/help-tests.el +++ b/test/lisp/help-tests.el @@ -65,7 +65,7 @@ result)))) (test-re (lambda (orig regexp) - (should (string-match (concat "^" regexp "$") + (should (string-match (concat "\\`" regexp "\\'") (substitute-command-keys orig)))))) ,@body)) @@ -88,41 +88,77 @@ (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/keymaps () +(ert-deftest help-tests-substitute-command-keys/literal-key-sequence () + "Literal replacement." (with-substitute-command-keys-test - (test "\\{minibuffer-local-must-match-map}" - "\ -key binding ---- ------- + (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 "\\`<foo bar baz>'"))) + +(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))) + +(defvar-keymap help-tests--test-keymap + :doc "Just some keymap for testing." + "C-g" #'abort-minibuffers + "TAB" #'minibuffer-complete + "C-j" #'minibuffer-complete-and-exit + "RET" #'minibuffer-complete-and-exit + "SPC" #'minibuffer-complete-word + "?" #'minibuffer-completion-help + "C-<tab>" #'file-cache-minibuffer-complete + "<XF86Back>" #'previous-history-element + "<XF86Forward>" #'next-history-element + "<backtab>" #'minibuffer-complete + "<down>" #'next-line-or-history-element + "<next>" #'next-history-element + "<prior>" #'switch-to-completions + "<up>" #'previous-line-or-history-element + "M-v" #'switch-to-completions + "M-<" #'minibuffer-beginning-of-buffer + "M-n" #'next-history-element + "M-p" #'previous-history-element + "M-r" #'previous-matching-history-element + "M-s" #'next-matching-history-element + "M-g M-c" #'switch-to-completions) +(ert-deftest help-tests-substitute-command-keys/keymaps () + (with-substitute-command-keys-test + (test-re "\\{help-tests--test-keymap}" + " +Key Binding +-+ C-g abort-minibuffers TAB minibuffer-complete C-j minibuffer-complete-and-exit RET minibuffer-complete-and-exit -ESC Prefix Command SPC minibuffer-complete-word -? minibuffer-completion-help +\\? minibuffer-completion-help C-<tab> file-cache-minibuffer-complete <XF86Back> previous-history-element <XF86Forward> next-history-element +<backtab> minibuffer-complete <down> next-line-or-history-element <next> next-history-element <prior> switch-to-completions <up> previous-line-or-history-element -M-g Prefix Command -M-v switch-to-completions - -M-g ESC Prefix Command - M-< minibuffer-beginning-of-buffer M-n next-history-element M-p previous-history-element M-r previous-matching-history-element M-s next-matching-history-element +M-v switch-to-completions M-g M-c switch-to-completions - "))) (ert-deftest help-tests-substitute-command-keys/keymap-change () @@ -130,12 +166,11 @@ M-g M-c switch-to-completions (test "\\<minibuffer-local-must-match-map>\\[abort-recursive-edit]" "C-]") (test "\\<emacs-lisp-mode-map>\\[eval-defun]" "C-M-x"))) -(defvar help-tests-remap-map - (let ((map (make-keymap))) - (define-key map (kbd "x") 'foo) - (define-key map (kbd "y") 'bar) - (define-key map [remap foo] 'bar) - map)) +(defvar-keymap help-tests-remap-map + :full t + "x" 'foo + "y" 'bar + "<remap> <foo>" 'bar) (ert-deftest help-tests-substitute-command-keys/remap () (should (equal (substitute-command-keys "\\<help-tests-remap-map>\\[foo]") "y")) @@ -180,7 +215,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 "\\=" "\\="))) @@ -199,30 +234,28 @@ M-g M-c switch-to-completions (goto-char (point-min)) (should (looking-at "Type RET on")))) -(defvar help-tests-major-mode-map - (let ((map (make-keymap))) - (define-key map "x" 'foo-original) - (define-key map "1" 'foo-range) - (define-key map "2" 'foo-range) - (define-key map "3" 'foo-range) - (define-key map "4" 'foo-range) - (define-key map (kbd "C-e") 'foo-something) - (define-key map '[F1] 'foo-function-key1) - (define-key map "(" 'short-range) - (define-key map ")" 'short-range) - (define-key map "a" 'foo-other-range) - (define-key map "b" 'foo-other-range) - (define-key map "c" 'foo-other-range) - map)) +(defvar-keymap help-tests-major-mode-map + :full t + "x" 'foo-original + "1" 'foo-range + "2" 'foo-range + "3" 'foo-range + "4" 'foo-range + "C-e" 'foo-something + "<f1>" 'foo-function-key1 + "(" 'short-range + ")" 'short-range + "a" 'foo-other-range + "b" 'foo-other-range + "c" 'foo-other-range) (define-derived-mode help-tests-major-mode nil "Major mode for testing shadowing.") -(defvar help-tests-minor-mode-map - (let ((map (make-keymap))) - (define-key map "x" 'foo-shadow) - (define-key map (kbd "C-e") 'foo-shadow) - map)) +(defvar-keymap help-tests-minor-mode-map + :full t + "x" 'foo-shadow + "C-e" 'foo-shadow) (define-minor-mode help-tests-minor-mode "Minor mode for testing shadowing.") @@ -249,11 +282,10 @@ M-g M-c switch-to-completions (with-substitute-command-keys-test (with-temp-buffer (help-tests-major-mode) - (test "\\{help-tests-major-mode-map}" - "\ -key binding ---- ------- - + (test-re "\\{help-tests-major-mode-map}" + " +Key Binding +-+ ( .. ) short-range 1 .. 4 foo-range a .. c foo-other-range @@ -261,7 +293,6 @@ a .. c foo-other-range C-e foo-something x foo-original <F1> foo-function-key1 - ")))) (ert-deftest help-tests-substitute-command-keys/shadow () @@ -269,11 +300,10 @@ x foo-original (with-temp-buffer (help-tests-major-mode) (help-tests-minor-mode) - (test "\\{help-tests-major-mode-map}" - "\ -key binding ---- ------- - + (test-re "\\{help-tests-major-mode-map}" + " +Key Binding +-+ ( .. ) short-range 1 .. 4 foo-range a .. c foo-other-range @@ -283,7 +313,6 @@ C-e foo-something x foo-original (this binding is currently shadowed) <F1> foo-function-key1 - ")))) (ert-deftest help-tests-substitute-command-keys/command-remap () @@ -292,15 +321,11 @@ x foo-original (with-temp-buffer (help-tests-major-mode) (define-key help-tests-major-mode-map [remap foo] 'bar) - (test "\\{help-tests-major-mode-map}" - "\ -key binding ---- ------- - -<remap> Prefix Command - + (test-re "\\{help-tests-major-mode-map}" + " +Key Binding +-+ <remap> <foo> bar - "))))) (ert-deftest help-tests-describe-map-tree/no-menu-t () @@ -312,12 +337,11 @@ key binding :enable mark-active :help "Help text")))))) (describe-map-tree map nil nil nil nil t nil nil nil) - (should (equal (buffer-string) "key binding ---- ------- - -C-a foo - -"))))) + (should (string-match " +Key Binding +-+ +C-a foo\n" + (buffer-string)))))) (ert-deftest help-tests-describe-map-tree/no-menu-nil () (with-temp-buffer @@ -328,15 +352,13 @@ C-a foo :enable mark-active :help "Help text")))))) (describe-map-tree map nil nil nil nil nil nil nil nil) - (should (equal (buffer-string) "key binding ---- ------- - + (should (string-match " +Key Binding +-+ C-a foo -<menu-bar> Prefix Command -<menu-bar> <foo> foo - -"))))) +<menu-bar> <foo> foo\n" + (buffer-string)))))) (ert-deftest help-tests-describe-map-tree/mention-shadow-t () (with-temp-buffer @@ -345,14 +367,13 @@ C-a foo (2 . bar)))) (shadow-maps '((keymap . ((1 . baz)))))) (describe-map-tree map t shadow-maps nil nil t nil nil t) - (should (equal (buffer-string) "key binding ---- ------- - + (should (string-match " +Key Binding +-+ C-a foo (this binding is currently shadowed) -C-b bar - -"))))) +C-b bar\n" + (buffer-string)))))) (ert-deftest help-tests-describe-map-tree/mention-shadow-nil () (with-temp-buffer @@ -361,12 +382,11 @@ C-b bar (2 . bar)))) (shadow-maps '((keymap . ((1 . baz)))))) (describe-map-tree map t shadow-maps nil nil t nil nil nil) - (should (equal (buffer-string) "key binding ---- ------- - -C-b bar - -"))))) + (should (string-match " +Key Binding +-+ +C-b bar\n" + (buffer-string)))))) (ert-deftest help-tests-describe-map-tree/partial-t () (with-temp-buffer @@ -374,12 +394,11 @@ C-b bar (map '(keymap . ((1 . foo) (2 . undefined))))) (describe-map-tree map t nil nil nil nil nil nil nil) - (should (equal (buffer-string) "key binding ---- ------- - -C-a foo - -"))))) + (should (string-match " +Key Binding +-+ +C-a foo\n" + (buffer-string)))))) (ert-deftest help-tests-describe-map-tree/partial-nil () (with-temp-buffer @@ -387,13 +406,12 @@ C-a foo (map '(keymap . ((1 . foo) (2 . undefined))))) (describe-map-tree map nil nil nil nil nil nil nil nil) - (should (equal (buffer-string) "key binding ---- ------- - + (should (string-match " +Key Binding +-+ C-a foo -C-b undefined - -"))))) +C-b undefined\n" + (buffer-string)))))) (defvar help-tests--was-in-buffer nil) diff --git a/test/lisp/image-dired-tests.el b/test/lisp/image-dired-tests.el new file mode 100644 index 00000000000..3f0304ee405 --- /dev/null +++ b/test/lisp/image-dired-tests.el @@ -0,0 +1,37 @@ +;;; image-dired-tests.el --- Tests for image-dired.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 <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) +(require 'image-dired) + +(defun image-dired-test-image-file (name) + (expand-file-name + name (expand-file-name "data/image" + (or (getenv "EMACS_TEST_DIRECTORY") + "../")))) + +(ert-deftest image-dired-tests-get-exif-file-name () + (skip-unless (image-type-available-p 'jpeg)) + (let ((img (image-dired-test-image-file "black.jpg"))) + (should (equal (image-dired-get-exif-file-name img) + "2019_09_21_16_22_13_black.jpg")))) + +;;; image-dired-tests.el ends here diff --git a/test/lisp/image-tests.el b/test/lisp/image-tests.el index aa8600609c4..47d321d5b53 100644 --- a/test/lisp/image-tests.el +++ b/test/lisp/image-tests.el @@ -28,6 +28,27 @@ (expand-file-name "images" data-directory) "Directory containing Emacs images.") +(defconst image-tests--files + `((gif . ,(expand-file-name "test/data/image/black.gif" + source-directory)) + (jpeg . ,(expand-file-name "test/data/image/black.jpg" + source-directory)) + (pbm . ,(expand-file-name "splash.pbm" + image-tests--emacs-images-directory)) + (png . ,(expand-file-name "splash.png" + image-tests--emacs-images-directory)) + (svg . ,(expand-file-name "splash.svg" + image-tests--emacs-images-directory)) + (tiff . ,(expand-file-name + "nextstep/GNUstep/Emacs.base/Resources/emacs.tiff" + source-directory)) + (webp . ,(expand-file-name "test/data/image/black.webp" + source-directory)) + (xbm . ,(expand-file-name "gnus/gnus.xbm" + image-tests--emacs-images-directory)) + (xpm . ,(expand-file-name "splash.xpm" + image-tests--emacs-images-directory)))) + (ert-deftest image--set-property () "Test `image--set-property' behavior." (let ((image (list 'image))) @@ -49,25 +70,53 @@ (should (equal image '(image))))) (ert-deftest image-find-image () - (find-image '((:type xpm :file "undo.xpm"))) - (find-image '((:type png :file "newsticker/rss-feed.png" :ascent center)))) + (should (listp (find-image '((:type xpm :file "undo.xpm"))))) + (should (listp (find-image '((:type png :file "newsticker/rss-feed.png" :ascent center))))) + (should-not (find-image '((:type png :file "does-not-exist-foo-bar.png"))))) (ert-deftest image-type-from-file-name () (should (eq (image-type-from-file-name "foo.jpg") 'jpeg)) - (should (eq (image-type-from-file-name "foo.png") 'png))) + (should (eq (image-type-from-file-name "foo.png") 'png)) + (should (eq (image-type-from-file-name "foo.webp") 'webp))) (ert-deftest image-type/from-filename () ;; On emba, `image-types' and `image-load-path' do not exist. (skip-unless (and (bound-and-true-p image-types) - (bound-and-true-p image-load-path))) + (bound-and-true-p image-load-path) + (image-type-available-p 'jpeg))) (should (eq (image-type "foo.jpg") 'jpeg))) -(ert-deftest image-type-from-file-header-test () +(defun image-tests--type-from-file-header (type) "Test image-type-from-file-header." - (should (eq (if (image-type-available-p 'svg) 'svg) - (image-type-from-file-header - (expand-file-name "splash.svg" - image-tests--emacs-images-directory))))) + (should (eq (if (image-type-available-p type) type) + (image-type-from-file-header (cdr (assq type image-tests--files)))))) + +(ert-deftest image-type-from-file-header-test/gif () + (image-tests--type-from-file-header 'gif)) + +(ert-deftest image-type-from-file-header-test/jpeg () + (image-tests--type-from-file-header 'jpeg)) + +(ert-deftest image-type-from-file-header-test/pbm () + (image-tests--type-from-file-header 'pbm)) + +(ert-deftest image-type-from-file-header-test/png () + (image-tests--type-from-file-header 'png)) + +(ert-deftest image-type-from-file-header-test/svg () + (image-tests--type-from-file-header 'svg)) + +(ert-deftest image-type-from-file-header-test/tiff () + (image-tests--type-from-file-header 'tiff)) + +(ert-deftest image-type-from-file-header-test/webp () + (image-tests--type-from-file-header 'webp)) + +(ert-deftest image-type-from-file-header-test/xbm () + (image-tests--type-from-file-header 'xbm)) + +(ert-deftest image-type-from-file-header-test/xpm () + (image-tests--type-from-file-header 'xpm)) (ert-deftest image-rotate () "Test `image-rotate'." diff --git a/test/lisp/image/exif-tests.el b/test/lisp/image/exif-tests.el index ddbee75467e..2357113f630 100644 --- a/test/lisp/image/exif-tests.el +++ b/test/lisp/image/exif-tests.el @@ -28,24 +28,19 @@ (or (getenv "EMACS_TEST_DIRECTORY") "../../")))) -(defun exif-elem (exif elem) - (plist-get (seq-find (lambda (e) - (eq elem (plist-get e :tag-name))) - exif) - :value)) - (ert-deftest test-exif-parse () (let ((exif (exif-parse-file (test-image-file "black.jpg")))) - (should (equal (exif-elem exif 'make) "Panasonic")) - (should (equal (exif-elem exif 'orientation) 1)) - (should (equal (exif-elem exif 'x-resolution) '(180 . 1))))) + (should (equal (exif-field 'make exif) "Panasonic")) + (should (equal (exif-field 'orientation exif) 1)) + (should (equal (exif-field 'x-resolution exif) '(180 . 1))) + (should (equal (exif-field 'date-time exif) "2019:09:21 16:22:13")))) (ert-deftest test-exif-parse-short () (let ((exif (exif-parse-file (test-image-file "black-short.jpg")))) - (should (equal (exif-elem exif 'make) "thr")) - (should (equal (exif-elem exif 'model) "four")) - (should (equal (exif-elem exif 'software) "em")) - (should (equal (exif-elem exif 'artist) "z")))) + (should (equal (exif-field 'make exif) "thr")) + (should (equal (exif-field 'model exif) "four")) + (should (equal (exif-field 'software exif) "em")) + (should (equal (exif-field 'artist exif) "z")))) (ert-deftest test-exit-direct-ascii-value () (should (equal (exif--direct-ascii-value 28005 2 t) (string ?e ?m 0))) diff --git a/test/lisp/info-tests.el b/test/lisp/info-tests.el new file mode 100644 index 00000000000..3e2aa3e089d --- /dev/null +++ b/test/lisp/info-tests.el @@ -0,0 +1,39 @@ +;;; info-tests.el --- Tests for info.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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'info) +(require 'ert) +(require 'ert-x) + +(ert-deftest test-info-urls () + (should (equal (Info-url-for-node "(emacs)Minibuffer") + "https://www.gnu.org/software/emacs/manual/html_node/emacs/Minibuffer.html")) + (should (equal (Info-url-for-node "(emacs)Minibuffer File") + "https://www.gnu.org/software/emacs/manual/html_node/emacs/Minibuffer-File.html")) + (should (equal (Info-url-for-node "(elisp)Backups and Auto-Saving") + "https://www.gnu.org/software/emacs/manual/html_node/elisp/Backups-and-Auto_002dSaving.html")) + (should-error (Info-url-for-node "(gnus)Minibuffer File"))) + +;;; info-tests.el ends here diff --git a/test/lisp/info-xref-tests.el b/test/lisp/info-xref-tests.el index 0b8091f17af..9379a53fe1d 100644 --- a/test/lisp/info-xref-tests.el +++ b/test/lisp/info-xref-tests.el @@ -22,6 +22,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'info-xref) (defun info-xref-test-internal (body result) @@ -96,15 +97,17 @@ text. (ert-deftest info-xref-test-makeinfo () "Test that info-xref can parse basic makeinfo output." (skip-unless (executable-find "makeinfo")) - (let ((tempfile (make-temp-file "info-xref-test" nil ".texi")) - (tempfile2 (make-temp-file "info-xref-test2" nil ".texi")) - (errflag t)) - (unwind-protect - (progn - ;; tempfile contains xrefs to various things, including tempfile2. - (info-xref-test-write-file - tempfile - (concat "\ + (ert-with-temp-file tempfile + :suffix ".texi" + (ert-with-temp-file tempfile2 + :suffix ".texi" + (let ((errflag t)) + (unwind-protect + (progn + ;; tempfile contains xrefs to various things, including tempfile2. + (info-xref-test-write-file + tempfile + (concat "\ @xref{nodename,,,missing,Missing Manual}. @xref{nodename,crossref,title,missing,Missing Manual}. @@ -114,35 +117,36 @@ text. @xref{Chapter One,Something}. " - (format "@xref{Chapter One,,,%s,Present Manual}.\n" - (file-name-sans-extension (file-name-nondirectory - tempfile2))))) - ;; Something for tempfile to xref to. - (info-xref-test-write-file tempfile2 "") - (require 'info) - (save-window-excursion - (let ((Info-directory-list - (list - (or (file-name-directory tempfile) "."))) - Info-additional-directory-list) - (info-xref-check (format "%s.info" (file-name-sans-extension - tempfile)))) - (should (equal (list info-xref-bad info-xref-good - info-xref-unavail) - '(0 1 2))) - (setq errflag nil) - ;; If there was an error, we can leave this around. - (kill-buffer info-xref-output-buffer))) - ;; Useful diagnostic in case of problems. - (if errflag - (with-temp-buffer - (call-process "makeinfo" nil t nil "--version") - (message "%s" (buffer-string)))) - (mapc 'delete-file (list tempfile tempfile2 - (format "%s.info" (file-name-sans-extension - tempfile)) - (format "%s.info" (file-name-sans-extension - tempfile2))))))) + (format "@xref{Chapter One,,,%s,Present Manual}.\n" + (file-name-sans-extension (file-name-nondirectory + tempfile2))))) + ;; Something for tempfile to xref to. + (info-xref-test-write-file tempfile2 "") + (require 'info) + (save-window-excursion + (let ((Info-directory-list + (list + (or (file-name-directory tempfile) "."))) + Info-additional-directory-list) + (info-xref-check (format "%s.info" (file-name-sans-extension + tempfile)))) + (should (equal (list info-xref-bad info-xref-good + info-xref-unavail) + '(0 1 2))) + (setq errflag nil) + ;; If there was an error, we can leave this around. + (kill-buffer info-xref-output-buffer))) + ;; Useful diagnostic in case of problems. + (if errflag + (with-temp-buffer + (call-process "makeinfo" nil t nil "--version") + (message "%s" (buffer-string)))) + (ignore-errors + (delete-file (format "%s.info" (file-name-sans-extension + tempfile)))) + (ignore-errors + (delete-file (format "%s.info" (file-name-sans-extension + tempfile2))))))))) (ert-deftest info-xref-test-emacs-manuals () "Test that all internal links in the Emacs manuals work." diff --git a/test/lisp/kmacro-tests.el b/test/lisp/kmacro-tests.el index ecd3d5fc22b..49b40935387 100644 --- a/test/lisp/kmacro-tests.el +++ b/test/lisp/kmacro-tests.el @@ -91,33 +91,30 @@ body in KEYS-AND-BODY." ,docstring ,@keys (kmacro-tests-with-kmacro-clean-slate ,@body)))) -(defvar kmacro-tests-keymap - (let ((map (make-sparse-keymap))) - (dotimes (i 26) - (define-key map (string (+ ?a i)) 'self-insert-command)) - (dotimes (i 10) - (define-key map (string (+ ?0 i)) 'self-insert-command)) - ;; Define a few key sequences of different lengths. - (dolist (item '(("\C-a" . beginning-of-line) - ("\C-b" . backward-char) - ("\C-e" . end-of-line) - ("\C-f" . forward-char) - ("\C-r" . isearch-backward) - ("\C-u" . universal-argument) - ("\C-w" . kill-region) - ("\C-SPC" . set-mark-command) - ("\M-w" . kill-ring-save) - ("\M-x" . execute-extended-command) - ("\C-cd" . downcase-word) - ("\C-cxu" . upcase-word) - ("\C-cxq" . quoted-insert) - ("\C-cxi" . kmacro-insert-counter) - ("\C-x\C-k" . kmacro-keymap))) - (define-key map (car item) (cdr item))) - map) - "Keymap to use for testing keyboard macros. +(defvar-keymap kmacro-tests-keymap + :doc "Keymap to use for testing keyboard macros. This is used to obtain consistent results even if tests are run -in an environment with rebound keys.") +in an environment with rebound keys." + ;; Define a few key sequences of different lengths. + "C-a" 'beginning-of-line + "C-b" 'backward-char + "C-e" 'end-of-line + "C-f" 'forward-char + "C-r" 'isearch-backward + "C-u" 'universal-argument + "C-w" 'kill-region + "C-SPC" 'set-mark-command + "M-w" 'kill-ring-save + "M-x" 'execute-extended-command + "C-c d" 'downcase-word + "C-c x u" 'upcase-word + "C-c x q" 'quoted-insert + "C-c x i" 'kmacro-insert-counter + "C-x C-k" 'kmacro-keymap) +(dotimes (i 26) + (keymap-set kmacro-tests-keymap (string (+ ?a i)) 'self-insert-command)) +(dotimes (i 10) + (keymap-set kmacro-tests-keymap (string (+ ?0 i)) 'self-insert-command)) (defvar kmacro-tests-events nil "Input events used by the kmacro test in progress.") diff --git a/test/lisp/ls-lisp-tests.el b/test/lisp/ls-lisp-tests.el index e386398eea2..9f2c63225b5 100644 --- a/test/lisp/ls-lisp-tests.el +++ b/test/lisp/ls-lisp-tests.el @@ -25,6 +25,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'ls-lisp) (require 'dired) @@ -53,28 +54,29 @@ (kill-buffer buf) (setq buf (dired (nconc (list dir) files))) (should (looking-at "src")) - (next-line) ; File names must be aligned. + (with-suppressed-warnings ((interactive-only next-line)) + (next-line)) ; File names must be aligned. (should (looking-at "src"))) (when (buffer-live-p buf) (kill-buffer buf))))) (ert-deftest ls-lisp-test-bug27631 () "Test for https://debbugs.gnu.org/27631 ." - (let* ((dir (make-temp-file "bug27631" 'dir)) - (dir1 (expand-file-name "dir1" dir)) - (dir2 (expand-file-name "dir2" dir)) - (default-directory dir) - ls-lisp-use-insert-directory-program buf) - (unwind-protect - (progn - (make-directory dir1) - (make-directory dir2) - (with-temp-file (expand-file-name "a.txt" dir1)) - (with-temp-file (expand-file-name "b.txt" dir2)) - (setq buf (dired (expand-file-name "dir*/*.txt" dir))) - (dired-toggle-marks) - (should (cdr (dired-get-marked-files)))) - (delete-directory dir 'recursive) - (when (buffer-live-p buf) (kill-buffer buf))))) + (ert-with-temp-directory dir + :suffix "bug27631" + (let* ((dir1 (expand-file-name "dir1" dir)) + (dir2 (expand-file-name "dir2" dir)) + (default-directory dir) + ls-lisp-use-insert-directory-program buf) + (unwind-protect + (progn + (make-directory dir1) + (make-directory dir2) + (with-temp-file (expand-file-name "a.txt" dir1)) + (with-temp-file (expand-file-name "b.txt" dir2)) + (setq buf (dired (expand-file-name "dir*/*.txt" dir))) + (dired-toggle-marks) + (should (cdr (dired-get-marked-files)))) + (when (buffer-live-p buf) (kill-buffer buf)))))) (ert-deftest ls-lisp-test-bug27693 () "Test for https://debbugs.gnu.org/27693 ." diff --git a/test/lisp/mail/mail-utils-tests.el b/test/lisp/mail/mail-utils-tests.el index 5b54f2440c7..f75de5c620c 100644 --- a/test/lisp/mail/mail-utils-tests.el +++ b/test/lisp/mail/mail-utils-tests.el @@ -85,7 +85,8 @@ "foo@example.org\\|bar@example.org\\|baz@example.org"))) (ert-deftest mail-utils-tests-mail-rfc822-time-zone () - (should (stringp (mail-rfc822-time-zone (current-time))))) + (with-suppressed-warnings ((obsolete mail-rfc822-time-zone)) + (should (stringp (mail-rfc822-time-zone (current-time)))))) (ert-deftest mail-utils-test-mail-rfc822-date/contains-year () (should (string-match (rx " 20" digit digit " ") diff --git a/test/lisp/mail/uudecode-tests.el b/test/lisp/mail/uudecode-tests.el index 981ce1c4ae0..1899ff50f69 100644 --- a/test/lisp/mail/uudecode-tests.el +++ b/test/lisp/mail/uudecode-tests.el @@ -50,14 +50,11 @@ Same as `uudecode-tests-encoded-str' but plain text.") (should (equal (buffer-string) uudecode-tests-decoded-str))) ;; Write to file (with-temp-buffer - (let ((tmpfile (make-temp-file "uudecode-tests-"))) - (unwind-protect - (progn - (insert uudecode-tests-encoded-str) - (uudecode-decode-region-internal (point-min) (point-max) tmpfile) - (should (equal (uudecode-tests-read-file tmpfile) - uudecode-tests-decoded-str))) - (delete-file tmpfile))))) + (ert-with-temp-file tmpfile + (insert uudecode-tests-encoded-str) + (uudecode-decode-region-internal (point-min) (point-max) tmpfile) + (should (equal (uudecode-tests-read-file tmpfile) + uudecode-tests-decoded-str))))) (ert-deftest uudecode-tests-decode-region-external () ;; Write to buffer @@ -68,14 +65,11 @@ Same as `uudecode-tests-encoded-str' but plain text.") (should (equal (buffer-string) uudecode-tests-decoded-str))) ;; Write to file (with-temp-buffer - (let ((tmpfile (make-temp-file "uudecode-tests-"))) - (unwind-protect - (progn - (insert uudecode-tests-encoded-str) - (uudecode-decode-region-external (point-min) (point-max) tmpfile) - (should (equal (uudecode-tests-read-file tmpfile) - uudecode-tests-decoded-str))) - (delete-file tmpfile)))))) + (ert-with-temp-file tmpfile + (insert uudecode-tests-encoded-str) + (uudecode-decode-region-external (point-min) (point-max) tmpfile) + (should (equal (uudecode-tests-read-file tmpfile) + uudecode-tests-decoded-str)))))) (provide 'uudecode-tests) ;;; uudecode-tests.el ends here 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 <https://www.gnu.org/licenses/>. + +;;; 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/browse-url-tests.el b/test/lisp/net/browse-url-tests.el index 4264e03d912..68c7c349013 100644 --- a/test/lisp/net/browse-url-tests.el +++ b/test/lisp/net/browse-url-tests.el @@ -28,6 +28,7 @@ (require 'browse-url) (require 'ert) +(require 'ert-x) (ert-deftest browse-url-tests-browser-kind () (should (eq (browse-url--browser-kind #'browse-url-w3 "gnu.org") @@ -87,11 +88,10 @@ "ftp://foo/"))) (ert-deftest browse-url-tests-delete-temp-file () - (let ((browse-url-temp-file-name - (make-temp-file "browse-url-tests-"))) + (ert-with-temp-file browse-url-temp-file-name (browse-url-delete-temp-file) (should-not (file-exists-p browse-url-temp-file-name))) - (let ((file (make-temp-file "browse-url-tests-"))) + (ert-with-temp-file file (browse-url-delete-temp-file file) (should-not (file-exists-p file)))) diff --git a/test/lisp/net/gnutls-tests.el b/test/lisp/net/gnutls-tests.el index 76c00b7eaac..f549ecd51dc 100644 --- a/test/lisp/net/gnutls-tests.el +++ b/test/lisp/net/gnutls-tests.el @@ -30,6 +30,14 @@ (require 'gnutls) (require 'hex-util) +(declare-function gnutls-symmetric-decrypt "gnutls.c") +(declare-function gnutls-symmetric-encrypt "gnutls.c") +(declare-function gnutls-hash-mac "gnutls.c") +(declare-function gnutls-hash-digest "gnutls.c") +(declare-function gnutls-ciphers "gnutls.c") +(declare-function gnutls-digests "gnutls.c") +(declare-function gnutls-macs "gnutls.c") + (defvar gnutls-tests-message-prefix "") (defsubst gnutls-tests-message (format-string &rest args) 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/network-stream-tests.el b/test/lisp/net/network-stream-tests.el index 8f5bddb71fa..1e1eacb9838 100644 --- a/test/lisp/net/network-stream-tests.el +++ b/test/lisp/net/network-stream-tests.el @@ -32,6 +32,8 @@ ;; it pulls in nsm, which then makes the :nowait t' tests fail unless ;; we disable the nsm, which we do by binding 'network-security-level' +(declare-function gnutls-peer-status "gnutls.c") + (ert-deftest make-local-unix-server () (skip-unless (featurep 'make-network-process '(:family local))) (let* ((file (make-temp-name "/tmp/server-test")) diff --git a/test/lisp/net/ntlm-tests.el b/test/lisp/net/ntlm-tests.el index 2420b3b48a9..7b89e6b0784 100644 --- a/test/lisp/net/ntlm-tests.el +++ b/test/lisp/net/ntlm-tests.el @@ -227,6 +227,8 @@ This string will be returned from the NTLM server to the NTLM client." ;; Silence some byte-compiler warnings that occur when ;; web-server/web-server.el is not found. +(eval-when-compile (cl-pushnew 'headers eieio--known-slot-names) + (cl-pushnew 'process eieio--known-slot-names)) (declare-function ws-send nil) (declare-function ws-parse-request nil) (declare-function ws-start nil) 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/secrets-tests.el b/test/lisp/net/secrets-tests.el index b392c4d1847..03d3e26faa6 100644 --- a/test/lisp/net/secrets-tests.el +++ b/test/lisp/net/secrets-tests.el @@ -57,8 +57,11 @@ (defun secrets--test-delete-all-session-items () "Delete all items of collection \"session\" bound to this Emacs." - (dolist (item (secrets-list-items "session")) - (secrets-delete-item "session" item))) + ;; If the "session" collection does not exist, a `dbus-error' is + ;; fired, which we ignore. + (dbus-ignore-errors + (dolist (item (secrets-list-items "session")) + (secrets-delete-item "session" item)))) (ert-deftest secrets-test01-sessions () "Test opening / closing a secrets session." @@ -93,7 +96,7 @@ (unwind-protect (progn (should (secrets-open-session)) - (should (member "session" (secrets-list-collections))) + (skip-unless (member "session" (secrets-list-collections))) ;; Create a random collection. This asks for a password ;; outside our control, so we make it in the interactive case @@ -153,6 +156,7 @@ (unwind-protect (let (item-path) (should (secrets-open-session)) + (skip-unless (member "session" (secrets-list-collections))) ;; Cleanup. There could be items in the "session" collection. (secrets--test-delete-all-session-items) @@ -214,6 +218,7 @@ (unwind-protect (progn (should (secrets-open-session)) + (skip-unless (member "session" (secrets-list-collections))) ;; Cleanup. There could be items in the "session" collection. (secrets--test-delete-all-session-items) diff --git a/test/lisp/net/shr-tests.el b/test/lisp/net/shr-tests.el index bfb83f25184..846ec1a9db2 100644 --- a/test/lisp/net/shr-tests.el +++ b/test/lisp/net/shr-tests.el @@ -27,6 +27,8 @@ (require 'ert-x) (require 'shr) +(declare-function libxml-parse-html-region "xml.c") + (defun shr-test (name) (with-temp-buffer (insert-file-contents (format (concat (ert-resource-directory) "/%s.html") name)) diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el index 0a484ff9bd1..a307a40157f 100644 --- a/test/lisp/net/tramp-archive-tests.el +++ b/test/lisp/net/tramp-archive-tests.el @@ -122,12 +122,6 @@ the origin of the temporary TMPFILE, have no write permissions." (directory-files tmpfile 'full directory-files-no-dot-files-regexp)) (delete-directory tmpfile))) -(defun tramp-archive--test-emacs26-p () - "Check for Emacs version >= 26.1. -Some semantics has been changed for there, w/o new functions or -variables, so we check the Emacs version directly." - (>= emacs-major-version 26)) - (defun tramp-archive--test-emacs27-p () "Check for Emacs version >= 27.1. Some semantics has been changed for there, w/o new functions or @@ -433,7 +427,7 @@ This checks also `file-name-as-directory', `file-name-directory', (setq tmp-name (file-local-copy (expand-file-name "what" tramp-archive-test-archive))) - :type tramp-file-missing)) + :type 'file-missing)) ;; Cleanup. (ignore-errors (tramp-archive--test-delete tmp-name)) @@ -461,7 +455,7 @@ This checks also `file-name-as-directory', `file-name-directory', (should-error (insert-file-contents (expand-file-name "what" tramp-archive-test-archive)) - :type tramp-file-missing)) + :type 'file-missing)) ;; Cleanup. (tramp-archive-cleanup-hash)))) @@ -552,11 +546,9 @@ This checks also `file-name-as-directory', `file-name-directory', (should (file-directory-p tmp-name2)) (should (file-exists-p tmp-name4)) ;; Target directory does exist already. - ;; This has been changed in Emacs 26.1. - (when (tramp-archive--test-emacs26-p) - (should-error - (copy-directory tmp-name1 tmp-name2) - :type 'file-error)) + (should-error + (copy-directory tmp-name1 tmp-name2) + :type 'file-error) (tramp-archive--test-delete tmp-name4) (copy-directory tmp-name1 (file-name-as-directory tmp-name2)) (should (file-directory-p tmp-name3)) @@ -621,13 +613,11 @@ This checks also `file-name-as-directory', `file-name-directory', (append '("LANG=C" "LANGUAGE=C" "LC_ALL=C") process-environment))) (unwind-protect (progn - ;; Due to Bug#29423, this works only since for Emacs 26.1. - (when nil ;; TODO (tramp-archive--test-emacs26-p) - (with-temp-buffer - (insert-directory tramp-archive-test-archive nil) - (goto-char (point-min)) - (should - (looking-at-p (regexp-quote tramp-archive-test-archive))))) + (with-temp-buffer + (insert-directory tramp-archive-test-archive nil) + (goto-char (point-min)) + (should + (looking-at-p (regexp-quote tramp-archive-test-archive)))) (with-temp-buffer (insert-directory tramp-archive-test-archive "-al") (goto-char (point-min)) @@ -655,7 +645,7 @@ This checks also `file-name-as-directory', `file-name-directory', (should-error (insert-directory (expand-file-name "baz" tramp-archive-test-archive) nil) - :type tramp-file-missing))) + :type 'file-missing))) ;; Cleanup. (tramp-archive-cleanup-hash)))) @@ -715,7 +705,7 @@ This tests also `access-file', `file-readable-p' and `file-regular-p'." ;; Check error case. (should-error (access-file tmp-name4 "error") - :type tramp-file-missing)) + :type 'file-missing)) ;; Cleanup. (tramp-archive-cleanup-hash)))) @@ -854,38 +844,27 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." ;; Cleanup. (tramp-archive-cleanup-hash)))) -;; The functions were introduced in Emacs 26.1. (ert-deftest tramp-archive-test40-make-nearby-temp-file () "Check `make-nearby-temp-file' and `temporary-file-directory'." (skip-unless tramp-archive-enabled) - ;; Since Emacs 26.1. - (skip-unless - (and (fboundp 'make-nearby-temp-file) (fboundp 'temporary-file-directory))) - ;; `make-nearby-temp-file' and `temporary-file-directory' exists - ;; since Emacs 26.1. We don't want to see compiler warnings for - ;; older Emacsen. (let ((default-directory tramp-archive-test-archive) tmp-file) ;; The file archive shall know a temporary file directory. It is ;; not in the archive itself. - (should - (stringp (with-no-warnings (with-no-warnings (temporary-file-directory))))) - (should-not - (tramp-archive-file-name-p (with-no-warnings (temporary-file-directory)))) + (should (stringp (temporary-file-directory))) + (should-not (tramp-archive-file-name-p (temporary-file-directory))) ;; A temporary file or directory shall not be located in the ;; archive itself. - (setq tmp-file - (with-no-warnings (make-nearby-temp-file "tramp-archive-test"))) + (setq tmp-file (make-nearby-temp-file "tramp-archive-test")) (should (file-exists-p tmp-file)) (should (file-regular-p tmp-file)) (should-not (tramp-archive-file-name-p tmp-file)) (delete-file tmp-file) (should-not (file-exists-p tmp-file)) - (setq tmp-file - (with-no-warnings (make-nearby-temp-file "tramp-archive-test" 'dir))) + (setq tmp-file (make-nearby-temp-file "tramp-archive-test" 'dir)) (should (file-exists-p tmp-file)) (should (file-directory-p tmp-file)) (should-not (tramp-archive-file-name-p tmp-file)) @@ -909,7 +888,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (zerop (nth 1 fsi)) (zerop (nth 2 fsi)))))) -(ert-deftest tramp-archive-test45-auto-load () +(ert-deftest tramp-archive-test46-auto-load () "Check that `tramp-archive' autoloads properly." :tags '(:expensive-test) (skip-unless tramp-archive-enabled) @@ -949,7 +928,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument (format code file)))))))))) -(ert-deftest tramp-archive-test45-delay-load () +(ert-deftest tramp-archive-test46-delay-load () "Check that `tramp-archive' is loaded lazily, only when needed." :tags '(:expensive-test) (skip-unless tramp-archive-enabled) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 1fa8fbea172..7ba5a870766 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -43,8 +43,10 @@ (require 'cl-lib) (require 'dired) +(require 'dired-aux) (require 'ert) (require 'ert-x) +(require 'seq) ; For `seq-random-elt', autoloaded since Emacs 28.1 (require 'trace) (require 'tramp) (require 'vc) @@ -74,11 +76,6 @@ (defvar tramp-remote-path) (defvar tramp-remote-process-environment) -;; Needed for Emacs 25. -(defvar connection-local-criteria-alist) -(defvar connection-local-profile-alist) -;; Needed for Emacs 26. -(defvar async-shell-command-width) ;; Needed for Emacs 27. (defvar process-file-return-signal-string) (defvar shell-command-dont-erase-buffer) @@ -160,13 +157,6 @@ being the result.") ;; Return result. (cdr tramp--test-enabled-checked)) -(defsubst tramp--test-expensive-test () - "Whether expensive tests are run." - (ert-select-tests - (ert--stats-selector ert--current-run-stats) - (list (make-ert-test :name (ert-test-name (ert-running-test)) - :body nil :tags '(:expensive-test))))) - (defun tramp--test-make-temp-name (&optional local quoted) "Return a temporary file name for test. If LOCAL is non-nil, a local file name is returned. @@ -222,8 +212,7 @@ is greater than 10. (when (and (null tramp--test-instrument-test-case-p) (> tramp-verbose 3)) (untrace-all) (dolist (buf (tramp-list-tramp-buffers)) - (with-current-buffer buf - (message ";; %s\n%s" buf (buffer-string))) + (message ";; %s\n%s" buf (tramp-get-buffer-string buf)) (kill-buffer buf)))))) (defsubst tramp--test-message (fmt-string &rest arguments) @@ -243,8 +232,7 @@ is greater than 10. (unwind-protect (progn ,@body) (tramp--test-message - "%s %f sec" - ,message (float-time (time-subtract (current-time) start)))))) + "%s %f sec" ,message (float-time (time-subtract nil start)))))) ;; `always' is introduced with Emacs 28.1. (defalias 'tramp--test-always @@ -2083,44 +2071,41 @@ Also see `ignore'." (substitute-in-file-name "/method:host:/:/path//foo") "/method:host:/:/path//foo")) - ;; Forwhatever reasons, the following tests let Emacs crash for - ;; Emacs 25, occasionally. No idea what's up. - (when (tramp--test-emacs26-p) - (should - (string-equal - (substitute-in-file-name (concat "/method:host://~" foo)) - (concat "/~" foo))) - (should - (string-equal - (substitute-in-file-name (concat "/method:host:/~" foo)) - (concat "/method:host:/~" foo))) - (should - (string-equal - (substitute-in-file-name (concat "/method:host:/path//~" foo)) - (concat "/~" foo))) - ;; (substitute-in-file-name "/path/~foo") expands only for a local - ;; user "foo" to "/~foo"". Otherwise, it doesn't expand. - (should - (string-equal - (substitute-in-file-name (concat "/method:host:/path/~" foo)) - (concat "/method:host:/path/~" foo))) - ;; Quoting local part. - (should - (string-equal - (substitute-in-file-name (concat "/method:host:/://~" foo)) - (concat "/method:host:/://~" foo))) - (should - (string-equal - (substitute-in-file-name (concat "/method:host:/:/~" foo)) - (concat "/method:host:/:/~" foo))) - (should - (string-equal - (substitute-in-file-name (concat "/method:host:/:/path//~" foo)) - (concat "/method:host:/:/path//~" foo))) - (should - (string-equal - (substitute-in-file-name (concat "/method:host:/:/path/~" foo)) - (concat "/method:host:/:/path/~" foo)))) + (should + (string-equal + (substitute-in-file-name (concat "/method:host://~" foo)) + (concat "/~" foo))) + (should + (string-equal + (substitute-in-file-name (concat "/method:host:/~" foo)) + (concat "/method:host:/~" foo))) + (should + (string-equal + (substitute-in-file-name (concat "/method:host:/path//~" foo)) + (concat "/~" foo))) + ;; (substitute-in-file-name "/path/~foo") expands only for a local + ;; user "foo" to "/~foo"". Otherwise, it doesn't expand. + (should + (string-equal + (substitute-in-file-name (concat "/method:host:/path/~" foo)) + (concat "/method:host:/path/~" foo))) + ;; Quoting local part. + (should + (string-equal + (substitute-in-file-name (concat "/method:host:/://~" foo)) + (concat "/method:host:/://~" foo))) + (should + (string-equal + (substitute-in-file-name (concat "/method:host:/:/~" foo)) + (concat "/method:host:/:/~" foo))) + (should + (string-equal + (substitute-in-file-name (concat "/method:host:/:/path//~" foo)) + (concat "/method:host:/:/path//~" foo))) + (should + (string-equal + (substitute-in-file-name (concat "/method:host:/:/path/~" foo)) + (concat "/method:host:/:/path/~" foo))) (let (process-environment) (should @@ -2294,11 +2279,51 @@ 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 (not (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)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted))) (should-not (file-exists-p tmp-name)) (write-region "foo" nil tmp-name) @@ -2306,8 +2331,10 @@ This checks also `file-name-as-directory', `file-name-directory', (delete-file tmp-name) (should-not (file-exists-p tmp-name)) - ;; Trashing files doesn't work on MS Windows, and for crypted remote files. - (unless (or (tramp--test-windows-nt-p) (tramp--test-crypt-p)) + ;; Trashing files doesn't work when `system-move-file-to-trash' + ;; is defined (on MS Windows and macOS), and for crypted remote + ;; files. + (unless (or (fboundp 'system-move-file-to-trash) (tramp--test-crypt-p)) (let ((trash-directory (tramp--test-make-temp-name 'local quoted)) (delete-by-moving-to-trash t)) (make-directory trash-directory) @@ -2331,7 +2358,7 @@ This checks also `file-name-as-directory', `file-name-directory', "Check `file-local-copy'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) tmp-name2) (unwind-protect @@ -2352,7 +2379,7 @@ This checks also `file-name-as-directory', `file-name-directory', (delete-file tmp-name2) (should-error (setq tmp-name2 (file-local-copy tmp-name1)) - :type tramp-file-missing)) + :type 'file-missing)) ;; Cleanup. (ignore-errors @@ -2363,7 +2390,7 @@ This checks also `file-name-as-directory', `file-name-directory', "Check `insert-file-contents'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted))) (unwind-protect (with-temp-buffer @@ -2391,7 +2418,7 @@ This checks also `file-name-as-directory', `file-name-directory', (delete-file tmp-name) (should-error (insert-file-contents tmp-name) - :type tramp-file-missing)) + :type 'file-missing)) ;; Cleanup. (ignore-errors (delete-file tmp-name)))))) @@ -2400,7 +2427,7 @@ This checks also `file-name-as-directory', `file-name-directory', "Check `write-region'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted)) (inhibit-message t)) (unwind-protect @@ -2462,23 +2489,20 @@ This checks also `file-name-as-directory', `file-name-directory', (should (string-equal (buffer-string) "34"))) ;; Check message. - ;; Macro `ert-with-message-capture' was introduced in Emacs 26.1. - (with-no-warnings (when (symbol-plist 'ert-with-message-capture) - (let (inhibit-message) - (dolist - (noninteractive (unless (tramp--test-ange-ftp-p) '(nil t))) - (dolist (visit '(nil t "string" no-message)) - (ert-with-message-capture tramp--test-messages - (write-region "foo" nil tmp-name nil visit) - ;; We must check the last line. There could be - ;; other messages from the progress reporter. - (should - (string-match-p - (if (and (null noninteractive) - (or (eq visit t) (null visit) (stringp visit))) - (format "^Wrote %s\n\\'" (regexp-quote tmp-name)) - "^\\'") - tramp--test-messages)))))))) + (let (inhibit-message) + (dolist (noninteractive (unless (tramp--test-ange-ftp-p) '(nil t))) + (dolist (visit '(nil t "string" no-message)) + (ert-with-message-capture tramp--test-messages + (write-region "foo" nil tmp-name nil visit) + ;; We must check the last line. There could be + ;; other messages from the progress reporter. + (should + (string-match-p + (if (and (null noninteractive) + (or (eq visit t) (null visit) (stringp visit))) + (format "^Wrote %s\n\\'" (regexp-quote tmp-name)) + "^\\'") + tramp--test-messages)))))) ;; We do not test lockname here. See ;; `tramp-test39-make-lock-file-name'. @@ -2488,17 +2512,15 @@ This checks also `file-name-as-directory', `file-name-directory', ;; Ange-FTP. ((symbol-function 'yes-or-no-p) #'tramp--test-always)) (write-region "foo" nil tmp-name nil nil nil 'mustbenew)) - ;; `mustbenew' is passed to Tramp since Emacs 26.1. - (when (tramp--test-emacs26-p) - (should-error - (cl-letf (((symbol-function #'y-or-n-p) #'ignore) - ;; Ange-FTP. - ((symbol-function #'yes-or-no-p) #'ignore)) - (write-region "foo" nil tmp-name nil nil nil 'mustbenew)) - :type 'file-already-exists) - (should-error - (write-region "foo" nil tmp-name nil nil nil 'excl) - :type 'file-already-exists))) + (should-error + (cl-letf (((symbol-function #'y-or-n-p) #'ignore) + ;; Ange-FTP. + ((symbol-function #'yes-or-no-p) #'ignore)) + (write-region "foo" nil tmp-name nil nil nil 'mustbenew)) + :type 'file-already-exists) + (should-error + (write-region "foo" nil tmp-name nil nil nil 'excl) + :type 'file-already-exists)) ;; Cleanup. (ignore-errors (delete-file tmp-name)))))) @@ -2541,8 +2563,9 @@ This checks also `file-name-as-directory', `file-name-directory', (skip-unless (tramp--test-enabled)) ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579. - (dolist (quoted (if (and (tramp--test-expensive-test) (tramp--test-emacs27-p)) - '(nil t) '(nil))) + (dolist (quoted + (if (and (tramp--test-expensive-test-p) (tramp--test-emacs27-p)) + '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (tmp-name3 (tramp--test-make-temp-name 'local quoted))) @@ -2561,7 +2584,7 @@ This checks also `file-name-as-directory', `file-name-directory', (progn (should-error (copy-file source target) - :type tramp-file-missing) + :type 'file-missing) (write-region "foo" nil source) (should (file-exists-p source)) (copy-file source target) @@ -2569,7 +2592,7 @@ This checks also `file-name-as-directory', `file-name-directory', (with-temp-buffer (insert-file-contents target) (should (string-equal (buffer-string) "foo"))) - (when (tramp--test-expensive-test) + (when (tramp--test-expensive-test-p) (should-error (copy-file source target) :type 'file-already-exists)) @@ -2587,8 +2610,7 @@ This checks also `file-name-as-directory', `file-name-directory', (should (file-exists-p source)) (make-directory target) (should (file-directory-p target)) - ;; This has been changed in Emacs 26.1. - (when (and (tramp--test-expensive-test) (tramp--test-emacs26-p)) + (when (tramp--test-expensive-test-p) (should-error (copy-file source target) :type 'file-already-exists) @@ -2653,8 +2675,9 @@ This checks also `file-name-as-directory', `file-name-directory', (skip-unless (tramp--test-enabled)) ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579. - (dolist (quoted (if (and (tramp--test-expensive-test) (tramp--test-emacs27-p)) - '(nil t) '(nil))) + (dolist (quoted + (if (and (tramp--test-expensive-test-p) (tramp--test-emacs27-p)) + '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (tmp-name3 (tramp--test-make-temp-name 'local quoted))) @@ -2673,7 +2696,7 @@ This checks also `file-name-as-directory', `file-name-directory', (progn (should-error (rename-file source target) - :type tramp-file-missing) + :type 'file-missing) (write-region "foo" nil source) (should (file-exists-p source)) (rename-file source target) @@ -2684,7 +2707,7 @@ This checks also `file-name-as-directory', `file-name-directory', (should (string-equal (buffer-string) "foo"))) (write-region "foo" nil source) (should (file-exists-p source)) - (when (tramp--test-expensive-test) + (when (tramp--test-expensive-test-p) (should-error (rename-file source target) :type 'file-already-exists)) @@ -2702,8 +2725,7 @@ This checks also `file-name-as-directory', `file-name-directory', (should (file-exists-p source)) (make-directory target) (should (file-directory-p target)) - ;; This has been changed in Emacs 26.1. - (when (and (tramp--test-expensive-test) (tramp--test-emacs26-p)) + (when (tramp--test-expensive-test-p) (should-error (rename-file source target) :type 'file-already-exists) @@ -2771,7 +2793,7 @@ This checks also `file-name-as-directory', `file-name-directory', This tests also `file-directory-p' and `file-accessible-directory-p'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let* ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (expand-file-name "foo/bar" tmp-name1)) (unusual-file-mode-1 #o740) @@ -2809,7 +2831,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." "Check `delete-directory'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let* ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (expand-file-name "foo" tmp-name1))) ;; Delete empty directory. @@ -2833,9 +2855,12 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (should-not (file-directory-p tmp-name1)) ;; Trashing directories works only since Emacs 27.1. It doesn't - ;; work on MS Windows, for crypted remote directories and for ange-ftp. - (when (and (not (tramp--test-windows-nt-p)) (not (tramp--test-crypt-p)) - (not (tramp--test-ftp-p)) (tramp--test-emacs27-p)) + ;; work when `system-move-file-to-trash' is defined (on MS + ;; Windows and macOS), for crypted remote directories and for + ;; ange-ftp. + (when (and (not (fboundp 'system-move-file-to-trash)) + (not (tramp--test-crypt-p)) (not (tramp--test-ftp-p)) + (tramp--test-emacs27-p)) (let ((trash-directory (tramp--test-make-temp-name 'local quoted)) (delete-by-moving-to-trash t)) (make-directory trash-directory) @@ -2881,9 +2906,9 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (ert-deftest tramp-test15-copy-directory () "Check `copy-directory'." (skip-unless (tramp--test-enabled)) - (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) + (skip-unless (not (tramp--test-rclone-p))) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let* ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (tmp-name3 (expand-file-name @@ -2898,7 +2923,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (progn (should-error (copy-directory tmp-name1 tmp-name2) - :type tramp-file-missing) + :type 'file-missing) ;; Copy empty directory. (make-directory tmp-name1) (write-region "foo" nil tmp-name4) @@ -2908,11 +2933,9 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (should (file-directory-p tmp-name2)) (should (file-exists-p tmp-name5)) ;; Target directory does exist already. - ;; This has been changed in Emacs 26.1. - (when (tramp--test-emacs26-p) - (should-error - (copy-directory tmp-name1 tmp-name2) - :type 'file-already-exists)) + (should-error + (copy-directory tmp-name1 tmp-name2) + :type 'file-already-exists) (copy-directory tmp-name1 (file-name-as-directory tmp-name2)) (should (file-directory-p tmp-name3)) (should (file-exists-p tmp-name6))) @@ -2994,7 +3017,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." "Check `directory-files'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let* ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (expand-file-name "bla" tmp-name1)) (tmp-name3 (expand-file-name "foo" tmp-name1))) @@ -3002,7 +3025,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (progn (should-error (directory-files tmp-name1) - :type tramp-file-missing) + :type 'file-missing) (make-directory tmp-name1) (write-region "foo" nil tmp-name2) (write-region "bla" nil tmp-name3) @@ -3038,7 +3061,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." "Check `file-expand-wildcards'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let* ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (expand-file-name "foo" tmp-name1)) (tmp-name3 (expand-file-name "bar" tmp-name1)) @@ -3108,7 +3131,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." ;; Emacs 27.1. (skip-unless (or (not (tramp--test-crypt-p)) (tramp--test-emacs27-p))) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let* ((tmp-name1 (expand-file-name (tramp--test-make-temp-name nil quoted))) (tmp-name2 (expand-file-name "foo" tmp-name1)) @@ -3125,14 +3148,12 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (insert-directory tmp-name1 nil) (goto-char (point-min)) (should (looking-at-p (regexp-quote tmp-name1)))) - ;; This has been fixed in Emacs 26.1. See Bug#29423. - (when (tramp--test-emacs26-p) - (with-temp-buffer - (insert-directory (file-name-as-directory tmp-name1) nil) - (goto-char (point-min)) - (should - (looking-at-p - (regexp-quote (file-name-as-directory tmp-name1)))))) + (with-temp-buffer + (insert-directory (file-name-as-directory tmp-name1) nil) + (goto-char (point-min)) + (should + (looking-at-p + (regexp-quote (file-name-as-directory tmp-name1))))) (with-temp-buffer (insert-directory tmp-name1 "-al") (goto-char (point-min)) @@ -3164,7 +3185,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." ;; modes are still "accessible". (not (tramp--test-sshfs-p)) ;; A directory is always accessible for user "root". - (not (zerop (tramp-compat-file-attribute-user-id + (not (zerop (file-attribute-user-id (file-attributes tmp-name1))))) (set-file-modes tmp-name1 0) (with-temp-buffer @@ -3176,7 +3197,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (with-temp-buffer (should-error (insert-directory tmp-name1 nil) - :type tramp-file-missing))) + :type 'file-missing))) ;; Cleanup. (ignore-errors (delete-directory tmp-name1 'recursive)))))) @@ -3190,10 +3211,8 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (skip-unless (not (tramp--test-rsync-p))) ;; Wildcards are not supported in tramp-crypt.el. (skip-unless (not (tramp--test-crypt-p))) - ;; Since Emacs 26.1. - (skip-unless (fboundp 'insert-directory-wildcard-in-dir-p)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let* ((tmp-name1 (expand-file-name (tramp--test-make-temp-name nil quoted))) (tmp-name2 @@ -3297,7 +3316,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." ;; Relative file names in dired are not supported in tramp-crypt.el. (skip-unless (not (tramp--test-crypt-p))) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let* ((tmp-name1 (expand-file-name (tramp--test-make-temp-name nil quoted))) (tmp-name2 (expand-file-name "foo" tmp-name1)) @@ -3320,7 +3339,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)) @@ -3330,14 +3349,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)) @@ -3351,7 +3370,7 @@ This tests also `access-file', `file-readable-p', `file-regular-p' and `file-ownership-preserved-p'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) ;; We must use `file-truename' for the temporary directory, ;; because it could be located on a symlinked directory. This ;; would let the test fail. @@ -3379,25 +3398,24 @@ This tests also `access-file', `file-readable-p', (file-modes tramp-test-temporary-file-directory)))) (write-region "foo" nil tmp-name1) (setq test-file-ownership-preserved-p - (= (tramp-compat-file-attribute-group-id - (file-attributes tmp-name1)) + (= (file-attribute-group-id (file-attributes tmp-name1)) (tramp-get-remote-gid tramp-test-vec 'integer))) (delete-file tmp-name1)) (when (tramp--test-supports-set-file-modes-p) (write-region "foo" nil tmp-name1) ;; A file is always accessible for user "root". - (when (not (zerop (tramp-compat-file-attribute-user-id - (file-attributes tmp-name1)))) + (unless + (zerop (file-attribute-user-id (file-attributes tmp-name1))) (set-file-modes tmp-name1 0) (should-error (access-file tmp-name1 "error") - :type 'file-error) + :type tramp-permission-denied) (set-file-modes tmp-name1 #o777)) (delete-file tmp-name1)) (should-error (access-file tmp-name1 "error") - :type tramp-file-missing) + :type 'file-missing) ;; `file-ownership-preserved-p' should return t for ;; non-existing files. @@ -3414,33 +3432,29 @@ This tests also `access-file', `file-readable-p', ;; We do not test inodes and device numbers. (setq attr (file-attributes tmp-name1)) (should (consp attr)) - (should (null (tramp-compat-file-attribute-type attr))) - (should (numberp (tramp-compat-file-attribute-link-number attr))) - (should (numberp (tramp-compat-file-attribute-user-id attr))) - (should (numberp (tramp-compat-file-attribute-group-id attr))) + (should (null (file-attribute-type attr))) + (should (numberp (file-attribute-link-number attr))) + (should (numberp (file-attribute-user-id attr))) + (should (numberp (file-attribute-group-id attr))) (should - (stringp - (current-time-string - (tramp-compat-file-attribute-access-time attr)))) + (stringp (current-time-string (file-attribute-access-time attr)))) (should (stringp - (current-time-string - (tramp-compat-file-attribute-modification-time attr)))) + (current-time-string (file-attribute-modification-time attr)))) (should (stringp - (current-time-string - (tramp-compat-file-attribute-status-change-time attr)))) - (should (numberp (tramp-compat-file-attribute-size attr))) - (should (stringp (tramp-compat-file-attribute-modes attr))) + (current-time-string (file-attribute-status-change-time attr)))) + (should (numberp (file-attribute-size attr))) + (should (stringp (file-attribute-modes attr))) (setq attr (file-attributes tmp-name1 'string)) - (should (stringp (tramp-compat-file-attribute-user-id attr))) - (should (stringp (tramp-compat-file-attribute-group-id attr))) + (should (stringp (file-attribute-user-id attr))) + (should (stringp (file-attribute-group-id attr))) (tramp--test-ignore-make-symbolic-link-error (should-error (access-file tmp-name2 "error") - :type tramp-file-missing) + :type 'file-missing) (when test-file-ownership-preserved-p (should (file-ownership-preserved-p tmp-name2 'group))) (make-symbolic-link tmp-name1 tmp-name2) @@ -3454,7 +3468,7 @@ This tests also `access-file', `file-readable-p', (string-equal (funcall (if quoted #'tramp-compat-file-name-quote #'identity) - (tramp-compat-file-attribute-type attr)) + (file-attribute-type attr)) (file-remote-p (file-truename tmp-name1) 'localname))) (delete-file tmp-name2)) @@ -3473,7 +3487,7 @@ This tests also `access-file', `file-readable-p', (setq attr (file-attributes tmp-name2)) (should (string-equal - (tramp-compat-file-attribute-type attr) + (file-attribute-type attr) (tramp-file-name-localname (tramp-dissect-file-name tmp-name3)))) (delete-file tmp-name2)) @@ -3489,7 +3503,7 @@ This tests also `access-file', `file-readable-p', (when test-file-ownership-preserved-p (should (file-ownership-preserved-p tmp-name1 'group))) (setq attr (file-attributes tmp-name1)) - (should (eq (tramp-compat-file-attribute-type attr) t))) + (should (eq (file-attribute-type attr) t))) ;; Cleanup. (ignore-errors (delete-directory tmp-name1)) @@ -3507,9 +3521,9 @@ They might differ only in time attributes or directory size." (start-time (- tramp--test-start-time 10))) ;; Link number. For directories, it includes the number of ;; subdirectories. Set it to 1. - (when (eq (tramp-compat-file-attribute-type attr1) t) + (when (eq (file-attribute-type attr1) t) (setcar (nthcdr 1 attr1) 1)) - (when (eq (tramp-compat-file-attribute-type attr2) t) + (when (eq (file-attribute-type attr2) t) (setcar (nthcdr 1 attr2) 1)) ;; Access time. (setcar (nthcdr 4 attr1) tramp-time-dont-know) @@ -3522,42 +3536,33 @@ They might differ only in time attributes or directory size." ;; order to compensate a possible timestamp resolution higher than ;; a second on the remote machine. (when (or (tramp-compat-time-equal-p - (tramp-compat-file-attribute-modification-time attr1) - tramp-time-dont-know) + (file-attribute-modification-time attr1) tramp-time-dont-know) (tramp-compat-time-equal-p - (tramp-compat-file-attribute-modification-time attr2) - tramp-time-dont-know)) + (file-attribute-modification-time attr2) tramp-time-dont-know)) (setcar (nthcdr 5 attr1) tramp-time-dont-know) (setcar (nthcdr 5 attr2) tramp-time-dont-know)) (when (< start-time - (float-time (tramp-compat-file-attribute-modification-time attr1))) + (float-time (file-attribute-modification-time attr1))) (setcar (nthcdr 5 attr1) tramp-time-dont-know)) (when (< start-time - (float-time (tramp-compat-file-attribute-modification-time attr2))) + (float-time (file-attribute-modification-time attr2))) (setcar (nthcdr 5 attr2) tramp-time-dont-know)) ;; Status change time. Ditto. (when (or (tramp-compat-time-equal-p - (tramp-compat-file-attribute-status-change-time attr1) - tramp-time-dont-know) + (file-attribute-status-change-time attr1) tramp-time-dont-know) (tramp-compat-time-equal-p - (tramp-compat-file-attribute-status-change-time attr2) - tramp-time-dont-know)) + (file-attribute-status-change-time attr2) tramp-time-dont-know)) (setcar (nthcdr 6 attr1) tramp-time-dont-know) (setcar (nthcdr 6 attr2) tramp-time-dont-know)) - (when - (< start-time - (float-time - (tramp-compat-file-attribute-status-change-time attr1))) + (when (< start-time (float-time (file-attribute-status-change-time attr1))) (setcar (nthcdr 6 attr1) tramp-time-dont-know)) - (when - (< start-time - (float-time (tramp-compat-file-attribute-status-change-time attr2))) + (when (< start-time (float-time (file-attribute-status-change-time attr2))) (setcar (nthcdr 6 attr2) tramp-time-dont-know)) ;; Size. Set it to 0 for directories, because it might have ;; changed. For example the upper directory "../". - (when (eq (tramp-compat-file-attribute-type attr1) t) + (when (eq (file-attribute-type attr1) t) (setcar (nthcdr 7 attr1) 0)) - (when (eq (tramp-compat-file-attribute-type attr2) t) + (when (eq (file-attribute-type attr2) t) (setcar (nthcdr 7 attr2) 0)) ;; The check. (unless (equal attr1 attr2) (tramp--test-message "%S\n%S" attr1 attr2)) @@ -3570,7 +3575,7 @@ They might differ only in time attributes or directory size." "Check `directory-files-and-attributes'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) ;; `directory-files-and-attributes' contains also values for ;; "../". Ensure that this doesn't change during tests, for ;; example due to handling temporary files. @@ -3581,12 +3586,12 @@ They might differ only in time attributes or directory size." (progn (should-error (directory-files-and-attributes tmp-name1) - :type tramp-file-missing) + :type 'file-missing) (make-directory tmp-name1) (should (file-directory-p tmp-name1)) (setq tramp--test-start-time (float-time - (tramp-compat-file-attribute-modification-time + (file-attribute-modification-time (file-attributes tmp-name1)))) (make-directory tmp-name2) (should (file-directory-p tmp-name2)) @@ -3628,7 +3633,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-supports-set-file-modes-p)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted))) @@ -3644,8 +3649,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (should (= (file-modes tmp-name1) #o444)) (should-not (file-executable-p tmp-name1)) ;; A file is always writable for user "root". - (unless (zerop (tramp-compat-file-attribute-user-id - (file-attributes tmp-name1))) + (unless (zerop (file-attribute-user-id (file-attributes tmp-name1))) (should-not (file-writable-p tmp-name1))) ;; Check the NOFOLLOW arg. It exists since Emacs 28. For ;; regular files, there shouldn't be a difference. @@ -3719,11 +3723,8 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." "Check `file-symlink-p'. This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (skip-unless (tramp--test-enabled)) - ;; The semantics have changed heavily in Emacs 26.1. We cannot test - ;; older Emacsen, therefore. - (skip-unless (tramp--test-emacs26-p)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) ;; We must use `file-truename' for the temporary directory, ;; because it could be located on a symlinked directory. This ;; would let the test fail. @@ -3748,11 +3749,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (if quoted #'tramp-compat-file-name-unquote #'identity) (file-remote-p tmp-name1 'localname)) (file-symlink-p tmp-name2))) - (when (tramp--test-expensive-test) + (when (tramp--test-expensive-test-p) (should-error (make-symbolic-link tmp-name1 tmp-name2) :type 'file-already-exists)) - (when (tramp--test-expensive-test) + (when (tramp--test-expensive-test-p) ;; A number means interactive case. (cl-letf (((symbol-function #'yes-or-no-p) #'ignore)) (should-error @@ -3792,7 +3793,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (string-equal tmp-name1 (file-symlink-p tmp-name3)))) ;; Check directory as newname. (make-directory tmp-name4) - (when (tramp--test-expensive-test) + (when (tramp--test-expensive-test-p) (should-error (make-symbolic-link tmp-name1 tmp-name4) :type 'file-already-exists)) @@ -3820,7 +3821,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Check `add-name-to-file'. (unwind-protect - (when (tramp--test-expensive-test) + (when (tramp--test-expensive-test-p) (tramp--test-ignore-add-name-to-file-error (write-region "foo" nil tmp-name1) (should (file-exists-p tmp-name1)) @@ -3935,14 +3936,14 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (string-equal (file-truename tmp-name2) (file-truename tmp-name3))) - (when (tramp--test-expensive-test) + (when (tramp--test-expensive-test-p) (should-error (with-temp-buffer (insert-file-contents tmp-name2)) - :type tramp-file-missing)) - (when (tramp--test-expensive-test) + :type 'file-missing)) + (when (tramp--test-expensive-test-p) (should-error (with-temp-buffer (insert-file-contents tmp-name3)) - :type tramp-file-missing)) + :type 'file-missing)) ;; `directory-files' does not show symlinks to ;; non-existing targets in the "smb" case. So we remove ;; the symlinks manually. @@ -3957,7 +3958,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Detect cyclic symbolic links. (unwind-protect - (when (tramp--test-expensive-test) + (when (tramp--test-expensive-test-p) (tramp--test-ignore-make-symbolic-link-error (make-symbolic-link tmp-name2 tmp-name1) (should (file-symlink-p tmp-name1)) @@ -3995,7 +3996,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (or (tramp--test-adb-p) (tramp--test-gvfs-p) (tramp--test-sh-p) (tramp--test-sudoedit-p))) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (tmp-name3 (tramp--test-make-temp-name nil quoted))) @@ -4003,7 +4004,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (progn (write-region "foo" nil tmp-name1) (should (file-exists-p tmp-name1)) - (should (consp (tramp-compat-file-attribute-modification-time + (should (consp (file-attribute-modification-time (file-attributes tmp-name1)))) ;; Skip the test, if the remote handler is not able to set ;; the correct time. @@ -4011,13 +4012,12 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Dumb remote shells without perl(1) or stat(1) are not ;; able to return the date correctly. They say "don't know". (unless (tramp-compat-time-equal-p - (tramp-compat-file-attribute-modification-time + (file-attribute-modification-time (file-attributes tmp-name1)) tramp-time-dont-know) (should (tramp-compat-time-equal-p - (tramp-compat-file-attribute-modification-time - (file-attributes tmp-name1)) + (file-attribute-modification-time (file-attributes tmp-name1)) (seconds-to-time 1))) (write-region "bla" nil tmp-name2) (should (file-exists-p tmp-name2)) @@ -4032,7 +4032,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (set-file-times tmp-name1 (seconds-to-time 1) 'nofollow) (should (tramp-compat-time-equal-p - (tramp-compat-file-attribute-modification-time + (file-attribute-modification-time (file-attributes tmp-name1)) (seconds-to-time 1))))))) @@ -4045,7 +4045,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "Check `set-visited-file-modtime' and `verify-visited-file-modtime'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted))) (unwind-protect (progn @@ -4078,8 +4078,9 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (skip-unless (not (tramp--test-crypt-p))) ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579. - (dolist (quoted (if (and (tramp--test-expensive-test) (tramp--test-emacs27-p)) - '(nil t) '(nil))) + (dolist (quoted + (if (and (tramp--test-expensive-test-p) (tramp--test-emacs27-p)) + '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (tmp-name3 (tramp--test-make-temp-name 'local quoted))) @@ -4094,7 +4095,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should (file-acl tmp-name2)) (should (string-equal (file-acl tmp-name1) (file-acl tmp-name2))) ;; Different permissions mean different ACLs. - (when (not (tramp--test-windows-nt-or-smb-p)) + (unless (tramp--test-windows-nt-or-smb-p) (set-file-modes tmp-name1 #o777) (set-file-modes tmp-name2 #o444) (should-not @@ -4157,8 +4158,9 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (skip-unless (not (tramp--test-crypt-p))) ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579. - (dolist (quoted (if (and (tramp--test-expensive-test) (tramp--test-emacs27-p)) - '(nil t) '(nil))) + (dolist (quoted + (if (and (tramp--test-expensive-test-p) (tramp--test-emacs27-p)) + '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (tmp-name3 (tramp--test-make-temp-name 'local quoted))) @@ -4295,7 +4297,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Method and host name in completion mode. This kind of completion ;; does not work on MS Windows. - (when (not (memq system-type '(cygwin windows-nt))) + (unless (memq system-type '(cygwin windows-nt)) (let ((method (file-remote-p tramp-test-temporary-file-directory 'method)) (host (file-remote-p tramp-test-temporary-file-directory 'host)) (orig-syntax tramp-syntax)) @@ -4305,7 +4307,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (unwind-protect (dolist (syntax - (if (tramp--test-expensive-test) + (if (tramp--test-expensive-test-p) (tramp-syntax-values) `(,orig-syntax))) (tramp-change-syntax syntax) ;; This has cleaned up all connection data, which are used @@ -4347,7 +4349,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (tramp-change-syntax orig-syntax)))) (dolist (non-essential '(nil t)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted))) (unwind-protect @@ -4414,7 +4416,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "Check `load'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted))) (unwind-protect (progn @@ -4443,7 +4445,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-supports-processes-p)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let* ((tmp-name (tramp--test-make-temp-name nil quoted)) (fnnd (file-name-nondirectory tmp-name)) (default-directory tramp-test-temporary-file-directory) @@ -4519,11 +4521,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (ert-deftest tramp-test29-start-file-process () "Check `start-file-process'." - :tags '(:expensive-test) + :tags '(:expensive-test :tramp-asynchronous-processes) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-supports-processes-p)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((default-directory tramp-test-temporary-file-directory) (tmp-name (tramp--test-make-temp-name nil quoted)) kill-buffer-query-functions proc) @@ -4586,8 +4588,8 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Cleanup. (ignore-errors (delete-process proc))) - ;; "telnet" and "sshfs" do not cooperate with disabled filter. - (unless (or (tramp--test-telnet-p) (tramp--test-sshfs-p)) + ;; Disabled process filter. "sshfs" does not cooperate. + (unless (tramp--test-sshfs-p) (unwind-protect (with-temp-buffer (setq proc (start-file-process "test3" (current-buffer) "cat")) @@ -4596,8 +4598,8 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (set-process-filter proc t) (process-send-string proc "foo\n") (process-send-eof proc) - ;; Read output. - (with-timeout (10 (tramp--test-timeout-handler)) + ;; Read output. There shouldn't be any. + (with-timeout (10) (while (process-live-p proc) (while (accept-process-output proc 0 nil t)))) ;; No output due to process filter. @@ -4675,7 +4677,8 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (ignore-errors (make-process :file-handler t))) `(ert-deftest ,(intern (concat (symbol-name test) "-direct-async")) () ,docstring - :tags (if ,unstable '(:expensive-test :unstable) '(:expensive-test)) + :tags (append '(:expensive-test :tramp-asynchronous-processes) + (and ,unstable '(:unstable))) (skip-unless (tramp--test-enabled)) (let ((default-directory tramp-test-temporary-file-directory) (ert-test (ert-get-test ',test)) @@ -4698,13 +4701,13 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (ert-deftest tramp-test30-make-process () "Check `make-process'." - :tags '(:expensive-test) + :tags '(:expensive-test :tramp-asynchronous-processes) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-supports-processes-p)) ;; `make-process' supports file name handlers since Emacs 27. (skip-unless (tramp--test-emacs27-p)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((default-directory tramp-test-temporary-file-directory) (tmp-name (tramp--test-make-temp-name nil quoted)) kill-buffer-query-functions proc) @@ -4778,8 +4781,8 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; Cleanup. (ignore-errors (delete-process proc))) - ;; "telnet" and "sshfs" do not cooperate with disabled filter. - (unless (or (tramp--test-telnet-p) (tramp--test-sshfs-p)) + ;; Disabled process filter. "sshfs" does not cooperate. + (unless (tramp--test-sshfs-p) (unwind-protect (with-temp-buffer (setq proc @@ -4792,8 +4795,8 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (should (equal (process-status proc) 'run)) (process-send-string proc "foo\n") (process-send-eof proc) - ;; Read output. - (with-timeout (10 (tramp--test-timeout-handler)) + ;; Read output. There shouldn't be any. + (with-timeout (10) (while (process-live-p proc) (while (accept-process-output proc 0 nil t)))) ;; No output due to process filter. @@ -4941,13 +4944,12 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (ert-deftest tramp-test31-interrupt-process () "Check `interrupt-process'." - :tags (if (or (getenv "EMACS_HYDRA_CI") (getenv "EMACS_EMBA_CI")) - '(:expensive-test :unstable) '(:expensive-test)) + :tags (append '(:expensive-test :tramp-asynchronous-processes) + (and (or (getenv "EMACS_HYDRA_CI") (getenv "EMACS_EMBA_CI")) + '(:unstable))) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-crypt-p))) - ;; Since Emacs 26.1. - (skip-unless (boundp 'interrupt-process-functions)) ;; We must use `file-truename' for the temporary directory, in ;; order to establish the connection prior running an asynchronous @@ -5009,7 +5011,7 @@ INPUT, if non-nil, is a string sent to the process." (when (tramp--test-adb-p) (skip-unless (tramp--test-emacs27-p))) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted)) (default-directory tramp-test-temporary-file-directory) ;; Suppress nasty messages. @@ -5017,10 +5019,12 @@ INPUT, if non-nil, is a string sent to the process." kill-buffer-query-functions) (dolist (this-shell-command - '(;; Synchronously. - shell-command - ;; Asynchronously. - tramp--test-async-shell-command)) + (append + ;; Synchronously. + '(shell-command) + ;; Asynchronously. + (and (tramp--test-asynchronous-processes-p) + '(tramp--test-async-shell-command)))) ;; Test ordinary `{async-}shell-command'. (unwind-protect @@ -5054,38 +5058,41 @@ INPUT, if non-nil, is a string sent to the process." "echo foo >&2; echo bar" (current-buffer) stderr) (should (string-equal "bar\n" (buffer-string))) ;; Check stderr. - (with-current-buffer stderr - (should (string-equal "foo\n" (buffer-string))))) + (should + (string-equal "foo\n" (tramp-get-buffer-string stderr)))) ;; Cleanup. (ignore-errors (kill-buffer stderr)))))) ;; Test sending string to `async-shell-command'. - (unwind-protect - (with-temp-buffer - (write-region "foo" nil tmp-name) - (should (file-exists-p tmp-name)) - (tramp--test-async-shell-command - "read line; ls $line" (current-buffer) nil - ;; String to be sent. - (format "%s\n" (file-name-nondirectory tmp-name))) - (should - (string-equal - ;; tramp-adb.el echoes, so we must add the string. - (if (and (tramp--test-adb-p) (not (tramp-direct-async-process-p))) - (format - "%s\n%s\n" - (file-name-nondirectory tmp-name) - (file-name-nondirectory tmp-name)) - (format "%s\n" (file-name-nondirectory tmp-name))) - (buffer-string)))) + (when (tramp--test-asynchronous-processes-p) + (unwind-protect + (with-temp-buffer + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (tramp--test-async-shell-command + "read line; ls $line" (current-buffer) nil + ;; String to be sent. + (format "%s\n" (file-name-nondirectory tmp-name))) + (should + (string-equal + ;; tramp-adb.el echoes, so we must add the string. + (if (and (tramp--test-adb-p) + (not (tramp-direct-async-process-p))) + (format + "%s\n%s\n" + (file-name-nondirectory tmp-name) + (file-name-nondirectory tmp-name)) + (format "%s\n" (file-name-nondirectory tmp-name))) + (buffer-string)))) - ;; Cleanup. - (ignore-errors (delete-file tmp-name))))) + ;; Cleanup. + (ignore-errors (delete-file tmp-name)))))) ;; Test `async-shell-command-width'. It exists since Emacs 26.1, ;; but seems to work since Emacs 27.1 only. - (when (and (tramp--test-sh-p) (tramp--test-emacs27-p)) + (when (and (tramp--test-asynchronous-processes-p) + (tramp--test-sh-p) (tramp--test-emacs27-p)) (let* ((async-shell-command-width 1024) (default-directory tramp-test-temporary-file-directory) (cols (ignore-errors @@ -5232,10 +5239,12 @@ INPUT, if non-nil, is a string sent to the process." (skip-unless (not (tramp--test-crypt-p))) (dolist (this-shell-command-to-string - '(;; Synchronously. - shell-command-to-string - ;; Asynchronously. - tramp--test-shell-command-to-string-asynchronously)) + (append + ;; Synchronously. + '(shell-command-to-string) + ;; Asynchronously. + (and (tramp--test-asynchronous-processes-p) + '(tramp--test-shell-command-to-string-asynchronously)))) (let ((default-directory tramp-test-temporary-file-directory) (shell-file-name "/bin/sh") @@ -5362,9 +5371,6 @@ Use direct async.") ;; Since Emacs 27.1. (skip-unless (fboundp 'with-connection-local-variables)) - ;; `connection-local-set-profile-variables' and - ;; `connection-local-set-profiles' exist since Emacs 26.1. We don't - ;; want to see compiler warnings for older Emacsen. (let* ((default-directory tramp-test-temporary-file-directory) (tmp-name1 (tramp--test-make-temp-name)) (tmp-name2 (expand-file-name "foo" tmp-name1)) @@ -5380,23 +5386,22 @@ Use direct async.") ;; `local-variable' is buffer-local due to explicit setting. (with-no-warnings - (defvar-local local-variable 'buffer)) + (defvar-local local-variable 'buffer)) (with-temp-buffer (should (eq local-variable 'buffer))) ;; `local-variable' is connection-local due to Tramp. (write-region "foo" nil tmp-name2) (should (file-exists-p tmp-name2)) - (with-no-warnings - (connection-local-set-profile-variables - 'local-variable-profile - '((local-variable . connect))) - (connection-local-set-profiles - `(:application tramp - :protocol ,(file-remote-p default-directory 'method) - :user ,(file-remote-p default-directory 'user) - :machine ,(file-remote-p default-directory 'host)) - 'local-variable-profile)) + (connection-local-set-profile-variables + 'local-variable-profile + '((local-variable . connect))) + (connection-local-set-profiles + `(:application tramp + :protocol ,(file-remote-p default-directory 'method) + :user ,(file-remote-p default-directory 'user) + :machine ,(file-remote-p default-directory 'host)) + 'local-variable-profile) (with-current-buffer (find-file-noselect tmp-name2) (should (eq local-variable 'connect)) (kill-buffer (current-buffer))) @@ -5421,23 +5426,16 @@ Use direct async.") ;; Cleanup. (ignore-errors (delete-directory tmp-name1 'recursive))))) -;; The functions were introduced in Emacs 26.1. (ert-deftest tramp-test34-explicit-shell-file-name () "Check that connection-local `explicit-shell-file-name' is set." - :tags '(:expensive-test) + :tags '(:expensive-test :tramp-asynchronous-processes) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-supports-processes-p)) ;; Prior Emacs 27, `shell-file-name' was hard coded as "/bin/sh" for ;; remote processes in Emacs. That doesn't work for tramp-adb.el. (when (tramp--test-adb-p) (skip-unless (tramp--test-emacs27-p))) - ;; Since Emacs 26.1. - (skip-unless (and (fboundp 'connection-local-set-profile-variables) - (fboundp 'connection-local-set-profiles))) - ;; `connection-local-set-profile-variables' and - ;; `connection-local-set-profiles' exist since Emacs 26.1. We don't - ;; want to see compiler warnings for older Emacsen. (let ((default-directory tramp-test-temporary-file-directory) explicit-shell-file-name kill-buffer-query-functions connection-local-profile-alist connection-local-criteria-alist) @@ -5446,19 +5444,16 @@ Use direct async.") ;; `shell-mode' would ruin our test, because it deletes all ;; buffer local variables. Not needed in Emacs 27.1. (put 'explicit-shell-file-name 'permanent-local t) - ;; Declare connection-local variables `explicit-shell-file-name' - ;; and `explicit-sh-args'. - (with-no-warnings - (connection-local-set-profile-variables - 'remote-sh - `((explicit-shell-file-name . ,(tramp--test-shell-file-name)) - (explicit-sh-args . ("-c" "echo foo")))) - (connection-local-set-profiles - `(:application tramp - :protocol ,(file-remote-p default-directory 'method) - :user ,(file-remote-p default-directory 'user) - :machine ,(file-remote-p default-directory 'host)) - 'remote-sh)) + (connection-local-set-profile-variables + 'remote-sh + `((explicit-shell-file-name . ,(tramp--test-shell-file-name)) + (explicit-sh-args . ("-c" "echo foo")))) + (connection-local-set-profiles + `(:application tramp + :protocol ,(file-remote-p default-directory 'method) + :user ,(file-remote-p default-directory 'user) + :machine ,(file-remote-p default-directory 'host)) + 'remote-sh) (put 'explicit-shell-file-name 'safe-local-variable #'identity) (put 'explicit-sh-args 'safe-local-variable #'identity) @@ -5598,7 +5593,7 @@ Use direct async.") (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-crypt-p))) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) ;; We must use `file-truename' for the temporary directory, in ;; order to establish the connection prior running an asynchronous ;; process. @@ -5668,7 +5663,7 @@ Use direct async.") "Check `make-auto-save-file-name'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) tramp-allow-unsafe-temporary-files) @@ -5761,7 +5756,7 @@ Use direct async.") ;; files, owned by root. (let ((tramp-auto-save-directory temporary-file-directory)) (write-region "foo" nil tmp-name1) - (when (zerop (or (tramp-compat-file-attribute-user-id + (when (zerop (or (file-attribute-user-id (file-attributes tmp-name1)) tramp-unknown-id-integer)) (with-temp-buffer @@ -5791,7 +5786,7 @@ Use direct async.") "Check `find-backup-file-name'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (ange-ftp-make-backup-files t) @@ -5908,8 +5903,7 @@ Use direct async.") (let ((backup-directory-alist `(("." . ,temporary-file-directory))) tramp-backup-directory-alist) (write-region "foo" nil tmp-name1) - (when (zerop (or (tramp-compat-file-attribute-user-id - (file-attributes tmp-name1)) + (when (zerop (or (file-attribute-user-id (file-attributes tmp-name1)) tramp-unknown-id-integer)) (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) @@ -5943,7 +5937,7 @@ Use direct async.") ;; `lock-file', `unlock-file', `file-locked-p' and ;; `make-lock-file-name' exists since Emacs 28.1. We don't want to ;; see compiler warnings for older Emacsen. - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (remote-file-name-inhibit-cache t) @@ -6045,8 +6039,7 @@ Use direct async.") ;; files, owned by root. (let ((lock-file-name-transforms auto-save-file-name-transforms)) (write-region "foo" nil tmp-name1) - (when (zerop (or (tramp-compat-file-attribute-user-id - (file-attributes tmp-name1)) + (when (zerop (or (file-attribute-user-id (file-attributes tmp-name1)) tramp-unknown-id-integer)) (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) @@ -6064,29 +6057,22 @@ Use direct async.") (ignore-errors (delete-file tmp-name1)) (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password))))) -;; The functions were introduced in Emacs 26.1. (ert-deftest tramp-test40-make-nearby-temp-file () "Check `make-nearby-temp-file' and `temporary-file-directory'." (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-ange-ftp-p))) - ;; Since Emacs 26.1. - (skip-unless - (and (fboundp 'make-nearby-temp-file) (fboundp 'temporary-file-directory))) - ;; `make-nearby-temp-file' and `temporary-file-directory' exists - ;; since Emacs 26.1. We don't want to see compiler warnings for - ;; older Emacsen. (let ((default-directory tramp-test-temporary-file-directory) tmp-file) ;; The remote host shall know a temporary file directory. - (should (stringp (with-no-warnings (temporary-file-directory)))) + (should (stringp (temporary-file-directory))) (should (string-equal (file-remote-p default-directory) - (file-remote-p (with-no-warnings (temporary-file-directory))))) + (file-remote-p (temporary-file-directory)))) ;; The temporary file shall be located on the remote host. - (setq tmp-file (with-no-warnings (make-nearby-temp-file "tramp-test"))) + (setq tmp-file (make-nearby-temp-file "tramp-test")) (should (file-exists-p tmp-file)) (should (file-regular-p tmp-file)) (should @@ -6096,18 +6082,12 @@ Use direct async.") (delete-file tmp-file) (should-not (file-exists-p tmp-file)) - (setq tmp-file (with-no-warnings (make-nearby-temp-file "tramp-test" 'dir))) + (setq tmp-file (make-nearby-temp-file "tramp-test" 'dir)) (should (file-exists-p tmp-file)) (should (file-directory-p tmp-file)) (delete-directory tmp-file) (should-not (file-exists-p tmp-file)))) -(defun tramp--test-emacs26-p () - "Check for Emacs version >= 26.1. -Some semantics has been changed for there, w/o new functions or -variables, so we check the Emacs version directly." - (>= emacs-major-version 26)) - (defun tramp--test-emacs27-p () "Check for Emacs version >= 27.1. Some semantics has been changed for there, w/o new functions or @@ -6120,6 +6100,12 @@ Some semantics has been changed for there, w/o new functions or variables, so we check the Emacs version directly." (>= emacs-major-version 28)) +(defun tramp--test-emacs29-p () + "Check for Emacs version >= 29.1. +Some semantics has been changed for there, w/o new functions or +variables, so we check the Emacs version directly." + (>= emacs-major-version 29)) + (defun tramp--test-adb-p () "Check, whether the remote host runs Android. This requires restrictions of file name syntax." @@ -6131,6 +6117,15 @@ This requires restrictions of file name syntax." (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) 'tramp-ftp-file-name-handler)) +(defun tramp--test-asynchronous-processes-p () + "Whether asynchronous processes tests are run. +This is used in tests which we dont't want to tag +`:tramp-asynchronous-processes' completely." + (ert-select-tests + (ert--stats-selector ert--current-run-stats) + (list (make-ert-test :name (ert-test-name (ert-running-test)) + :body nil :tags '(:tramp-asynchronous-processes))))) + (defun tramp--test-crypt-p () "Check, whether the remote directory is crypted." (tramp-crypt-file-name-p tramp-test-temporary-file-directory)) @@ -6141,6 +6136,15 @@ This does not support some special file names." (string-equal "docker" (file-remote-p tramp-test-temporary-file-directory 'method))) +(defun tramp--test-expensive-test-p () + "Whether expensive tests are run. +This is used in tests which we dont't want to tag `:expensive' +completely." + (ert-select-tests + (ert--stats-selector ert--current-run-stats) + (list (make-ert-test :name (ert-test-name (ert-running-test)) + :body nil :tags '(:expensive-test))))) + (defun tramp--test-ftp-p () "Check, whether an FTP-like method is used. This does not support globbing characters in file names (yet)." @@ -6284,8 +6288,9 @@ This requires restrictions of file name syntax." (defun tramp--test-check-files (&rest files) "Run a simple but comprehensive test over every file in FILES." ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579. - (dolist (quoted (if (and (tramp--test-expensive-test) (tramp--test-emacs27-p)) - '(nil t) '(nil))) + (dolist (quoted + (if (and (tramp--test-expensive-test-p) (tramp--test-emacs27-p)) + '(nil t) '(nil))) ;; We must use `file-truename' for the temporary directory, ;; because it could be located on a symlinked directory. This ;; would let the test fail. @@ -6335,7 +6340,7 @@ This requires restrictions of file name syntax." (string-equal (funcall (if quoted #'tramp-compat-file-name-quote #'identity) - (tramp-compat-file-attribute-type (file-attributes file3))) + (file-attribute-type (file-attributes file3))) (file-remote-p (file-truename file1) 'localname))) ;; Check file contents. (with-temp-buffer @@ -6366,7 +6371,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)))) @@ -6445,7 +6450,7 @@ This requires restrictions of file name syntax." ;; Check, that environment variables are set correctly. ;; We do not run on macOS due to encoding problems. See ;; Bug#36940. - (when (and (tramp--test-expensive-test) (tramp--test-sh-p) + (when (and (tramp--test-expensive-test-p) (tramp--test-sh-p) (not (tramp--test-crypt-p)) (not (eq system-type 'darwin))) (dolist (elt files) @@ -6527,7 +6532,7 @@ This requires restrictions of file name syntax." "{foo}bar{baz}"))) ;; Simplify test in order to speed up. (apply #'tramp--test-check-files - (if (tramp--test-expensive-test) + (if (tramp--test-expensive-test-p) files (list (mapconcat #'identity files "")))))) ;; These tests are inspired by Bug#17238. @@ -6536,7 +6541,7 @@ This requires restrictions of file name syntax." (skip-unless (not (getenv "EMACS_HYDRA_CI"))) ; SLOW ~ 245s (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) + (skip-unless (not (tramp--test-rclone-p))) (tramp--test-special-characters)) @@ -6626,13 +6631,13 @@ Use the \"ls\" command." ;; to U+1FFFF). "🌈🍒👋") - (when (tramp--test-expensive-test) + (when (tramp--test-expensive-test-p) (delete-dups (mapcar ;; 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 @@ -6659,7 +6664,7 @@ Use the \"ls\" command." (skip-unless (not (tramp--test-ksh-p))) (skip-unless (not (tramp--test-gdrive-p))) (skip-unless (not (tramp--test-crypt-p))) - (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) + (skip-unless (not (tramp--test-rclone-p))) (tramp--test-utf8)) @@ -6798,8 +6803,8 @@ This is needed in timer functions as well as process filters and sentinels." "Check parallel asynchronous requests. Such requests could arrive from timers, process filters and process sentinels. They shall not disturb each other." - :tags (if (getenv "EMACS_EMBA_CI") - '(:expensive-test :unstable) '(:expensive-test)) + :tags (append '(:expensive-test :tramp-asynchronous-processes) + (and (getenv "EMACS_HYDRA_CI") '(:unstable))) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-supports-processes-p)) ;; Prior Emacs 27, `shell-file-name' was hard coded as "/bin/sh" for @@ -6871,11 +6876,7 @@ process sentinels. They shall not disturb each other." (when buffers (let ((time (float-time)) (default-directory tmp-name) - (file - (buffer-name - ;; Use `seq-random-elt' once <26.1 support - ;; is dropped. - (nth (random (length buffers)) buffers))) + (file (buffer-name (seq-random-elt buffers))) ;; A remote operation in a timer could ;; confuse Tramp heavily. So we ignore this ;; error here. @@ -6940,8 +6941,7 @@ process sentinels. They shall not disturb each other." ;; the buffers. Mix with regular operation. (let ((buffers (copy-sequence buffers))) (while buffers - ;; Use `seq-random-elt' once <26.1 support is dropped. - (let* ((buf (nth (random (length buffers)) buffers)) + (let* ((buf (seq-random-elt buffers)) (proc (get-buffer-process buf)) (file (process-get proc 'foo)) (count (process-get proc 'bar))) @@ -6997,8 +6997,51 @@ process sentinels. They shall not disturb each other." ;; (tramp--test--deftest-direct-async-process tramp-test44-asynchronous-requests ;; "Check parallel direct asynchronous requests." 'unstable) +(ert-deftest tramp-test45-dired-compress-file () + "Check that Tramp (un)compresses normal files." + (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' is performed by + ;; default handler. + (skip-unless (not (tramp--test-emacs29-p))) + + (let ((default-directory tramp-test-temporary-file-directory) + (tmp-name (tramp--test-make-temp-name))) + (write-region "foo" nil tmp-name) + (dired default-directory) + (dired-revert) + (dired-goto-file tmp-name) + (should-not (dired-compress)) + (should (string= (concat tmp-name ".gz") (dired-get-filename))) + (should-not (dired-compress)) + (should (string= tmp-name (dired-get-filename))) + (delete-file tmp-name))) + +(ert-deftest tramp-test45-dired-compress-dir () + "Check that Tramp (un)compresses directories." + (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' is performed by + ;; default handler. + (skip-unless (not (tramp--test-emacs29-p))) + + (let ((default-directory tramp-test-temporary-file-directory) + (tmp-name (tramp--test-make-temp-name))) + (make-directory tmp-name) + (dired default-directory) + (dired-revert) + (dired-goto-file tmp-name) + (should-not (dired-compress)) + (should (string= (concat tmp-name ".tar.gz") (dired-get-filename))) + (should-not (dired-compress)) + (should (string= tmp-name (dired-get-filename))) + (delete-directory tmp-name) + (delete-file (concat tmp-name ".tar.gz")))) + ;; This test is inspired by Bug#29163. -(ert-deftest tramp-test45-auto-load () +(ert-deftest tramp-test46-auto-load () "Check that Tramp autoloads properly." ;; If we use another syntax but `default', Tramp is already loaded ;; due to the `tramp-change-syntax' call. @@ -7023,12 +7066,8 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument code))))))) -(ert-deftest tramp-test45-delay-load () +(ert-deftest tramp-test46-delay-load () "Check that Tramp is loaded lazily, only when needed." - ;; The autoloaded Tramp objects are different since Emacs 26.1. We - ;; cannot test older Emacsen, therefore. - (skip-unless (tramp--test-emacs26-p)) - ;; Tramp is neither loaded at Emacs startup, nor when completing a ;; non-Tramp file name like "/foo". Completing a Tramp-alike file ;; name like "/foo:" autoloads Tramp, when `tramp-mode' is t. @@ -7056,7 +7095,7 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument (format code tm))))))))) -(ert-deftest tramp-test45-recursive-load () +(ert-deftest tramp-test46-recursive-load () "Check that Tramp does not fail due to recursive load." (skip-unless (tramp--test-enabled)) @@ -7080,12 +7119,8 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument code)))))))) -(ert-deftest tramp-test45-remote-load-path () +(ert-deftest tramp-test46-remote-load-path () "Check that Tramp autoloads its packages with remote `load-path'." - ;; The autoloaded Tramp objects are different since Emacs 26.1. We - ;; cannot test older Emacsen, therefore. - (skip-unless (tramp--test-emacs26-p)) - ;; `tramp-cleanup-all-connections' is autoloaded from tramp-cmds.el. ;; It shall still work, when a remote file name is in the ;; `load-path'. @@ -7109,15 +7144,11 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument code))))))) -(ert-deftest tramp-test46-unload () +(ert-deftest tramp-test47-unload () "Check that Tramp and its subpackages unload completely. Since it unloads Tramp, it shall be the last test to run." :tags '(:expensive-test) (skip-unless noninteractive) - ;; The autoloaded Tramp objects are different since Emacs 26.1. We - ;; cannot test older Emacsen, therefore. - (skip-unless (tramp--test-emacs26-p)) - ;; We have autoloaded objects from tramp.el and tramp-archive.el. ;; In order to remove them, we first need to load both packages. (require 'tramp) @@ -7177,8 +7208,7 @@ If INTERACTIVE is non-nil, the tests are run interactively." ;; TODO: -;; * dired-compress-file -;; * dired-uncache +;; * dired-uncache (partly done in other test functions) ;; * file-equal-p (partly done in `tramp-test21-file-links') ;; * file-in-directory-p ;; * file-name-case-insensitive-p diff --git a/test/lisp/obsolete/cl-tests.el b/test/lisp/obsolete/cl-tests.el index 0e02e1ca1bc..659c51ebcf8 100644 --- a/test/lisp/obsolete/cl-tests.el +++ b/test/lisp/obsolete/cl-tests.el @@ -25,12 +25,11 @@ (require 'cl)) (require 'ert) - - (ert-deftest labels-function-quoting () "Test that #'foo does the right thing in `labels'." ; Bug#31792. - (should (eq (funcall (labels ((foo () t)) - #'foo)) - t))) + (with-suppressed-warnings ((obsolete labels)) + (should (eq (funcall (labels ((foo () t)) + #'foo)) + t)))) ;;; cl-tests.el ends here diff --git a/test/lisp/paren-tests.el b/test/lisp/paren-tests.el index c4bec5d86de..11249ee9bc1 100644 --- a/test/lisp/paren-tests.el +++ b/test/lisp/paren-tests.el @@ -117,5 +117,36 @@ (- (point-max) 1) (point-max) nil))))) +(ert-deftest paren-tests-open-paren-line () + (cl-flet ((open-paren-line () + (let* ((data (show-paren--default)) + (here-beg (nth 0 data)) + (there-beg (nth 2 data))) + (blink-paren-open-paren-line-string + (min here-beg there-beg))))) + ;; Lisp-like + (with-temp-buffer + (insert "(defun foo () + (dummy))") + (goto-char (point-max)) + (should (string= "(defun foo ()" (open-paren-line)))) + + ;; C-like + (with-temp-buffer + (insert "int foo() { + int blah; + }") + (goto-char (point-max)) + (should (string= "int foo() {" (open-paren-line)))) + + ;; C-like with hanging { + (with-temp-buffer + (insert "int foo() + { + int blah; + }") + (goto-char (point-max)) + (should (string= "int foo()...{" (open-paren-line)))))) + (provide 'paren-tests) ;;; paren-tests.el ends here diff --git a/test/lisp/progmodes/bug-reference-tests.el b/test/lisp/progmodes/bug-reference-tests.el new file mode 100644 index 00000000000..7a3ab5fbda0 --- /dev/null +++ b/test/lisp/progmodes/bug-reference-tests.el @@ -0,0 +1,128 @@ +;;; bug-reference-tests.el --- Tests for bug-reference.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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'bug-reference) +(require 'ert) + +(defun test--get-github-entry (url) + (and (string-match + (car (bug-reference--build-forge-setup-entry + "github.com" 'github "https")) + url) + (match-string 1 url))) + +(defun test--get-gitlab-entry (url) + (and (string-match + (car (bug-reference--build-forge-setup-entry + "gitlab.com" 'gitlab "https")) + url) + (match-string 1 url))) + +(defun test--get-gitea-entry (url) + (and (string-match + (car (bug-reference--build-forge-setup-entry + "gitea.com" 'gitea "https")) + url) + (match-string 1 url))) + +(ert-deftest test-github-entry () + (should + (equal + (test--get-github-entry "git@github.com:larsmagne/csid.git") + "larsmagne/csid")) + (should + (equal + (test--get-github-entry "git@github.com:larsmagne/csid") + "larsmagne/csid")) + (should + (equal + (test--get-github-entry "https://github.com/magit/magit.git") + "magit/magit")) + (should + (equal + (test--get-github-entry "https://github.com/magit/magit.git/") + "magit/magit")) + (should + (equal + (test--get-github-entry "https://github.com/magit/magit") + "magit/magit")) + (should + (equal + (test--get-github-entry "https://github.com/magit/magit/") + "magit/magit"))) + +(ert-deftest test-gitlab-entry () + (should + (equal + (test--get-gitlab-entry "git@gitlab.com:larsmagne/csid.git") + "larsmagne/csid")) + (should + (equal + (test--get-gitlab-entry "git@gitlab.com:larsmagne/csid") + "larsmagne/csid")) + (should + (equal + (test--get-gitlab-entry "https://gitlab.com/magit/magit.git") + "magit/magit")) + (should + (equal + (test--get-gitlab-entry "https://gitlab.com/magit/magit.git/") + "magit/magit")) + (should + (equal + (test--get-gitlab-entry "https://gitlab.com/magit/magit") + "magit/magit")) + (should + (equal + (test--get-gitlab-entry "https://gitlab.com/magit/magit/") + "magit/magit"))) + +(ert-deftest test-gitea-entry () + (should + (equal + (test--get-gitea-entry "git@gitea.com:larsmagne/csid.git") + "larsmagne/csid")) + (should + (equal + (test--get-gitea-entry "git@gitea.com:larsmagne/csid") + "larsmagne/csid")) + (should + (equal + (test--get-gitea-entry "https://gitea.com/magit/magit.git") + "magit/magit")) + (should + (equal + (test--get-gitea-entry "https://gitea.com/magit/magit.git/") + "magit/magit")) + (should + (equal + (test--get-gitea-entry "https://gitea.com/magit/magit") + "magit/magit")) + (should + (equal + (test--get-gitea-entry "https://gitea.com/magit/magit/") + "magit/magit"))) + +;;; bug-reference-tests.el ends here 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-resources/elisp-indents.erts b/test/lisp/progmodes/elisp-mode-resources/elisp-indents.erts new file mode 100644 index 00000000000..2c0d51edae8 --- /dev/null +++ b/test/lisp/progmodes/elisp-mode-resources/elisp-indents.erts @@ -0,0 +1,88 @@ +Code: + (lambda () + (emacs-lisp-mode) + (indent-region (point-min) (point-max))) + +Name: defun + +=-= +(defun foo () +"doc" +(+ 1 2)) +=-= +(defun foo () + "doc" + (+ 1 2)) +=-=-= + +Name: function call + +=-= +(foo zot +bar +(zot bar)) +=-= +(foo zot + bar + (zot bar)) +=-=-= + +Name: lisp data + +=-= +( foo zot +bar +(zot bar)) +=-= +( foo zot + bar + (zot bar)) +=-=-= + +Name: defun-space + +=-= +(defun x () + (print (quote ( thingy great + stuff))) + (print (quote (thingy great + stuff)))) +=-=-= + +Name: defvar-keymap + +=-= +(defvar-keymap eww-link-keymap + :copy shr-map + :foo bar + "\r" #'eww-follow-link) +=-=-= + +Name: def-indent1 + +=-= +(defzot-does-not-exist 1 + 2 3) +=-=-= + +Name: def-indent2 + +=-= +(define-keymap 1 + 2 3) +=-=-= + +Name: elisp-indents1 + +=-= +(defvar foo + () + "bar") +=-=-= + +Name: elisp-indents2 + +=-= +(defvar foo () + "bar") +=-=-= diff --git a/test/lisp/progmodes/elisp-mode-resources/flet.erts b/test/lisp/progmodes/elisp-mode-resources/flet.erts new file mode 100644 index 00000000000..da3dcb6ec3e --- /dev/null +++ b/test/lisp/progmodes/elisp-mode-resources/flet.erts @@ -0,0 +1,353 @@ +Name: flet1 + +=-= +(cl-flet () + (a (dangerous-position + b))) +=-=-= + +Name: flet2 + +=-= +(cl-flet wrong-syntax-but-should-not-obstruct-indentation + (a (dangerous-position + b))) +=-=-= + +Name: flet3 + +=-= +(cl-flet ((a (arg-of-flet-a) + b + c))) +=-=-= + +Name: flet4 + +=-= +(cl-flet ((a (arg-of-flet-a) + b + c + (if d + e + f)) + (irregular-local-def (form + returning + lambda)) + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet5 + +=-= +(cl-flet ((a (arg-of-flet-a) + b + c + (if d + e + f)) + (irregular-local-def (form + returning + lambda)) + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet6 + +=-= +(cl-flet ((a (arg-of-flet-a) + b + c + (if d + e + f)) + (irregular-local-def (form + returning + lambda)) + (irregular-local-def (form returning + lambda)) + wrong-syntax-but-should-not-osbtruct-indentation + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet7 + +=-= +(cl-flet ((a (arg-of-flet-a) + b + c + (if d + e + f)) + (irregular-local-def (form + returning + lambda)) + wrong-syntax-but-should-not-osbtruct-indentation + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet8 + +=-= +(cl-flet (wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +;; (setf _) not yet supported but looks like it will be +Name: flet9 + +=-= +(cl-flet (((setf a) (new value) + stuff) + wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet10 + +=-= +(cl-flet ( (a (arg-of-flet-a) + b + c + (if d + e + f)) + (irregular-local-def (form + returning + lambda)) + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet11 + +=-= +(cl-flet ( wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet12 + +=-= +(cl-flet ( wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet13 + +=-= +(cl-flet (wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i) + wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i))) +=-=-= + +Name: flet14 + +=-= +(cl-flet (wrong-syntax-but-should-not-obstruct-indentation + wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i) + wrong-syntax-but-should-not-obstruct-indentation)) +=-=-= + +Name: flet15 + +=-= +(cl-flet (wrong-syntax-but-should-not-obstruct-indentation + wrong-syntax-but-should-not-obstruct-indentation + wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i))) +=-=-= + +Name: flet16 + +=-= +(cl-flet ((f (x) + (g x))) + (pcase e + ((dangerous-expression) + (form)))) +=-=-= + +Name: flet-indentation-incomplete-sexp-no-side-effects-1 +Code: (lambda () (emacs-lisp-mode) (setq indent-tabs-mode nil) (newline nil t)) +Point-Char: | + +=-= +(let ((x (and y| +=-= +(let ((x (and y + | +=-=-= + +Name: flet-indentation-incomplete-sexp-no-side-effects-2 + +=-= +(let ((x| +=-= +(let ((x + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-whitespace-1 +Point-Char: | + +=-= +(cl-flet((f (x)| +=-= +(cl-flet((f (x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-whitespace-2 +Point-Char: | + +=-= +(cl-flet((f(x)| +=-= +(cl-flet((f(x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-whitespace-3 + +=-= +(cl-flet ((f(x)| +=-= +(cl-flet ((f(x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-whitespace-4 + +=-= +(cl-flet( (f (x)| +=-= +(cl-flet( (f (x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-whitespace-5 + +=-= +(cl-flet( (f(x)| +=-= +(cl-flet( (f(x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-and-excessive-whitespace-1 + +=-= +(cl-flet((f (x)| +=-= +(cl-flet((f (x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-and-excessive-whitespace-2 + +=-= +(cl-flet ((f(x)| +=-= +(cl-flet ((f(x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-and-excessive-whitespace-3 + +=-= +(cl-flet( (f (x)| +=-= +(cl-flet( (f (x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-and-excessive-whitespace-4 + +=-= +(cl-flet( (f (x)| +=-= +(cl-flet( (f (x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-and-excessive-whitespace-5 + +=-= +(cl-flet( (f (x)| +=-= +(cl-flet( (f (x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-and-excessive-whitespace-6 + +=-= +(cl-flet( (f(x)| +=-= +(cl-flet( (f(x) + | +=-=-= diff --git a/test/lisp/progmodes/elisp-mode-resources/simple-shorthand-test.el b/test/lisp/progmodes/elisp-mode-resources/simple-shorthand-test.el index 14c8e845d11..9b41fb5426c 100644 --- a/test/lisp/progmodes/elisp-mode-resources/simple-shorthand-test.el +++ b/test/lisp/progmodes/elisp-mode-resources/simple-shorthand-test.el @@ -1,3 +1,5 @@ +;;; simple-shorthand-test.el --- -*- lexical-binding: t; -*- + (defun f-test () (let ((read-symbol-shorthands '(("foo-" . "bar-")))) (with-temp-buffer diff --git a/test/lisp/progmodes/elisp-mode-tests.el b/test/lisp/progmodes/elisp-mode-tests.el index f887bb1dca5..62e0c29323c 100644 --- a/test/lisp/progmodes/elisp-mode-tests.el +++ b/test/lisp/progmodes/elisp-mode-tests.el @@ -26,6 +26,7 @@ (require 'ert-x) (require 'xref) (eval-when-compile (require 'cl-lib)) +(require 'ert-x) ;;; Completion @@ -108,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") @@ -301,12 +302,9 @@ ;; tmp may be on a different filesystem to the tests, but, ehh. (defvar xref--case-insensitive - (let ((dir (make-temp-file "xref-test" t))) - (unwind-protect - (progn - (with-temp-file (expand-file-name "hElLo" dir) "hello") - (file-exists-p (expand-file-name "HELLO" dir))) - (delete-directory dir t))) + (ert-with-temp-directory dir + (with-temp-file (expand-file-name "hElLo" dir) "hello") + (file-exists-p (expand-file-name "HELLO" dir))) "Non-nil if file system seems to be case-insensitive.") (defun xref-elisp-test-run (xrefs expected-xrefs) @@ -440,7 +438,8 @@ to (xref-elisp-test-descr-to-target xref)." ;; track down the problem. (cl-defmethod xref-elisp-generic-no-default ((this xref-elisp-root-type) arg2) "Doc string generic no-default xref-elisp-root-type." - "non-default for no-default") + "non-default for no-default" + (list this arg2)) ; silence byte-compiler ;; defgeneric after defmethod in file to ensure the fallback search ;; method of just looking for the function name will fail. @@ -450,13 +449,15 @@ to (xref-elisp-test-descr-to-target xref)." ;; dispatching code. ) -(cl-defgeneric xref-elisp-generic-co-located-default (arg1 arg2) - "Doc string generic co-located-default." - "co-located default") +(with-no-warnings ; FIXME: Make more specific. + (cl-defgeneric xref-elisp-generic-co-located-default (arg1 arg2) + "Doc string generic co-located-default." + "co-located default")) -(cl-defmethod xref-elisp-generic-co-located-default ((this xref-elisp-root-type) arg2) - "Doc string generic co-located-default xref-elisp-root-type." - "non-default for co-located-default") +(with-no-warnings ; FIXME: Make more specific. + (cl-defmethod xref-elisp-generic-co-located-default ((this xref-elisp-root-type) arg2) + "Doc string generic co-located-default xref-elisp-root-type." + "non-default for co-located-default")) (cl-defgeneric xref-elisp-generic-separate-default (arg1 arg2) "Doc string generic separate-default." @@ -465,19 +466,23 @@ to (xref-elisp-test-descr-to-target xref)." (cl-defmethod xref-elisp-generic-separate-default (arg1 arg2) "Doc string generic separate-default default." - "separate default") + "separate default" + (list arg1 arg2)) ; silence byte-compiler (cl-defmethod xref-elisp-generic-separate-default ((this xref-elisp-root-type) arg2) "Doc string generic separate-default xref-elisp-root-type." - "non-default for separate-default") + "non-default for separate-default" + (list this arg2)) ; silence byte-compiler (cl-defmethod xref-elisp-generic-implicit-generic (arg1 arg2) "Doc string generic implicit-generic default." - "default for implicit generic") + "default for implicit generic" + (list arg1 arg2)) ; silence byte-compiler (cl-defmethod xref-elisp-generic-implicit-generic ((this xref-elisp-root-type) arg2) "Doc string generic implicit-generic xref-elisp-root-type." - "non-default for implicit generic") + "non-default for implicit generic" + (list this arg2)) ; silence byte-compiler (xref-elisp-deftest find-defs-defgeneric-no-methods @@ -612,7 +617,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 @@ -714,7 +719,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 @@ -781,11 +786,11 @@ to (xref-elisp-test-descr-to-target xref)." )) (xref-elisp-deftest find-defs-defvar-el - (elisp--xref-find-definitions 'xref--marker-ring) + (elisp--xref-find-definitions 'xref--history) (list - (xref-make "(defvar xref--marker-ring)" + (xref-make "(defvar xref--history)" (xref-make-elisp-location - 'xref--marker-ring 'defvar + 'xref--history 'defvar (expand-file-name "../../../lisp/progmodes/xref.el" emacs-test-dir))) )) @@ -799,7 +804,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 @@ -817,7 +822,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 @@ -832,7 +837,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 () @@ -841,25 +846,14 @@ to (xref-elisp-test-descr-to-target xref)." (insert "?\\N{HEAVY CHECK MARK}") (should (equal (elisp--preceding-sexp) ?\N{HEAVY CHECK MARK})))) -(ert-deftest elisp-indent-basic () - (with-temp-buffer - (emacs-lisp-mode) - (let ((orig "(defun x () - (print (quote ( thingy great - stuff))) - (print (quote (thingy great - stuff))))")) - (insert orig) - (indent-region (point-min) (point-max)) - (should (equal (buffer-string) orig))))) - (defun test--font (form search) (with-temp-buffer (emacs-lisp-mode) (if (stringp form) (insert form) (pp form (current-buffer))) - (font-lock-debug-fontify) + (with-suppressed-warnings ((interactive-only font-lock-debug-fontify)) + (font-lock-debug-fontify)) (goto-char (point-min)) (and (re-search-forward search nil t) (get-text-property (match-beginning 1) 'face)))) @@ -1115,17 +1109,12 @@ evaluation of BODY." (buffer-string))))))) (should (equal observed expected-longhand-form)))) -(ert-deftest test-cl-flet-indentation () - :expected-result :failed ; FIXME: bug#9622 - (should (equal - (with-temp-buffer - (emacs-lisp-mode) - (insert "(cl-flet ((bla (x)\n(* x x)))\n(bla 42))") - (indent-region (point-min) (point-max)) - (buffer-string)) - "(cl-flet ((bla (x) - (* x x))) - (bla 42))"))) +(ert-deftest test-indentation () + (ert-test-erts-file (ert-resource-file "elisp-indents.erts")) + (ert-test-erts-file (ert-resource-file "flet.erts") + (lambda () + (emacs-lisp-mode) + (indent-region (point-min) (point-max))))) (provide 'elisp-mode-tests) ;;; elisp-mode-tests.el ends here diff --git a/test/lisp/progmodes/etags-tests.el b/test/lisp/progmodes/etags-tests.el index 9b14a3ae860..32b73f101e1 100644 --- a/test/lisp/progmodes/etags-tests.el +++ b/test/lisp/progmodes/etags-tests.el @@ -22,6 +22,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'etags) (eval-when-compile (require 'cl-lib)) @@ -95,21 +96,19 @@ (ert-deftest etags-buffer-local-tags-table-list () "Test that a buffer-local value of `tags-table-list' is used." - (let ((file (make-temp-file "etag-test-tmpfile"))) - (unwind-protect - (progn - (set-buffer (find-file-noselect file)) - (fundamental-mode) - (setq-local tags-table-list - (list (expand-file-name "manual/etags/ETAGS.good_3" - etags-tests--test-dir))) - (cl-letf ((tag-tables tags-table-list) - (tags-file-name nil) - ((symbol-function 'read-file-name) - (lambda (&rest _) - (error "We should not prompt the user")))) - (should (visit-tags-table-buffer)) - (should (equal tags-file-name (car tag-tables))))) - (delete-file file)))) + (ert-with-temp-file file + :suffix "etag-test-tmpfile" + (set-buffer (find-file-noselect file)) + (fundamental-mode) + (setq-local tags-table-list + (list (expand-file-name "manual/etags/ETAGS.good_3" + etags-tests--test-dir))) + (cl-letf ((tag-tables tags-table-list) + (tags-file-name nil) + ((symbol-function 'read-file-name) + (lambda (&rest _) + (error "We should not prompt the user")))) + (should (visit-tags-table-buffer)) + (should (equal tags-file-name (car tag-tables)))))) ;;; etags-tests.el ends here diff --git a/test/lisp/progmodes/flymake-tests.el b/test/lisp/progmodes/flymake-tests.el index 4c0d15d1e1b..4840018236a 100644 --- a/test/lisp/progmodes/flymake-tests.el +++ b/test/lisp/progmodes/flymake-tests.el @@ -23,6 +23,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'flymake) (eval-when-compile (require 'subr-x)) ; string-trim @@ -123,22 +124,21 @@ SEVERITY-PREDICATE is used to setup "Test the ruby backend." (skip-unless (executable-find "ruby")) ;; Some versions of ruby fail if HOME doesn't exist (bug#29187). - (let* ((tempdir (make-temp-file "flymake-tests-ruby" t)) - (process-environment (cons (format "HOME=%s" tempdir) - process-environment)) - ;; And see https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19657#20 - ;; for this particular yuckiness - (abbreviated-home-dir nil)) - (unwind-protect - (let ((ruby-mode-hook - (lambda () - (setq flymake-diagnostic-functions '(ruby-flymake-simple))))) - (flymake-tests--with-flymake ("test.rb") - (flymake-goto-next-error) - (should (eq 'flymake-warning (face-at-point))) - (flymake-goto-next-error) - (should (eq 'flymake-error (face-at-point))))) - (delete-directory tempdir t)))) + (ert-with-temp-directory tempdir + :suffix "flymake-tests-ruby" + (let* ((process-environment (cons (format "HOME=%s" tempdir) + process-environment)) + ;; And see https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19657#20 + ;; for this particular yuckiness + (abbreviated-home-dir nil) + (ruby-mode-hook + (lambda () + (setq flymake-diagnostic-functions '(ruby-flymake-simple))))) + (flymake-tests--with-flymake ("test.rb") + (flymake-goto-next-error) + (should (eq 'flymake-warning (face-at-point))) + (flymake-goto-next-error) + (should (eq 'flymake-error (face-at-point))))))) (ert-deftest different-diagnostic-types () "Test GCC warning via function predicate." diff --git a/test/lisp/progmodes/perl-mode-tests.el b/test/lisp/progmodes/perl-mode-tests.el index 3f4af5e1f61..b059f539159 100644 --- a/test/lisp/progmodes/perl-mode-tests.el +++ b/test/lisp/progmodes/perl-mode-tests.el @@ -37,4 +37,6 @@ (file-name-directory (or load-file-name buffer-file-name))))) +(setq ert-load-file-name load-file-name) + ;;; perl-mode-tests.el ends here diff --git a/test/lisp/progmodes/project-tests.el b/test/lisp/progmodes/project-tests.el index 1e3f258ac2a..a469414a743 100644 --- a/test/lisp/progmodes/project-tests.el +++ b/test/lisp/progmodes/project-tests.el @@ -29,29 +29,17 @@ (require 'cl-lib) (require 'ert) +(require 'ert-x) ; ert-with-temp-directory (require 'grep) (require 'xref) -(defmacro project-tests--with-temporary-directory (var &rest body) - "Create a new temporary directory. -Bind VAR to the name of the directory, and evaluate BODY. Delete -the directory after BODY exits." - (declare (debug (symbolp body)) (indent 1)) - (cl-check-type var symbol) - (let ((directory (make-symbol "directory"))) - `(let ((,directory (make-temp-file "project-tests-" :directory))) - (unwind-protect - (let ((,var ,directory)) - ,@body) - (delete-directory ,directory :recursive))))) - (ert-deftest project/quoted-directory () "Check that `project-files' and `project-find-regexp' deal with quoted directory names (Bug#47799)." (skip-unless (executable-find find-program)) (skip-unless (executable-find "xargs")) (skip-unless (executable-find "grep")) - (project-tests--with-temporary-directory directory + (ert-with-temp-directory directory (let ((default-directory directory) (project-current-inhibit-prompt t) (project-find-functions nil) @@ -95,7 +83,7 @@ quoted directory names (Bug#47799)." returned by `project-ignores' if the root directory is a directory name (Bug#48471)." (skip-unless (executable-find find-program)) - (project-tests--with-temporary-directory dir + (ert-with-temp-directory dir (make-empty-file (expand-file-name "some-file" dir)) (make-empty-file (expand-file-name "ignored-file" dir)) (let* ((project (make-project-tests--trivial @@ -111,7 +99,7 @@ directory name (Bug#48471)." "Check that `project-files' does not ignore all files. When `project-ignores' includes a name matching project dir." (skip-unless (executable-find find-program)) - (project-tests--with-temporary-directory dir + (ert-with-temp-directory dir (make-empty-file (expand-file-name "some-file" dir)) (let* ((project (make-project-tests--trivial :root (file-name-as-directory dir) diff --git a/test/lisp/progmodes/python-tests.el b/test/lisp/progmodes/python-tests.el index 752a4f0113f..2d1ccdca41d 100644 --- a/test/lisp/progmodes/python-tests.el +++ b/test/lisp/progmodes/python-tests.el @@ -22,6 +22,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'python) ;; Dependencies for testing: @@ -48,17 +49,17 @@ BODY is code to be executed within the temp buffer. Point is always located at the beginning of buffer." (declare (indent 1) (debug t)) ;; temp-file never actually used for anything? - `(let* ((temp-file (make-temp-file "python-tests" nil ".py")) - (buffer (find-file-noselect temp-file)) - (python-indent-guess-indent-offset nil)) - (unwind-protect - (with-current-buffer buffer - (python-mode) - (insert ,contents) - (goto-char (point-min)) - ,@body) - (and buffer (kill-buffer buffer)) - (delete-file temp-file)))) + `(ert-with-temp-file temp-file + :suffix "-python.py" + (let ((buffer (find-file-noselect temp-file)) + (python-indent-guess-indent-offset nil)) + (unwind-protect + (with-current-buffer buffer + (python-mode) + (insert ,contents) + (goto-char (point-min)) + ,@body) + (and buffer (kill-buffer buffer)))))) (defun python-tests-look-at (string &optional num restore-point) "Move point at beginning of STRING in the current buffer. diff --git a/test/lisp/progmodes/sql-tests.el b/test/lisp/progmodes/sql-tests.el index 99b79b61d65..1bbe3a95e90 100644 --- a/test/lisp/progmodes/sql-tests.el +++ b/test/lisp/progmodes/sql-tests.el @@ -28,6 +28,7 @@ (require 'cl-lib) (require 'ert) +(require 'ert-x) (require 'sql) (ert-deftest sql-tests-postgres-list-databases () @@ -63,52 +64,49 @@ Identify tests by ID. Set :sql-login dialect attribute to LOGIN-PARAMS. Provide the CONNECTION parameters and the EXPECTED string of values passed to the comint function for validation." (declare (indent 2)) - `(cl-letf - ((sql-test-login-params ' ,login-params) - ((symbol-function 'sql-comint-test) - (lambda (product options &optional buf-name) - (with-current-buffer (get-buffer-create buf-name) - (insert (pp-to-string (list product options sql-user sql-password sql-server sql-database)))))) - ((symbol-function 'sql-run-test) - (lambda (&optional buffer) - (interactive "P") - (sql-product-interactive 'sqltest buffer))) - (sql-user nil) - (sql-server nil) - (sql-database nil) - (sql-product-alist - '((ansi) - (sqltest - :name "SqlTest" - :sqli-login sql-test-login-params - :sqli-comint-func sql-comint-test))) - (sql-connection-alist - '((,(format "test-%s" id) - ,@connection))) - (sql-password-wallet - (list - (make-temp-file - "sql-test-netrc" nil nil - (mapconcat #'identity - '("machine aMachine user aUserName password \"netrc-A aPassword\"" - "machine aServer user aUserName password \"netrc-B aPassword\"" - "machine aMachine server aServer user aUserName password \"netrc-C aPassword\"" - "machine aMachine database aDatabase user aUserName password \"netrc-D aPassword\"" - "machine aDatabase user aUserName password \"netrc-E aPassword\"" - "machine aMachine server aServer database aDatabase user aUserName password \"netrc-F aPassword\"" - "machine \"aServer/aDatabase\" user aUserName password \"netrc-G aPassword\"" - ) "\n"))))) - - (let* ((connection ,(format "test-%s" id)) - (buffername (format "*SQL: ERT TEST <%s>*" connection))) - (when (get-buffer buffername) - (kill-buffer buffername)) - (sql-connect connection buffername) - (should (get-buffer buffername)) - (should (string-equal (with-current-buffer buffername (buffer-string)) ,expected)) - (when (get-buffer buffername) - (kill-buffer buffername)) - (delete-file (car sql-password-wallet))))) + `(ert-with-temp-file tempfile + :suffix "sql-test-netrc" + :text (concat + "machine aMachine user aUserName password \"netrc-A aPassword\"" + "machine aServer user aUserName password \"netrc-B aPassword\"" + "machine aMachine server aServer user aUserName password \"netrc-C aPassword\"" + "machine aMachine database aDatabase user aUserName password \"netrc-D aPassword\"" + "machine aDatabase user aUserName password \"netrc-E aPassword\"" + "machine aMachine server aServer database aDatabase user aUserName password \"netrc-F aPassword\"" + "machine \"aServer/aDatabase\" user aUserName password \"netrc-G aPassword\"" + "\n") + (cl-letf + ((sql-test-login-params ' ,login-params) + ((symbol-function 'sql-comint-test) + (lambda (product options &optional buf-name) + (with-current-buffer (get-buffer-create buf-name) + (insert (pp-to-string (list product options sql-user sql-password sql-server sql-database)))))) + ((symbol-function 'sql-run-test) + (lambda (&optional buffer) + (interactive "P") + (sql-product-interactive 'sqltest buffer))) + (sql-user nil) + (sql-server nil) + (sql-database nil) + (sql-product-alist + '((ansi) + (sqltest + :name "SqlTest" + :sqli-login sql-test-login-params + :sqli-comint-func sql-comint-test))) + (sql-connection-alist + '((,(format "test-%s" id) + ,@connection))) + (sql-password-wallet (list tempfile))) + (let* ((connection ,(format "test-%s" id)) + (buffername (format "*SQL: ERT TEST <%s>*" connection))) + (when (get-buffer buffername) + (kill-buffer buffername)) + (sql-connect connection buffername) + (should (get-buffer buffername)) + (should (string-equal (with-current-buffer buffername (buffer-string)) ,expected)) + (when (get-buffer buffername) + (kill-buffer buffername)))))) (ert-deftest sql-test-connect () "Test of basic `sql-connect'." @@ -416,6 +414,16 @@ The ACTION will be tested after set-up of PRODUCT." (kill-buffer "*SQL: exist*"))) +(ert-deftest sql-tests-comint-automatic-password () + (let ((sql-password nil)) + (should-not (sql-comint-automatic-password "Password: "))) + (let ((sql-password "")) + (should-not (sql-comint-automatic-password "Password: "))) + (let ((sql-password "password")) + (should (equal "password" (sql-comint-automatic-password "Password: ")))) + ;; Also, we shouldn't care what the password is - we rely on comint for that. + (let ((sql-password "password")) + (should (equal "password" (sql-comint-automatic-password ""))))) (provide 'sql-tests) ;;; sql-tests.el ends here diff --git a/test/lisp/repeat-tests.el b/test/lisp/repeat-tests.el index 02d9ddbc96e..84a4d722a83 100644 --- a/test/lisp/repeat-tests.el +++ b/test/lisp/repeat-tests.el @@ -34,20 +34,16 @@ (interactive "p") (push `(,arg b) repeat-tests-calls)) -(defvar repeat-tests-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-x w a") 'repeat-tests-call-a) - (define-key map (kbd "M-C-a") 'repeat-tests-call-a) - (define-key map (kbd "M-C-z") 'repeat-tests-call-a) - map) - "Keymap for keys that initiate repeating sequences.") - -(defvar repeat-tests-repeat-map - (let ((map (make-sparse-keymap))) - (define-key map "a" 'repeat-tests-call-a) - (define-key map "b" 'repeat-tests-call-b) - map) - "Keymap for repeating sequences.") +(defvar-keymap repeat-tests-map + :doc "Keymap for keys that initiate repeating sequences." + "C-x w a" 'repeat-tests-call-a + "C-M-a" 'repeat-tests-call-a + "C-M-z" 'repeat-tests-call-a) + +(defvar-keymap repeat-tests-repeat-map + :doc "Keymap for repeating sequences." + "a" 'repeat-tests-call-a + "b" 'repeat-tests-call-b) (put 'repeat-tests-call-a 'repeat-map 'repeat-tests-repeat-map) (put 'repeat-tests-call-b 'repeat-map repeat-tests-repeat-map) diff --git a/test/lisp/replace-tests.el b/test/lisp/replace-tests.el index 7f62a417a02..dcd5ebb1fe6 100644 --- a/test/lisp/replace-tests.el +++ b/test/lisp/replace-tests.el @@ -599,11 +599,12 @@ bound to HIGHLIGHT-LOCUS." (with-temp-buffer (insert before) (goto-char (point-min)) - (replace-regexp - "\\(\\(L\\)\\|\\(R\\)\\)" - '(replace-eval-replacement - replace-quote - (if (match-string 2) "R" "L"))) + (with-suppressed-warnings ((interactive-only replace-regexp)) + (replace-regexp + "\\(\\(L\\)\\|\\(R\\)\\)" + '(replace-eval-replacement + replace-quote + (if (match-string 2) "R" "L")))) (should (equal (buffer-string) after))))) (ert-deftest test-count-matches () diff --git a/test/lisp/saveplace-tests.el b/test/lisp/saveplace-tests.el index 63577fdd167..190ffb78288 100644 --- a/test/lisp/saveplace-tests.el +++ b/test/lisp/saveplace-tests.el @@ -41,49 +41,42 @@ (ert-deftest saveplace-test-save-place-to-alist/file () (save-place-mode) - (let* ((tmpfile (make-temp-file "emacs-test-saveplace-")) - (tmpfile (file-truename tmpfile)) - (save-place-alist nil) - (save-place-loaded t) - (loc tmpfile) - (pos 4)) - (unwind-protect - (save-window-excursion - (find-file loc) - (insert "abc") ; must insert something - (save-place-to-alist) - (should (equal save-place-alist (list (cons tmpfile pos))))) - (delete-file tmpfile)))) + (ert-with-temp-file tmpfile + (let* ((tmpfile (file-truename tmpfile)) + (save-place-alist nil) + (save-place-loaded t) + (loc tmpfile) + (pos 4)) + (save-window-excursion + (find-file loc) + (insert "abc") ; must insert something + (save-place-to-alist) + (should (equal save-place-alist (list (cons tmpfile pos)))))))) (ert-deftest saveplace-test-forget-unreadable-files () (save-place-mode) - (let* ((save-place-loaded t) - (tmpfile (make-temp-file "emacs-test-saveplace-")) - (alist-orig (list (cons "/this/file/does/not/exist" 10) - (cons tmpfile 1917))) - (save-place-alist alist-orig)) - (unwind-protect - (progn - (save-place-forget-unreadable-files) - (should (equal save-place-alist (cdr alist-orig)))) - (delete-file tmpfile)))) + (ert-with-temp-file tmpfile + :suffix "-saveplace" + (let* ((save-place-loaded t) + (alist-orig (list (cons "/this/file/does/not/exist" 10) + (cons tmpfile 1917))) + (save-place-alist alist-orig)) + (save-place-forget-unreadable-files) + (should (equal save-place-alist (cdr alist-orig)))))) (ert-deftest saveplace-test-place-alist-to-file () (save-place-mode) - (let* ((tmpfile (make-temp-file "emacs-test-saveplace-")) - (tmpfile2 (make-temp-file "emacs-test-saveplace-")) - (save-place-file tmpfile) - (save-place-alist (list (cons tmpfile2 99)))) - (unwind-protect - (progn (save-place-alist-to-file) - (setq save-place-alist nil) - (save-window-excursion - (find-file save-place-file) - (unwind-protect - (should (string-match tmpfile2 (buffer-string))) - (kill-buffer)))) - (delete-file tmpfile) - (delete-file tmpfile2)))) + (ert-with-temp-file tmpfile + (ert-with-temp-file tmpfile2 + (let* ((save-place-file tmpfile) + (save-place-alist (list (cons tmpfile2 99)))) + (save-place-alist-to-file) + (setq save-place-alist nil) + (save-window-excursion + (find-file save-place-file) + (unwind-protect + (should (string-match tmpfile2 (buffer-string))) + (kill-buffer))))))) (ert-deftest saveplace-test-load-alist-from-file () (save-place-mode) diff --git a/test/lisp/ses-tests.el b/test/lisp/ses-tests.el index 9a7fb502d7c..932291afcc1 100644 --- a/test/lisp/ses-tests.el +++ b/test/lisp/ses-tests.el @@ -24,6 +24,10 @@ (require 'ert) (require 'ses) +;; Silence byte-compiler. +(with-suppressed-warnings ((lexical A2) (lexical A3)) + (defvar A2) + (defvar A3)) ;; PLAIN FORMULA TESTS ;; ====================================================================== diff --git a/test/lisp/so-long-tests/so-long-tests.el b/test/lisp/so-long-tests/so-long-tests.el index 7eee345aadd..cda5ae497fd 100644 --- a/test/lisp/so-long-tests/so-long-tests.el +++ b/test/lisp/so-long-tests/so-long-tests.el @@ -32,7 +32,7 @@ ;; Running manually: ;; ;; for test in lisp/so-long-tests/*-tests.el; do make ${test%.el}; done \ -;; 2>&1 | egrep -v '^(Loading|Source file|make|Changed to so-long-mode)' +;; 2>&1 | grep -E -v '^(Loading|Source file|make|Changed to so-long-mode)' ;; ;; Which is equivalent to: ;; @@ -41,7 +41,7 @@ ;; "../src/emacs" --no-init-file --no-site-file --no-site-lisp \ ;; -L ":." -l ert -l "$test" --batch --eval \ ;; '(ert-run-tests-batch-and-exit (quote (not (tag :unstable))))'; \ -;; done 2>&1 | egrep -v '^(Loading|Source file|Changed to so-long-mode)' +;; done 2>&1 | grep -E -v '^(Loading|Source file|Changed to so-long-mode)' ;; ;; See also `ert-run-tests-batch-and-exit'. diff --git a/test/lisp/so-long-tests/spelling-tests.el b/test/lisp/so-long-tests/spelling-tests.el index f778b646635..b598366ba7a 100644 --- a/test/lisp/so-long-tests/spelling-tests.el +++ b/test/lisp/so-long-tests/spelling-tests.el @@ -23,6 +23,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'ispell) (require 'cl-lib) @@ -50,20 +51,19 @@ ;; The Emacs test Makefile's use of HOME=/nonexistent triggers an error ;; when starting the inferior ispell process, so we set HOME to a valid ;; (but empty) temporary directory for this test. - (let* ((tmpdir (make-temp-file "so-long." :dir ".ispell")) - (process-environment (cons (format "HOME=%s" tmpdir) - process-environment)) - (find-spelling-mistake - (unwind-protect - (cl-letf (((symbol-function 'ispell-command-loop) - (lambda (_miss _guess word _start _end) - (message "Unrecognised word: %s." word) - (throw 'mistake t)))) - (catch 'mistake - (find-library "so-long") - (ispell-buffer) - nil)) - (delete-directory tmpdir)))) - (should (not find-spelling-mistake))))) + (ert-with-temp-file tmpdir + :suffix "so-long.ispell" + (let* ((process-environment (cons (format "HOME=%s" tmpdir) + process-environment)) + (find-spelling-mistake + (cl-letf (((symbol-function 'ispell-command-loop) + (lambda (_miss _guess word _start _end) + (message "Unrecognised word: %s." word) + (throw 'mistake t)))) + (catch 'mistake + (find-library "so-long") + (ispell-buffer) + nil)))) + (should (not find-spelling-mistake)))))) ;;; spelling-tests.el ends here diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index 0da1ae96873..063c6fe6a7b 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -84,16 +84,237 @@ ;;;; Keymap support. (ert-deftest subr-test-kbd () + (should (equal (kbd "") "")) (should (equal (kbd "f") "f")) + (should (equal (kbd "X") "X")) + (should (equal (kbd "foobar") "foobar")) ; 6 characters + (should (equal (kbd "return") "return")) ; 6 characters + + (should (equal (kbd "<F2>") [F2])) + (should (equal (kbd "<f1> <f2> TAB") [f1 f2 ?\t])) + (should (equal (kbd "<f1> RET") [f1 ?\r])) + (should (equal (kbd "<f1> SPC") [f1 ? ])) (should (equal (kbd "<f1>") [f1])) - (should (equal (kbd "RET") "\C-m")) + (should (equal (kbd "<f1>") [f1])) + (should (equal (kbd "[f1]") "[f1]")) + (should (equal (kbd "<return>") [return])) + (should (equal (kbd "< right >") "<right>")) ; 7 characters + + ;; Modifiers: + (should (equal (kbd "C-x") "\C-x")) (should (equal (kbd "C-x a") "\C-xa")) - ;; Check that kbd handles both new and old style key descriptions - ;; (bug#45536). + (should (equal (kbd "C-;") [?\C-\;])) + (should (equal (kbd "C-a") "\C-a")) + (should (equal (kbd "C-c SPC") "\C-c ")) + (should (equal (kbd "C-c TAB") "\C-c\t")) + (should (equal (kbd "C-c c") "\C-cc")) + (should (equal (kbd "C-x 4 C-f") "\C-x4\C-f")) + (should (equal (kbd "C-x C-f") "\C-x\C-f")) + (should (equal (kbd "C-M-<down>") [C-M-down])) + (should (equal (kbd "<C-M-down>") [C-M-down])) + (should (equal (kbd "C-RET") [?\C-\C-m])) + (should (equal (kbd "C-SPC") [?\C- ])) + (should (equal (kbd "C-TAB") [?\C-\t])) + (should (equal (kbd "C-<down>") [C-down])) + (should (equal (kbd "C-c C-c C-c") "\C-c\C-c\C-c")) + + (should (equal (kbd "M-a") [?\M-a])) + (should (equal (kbd "M-<DEL>") [?\M-\d])) + (should (equal (kbd "M-C-a") [?\M-\C-a])) + (should (equal (kbd "M-ESC") [?\M-\e])) + (should (equal (kbd "M-RET") [?\M-\r])) + (should (equal (kbd "M-SPC") [?\M- ])) + (should (equal (kbd "M-TAB") [?\M-\t])) + (should (equal (kbd "M-x a") [?\M-x ?a])) + (should (equal (kbd "M-<up>") [M-up])) + (should (equal (kbd "M-c M-c M-c") [?\M-c ?\M-c ?\M-c])) + + (should (equal (kbd "s-SPC") [?\s- ])) + (should (equal (kbd "s-a") [?\s-a])) + (should (equal (kbd "s-x a") [?\s-x ?a])) + (should (equal (kbd "s-c s-c s-c") [?\s-c ?\s-c ?\s-c])) + + (should (equal (kbd "S-H-a") [?\S-\H-a])) + (should (equal (kbd "S-a") [?\S-a])) + (should (equal (kbd "S-x a") [?\S-x ?a])) + (should (equal (kbd "S-c S-c S-c") [?\S-c ?\S-c ?\S-c])) + + (should (equal (kbd "H-<RET>") [?\H-\r])) + (should (equal (kbd "H-DEL") [?\H-\d])) + (should (equal (kbd "H-a") [?\H-a])) + (should (equal (kbd "H-x a") [?\H-x ?a])) + (should (equal (kbd "H-c H-c H-c") [?\H-c ?\H-c ?\H-c])) + + (should (equal (kbd "A-H-a") [?\A-\H-a])) + (should (equal (kbd "A-SPC") [?\A- ])) + (should (equal (kbd "A-TAB") [?\A-\t])) + (should (equal (kbd "A-a") [?\A-a])) + (should (equal (kbd "A-c A-c A-c") [?\A-c ?\A-c ?\A-c])) + + (should (equal (kbd "C-M-a") [?\C-\M-a])) + (should (equal (kbd "C-M-<up>") [C-M-up])) + + ;; Special characters. + (should (equal (kbd "DEL") "\d")) + (should (equal (kbd "ESC C-a") "\e\C-a")) + (should (equal (kbd "ESC") "\e")) + (should (equal (kbd "LFD") "\n")) + (should (equal (kbd "NUL") "\0")) + (should (equal (kbd "RET") "\C-m")) + (should (equal (kbd "SPC") "\s")) + (should (equal (kbd "TAB") "\t")) + (should (equal (kbd "\^i") "")) + (should (equal (kbd "^M") "\^M")) + + ;; With numbers. + (should (equal (kbd "\177") "\^?")) + (should (equal (kbd "\000") "\0")) + (should (equal (kbd "\\177") "\^?")) + (should (equal (kbd "\\000") "\0")) + (should (equal (kbd "C-x \\150") "\C-xh")) + + ;; Multibyte + (should (equal (kbd "ñ") [?ñ])) + (should (equal (kbd "ü") [?ü])) + (should (equal (kbd "ö") [?ö])) + (should (equal (kbd "ğ") [?ğ])) + (should (equal (kbd "ա") [?ա])) + (should (equal (kbd "üüöö") [?ü ?ü ?ö ?ö])) + (should (equal (kbd "C-ü") [?\C-ü])) + (should (equal (kbd "M-ü") [?\M-ü])) + (should (equal (kbd "H-ü") [?\H-ü])) + + ;; Handle both new and old style key descriptions (bug#45536). (should (equal (kbd "s-<return>") [s-return])) (should (equal (kbd "<s-return>") [s-return])) (should (equal (kbd "C-M-<return>") [C-M-return])) - (should (equal (kbd "<C-M-return>") [C-M-return]))) + (should (equal (kbd "<C-M-return>") [C-M-return])) + + ;; Error. + (should-error (kbd "C-xx")) + (should-error (kbd "M-xx")) + (should-error (kbd "M-x<TAB>")) + + ;; These should be equivalent: + (should (equal (kbd "\C-xf") (kbd "C-x f")))) + +(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 (key-valid-p "<F2>")) + (should (key-valid-p "<f1> <f2> TAB")) + (should (key-valid-p "<f1> RET")) + (should (key-valid-p "<f1> SPC")) + (should (key-valid-p "<f1>")) + (should (not (key-valid-p "[f1]"))) + (should (key-valid-p "<return>")) + (should (not (key-valid-p "< right >"))) + + ;; Modifiers: + (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-<down>")) + (should (not (key-valid-p "<C-M-down>"))) + (should (key-valid-p "C-RET")) + (should (key-valid-p "C-SPC")) + (should (key-valid-p "C-TAB")) + (should (key-valid-p "C-<down>")) + (should (key-valid-p "C-c C-c C-c")) + + (should (key-valid-p "M-a")) + (should (key-valid-p "M-<DEL>")) + (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-<up>")) + (should (key-valid-p "M-c M-c M-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 (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 (key-valid-p "H-<RET>")) + (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 (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 (key-valid-p "C-M-a")) + (should (key-valid-p "C-M-<up>")) + + ;; Special characters. + (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 (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 (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 (key-valid-p "s-<return>")) + (should (not (key-valid-p "<s-return>"))) + (should (key-valid-p "C-M-<return>")) + (should (not (key-valid-p "<C-M-return>"))) + + (should (key-valid-p "<mouse-1>")) + (should (key-valid-p "<Scroll_Lock>")) + + (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<TAB>")))) (ert-deftest subr-test-define-prefix-command () (define-prefix-command 'foo-prefix-map) @@ -390,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 ." @@ -704,6 +926,7 @@ See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19350." (should-not (apropos-internal "^next-line$" #'keymapp))) +(defvar test-global-boundp) (ert-deftest test-buffer-local-boundp () (let ((buf (generate-new-buffer "boundp"))) (with-current-buffer buf @@ -776,7 +999,8 @@ mode runs the hook ‘foo-bar-baz-very-long-name-indeed-mode-hook’, as the fin or penultimate step during initialization.")) "In addition to any hooks its parent mode might have run, this mode runs the hook ‘foo-bar-baz-very-long-name-indeed-mode-hook’, as the -final or penultimate step during initialization."))) +final or penultimate step during initialization.")) + (should-error (internal--format-docstring-line "foo\nbar"))) (ert-deftest test-ensure-list () (should (equal (ensure-list nil) nil)) diff --git a/test/lisp/tar-mode-tests.el b/test/lisp/tar-mode-tests.el index 6964d423185..2e0d1529a57 100644 --- a/test/lisp/tar-mode-tests.el +++ b/test/lisp/tar-mode-tests.el @@ -32,7 +32,8 @@ (cons 1024 "-----S---") (cons 2048 "--S------")))) (dolist (x alist) - (should (equal (cdr x) (tar-grind-file-mode (car x))))))) + (with-suppressed-warnings ((obsolete tar-grind-file-mode)) + (should (equal (cdr x) (tar-grind-file-mode (car x)))))))) (ert-deftest tar-mode-test-tar-extract-gz () (skip-unless (executable-find "gzip")) diff --git a/test/lisp/term-tests.el b/test/lisp/term-tests.el index 96b6d734882..73d39cf3b66 100644 --- a/test/lisp/term-tests.el +++ b/test/lisp/term-tests.el @@ -42,36 +42,50 @@ `( :foreground "unspecified-fg" :background ,(face-background 'term-color-bright-yellow nil 'default) :inverse-video nil)) +(defvar custom-color-fg-props + `( :foreground "#87FFFF" + :background "unspecified-bg" :inverse-video nil)) (defvar ansi-test-strings `(("\e[33mHello World\e[0m" - ,(propertize "Hello World" 'font-lock-face yellow-fg-props)) + ,(propertize "Hello World" 'font-lock-face `(,yellow-fg-props))) ("\e[43mHello World\e[0m" - ,(propertize "Hello World" 'font-lock-face yellow-bg-props)) + ,(propertize "Hello World" 'font-lock-face `(,yellow-bg-props))) ("\e[93mHello World\e[0m" - ,(propertize "Hello World" 'font-lock-face bright-yellow-fg-props)) + ,(propertize "Hello World" 'font-lock-face `(,bright-yellow-fg-props))) ("\e[103mHello World\e[0m" - ,(propertize "Hello World" 'font-lock-face bright-yellow-bg-props)) + ,(propertize "Hello World" 'font-lock-face `(,bright-yellow-bg-props))) ("\e[1;33mHello World\e[0m" ,(propertize "Hello World" 'font-lock-face - `(,yellow-fg-props :inherit term-bold)) + `(,yellow-fg-props term-bold)) ,(propertize "Hello World" 'font-lock-face - `(,bright-yellow-fg-props :inherit term-bold))) + `(,bright-yellow-fg-props term-bold))) ("\e[33;1mHello World\e[0m" ,(propertize "Hello World" 'font-lock-face - `(,yellow-fg-props :inherit term-bold)) + `(,yellow-fg-props term-bold)) ,(propertize "Hello World" 'font-lock-face - `(,bright-yellow-fg-props :inherit term-bold))) + `(,bright-yellow-fg-props term-bold))) ("\e[1m\e[33mHello World\e[0m" ,(propertize "Hello World" 'font-lock-face - `(,yellow-fg-props :inherit term-bold)) + `(,yellow-fg-props term-bold)) ,(propertize "Hello World" 'font-lock-face - `(,bright-yellow-fg-props :inherit term-bold))) + `(,bright-yellow-fg-props term-bold))) ("\e[33m\e[1mHello World\e[0m" ,(propertize "Hello World" 'font-lock-face - `(,yellow-fg-props :inherit term-bold)) + `(,yellow-fg-props term-bold)) + ,(propertize "Hello World" 'font-lock-face + `(,bright-yellow-fg-props term-bold))) + ("\e[38;5;3;1mHello World\e[0m" + ,(propertize "Hello World" 'font-lock-face + `(,yellow-fg-props term-bold)) + ,(propertize "Hello World" 'font-lock-face + `(,bright-yellow-fg-props term-bold))) + ("\e[38;5;123;1mHello World\e[0m" + ,(propertize "Hello World" 'font-lock-face + `(,custom-color-fg-props term-bold))) + ("\e[38;2;135;255;255;1mHello World\e[0m" ,(propertize "Hello World" 'font-lock-face - `(,bright-yellow-fg-props :inherit term-bold))))) + `(,custom-color-fg-props term-bold))))) (defun term-test-screen-from-input (width height input &optional return-var) (with-temp-buffer diff --git a/test/lisp/textmodes/fill-tests.el b/test/lisp/textmodes/fill-tests.el index fcc2c757091..2a1195b87ea 100644 --- a/test/lisp/textmodes/fill-tests.el +++ b/test/lisp/textmodes/fill-tests.el @@ -76,6 +76,28 @@ (buffer-string) "aaa = baaaaaaaa aaaaaaaaaa\n aaaaaaaaaa\n"))))) +(ert-deftest test-fill-end-period () + (should + (equal + (with-temp-buffer + (text-mode) + (auto-fill-mode) + (insert "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eius.") + (self-insert-command 1 ?\s) + (buffer-string)) + "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eius. ")) + (should + (equal + (with-temp-buffer + (text-mode) + (auto-fill-mode) + (insert "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eius.Foo") + (forward-char -3) + (self-insert-command 1 ?\s) + (buffer-string)) + "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do +eius. Foo"))) + (provide 'fill-tests) ;;; fill-tests.el ends here diff --git a/test/lisp/textmodes/reftex-tests.el b/test/lisp/textmodes/reftex-tests.el index b824e05f6d5..cc5b23e1c9c 100644 --- a/test/lisp/textmodes/reftex-tests.el +++ b/test/lisp/textmodes/reftex-tests.el @@ -24,6 +24,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) ;;; reftex (require 'reftex) @@ -33,32 +34,31 @@ (ert-deftest reftex-locate-bibliography-files () "Test `reftex-locate-bibliography-files'." - (let ((temp-dir (make-temp-file "reftex-bib" 'dir)) - (files '("ref1.bib" "ref2.bib")) - (test '(("\\addbibresource{ref1.bib}\n" . ("ref1.bib")) - ("\\\\addbibresource[label=x]{ref2.bib}\\n" . ("ref2.bib")) - ("\\begin{document}\n\\bibliographystyle{plain}\n + (ert-with-temp-directory temp-dir + (let ((files '("ref1.bib" "ref2.bib")) + (test '(("\\addbibresource{ref1.bib}\n" . ("ref1.bib")) + ("\\\\addbibresource[label=x]{ref2.bib}\\n" . ("ref2.bib")) + ("\\begin{document}\n\\bibliographystyle{plain}\n \\bibliography{ref1,ref2}\n\\end{document}" . ("ref1.bib" "ref2.bib")))) - (reftex-bibliography-commands - ;; Default value: See reftex-vars.el `reftex-bibliography-commands' - '("bibliography" "nobibliography" "setupbibtex\\[.*?database=" - "addbibresource"))) - (with-temp-buffer - (insert "test\n") + (reftex-bibliography-commands + ;; Default value: See reftex-vars.el `reftex-bibliography-commands' + '("bibliography" "nobibliography" "setupbibtex\\[.*?database=" + "addbibresource"))) + (with-temp-buffer + (insert "test\n") + (mapc + (lambda (file) + (write-region (point-min) (point-max) (expand-file-name file + temp-dir))) + files)) (mapc - (lambda (file) - (write-region (point-min) (point-max) (expand-file-name file - temp-dir))) - files)) - (mapc - (lambda (data) - (with-temp-buffer - (insert (car data)) - (let ((res (mapcar #'file-name-nondirectory - (reftex-locate-bibliography-files temp-dir)))) - (should (equal res (cdr data)))))) - test) - (delete-directory temp-dir 'recursive))) + (lambda (data) + (with-temp-buffer + (insert (car data)) + (let ((res (mapcar #'file-name-nondirectory + (reftex-locate-bibliography-files temp-dir)))) + (should (equal res (cdr data)))))) + test)))) (ert-deftest reftex-what-environment-test () "Test `reftex-what-environment'." @@ -102,12 +102,12 @@ ;; reason. (An alternative solution would be to use file-equal-p, ;; but I'm too lazy to do that, as one of the tests compares a ;; list.) - (let* ((temp-dir (file-truename (make-temp-file "reftex-parse" 'dir))) - (tex-file (expand-file-name "test.tex" temp-dir)) - (bib-file (expand-file-name "ref.bib" temp-dir))) - (with-temp-buffer - (insert -"\\begin{document} + (ert-with-temp-directory temp-dir + (let* ((tex-file (expand-file-name "test.tex" temp-dir)) + (bib-file (expand-file-name "ref.bib" temp-dir))) + (with-temp-buffer + (insert + "\\begin{document} \\section{test}\\label{sec:test} \\subsection{subtest} @@ -118,27 +118,26 @@ \\bibliographystyle{plain} \\bibliography{ref} \\end{document}") - (write-region (point-min) (point-max) tex-file)) - (with-temp-buffer - (insert "test\n") - (write-region (point-min) (point-max) bib-file)) - (reftex-ensure-compiled-variables) - (let ((parsed (reftex-parse-from-file tex-file nil temp-dir))) - (should (equal (car parsed) `(eof ,tex-file))) - (pop parsed) - (while parsed - (let ((entry (pop parsed))) - (cond - ((eq (car entry) 'bib) - (should (string= (cadr entry) bib-file))) - ((eq (car entry) 'toc)) ;; ... - ((string= (car entry) "eq:foo")) - ((string= (car entry) "sec:test")) - ((eq (car entry) 'bof) - (should (string= (cadr entry) tex-file)) - (should (null parsed))) - (t (should-not t))))) - (delete-directory temp-dir 'recursive)))) + (write-region (point-min) (point-max) tex-file)) + (with-temp-buffer + (insert "test\n") + (write-region (point-min) (point-max) bib-file)) + (reftex-ensure-compiled-variables) + (let ((parsed (reftex-parse-from-file tex-file nil temp-dir))) + (should (equal (car parsed) `(eof ,tex-file))) + (pop parsed) + (while parsed + (let ((entry (pop parsed))) + (cond + ((eq (car entry) 'bib) + (should (string= (cadr entry) bib-file))) + ((eq (car entry) 'toc)) ;; ... + ((string= (car entry) "eq:foo")) + ((string= (car entry) "sec:test")) + ((eq (car entry) 'bof) + (should (string= (cadr entry) tex-file)) + (should (null parsed))) + (t (should-not t))))))))) ;;; reftex-cite (require 'reftex-cite) diff --git a/test/lisp/textmodes/texinfo-resources/fill.erts b/test/lisp/textmodes/texinfo-resources/fill.erts new file mode 100644 index 00000000000..95f3b09eba8 --- /dev/null +++ b/test/lisp/textmodes/texinfo-resources/fill.erts @@ -0,0 +1,70 @@ +Code: + (lambda () + (texinfo-mode) + (fill-paragraph)) + +Name: fill1 +Point-Char: | + +=-= +@noindent Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. +=-= +@noindent Everyone is permitted to copy and distribute verbatim copies +of this license document, but changing it is not allowed. +=-=-= + +Name: fill2 +Point-Char: | + +=-= +@cindex relative| remapping, faces +@cindex base remapping, faces + The following functions implement a higher-level interface to @code{face-remapping-alist}. +=-=-= + + +Name: fill3 +Point-Char: | + +=-= +@cindex relative remapping, faces +@cindex base remapping, faces| + The following functions implement a higher-level interface to @code{face-remapping-alist}. +=-=-= + +Name: fill4 +Point-Char: | + +=-= +@cindex relative remapping, faces +@cindex base remapping, faces + The following functions| implement a higher-level interface to @code{face-remapping-alist}. +=-= +@cindex relative remapping, faces +@cindex base remapping, faces + The following functions| implement a higher-level interface to +@code{face-remapping-alist}. +=-=-= + +Name: fill5 +Point-Char: | + +=-= +@defun face-remap-add-relative face &rest specs +|This function adds the face spec in @var{specs} as relative +remappings for face @var{face} in the current buffer. The remaining +arguments, @var{specs}, should form either a list of face names, or a +property list of attribute/value pairs. +=-= +@defun face-remap-add-relative face &rest specs +This function adds the face spec in @var{specs} as relative remappings +for face @var{face} in the current buffer. The remaining arguments, +@var{specs}, should form either a list of face names, or a property +list of attribute/value pairs. +=-=-= + +Name: fill6 + +=-= +@subsection This is a very very very very very very very very very very long subsection name +=-=-= diff --git a/test/lisp/textmodes/texinfo-tests.el b/test/lisp/textmodes/texinfo-tests.el new file mode 100644 index 00000000000..fa0c4de005e --- /dev/null +++ b/test/lisp/textmodes/texinfo-tests.el @@ -0,0 +1,33 @@ +;;; texinfo-tests.el --- Tests for texinfo.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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'texinfo) +(require 'ert) +(require 'ert-x) + +(ert-deftest test-filling () + (ert-test-erts-file (ert-resource-file "fill.erts"))) + +;;; texinfo-tests.el ends here diff --git a/test/lisp/thingatpt-tests.el b/test/lisp/thingatpt-tests.el index dc108c77c5c..1df1b8079e5 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/thumbs-tests.el b/test/lisp/thumbs-tests.el index ee096138453..a9b41d7c00f 100644 --- a/test/lisp/thumbs-tests.el +++ b/test/lisp/thumbs-tests.el @@ -20,15 +20,13 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'thumbs) (ert-deftest thumbs-tests-thumbsdir/create-if-missing () - (let ((thumbs-thumbsdir (make-temp-file "thumbs-test" t))) - (unwind-protect - (progn - (delete-directory thumbs-thumbsdir) - (should (file-directory-p (thumbs-thumbsdir)))) - (delete-directory thumbs-thumbsdir)))) + (ert-with-temp-directory thumbs-thumbsdir + (delete-directory thumbs-thumbsdir) + (should (file-directory-p (thumbs-thumbsdir))))) (provide 'thumbs-tests) ;;; thumbs-tests.el ends here 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/vc/diff-mode-tests.el b/test/lisp/vc/diff-mode-tests.el index ef19fe0e0e8..909d5620de6 100644 --- a/test/lisp/vc/diff-mode-tests.el +++ b/test/lisp/vc/diff-mode-tests.el @@ -173,35 +173,33 @@ wristwatches wrongheadedly wrongheadedness youthfulness -") - (temp-dir (make-temp-file "diff-mode-test" 'dir))) - - (let ((buf (find-file-noselect (format "%s/%s" temp-dir "fil" ))) - (buf2 (find-file-noselect (format "%s/%s" temp-dir "fil2")))) - (unwind-protect - (progn - (with-current-buffer buf (insert fil_before) (save-buffer)) - (with-current-buffer buf2 (insert fil2_before) (save-buffer)) - - (with-temp-buffer - (cd temp-dir) - (insert patch) - (goto-char (point-min)) - (diff-apply-hunk) - (diff-apply-hunk) - (diff-apply-hunk)) - - (should (equal (with-current-buffer buf (buffer-string)) - fil_after)) - (should (equal (with-current-buffer buf2 (buffer-string)) - fil2_after))) - - (ignore-errors - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf) - (with-current-buffer buf2 (set-buffer-modified-p nil)) - (kill-buffer buf2) - (delete-directory temp-dir 'recursive)))))) +")) + (ert-with-temp-directory temp-dir + (let ((buf (find-file-noselect (format "%s/%s" temp-dir "fil" ))) + (buf2 (find-file-noselect (format "%s/%s" temp-dir "fil2")))) + (unwind-protect + (progn + (with-current-buffer buf (insert fil_before) (save-buffer)) + (with-current-buffer buf2 (insert fil2_before) (save-buffer)) + + (with-temp-buffer + (cd temp-dir) + (insert patch) + (goto-char (point-min)) + (diff-apply-hunk) + (diff-apply-hunk) + (diff-apply-hunk)) + + (should (equal (with-current-buffer buf (buffer-string)) + fil_after)) + (should (equal (with-current-buffer buf2 (buffer-string)) + fil2_after))) + + (ignore-errors + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf) + (with-current-buffer buf2 (set-buffer-modified-p nil)) + (kill-buffer buf2))))))) (ert-deftest diff-mode-test-hunk-text-no-newline () "Check output of `diff-hunk-text' with no newline at end of file." diff --git a/test/lisp/vc/ediff-ptch-tests.el b/test/lisp/vc/ediff-ptch-tests.el index a464db2349d..0f09616a816 100644 --- a/test/lisp/vc/ediff-ptch-tests.el +++ b/test/lisp/vc/ediff-ptch-tests.el @@ -22,6 +22,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'ediff-ptch) (ert-deftest ediff-ptch-test-bug25010 () @@ -45,34 +46,33 @@ index 6a07f80..6e8e947 100644 "Test for https://debbugs.gnu.org/26084 ." (skip-unless (executable-find "git")) (skip-unless (executable-find ediff-patch-program)) - (let* ((tmpdir (make-temp-file "ediff-ptch-test" t)) - (default-directory (file-name-as-directory tmpdir)) - (patch (make-temp-file "ediff-ptch-test")) - (qux (expand-file-name "qux.txt" tmpdir)) - (bar (expand-file-name "bar.txt" tmpdir)) - (git-program (executable-find "git"))) - ;; Create repository. - (with-temp-buffer - (insert "qux here\n") - (write-region nil nil qux nil 'silent) - (erase-buffer) - (insert "bar here\n") - (write-region nil nil bar nil 'silent)) - (call-process git-program nil nil nil "init") - (call-process git-program nil nil nil "add" ".") - (call-process git-program nil nil nil "commit" "-m" "Test repository.") - ;; Update repo., save the diff and reset to initial state. - (with-temp-buffer - (insert "foo here\n") - (write-region nil nil qux nil 'silent) - (write-region nil nil bar nil 'silent)) - (call-process git-program nil `(:file ,patch) nil "diff") - (call-process git-program nil nil nil "reset" "--hard" "HEAD") - ;; Visit the diff file i.e., patch; extract from it the parts - ;; affecting just each of the files: store in patch-bar the part - ;; affecting 'bar', and in patch-qux the part affecting 'qux'. - (find-file patch) - (unwind-protect + (ert-with-temp-directory tmpdir + (ert-with-temp-file patch + (let* ((default-directory (file-name-as-directory tmpdir)) + (qux (expand-file-name "qux.txt" tmpdir)) + (bar (expand-file-name "bar.txt" tmpdir)) + (git-program (executable-find "git"))) + ;; Create repository. + (with-temp-buffer + (insert "qux here\n") + (write-region nil nil qux nil 'silent) + (erase-buffer) + (insert "bar here\n") + (write-region nil nil bar nil 'silent)) + (call-process git-program nil nil nil "init") + (call-process git-program nil nil nil "add" ".") + (call-process git-program nil nil nil "commit" "-m" "Test repository.") + ;; Update repo., save the diff and reset to initial state. + (with-temp-buffer + (insert "foo here\n") + (write-region nil nil qux nil 'silent) + (write-region nil nil bar nil 'silent)) + (call-process git-program nil `(:file ,patch) nil "diff") + (call-process git-program nil nil nil "reset" "--hard" "HEAD") + ;; Visit the diff file i.e., patch; extract from it the parts + ;; affecting just each of the files: store in patch-bar the part + ;; affecting 'bar', and in patch-qux the part affecting 'qux'. + (find-file patch) (let* ((info (progn (ediff-map-patch-buffer (current-buffer)) ediff-patch-map)) (patch-bar @@ -116,9 +116,7 @@ index 6a07f80..6e8e947 100644 (buffer-string)) (with-temp-buffer (insert-file-contents backup) - (buffer-string))))))) - (delete-directory tmpdir 'recursive) - (delete-file patch))))) + (buffer-string)))))))))))) (provide 'ediff-ptch-tests) diff --git a/test/lisp/vc/vc-bzr-tests.el b/test/lisp/vc/vc-bzr-tests.el index 43385de5955..afced819fbc 100644 --- a/test/lisp/vc/vc-bzr-tests.el +++ b/test/lisp/vc/vc-bzr-tests.el @@ -25,6 +25,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'vc-bzr) (require 'vc-dir) @@ -51,106 +52,97 @@ ;; temporary directory. ;; TODO does this means tests should be setting XDG_ variables (not ;; just HOME) to temporary values too? - (let* ((homedir (make-temp-file "vc-bzr-test" t)) - (bzrdir (expand-file-name "bzr" homedir)) - (ignored-dir (progn - (make-directory bzrdir) - (expand-file-name "ignored-dir" bzrdir))) - (default-directory (file-name-as-directory bzrdir)) - (process-environment (cons (format "HOME=%s" homedir) - process-environment))) - (unwind-protect - (progn - (make-directory ignored-dir) - (with-temp-buffer - (insert (file-name-nondirectory ignored-dir)) - (write-region nil nil (expand-file-name ".bzrignore" bzrdir) - nil 'silent)) - (skip-unless (eq 0 ; some internal bzr error - (call-process vc-bzr-program nil nil nil "init"))) - (call-process vc-bzr-program nil nil nil "add") - (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1") - (with-temp-buffer - (insert "unregistered file") - (write-region nil nil (expand-file-name "testfile2" ignored-dir) - nil 'silent)) - (vc-dir ignored-dir) - (while (vc-dir-busy) - (sit-for 0.1)) - ;; FIXME better to explicitly test for error from process sentinel. - (with-current-buffer "*vc-dir*" - (goto-char (point-min)) - (should (search-forward "unregistered" nil t)))) - (delete-directory homedir t)))) + (ert-with-temp-directory homedir + (let* ((bzrdir (expand-file-name "bzr" homedir)) + (ignored-dir (progn + (make-directory bzrdir) + (expand-file-name "ignored-dir" bzrdir))) + (default-directory (file-name-as-directory bzrdir)) + (process-environment (cons (format "HOME=%s" homedir) + process-environment))) + (make-directory ignored-dir) + (with-temp-buffer + (insert (file-name-nondirectory ignored-dir)) + (write-region nil nil (expand-file-name ".bzrignore" bzrdir) + nil 'silent)) + (skip-unless (eq 0 ; some internal bzr error + (call-process vc-bzr-program nil nil nil "init"))) + (call-process vc-bzr-program nil nil nil "add") + (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1") + (with-temp-buffer + (insert "unregistered file") + (write-region nil nil (expand-file-name "testfile2" ignored-dir) + nil 'silent)) + (vc-dir ignored-dir) + (while (vc-dir-busy) + (sit-for 0.1)) + ;; FIXME better to explicitly test for error from process sentinel. + (with-current-buffer "*vc-dir*" + (goto-char (point-min)) + (should (search-forward "unregistered" nil t)))))) ;; Not specific to bzr. (ert-deftest vc-bzr-test-bug9781 () "Test for https://debbugs.gnu.org/9781 ." (skip-unless (executable-find vc-bzr-program)) - (let* ((homedir (make-temp-file "vc-bzr-test" t)) - (bzrdir (expand-file-name "bzr" homedir)) - (subdir (progn - (make-directory bzrdir) - (expand-file-name "subdir" bzrdir))) - (file (expand-file-name "file" bzrdir)) - (default-directory (file-name-as-directory bzrdir)) - (process-environment (cons (format "HOME=%s" homedir) - process-environment))) - (unwind-protect - (progn - (skip-unless (eq 0 ; some internal bzr error - (call-process vc-bzr-program nil nil nil "init"))) - (make-directory subdir) - (with-temp-buffer - (insert "text") - (write-region nil nil file nil 'silent) - (write-region nil nil (expand-file-name "subfile" subdir) - nil 'silent)) - (call-process vc-bzr-program nil nil nil "add") - (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1") - (call-process vc-bzr-program nil nil nil "remove" subdir) - (with-temp-buffer - (insert "different text") - (write-region nil nil file nil 'silent)) - (vc-dir bzrdir) - (while (vc-dir-busy) - (sit-for 0.1)) - (vc-dir-mark-all-files t) - (cl-letf (((symbol-function 'y-or-n-p) (lambda (_) t))) - (vc-next-action nil)) - (should (get-buffer "*vc-log*"))) - (delete-directory homedir t)))) + (ert-with-temp-directory homedir + (let* ((bzrdir (expand-file-name "bzr" homedir)) + (subdir (progn + (make-directory bzrdir) + (expand-file-name "subdir" bzrdir))) + (file (expand-file-name "file" bzrdir)) + (default-directory (file-name-as-directory bzrdir)) + (process-environment (cons (format "HOME=%s" homedir) + process-environment))) + (skip-unless (eq 0 ; some internal bzr error + (call-process vc-bzr-program nil nil nil "init"))) + (make-directory subdir) + (with-temp-buffer + (insert "text") + (write-region nil nil file nil 'silent) + (write-region nil nil (expand-file-name "subfile" subdir) + nil 'silent)) + (call-process vc-bzr-program nil nil nil "add") + (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1") + (call-process vc-bzr-program nil nil nil "remove" subdir) + (with-temp-buffer + (insert "different text") + (write-region nil nil file nil 'silent)) + (vc-dir bzrdir) + (while (vc-dir-busy) + (sit-for 0.1)) + (vc-dir-mark-all-files t) + (cl-letf (((symbol-function 'y-or-n-p) (lambda (_) t))) + (vc-next-action nil)) + (should (get-buffer "*vc-log*"))))) ;; https://lists.gnu.org/r/help-gnu-emacs/2012-04/msg00145.html (ert-deftest vc-bzr-test-faulty-bzr-autoloads () "Test we can generate autoloads in a bzr directory when bzr is faulty." (skip-unless (executable-find vc-bzr-program)) - (let* ((homedir (make-temp-file "vc-bzr-test" t)) - (bzrdir (expand-file-name "bzr" homedir)) - (file (progn - (make-directory bzrdir) - (expand-file-name "foo.el" bzrdir))) - (default-directory (file-name-as-directory bzrdir)) - (process-environment (cons (format "HOME=%s" homedir) - process-environment))) - (unwind-protect - (progn - (call-process vc-bzr-program nil nil nil "init") - (with-temp-buffer - (insert ";;;###autoload + (ert-with-temp-directory homedir + (let* ((bzrdir (expand-file-name "bzr" homedir)) + (file (progn + (make-directory bzrdir) + (expand-file-name "foo.el" bzrdir))) + (default-directory (file-name-as-directory bzrdir)) + (process-environment (cons (format "HOME=%s" homedir) + process-environment))) + (call-process vc-bzr-program nil nil nil "init") + (with-temp-buffer + (insert ";;;###autoload \(defun foo () \"foo\" (interactive) (message \"foo!\"))") - (write-region nil nil file nil 'silent)) - (call-process vc-bzr-program nil nil nil "add") - (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1") - ;; Deleting dirstate ensures both that vc-bzr's status heuristic - ;; fails, so it has to call the external bzr status, and - ;; causes bzr status to fail. This simulates a broken bzr - ;; installation. - (delete-file ".bzr/checkout/dirstate") - (should (progn (make-directory-autoloads - default-directory - (expand-file-name "loaddefs.el" bzrdir)) - t))) - (delete-directory homedir t)))) + (write-region nil nil file nil 'silent)) + (call-process vc-bzr-program nil nil nil "add") + (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1") + ;; Deleting dirstate ensures both that vc-bzr's status heuristic + ;; fails, so it has to call the external bzr status, and + ;; causes bzr status to fail. This simulates a broken bzr + ;; installation. + (delete-file ".bzr/checkout/dirstate") + (should (progn (make-directory-autoloads + default-directory + (expand-file-name "loaddefs.el" bzrdir)) + t))))) ;;; vc-bzr-tests.el ends here diff --git a/test/lisp/vc/vc-git-tests.el b/test/lisp/vc/vc-git-tests.el new file mode 100644 index 00000000000..997ab3c4b5c --- /dev/null +++ b/test/lisp/vc/vc-git-tests.el @@ -0,0 +1,67 @@ +;;; vc-git-tests.el --- tests for vc/vc-git.el -*- lexical-binding:t -*- + +;; Copyright (C) 2016-2021 Free Software Foundation, Inc. + +;; Author: Justin Schell <justinmschell@gmail.com> +;; Maintainer: emacs-devel@gnu.org + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'vc-git) + +(ert-deftest vc-git-test-program-version-general () + (vc-git-test--run-program-version-test + "git version 2.30.1.0" + "2.30.1.0")) + +(ert-deftest vc-git-test-program-version-windows () + (vc-git-test--run-program-version-test + "git version 2.30.1.1.windows.1" + "2.30.1.1")) + +(ert-deftest vc-git-test-program-version-apple () + (vc-git-test--run-program-version-test + "git version 2.30.1.2 (Apple Git-130)" + "2.30.1.2")) + +(ert-deftest vc-git-test-program-version-other () + (vc-git-test--run-program-version-test + "git version 2.30.1.3.foo.bar" + "2.30.1.3")) + +(ert-deftest vc-git-test-program-version-invalid-leading-string () + (vc-git-test--run-program-version-test + "git version foo.bar.2.30.1.4" + "0")) + +(ert-deftest vc-git-test-program-version-invalid-leading-dot () + (vc-git-test--run-program-version-test + "git version .2.30.1.5" + "0")) + +(defun vc-git-test--run-program-version-test + (mock-version-string expected-output) + (cl-letf* (((symbol-function 'vc-git--run-command-string) + (lambda (_file _args) mock-version-string)) + (vc-git--program-version nil) + (actual-output (vc-git--program-version))) + (should (equal actual-output expected-output)))) + +;;; vc-git-tests.el ends here diff --git a/test/lisp/vc/vc-tests.el b/test/lisp/vc/vc-tests.el index aa401a23914..578d7ebb418 100644 --- a/test/lisp/vc/vc-tests.el +++ b/test/lisp/vc/vc-tests.el @@ -109,6 +109,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'vc) (require 'log-edit) @@ -178,41 +179,38 @@ For backends which dont support it, it is emulated." (defun vc-test--create-repo (backend) "Create a test repository in `default-directory', a temporary directory." - - (let ((vc-handled-backends `(,backend)) - (default-directory - (file-name-as-directory - (expand-file-name - (make-temp-name "vc-test") temporary-file-directory))) - (process-environment process-environment) - tempdir - vc-test--cleanup-hook) - (when (eq backend 'Bzr) - (setq tempdir (make-temp-file "vc-test--create-repo" t) - process-environment (cons (format "BZR_HOME=%s" tempdir) - process-environment))) - - (unwind-protect - (progn - ;; Cleanup. - (add-hook - 'vc-test--cleanup-hook - `(lambda () (delete-directory ,default-directory 'recursive))) - - ;; Check the revision granularity. - (should (memq (vc-test--revision-granularity-function backend) - '(file repository))) - - ;; Create empty repository. - (make-directory default-directory) - (should (file-directory-p default-directory)) - (vc-test--create-repo-function backend) - (should (eq (vc-responsible-backend default-directory) backend))) - - ;; Save exit. - (ignore-errors - (if tempdir (delete-directory tempdir t)) - (run-hooks 'vc-test--cleanup-hook))))) + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + (process-environment process-environment) + vc-test--cleanup-hook) + (when (eq backend 'Bzr) + (setq process-environment (cons (format "BZR_HOME=%s" tempdir) + process-environment))) + + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Check the revision granularity. + (should (memq (vc-test--revision-granularity-function backend) + '(file repository))) + + ;; Create empty repository. + (make-directory default-directory) + (should (file-directory-p default-directory)) + (vc-test--create-repo-function backend) + (should (eq (vc-responsible-backend default-directory) backend))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) ;; FIXME: Why isn't there `vc-unregister'? (defun vc-test--unregister-function (backend file) @@ -235,447 +233,429 @@ Catch the `vc-not-supported' error." (defun vc-test--register (backend) "Register and unregister a file. This checks also `vc-backend' and `vc-responsible-backend'." - - (let ((vc-handled-backends `(,backend)) - (default-directory - (file-name-as-directory - (expand-file-name - (make-temp-name "vc-test") temporary-file-directory))) - (process-environment process-environment) - tempdir - vc-test--cleanup-hook) - (when (eq backend 'Bzr) - (setq tempdir (make-temp-file "vc-test--register" t) - process-environment (cons (format "BZR_HOME=%s" tempdir) - process-environment))) - (unwind-protect - (progn - ;; Cleanup. - (add-hook - 'vc-test--cleanup-hook - `(lambda () (delete-directory ,default-directory 'recursive))) - - ;; Create empty repository. - (make-directory default-directory) - (vc-test--create-repo-function backend) - ;; For file oriented backends CVS, RCS and SVN the backend is - ;; returned, and the directory is registered already. - (should (if (vc-backend default-directory) - (vc-registered default-directory) - (not (vc-registered default-directory)))) - (should (eq (vc-responsible-backend default-directory) backend)) - - (let ((tmp-name1 (expand-file-name "foo" default-directory)) - (tmp-name2 "bla")) - ;; Register files. Check for it. - (write-region "foo" nil tmp-name1 nil 'nomessage) - (should (file-exists-p tmp-name1)) - (should-not (vc-backend tmp-name1)) - (should (eq (vc-responsible-backend tmp-name1) backend)) - (should-not (vc-registered tmp-name1)) - - (write-region "bla" nil tmp-name2 nil 'nomessage) - (should (file-exists-p tmp-name2)) - (should-not (vc-backend tmp-name2)) - (should (eq (vc-responsible-backend tmp-name2) backend)) - (should-not (vc-registered tmp-name2)) - - (vc-register (list backend (list tmp-name1 tmp-name2))) - (should (file-exists-p tmp-name1)) - (should (eq (vc-backend tmp-name1) backend)) - (should (eq (vc-responsible-backend tmp-name1) backend)) - (should (vc-registered tmp-name1)) - - (should (file-exists-p tmp-name2)) - (should (eq (vc-backend tmp-name2) backend)) - (should (eq (vc-responsible-backend tmp-name2) backend)) - (should (vc-registered tmp-name2)) - - ;; `vc-backend' accepts also a list of files, - ;; `vc-responsible-backend' doesn't. - (should (vc-backend (list tmp-name1 tmp-name2))) - - ;; Unregister the files. - (unless (eq (vc-test--run-maybe-unsupported-function - 'vc-test--unregister-function backend tmp-name1) - 'vc-not-supported) + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + (process-environment process-environment) + vc-test--cleanup-hook) + (when (eq backend 'Bzr) + (setq process-environment (cons (format "BZR_HOME=%s" tempdir) + process-environment))) + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Create empty repository. + (make-directory default-directory) + (vc-test--create-repo-function backend) + ;; For file oriented backends CVS, RCS and SVN the backend is + ;; returned, and the directory is registered already. + (should (if (vc-backend default-directory) + (vc-registered default-directory) + (not (vc-registered default-directory)))) + (should (eq (vc-responsible-backend default-directory) backend)) + + (let ((tmp-name1 (expand-file-name "foo" default-directory)) + (tmp-name2 "bla")) + ;; Register files. Check for it. + (write-region "foo" nil tmp-name1 nil 'nomessage) + (should (file-exists-p tmp-name1)) (should-not (vc-backend tmp-name1)) - (should-not (vc-registered tmp-name1))) - (unless (eq (vc-test--run-maybe-unsupported-function - 'vc-test--unregister-function backend tmp-name2) - 'vc-not-supported) - (should-not (vc-backend tmp-name2)) - (should-not (vc-registered tmp-name2))) + (should (eq (vc-responsible-backend tmp-name1) backend)) + (should-not (vc-registered tmp-name1)) - ;; The files should still exist. - (should (file-exists-p tmp-name1)) - (should (file-exists-p tmp-name2)))) - - ;; Save exit. - (ignore-errors - (if tempdir (delete-directory tempdir t)) - (run-hooks 'vc-test--cleanup-hook))))) + (write-region "bla" nil tmp-name2 nil 'nomessage) + (should (file-exists-p tmp-name2)) + (should-not (vc-backend tmp-name2)) + (should (eq (vc-responsible-backend tmp-name2) backend)) + (should-not (vc-registered tmp-name2)) + + (vc-register (list backend (list tmp-name1 tmp-name2))) + (should (file-exists-p tmp-name1)) + (should (eq (vc-backend tmp-name1) backend)) + (should (eq (vc-responsible-backend tmp-name1) backend)) + (should (vc-registered tmp-name1)) + + (should (file-exists-p tmp-name2)) + (should (eq (vc-backend tmp-name2) backend)) + (should (eq (vc-responsible-backend tmp-name2) backend)) + (should (vc-registered tmp-name2)) + + ;; `vc-backend' accepts also a list of files, + ;; `vc-responsible-backend' doesn't. + (should (vc-backend (list tmp-name1 tmp-name2))) + + ;; Unregister the files. + (unless (eq (vc-test--run-maybe-unsupported-function + 'vc-test--unregister-function backend tmp-name1) + 'vc-not-supported) + (should-not (vc-backend tmp-name1)) + (should-not (vc-registered tmp-name1))) + (unless (eq (vc-test--run-maybe-unsupported-function + 'vc-test--unregister-function backend tmp-name2) + 'vc-not-supported) + (should-not (vc-backend tmp-name2)) + (should-not (vc-registered tmp-name2))) + + ;; The files should still exist. + (should (file-exists-p tmp-name1)) + (should (file-exists-p tmp-name2)))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) (defun vc-test--state (backend) "Check the different states of a file." - - (let ((vc-handled-backends `(,backend)) - (default-directory - (file-name-as-directory - (expand-file-name - (make-temp-name "vc-test") temporary-file-directory))) - (process-environment process-environment) - tempdir - vc-test--cleanup-hook) - (when (eq backend 'Bzr) - (setq tempdir (make-temp-file "vc-test--state" t) - process-environment (cons (format "BZR_HOME=%s" tempdir) - process-environment))) - (unwind-protect - (progn - ;; Cleanup. - (add-hook - 'vc-test--cleanup-hook - `(lambda () (delete-directory ,default-directory 'recursive))) - - ;; Create empty repository. - (make-directory default-directory) - (vc-test--create-repo-function backend) - - (let ((tmp-name (expand-file-name "foo" default-directory))) - ;; Check state of a nonexistent file. - - (message "vc-state2 %s" (vc-state tmp-name)) - (should (null (vc-state tmp-name))) - - ;; Write a new file. Check state. - (write-region "foo" nil tmp-name nil 'nomessage) - - ;; nil: Mtn - ;; unregistered: Bzr CVS Git Hg SVN RCS - (message "vc-state3 %s %s" backend (vc-state tmp-name backend)) - (should (memq (vc-state tmp-name backend) '(nil unregistered))) - - ;; Register a file. Check state. - (vc-register - (list backend (list (file-name-nondirectory tmp-name)))) - - ;; FIXME: nil is definitely wrong. - ;; nil: SRC - ;; added: Bzr CVS Git Hg Mtn SVN - ;; up-to-date: RCS SCCS - (message "vc-state4 %s" (vc-state tmp-name)) - (should (memq (vc-state tmp-name) '(nil added up-to-date))) - - ;; Unregister the file. Check state. - (if (eq (vc-test--run-maybe-unsupported-function - 'vc-test--unregister-function backend tmp-name) - 'vc-not-supported) - (message "vc-state5 unsupported") - ;; unregistered: Bzr Git RCS Hg - ;; unsupported: CVS Mtn SCCS SRC SVN - (message "vc-state5 %s %s" backend (vc-state tmp-name backend)) - (should (memq (vc-state tmp-name backend) - '(nil unregistered)))))) - - ;; Save exit. - (ignore-errors - (if tempdir (delete-directory tempdir t)) - (run-hooks 'vc-test--cleanup-hook))))) + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + (process-environment process-environment) + vc-test--cleanup-hook) + (when (eq backend 'Bzr) + (setq process-environment (cons (format "BZR_HOME=%s" tempdir) + process-environment))) + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Create empty repository. + (make-directory default-directory) + (vc-test--create-repo-function backend) + + (let ((tmp-name (expand-file-name "foo" default-directory))) + ;; Check state of a nonexistent file. + + (message "vc-state2 %s" (vc-state tmp-name)) + (should (null (vc-state tmp-name))) + + ;; Write a new file. Check state. + (write-region "foo" nil tmp-name nil 'nomessage) + + ;; nil: Mtn + ;; unregistered: Bzr CVS Git Hg SVN RCS + (message "vc-state3 %s %s" backend (vc-state tmp-name backend)) + (should (memq (vc-state tmp-name backend) '(nil unregistered))) + + ;; Register a file. Check state. + (vc-register + (list backend (list (file-name-nondirectory tmp-name)))) + + ;; FIXME: nil is definitely wrong. + ;; nil: SRC + ;; added: Bzr CVS Git Hg Mtn SVN + ;; up-to-date: RCS SCCS + (message "vc-state4 %s" (vc-state tmp-name)) + (should (memq (vc-state tmp-name) '(nil added up-to-date))) + + ;; Unregister the file. Check state. + (if (eq (vc-test--run-maybe-unsupported-function + 'vc-test--unregister-function backend tmp-name) + 'vc-not-supported) + (message "vc-state5 unsupported") + ;; unregistered: Bzr Git RCS Hg + ;; unsupported: CVS Mtn SCCS SRC SVN + (message "vc-state5 %s %s" backend (vc-state tmp-name backend)) + (should (memq (vc-state tmp-name backend) + '(nil unregistered)))))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) (defun vc-test--working-revision (backend) "Check the working revision of a repository." - - (let ((vc-handled-backends `(,backend)) - (default-directory - (file-name-as-directory - (expand-file-name - (make-temp-name "vc-test") temporary-file-directory))) - (process-environment process-environment) - tempdir - vc-test--cleanup-hook) - (when (eq backend 'Bzr) - (setq tempdir (make-temp-file "vc-test--working-revision" t) - process-environment (cons (format "BZR_HOME=%s" tempdir) - process-environment))) - - (unwind-protect - (progn - ;; Cleanup. - (add-hook - 'vc-test--cleanup-hook - `(lambda () (delete-directory ,default-directory 'recursive))) - - ;; Create empty repository. Check working revision of - ;; repository, should be nil. - (make-directory default-directory) - (vc-test--create-repo-function backend) - - ;; FIXME: Is the value for SVN correct? - ;; nil: Bzr CVS Git Hg Mtn RCS SCCS SRC - ;; "0": SVN - (message - "vc-working-revision1 %s" (vc-working-revision default-directory)) - (should (member (vc-working-revision default-directory) '(nil "0"))) - - (let ((tmp-name (expand-file-name "foo" default-directory))) - ;; Check initial working revision, should be nil until - ;; it's registered. - - (message "vc-working-revision2 %s" (vc-working-revision tmp-name)) - (should-not (vc-working-revision tmp-name)) - - ;; Write a new file. Check working revision. - (write-region "foo" nil tmp-name nil 'nomessage) - - (message "vc-working-revision3 %s" (vc-working-revision tmp-name)) - (should-not (vc-working-revision tmp-name)) - - ;; Register a file. Check working revision. - (vc-register - (list backend (list (file-name-nondirectory tmp-name)))) - - ;; XXX: nil is fine, at least in Git's case, because - ;; `vc-register' only makes the file `added' in this case. - ;; nil: Git Mtn - ;; "0": Bzr CVS Hg SRC SVN - ;; "1.1": RCS SCCS - ;; "-1": Hg versions before 5 (probably) - (message "vc-working-revision4 %s" (vc-working-revision tmp-name)) - (should (member (vc-working-revision tmp-name) '(nil "0" "1.1" "-1"))) - - ;; TODO: Call `vc-checkin', and check the resulting - ;; working revision. None of the return values should be - ;; nil then. - - ;; Unregister the file. Check working revision. - (if (eq (vc-test--run-maybe-unsupported-function - 'vc-test--unregister-function backend tmp-name) - 'vc-not-supported) - (message "vc-working-revision5 unsupported") - ;; nil: Bzr Git Hg RCS - ;; unsupported: CVS Mtn SCCS SRC SVN - (message "vc-working-revision5 %s" (vc-working-revision tmp-name)) - (should-not (vc-working-revision tmp-name))))) - - ;; Save exit. - (ignore-errors - (if tempdir (delete-directory tempdir t)) - (run-hooks 'vc-test--cleanup-hook))))) + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + (process-environment process-environment) + vc-test--cleanup-hook) + (when (eq backend 'Bzr) + (setq process-environment (cons (format "BZR_HOME=%s" tempdir) + process-environment))) + + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Create empty repository. Check working revision of + ;; repository, should be nil. + (make-directory default-directory) + (vc-test--create-repo-function backend) + + ;; FIXME: Is the value for SVN correct? + ;; nil: Bzr CVS Git Hg Mtn RCS SCCS SRC + ;; "0": SVN + (message + "vc-working-revision1 %s" (vc-working-revision default-directory)) + (should (member (vc-working-revision default-directory) '(nil "0"))) + + (let ((tmp-name (expand-file-name "foo" default-directory))) + ;; Check initial working revision, should be nil until + ;; it's registered. + + (message "vc-working-revision2 %s" (vc-working-revision tmp-name)) + (should-not (vc-working-revision tmp-name)) + + ;; Write a new file. Check working revision. + (write-region "foo" nil tmp-name nil 'nomessage) + + (message "vc-working-revision3 %s" (vc-working-revision tmp-name)) + (should-not (vc-working-revision tmp-name)) + + ;; Register a file. Check working revision. + (vc-register + (list backend (list (file-name-nondirectory tmp-name)))) + + ;; XXX: nil is fine, at least in Git's case, because + ;; `vc-register' only makes the file `added' in this case. + ;; nil: Git Mtn + ;; "0": Bzr CVS Hg SRC SVN + ;; "1.1": RCS SCCS + ;; "-1": Hg versions before 5 (probably) + (message "vc-working-revision4 %s" (vc-working-revision tmp-name)) + (should (member (vc-working-revision tmp-name) '(nil "0" "1.1" "-1"))) + + ;; TODO: Call `vc-checkin', and check the resulting + ;; working revision. None of the return values should be + ;; nil then. + + ;; Unregister the file. Check working revision. + (if (eq (vc-test--run-maybe-unsupported-function + 'vc-test--unregister-function backend tmp-name) + 'vc-not-supported) + (message "vc-working-revision5 unsupported") + ;; nil: Bzr Git Hg RCS + ;; unsupported: CVS Mtn SCCS SRC SVN + (message "vc-working-revision5 %s" (vc-working-revision tmp-name)) + (should-not (vc-working-revision tmp-name))))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) (defun vc-test--checkout-model (backend) "Check the checkout model of a repository." - - (let ((vc-handled-backends `(,backend)) - (default-directory - (file-name-as-directory - (expand-file-name - (make-temp-name "vc-test") temporary-file-directory))) - (process-environment process-environment) - tempdir - vc-test--cleanup-hook) - (when (eq backend 'Bzr) - (setq tempdir (make-temp-file "vc-test--checkout-model" t) - process-environment (cons (format "BZR_HOME=%s" tempdir) - process-environment))) - - (unwind-protect - (progn - ;; Cleanup. - (add-hook - 'vc-test--cleanup-hook - `(lambda () (delete-directory ,default-directory 'recursive))) - - ;; Create empty repository. Check repository checkout model. - (make-directory default-directory) - (vc-test--create-repo-function backend) - - ;; Surprisingly, none of the backends returns 'announce. - ;; implicit: Bzr CVS Git Hg Mtn SRC SVN - ;; locking: RCS SCCS - (message - "vc-checkout-model1 %s" - (vc-checkout-model backend default-directory)) - (should (memq (vc-checkout-model backend default-directory) - '(announce implicit locking))) - - (let ((tmp-name (expand-file-name "foo" default-directory))) - ;; Check checkout model of a nonexistent file. - - ;; implicit: Bzr CVS Git Hg Mtn SRC SVN - ;; locking: RCS SCCS + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + (process-environment process-environment) + vc-test--cleanup-hook) + (when (eq backend 'Bzr) + (setq process-environment (cons (format "BZR_HOME=%s" tempdir) + process-environment))) + + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Create empty repository. Check repository checkout model. + (make-directory default-directory) + (vc-test--create-repo-function backend) + + ;; Surprisingly, none of the backends returns 'announce. + ;; implicit: Bzr CVS Git Hg Mtn SRC SVN + ;; locking: RCS SCCS (message - "vc-checkout-model2 %s" (vc-checkout-model backend tmp-name)) - (should (memq (vc-checkout-model backend tmp-name) - '(announce implicit locking))) + "vc-checkout-model1 %s" + (vc-checkout-model backend default-directory)) + (should (memq (vc-checkout-model backend default-directory) + '(announce implicit locking))) - ;; Write a new file. Check checkout model. - (write-region "foo" nil tmp-name nil 'nomessage) + (let ((tmp-name (expand-file-name "foo" default-directory))) + ;; Check checkout model of a nonexistent file. - ;; implicit: Bzr CVS Git Hg Mtn SRC SVN - ;; locking: RCS SCCS - (message - "vc-checkout-model3 %s" (vc-checkout-model backend tmp-name)) - (should (memq (vc-checkout-model backend tmp-name) - '(announce implicit locking))) + ;; implicit: Bzr CVS Git Hg Mtn SRC SVN + ;; locking: RCS SCCS + (message + "vc-checkout-model2 %s" (vc-checkout-model backend tmp-name)) + (should (memq (vc-checkout-model backend tmp-name) + '(announce implicit locking))) - ;; Register a file. Check checkout model. - (vc-register - (list backend (list (file-name-nondirectory tmp-name)))) + ;; Write a new file. Check checkout model. + (write-region "foo" nil tmp-name nil 'nomessage) - ;; implicit: Bzr CVS Git Hg Mtn SRC SVN - ;; locking: RCS SCCS - (message - "vc-checkout-model4 %s" (vc-checkout-model backend tmp-name)) - (should (memq (vc-checkout-model backend tmp-name) - '(announce implicit locking))) - - ;; Unregister the file. Check checkout model. - (if (eq (vc-test--run-maybe-unsupported-function - 'vc-test--unregister-function backend tmp-name) - 'vc-not-supported) - (message "vc-checkout-model5 unsupported") - ;; implicit: Bzr Git Hg - ;; locking: RCS - ;; unsupported: CVS Mtn SCCS SRC SVN + ;; implicit: Bzr CVS Git Hg Mtn SRC SVN + ;; locking: RCS SCCS (message - "vc-checkout-model5 %s" (vc-checkout-model backend tmp-name)) + "vc-checkout-model3 %s" (vc-checkout-model backend tmp-name)) (should (memq (vc-checkout-model backend tmp-name) - '(announce implicit locking)))))) + '(announce implicit locking))) - ;; Save exit. - (ignore-errors - (if tempdir (delete-directory tempdir t)) - (run-hooks 'vc-test--cleanup-hook))))) + ;; Register a file. Check checkout model. + (vc-register + (list backend (list (file-name-nondirectory tmp-name)))) + + ;; implicit: Bzr CVS Git Hg Mtn SRC SVN + ;; locking: RCS SCCS + (message + "vc-checkout-model4 %s" (vc-checkout-model backend tmp-name)) + (should (memq (vc-checkout-model backend tmp-name) + '(announce implicit locking))) + + ;; Unregister the file. Check checkout model. + (if (eq (vc-test--run-maybe-unsupported-function + 'vc-test--unregister-function backend tmp-name) + 'vc-not-supported) + (message "vc-checkout-model5 unsupported") + ;; implicit: Bzr Git Hg + ;; locking: RCS + ;; unsupported: CVS Mtn SCCS SRC SVN + (message + "vc-checkout-model5 %s" (vc-checkout-model backend tmp-name)) + (should (memq (vc-checkout-model backend tmp-name) + '(announce implicit locking)))))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) (defun vc-test--rename-file (backend) "Check the rename-file action." - - (let ((vc-handled-backends `(,backend)) - (default-directory - (file-name-as-directory - (expand-file-name - (make-temp-name "vc-test") temporary-file-directory))) - (process-environment process-environment) - tempdir - vc-test--cleanup-hook) - (when (eq backend 'Bzr) - (setq tempdir (make-temp-file "vc-test--rename-file" t) - process-environment (cons (format "BZR_HOME=%s" tempdir) - process-environment))) - - (unwind-protect - (progn - ;; Cleanup. - (add-hook - 'vc-test--cleanup-hook - `(lambda () (delete-directory ,default-directory 'recursive))) - - ;; Create empty repository. - (make-directory default-directory) - (vc-test--create-repo-function backend) - - (let ((tmp-name (expand-file-name "foo" default-directory)) - (new-name (expand-file-name "bar" default-directory))) - ;; Write a new file. - (write-region "foo" nil tmp-name nil 'nomessage) - - ;; Register it. Renaming can fail otherwise. - (vc-register - (list backend (list (file-name-nondirectory tmp-name)))) - - (vc-rename-file tmp-name new-name) - - (should (not (file-exists-p tmp-name))) - (should (file-exists-p new-name)) - - (should (equal (vc-state new-name) - (if (memq backend '(RCS SCCS)) - 'up-to-date - 'added))))) - - ;; Save exit. - (ignore-errors - (if tempdir (delete-directory tempdir t)) - (run-hooks 'vc-test--cleanup-hook))))) + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + (process-environment process-environment) + vc-test--cleanup-hook) + (when (eq backend 'Bzr) + (setq process-environment (cons (format "BZR_HOME=%s" tempdir) + process-environment))) + + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Create empty repository. + (make-directory default-directory) + (vc-test--create-repo-function backend) + + (let ((tmp-name (expand-file-name "foo" default-directory)) + (new-name (expand-file-name "bar" default-directory))) + ;; Write a new file. + (write-region "foo" nil tmp-name nil 'nomessage) + + ;; Register it. Renaming can fail otherwise. + (vc-register + (list backend (list (file-name-nondirectory tmp-name)))) + + (vc-rename-file tmp-name new-name) + + (should (not (file-exists-p tmp-name))) + (should (file-exists-p new-name)) + + (should (equal (vc-state new-name) + (if (memq backend '(RCS SCCS)) + 'up-to-date + 'added))))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) (declare-function log-edit-done "vc/log-edit") (defun vc-test--version-diff (backend) "Check the diff version of a repository." - - (let ((vc-handled-backends `(,backend)) - (default-directory - (file-name-as-directory - (expand-file-name - (make-temp-name "vc-test") temporary-file-directory))) - (process-environment process-environment) - tempdir - vc-test--cleanup-hook) - (when (eq backend 'Bzr) - (setq tempdir (make-temp-file "vc-test--version-diff" t) - process-environment (cons (format "BZR_HOME=%s" tempdir) - process-environment))) - ;; git tries various approaches to guess a user name and email, - ;; which can fail depending on how the system is configured. - ;; Eg if the user account has no GECOS, git commit can fail with - ;; status 128 "fatal: empty ident name". - (when (memq backend '(Bzr Git)) - (setq process-environment (cons "EMAIL=john@doe.ee" - process-environment))) - (if (eq backend 'Git) - (setq process-environment (append '("GIT_AUTHOR_NAME=A" - "GIT_COMMITTER_NAME=C") - process-environment))) - (unwind-protect - (progn - ;; Cleanup. - (add-hook - 'vc-test--cleanup-hook - `(lambda () (delete-directory ,default-directory 'recursive))) - - ;; Create empty repository. Check repository checkout model. - (make-directory default-directory) - (vc-test--create-repo-function backend) - - (let* ((tmp-name (expand-file-name "foo" default-directory)) - (files (list (file-name-nondirectory tmp-name)))) - ;; Write and register a new file. - (write-region "originaltext" nil tmp-name nil 'nomessage) - (vc-register (list backend files)) - - (let ((buff (find-file tmp-name))) - (with-current-buffer buff + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + (process-environment process-environment) + vc-test--cleanup-hook) + (when (eq backend 'Bzr) + (setq process-environment (cons (format "BZR_HOME=%s" tempdir) + process-environment))) + ;; git tries various approaches to guess a user name and email, + ;; which can fail depending on how the system is configured. + ;; Eg if the user account has no GECOS, git commit can fail with + ;; status 128 "fatal: empty ident name". + (when (memq backend '(Bzr Git)) + (setq process-environment (cons "EMAIL=john@doe.ee" + process-environment))) + (if (eq backend 'Git) + (setq process-environment (append '("GIT_AUTHOR_NAME=A" + "GIT_COMMITTER_NAME=C") + process-environment))) + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Create empty repository. Check repository checkout model. + (make-directory default-directory) + (vc-test--create-repo-function backend) + + (let* ((tmp-name (expand-file-name "foo" default-directory)) + (files (list (file-name-nondirectory tmp-name)))) + ;; Write and register a new file. + (write-region "originaltext" nil tmp-name nil 'nomessage) + (vc-register (list backend files)) + + (let ((buff (find-file tmp-name))) + (with-current-buffer buff + (progn + ;; Optionally checkout file. + (when (memq backend '(RCS CVS SCCS)) + (vc-checkout tmp-name)) + + ;; Checkin file. + (vc-checkin files backend) + (insert "Testing vc-version-diff") + (log-edit-done)))) + + ;; Modify file content. + (when (memq backend '(RCS CVS SCCS)) + (vc-checkout tmp-name)) + (write-region "updatedtext" nil tmp-name nil 'nomessage) + + ;; Check version diff. + (vc-version-diff files nil nil) + (should (bufferp (get-buffer "*vc-diff*"))) + + (with-current-buffer "*vc-diff*" (progn - ;; Optionally checkout file. - (when (memq backend '(RCS CVS SCCS)) - (vc-checkout tmp-name)) - - ;; Checkin file. - (vc-checkin files backend) - (insert "Testing vc-version-diff") - (log-edit-done)))) - - ;; Modify file content. - (when (memq backend '(RCS CVS SCCS)) - (vc-checkout tmp-name)) - (write-region "updatedtext" nil tmp-name nil 'nomessage) - - ;; Check version diff. - (vc-version-diff files nil nil) - (should (bufferp (get-buffer "*vc-diff*"))) - - (with-current-buffer "*vc-diff*" - (progn - (let ((rawtext (buffer-substring-no-properties (point-min) - (point-max)))) - (should (string-search "-originaltext" rawtext)) - (should (string-search "+updatedtext" rawtext))))))) - - ;; Save exit. - (ignore-errors - (if tempdir (delete-directory tempdir t)) - (run-hooks 'vc-test--cleanup-hook))))) + (let ((rawtext (buffer-substring-no-properties (point-min) + (point-max)))) + (should (string-search "-originaltext" rawtext)) + (should (string-search "+updatedtext" rawtext))))))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) ;; Create the test cases. diff --git a/test/lisp/wdired-tests.el b/test/lisp/wdired-tests.el index 96a01fc2c7b..47ed26f609d 100644 --- a/test/lisp/wdired-tests.el +++ b/test/lisp/wdired-tests.el @@ -20,7 +20,9 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'dired) +(require 'dired-x) (require 'wdired) (defvar dired-query) ; Pacify byte compiler. @@ -28,108 +30,100 @@ (ert-deftest wdired-test-bug32173-01 () "Test using non-nil wdired-use-interactive-rename. Partially modifying a file name should succeed." - (let* ((test-dir (make-temp-file "test-dir-" t)) - (test-file (concat (file-name-as-directory test-dir) "foo.c")) - (replace "bar") - (new-file (string-replace "foo" replace test-file)) - (wdired-use-interactive-rename t)) - (write-region "" nil test-file nil 'silent) - (advice-add 'dired-query ; Don't ask confirmation to overwrite a file. - :override - (lambda (_sym _prompt &rest _args) (setq dired-query t)) - '((name . "advice-dired-query"))) - (let ((buf (find-file-noselect test-dir))) - (unwind-protect - (with-current-buffer buf - (should (equal (dired-file-name-at-point) test-file)) - (dired-toggle-read-only) - (kill-region (point) (progn (search-forward ".") - (forward-char -1) (point))) - (insert replace) - (wdired-finish-edit) - (should (equal (dired-file-name-at-point) new-file))) - (if buf (kill-buffer buf)) - (delete-directory test-dir t))))) + (ert-with-temp-directory test-dir + (let* ((test-file (concat (file-name-as-directory test-dir) "foo.c")) + (replace "bar") + (new-file (string-replace "foo" replace test-file)) + (wdired-use-interactive-rename t)) + (write-region "" nil test-file nil 'silent) + (advice-add 'dired-query ; Don't ask confirmation to overwrite a file. + :override + (lambda (_sym _prompt &rest _args) (setq dired-query t)) + '((name . "advice-dired-query"))) + (let ((buf (find-file-noselect test-dir))) + (unwind-protect + (with-current-buffer buf + (should (equal (dired-file-name-at-point) test-file)) + (dired-toggle-read-only) + (kill-region (point) (progn (search-forward ".") + (forward-char -1) (point))) + (insert replace) + (wdired-finish-edit) + (should (equal (dired-file-name-at-point) new-file))) + (if buf (kill-buffer buf))))))) (ert-deftest wdired-test-bug32173-02 () "Test using non-nil wdired-use-interactive-rename. Aborting an edit should leaving original file name unchanged." - (let* ((test-dir (make-temp-file "test-dir-" t)) - (test-file (concat (file-name-as-directory test-dir) "foo.c")) - (wdired-use-interactive-rename t)) - (write-region "" nil test-file nil 'silent) - ;; Make dired-do-create-files-regexp a noop to mimic typing C-g - ;; at its prompt before wdired-finish-edit returns. - (advice-add 'dired-do-create-files-regexp - :override - (lambda (&rest _) (ignore)) - '((name . "advice-dired-do-create-files-regexp"))) - (let ((buf (find-file-noselect test-dir))) - (unwind-protect - (with-current-buffer buf - (should (equal (dired-file-name-at-point) test-file)) - (dired-toggle-read-only) - (kill-region (point) (progn (search-forward ".") - (forward-char -1) (point))) - (insert "bar") - (wdired-finish-edit) - (should (equal (dired-get-filename) test-file))) - (if buf (kill-buffer buf)) - (delete-directory test-dir t))))) + (ert-with-temp-directory test-dir + (let* ((test-file (concat (file-name-as-directory test-dir) "foo.c")) + (wdired-use-interactive-rename t)) + (write-region "" nil test-file nil 'silent) + ;; Make dired-do-create-files-regexp a noop to mimic typing C-g + ;; at its prompt before wdired-finish-edit returns. + (advice-add 'dired-do-create-files-regexp + :override + (lambda (&rest _) (ignore)) + '((name . "advice-dired-do-create-files-regexp"))) + (let ((buf (find-file-noselect test-dir))) + (unwind-protect + (with-current-buffer buf + (should (equal (dired-file-name-at-point) test-file)) + (dired-toggle-read-only) + (kill-region (point) (progn (search-forward ".") + (forward-char -1) (point))) + (insert "bar") + (wdired-finish-edit) + (should (equal (dired-get-filename) test-file))) + (if buf (kill-buffer buf))))))) (ert-deftest wdired-test-symlink-name () "Test the file name of a symbolic link. The Dired and WDired functions returning the name should include only the name before the link arrow." - (let* ((test-dir (make-temp-file "test-dir-" t)) - (link-name "foo")) - (let ((buf (find-file-noselect test-dir))) - (unwind-protect - (with-current-buffer buf - (skip-unless - ;; This check is for wdired, not symbolic links, so skip - ;; it when make-symbolic-link fails for any reason (like - ;; insufficient privileges). - (ignore-errors (make-symbolic-link "./bar/baz" link-name) t)) - (revert-buffer) - (let* ((file-name (dired-get-filename)) - (dir-part (file-name-directory file-name)) - (lf-name (concat dir-part link-name))) - (should (equal file-name lf-name)) - (dired-toggle-read-only) - (should (equal (wdired-get-filename) lf-name)) - (dired-toggle-read-only))) - (if buf (kill-buffer buf)) - (delete-directory test-dir t))))) + (ert-with-temp-directory test-dir + (let* ((link-name "foo")) + (let ((buf (find-file-noselect test-dir))) + (unwind-protect + (with-current-buffer buf + (skip-unless + ;; This check is for wdired, not symbolic links, so skip + ;; it when make-symbolic-link fails for any reason (like + ;; insufficient privileges). + (ignore-errors (make-symbolic-link "./bar/baz" link-name) t)) + (revert-buffer) + (let* ((file-name (dired-get-filename)) + (dir-part (file-name-directory file-name)) + (lf-name (concat dir-part link-name))) + (should (equal file-name lf-name)) + (dired-toggle-read-only) + (should (equal (wdired-get-filename) lf-name)) + (dired-toggle-read-only))) + (if buf (kill-buffer buf))))))) (ert-deftest wdired-test-unfinished-edit-01 () "Test editing a file name without saving the change. Finding the new name should be possible while still in wdired-mode." - (let* ((test-dir (make-temp-file "test-dir-" t)) - (test-file (concat (file-name-as-directory test-dir) "foo.c")) - (replace "bar") - (new-file (string-replace "foo" replace test-file))) - (write-region "" nil test-file nil 'silent) - (let ((buf (find-file-noselect test-dir))) - (unwind-protect - (with-current-buffer buf - (should (equal (dired-file-name-at-point) test-file)) - (dired-toggle-read-only) - (kill-region (point) (progn (search-forward ".") - (forward-char -1) (point))) - (insert replace) - (should (equal (dired-get-filename) new-file))) - (when buf - (with-current-buffer buf - ;; Prevent kill-buffer-query-functions from chiming in. - (set-buffer-modified-p nil) - (kill-buffer buf))) - (delete-directory test-dir t))))) - -(defvar server-socket-dir) -(declare-function dired-smart-shell-command "dired-x" - (command &optional output-buffer error-buffer)) + (ert-with-temp-directory test-dir + (let* ((test-file (concat (file-name-as-directory test-dir) "foo.c")) + (replace "bar") + (new-file (string-replace "foo" replace test-file))) + (write-region "" nil test-file nil 'silent) + (let ((buf (find-file-noselect test-dir))) + (unwind-protect + (with-current-buffer buf + (should (equal (dired-file-name-at-point) test-file)) + (dired-toggle-read-only) + (kill-region (point) (progn (search-forward ".") + (forward-char -1) (point))) + (insert replace) + (should (equal (dired-get-filename) new-file))) + (when buf + (with-current-buffer buf + ;; Prevent kill-buffer-query-functions from chiming in. + (set-buffer-modified-p nil) + (kill-buffer buf)))))))) (ert-deftest wdired-test-bug34915 () "Test editing when dired-listing-switches includes -F. @@ -139,61 +133,61 @@ dired-move-to-end-of-filename handles indicator characters, it 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? - (let* ((test-dir (make-temp-file "test-dir-" t)) - (server-socket-dir test-dir) - (dired-listing-switches "-Fl") - (dired-ls-F-marks-symlinks (eq system-type 'darwin)) - (buf (find-file-noselect test-dir))) - (unwind-protect - (progn - (with-current-buffer buf - (dired-create-empty-file "foo") - (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. - (kill-buffer buf)) - (dired test-dir) - (dired-toggle-read-only) - (let (names) - ;; Test that the file names are the same in Dired and WDired. - (while (not (eobp)) - (should (equal (dired-get-filename 'no-dir t) - (wdired-get-filename t))) - (insert "w") - (push (wdired-get-filename t) names) - (dired-next-line 1)) - (wdired-finish-edit) - ;; Test that editing the file names ignores the indicator - ;; character. - (let (dir) - (while (and (dired-previous-line 1) - (setq dir (dired-get-filename 'no-dir t))) - (should (equal dir (pop names))))))) - (kill-buffer (get-buffer test-dir)) - (server-force-delete) - (delete-directory test-dir t)))) + (ert-with-temp-directory test-dir + (let* ((dired-listing-switches "-Fl") + (dired-ls-F-marks-symlinks (eq system-type 'darwin)) + (buf (find-file-noselect test-dir)) + proc) + (unwind-protect + (progn + (with-current-buffer buf + (dired-create-empty-file "foo") + (set-file-modes "foo" (file-modes-symbolic-to-number "+x")) + (make-symbolic-link "foo" "bar") + (make-directory "foodir") + (dired-smart-shell-command "mkfifo foopipe") + (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) + (let (names) + ;; Test that the file names are the same in Dired and WDired. + (while (not (eobp)) + (should (equal (dired-get-filename 'no-dir t) + (wdired-get-filename t))) + (insert "w") + (push (wdired-get-filename t) names) + (dired-next-line 1)) + (wdired-finish-edit) + ;; Test that editing the file names ignores the indicator + ;; character. + (let (dir) + (while (and (dired-previous-line 1) + (setq dir (dired-get-filename 'no-dir t))) + (should (equal dir (pop names))))))) + (kill-buffer (get-buffer test-dir)) + (ignore-errors (delete-process proc)))))) (ert-deftest wdired-test-bug39280 () "Test for https://debbugs.gnu.org/39280." - (let* ((test-dir (make-temp-file "test-dir" 'dir)) - (fname "foo") - (full-fname (expand-file-name fname test-dir))) - (make-empty-file full-fname) - (let ((buf (find-file-noselect test-dir))) - (unwind-protect - (with-current-buffer buf - (dired-toggle-read-only) - (dolist (old '(t nil)) - (should (equal fname (wdired-get-filename 'nodir old))) - (should (equal full-fname (wdired-get-filename nil old)))) - (wdired-finish-edit)) - (if buf (kill-buffer buf)) - (delete-directory test-dir t))))) + (ert-with-temp-directory test-dir + (let* ((fname "foo") + (full-fname (expand-file-name fname test-dir))) + (make-empty-file full-fname) + (let ((buf (find-file-noselect test-dir))) + (unwind-protect + (with-current-buffer buf + (dired-toggle-read-only) + (dolist (old '(t nil)) + (should (equal fname (wdired-get-filename 'nodir old))) + (should (equal full-fname (wdired-get-filename nil old)))) + (wdired-finish-edit)) + (if buf (kill-buffer buf))))))) (provide 'wdired-tests) ;;; wdired-tests.el ends here diff --git a/test/manual/cedet/cedet-utests.el b/test/manual/cedet/cedet-utests.el index d68b5b8c090..af6b4defb3c 100644 --- a/test/manual/cedet/cedet-utests.el +++ b/test/manual/cedet/cedet-utests.el @@ -252,9 +252,7 @@ Optional argument TITLE is the title of this testing session." (defun cedet-utest-elapsed-time (start end) "Copied from elp.el. Was elp-elapsed-time. Argument START and END bound the time being calculated." - (+ (* (- (car end) (car start)) 65536.0) - (- (car (cdr end)) (car (cdr start))) - (/ (- (car (cdr (cdr end))) (car (cdr (cdr start)))) 1000000.0))) + (float-time (time-subtract start end))) (defun cedet-utest-log-shutdown (title &optional _errorcondition) "Shut-down a larger test suite. diff --git a/test/manual/cedet/tests/test.el b/test/manual/cedet/tests/test.el index 34c03619f88..246a856665b 100644 --- a/test/manual/cedet/tests/test.el +++ b/test/manual/cedet/tests/test.el @@ -63,11 +63,11 @@ ;;; Methods ;; -(defmethod a-method ((obj some-class) &optional arg2) +(cl-defmethod a-method ((obj some-class) &optional arg2) "Doc String for a method." (call-next-method)) -(defgeneric a-generic (arg1 arg2) +(cl-defgeneric a-generic (arg1 arg2) "General description of a-generic.") ;;; Advice diff --git a/test/manual/indent/perl.perl b/test/manual/indent/perl.perl index 6ec04303b4f..db94552a928 100755 --- a/test/manual/indent/perl.perl +++ b/test/manual/indent/perl.perl @@ -95,3 +95,15 @@ s#ijk#lmn#g; # This is a regular expression sustitution. s #lmn#opq#g; # FIXME: this should be a comment starting with "#lmn" /lmn/rst/g; # and this is the actual regular expression print; # prints "rstrst\n" + +given ($num) { + when ($num>10) { + printf "number is greater than 10\n"; + } + when ($num<10) { + printf "number is less than 10\n"; + } + default { + printf "number is equal to 10\n"; + } +} diff --git a/test/src/alloc-tests.el b/test/src/alloc-tests.el index 5383c436035..80b18dfa492 100644 --- a/test/src/alloc-tests.el +++ b/test/src/alloc-tests.el @@ -30,7 +30,7 @@ (require 'cl-lib) (ert-deftest finalizer-object-type () - (should (equal (type-of (make-finalizer nil)) 'finalizer))) + (should (equal (type-of (make-finalizer #'ignore)) 'finalizer))) (ert-deftest record-1 () (let ((x (record 'foo 1 2 3))) diff --git a/test/src/buffer-tests.el b/test/src/buffer-tests.el index 059926ff46b..9b7023d18b9 100644 --- a/test/src/buffer-tests.el +++ b/test/src/buffer-tests.el @@ -19,6 +19,8 @@ ;;; Code: +(require 'ert) +(require 'ert-x) (require 'cl-lib) (ert-deftest overlay-modification-hooks-message-other-buf () @@ -145,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)))))) @@ -434,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)) @@ -471,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)) @@ -522,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)) @@ -619,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)) @@ -1107,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)) @@ -1421,66 +1423,63 @@ with parameters from the *Messages* buffer modification." (should (= (length (overlays-in (point-min) (point-max))) 0)))) (ert-deftest test-kill-buffer-auto-save-default () - (let ((file (make-temp-file "ert")) - auto-save) - (should (file-exists-p file)) - ;; Always answer yes. - (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_) t))) - (unwind-protect - (progn - (find-file file) - (auto-save-mode t) - (insert "foo\n") - (should buffer-auto-save-file-name) - (setq auto-save buffer-auto-save-file-name) - (do-auto-save) - (should (file-exists-p auto-save)) - (kill-buffer (current-buffer)) - (should (file-exists-p auto-save))) - (ignore-errors (delete-file file)) - (when auto-save - (ignore-errors (delete-file auto-save))))))) + (ert-with-temp-file file + (let (auto-save) + ;; Always answer yes. + (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_) t))) + (unwind-protect + (progn + (find-file file) + (auto-save-mode t) + (insert "foo\n") + (should buffer-auto-save-file-name) + (setq auto-save buffer-auto-save-file-name) + (do-auto-save) + (should (file-exists-p auto-save)) + (kill-buffer (current-buffer)) + (should (file-exists-p auto-save))) + (when auto-save + (ignore-errors (delete-file auto-save)))))))) (ert-deftest test-kill-buffer-auto-save-delete () - (let ((file (make-temp-file "ert")) - auto-save) - (should (file-exists-p file)) - (setq kill-buffer-delete-auto-save-files t) - ;; Always answer yes. - (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_) t))) - (unwind-protect - (progn - (find-file file) - (auto-save-mode t) - (insert "foo\n") - (should buffer-auto-save-file-name) - (setq auto-save buffer-auto-save-file-name) - (do-auto-save) - (should (file-exists-p auto-save)) - ;; This should delete the auto-save file. - (kill-buffer (current-buffer)) - (should-not (file-exists-p auto-save))) - (ignore-errors (delete-file file)) - (when auto-save - (ignore-errors (delete-file auto-save))))) - ;; Answer no to deletion. - (cl-letf (((symbol-function #'yes-or-no-p) - (lambda (prompt) - (not (string-search "Delete auto-save file" prompt))))) - (unwind-protect - (progn - (find-file file) - (auto-save-mode t) - (insert "foo\n") - (should buffer-auto-save-file-name) - (setq auto-save buffer-auto-save-file-name) - (do-auto-save) - (should (file-exists-p auto-save)) - ;; This should not delete the auto-save file. - (kill-buffer (current-buffer)) - (should (file-exists-p auto-save))) - (ignore-errors (delete-file file)) - (when auto-save - (ignore-errors (delete-file auto-save))))))) + (ert-with-temp-file file + (let (auto-save) + (should (file-exists-p file)) + (setq kill-buffer-delete-auto-save-files t) + ;; Always answer yes. + (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_) t))) + (unwind-protect + (progn + (find-file file) + (auto-save-mode t) + (insert "foo\n") + (should buffer-auto-save-file-name) + (setq auto-save buffer-auto-save-file-name) + (do-auto-save) + (should (file-exists-p auto-save)) + ;; This should delete the auto-save file. + (kill-buffer (current-buffer)) + (should-not (file-exists-p auto-save))) + (ignore-errors (delete-file file)) + (when auto-save + (ignore-errors (delete-file auto-save))))) + ;; Answer no to deletion. + (cl-letf (((symbol-function #'yes-or-no-p) + (lambda (prompt) + (not (string-search "Delete auto-save file" prompt))))) + (unwind-protect + (progn + (find-file file) + (auto-save-mode t) + (insert "foo\n") + (should buffer-auto-save-file-name) + (setq auto-save buffer-auto-save-file-name) + (do-auto-save) + (should (file-exists-p auto-save)) + ;; This should not delete the auto-save file. + (kill-buffer (current-buffer)) + (should (file-exists-p auto-save))) + (when auto-save + (ignore-errors (delete-file auto-save)))))))) ;;; buffer-tests.el ends here diff --git a/test/src/casefiddle-tests.el b/test/src/casefiddle-tests.el index 9fa54dcaf43..dbbe9f30925 100644 --- a/test/src/casefiddle-tests.el +++ b/test/src/casefiddle-tests.el @@ -278,4 +278,20 @@ (with-temp-buffer (should-error (upcase-region nil nil t))))) +(ert-deftest casefiddle-turkish () + (skip-unless (member "tr_TR.utf8" (get-locale-names))) + ;; See bug#50752. The point is that unibyte and multibyte strings + ;; are upcased differently in the "dotless i" case in Turkish, + ;; turning ASCII into non-ASCII, which is very unusual. + (with-locale-environment "tr_TR.utf8" + (should (string-equal (downcase "I ı") "ı ı")) + (should (string-equal (downcase "İ i") "i̇ i")) + (should (string-equal (downcase "I") "i")) + (should (string-equal (capitalize "bIte") "Bite")) + (should (string-equal (capitalize "bIté") "Bıté")) + (should (string-equal (capitalize "indIa") "India")) + ;; This does not work -- it produces "Indıa". + ;;(should (string-equal (capitalize "indIá") "İndıa")) + )) + ;;; casefiddle-tests.el ends here diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index ecf62a4c128..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) @@ -53,30 +59,32 @@ "Compile the compiler and load it to compile it-self. Check that the resulting binaries do not differ." :tags '(:expensive-test :nativecomp) - (let* ((byte+native-compile t) ; FIXME HACK - (comp-src (expand-file-name "../../../lisp/emacs-lisp/comp.el" + (ert-with-temp-file comp1-src + :suffix "-comp-stage1.el" + (ert-with-temp-file comp2-src + :suffix "-comp-stage2.el" + (let* ((byte+native-compile t) ; FIXME HACK + (comp-src (expand-file-name "../../../lisp/emacs-lisp/comp.el" (ert-resource-directory))) - (comp1-src (make-temp-file "stage1-" nil ".el")) - (comp2-src (make-temp-file "stage2-" nil ".el")) - ;; Can't use debug symbols. - (native-comp-debug 0)) - (copy-file comp-src comp1-src t) - (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))) - (message "Compiling stage1...") - (let* ((t0 (current-time)) - (comp1-eln (native-compile comp1-src))) - (message "Done in %d secs" (float-time (time-since t0))) - (load comp1-eln nil nil t t) - (should (subr-native-elisp-p (symbol-function 'native-compile))) - (message "Compiling stage2...") - (let ((t0 (current-time)) - (comp2-eln (native-compile comp2-src))) - (message "Done in %d secs" (float-time (time-since t0))) - (message "Comparing %s %s" comp1-eln comp2-eln) - (should (= (call-process "cmp" nil nil nil comp1-eln comp2-eln) 0)))))) + ;; Can't use debug symbols. + (native-comp-debug 0)) + (copy-file comp-src comp1-src t) + (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))) + (message "Compiling stage1...") + (let* ((t0 (current-time)) + (comp1-eln (native-compile comp1-src))) + (message "Done in %d secs" (float-time (time-since t0))) + (load comp1-eln nil nil t t) + (should (subr-native-elisp-p (symbol-function 'native-compile))) + (message "Compiling stage2...") + (let ((t0 (current-time)) + (comp2-eln (native-compile comp2-src))) + (message "Done in %d secs" (float-time (time-since t0))) + (message "Comparing %s %s" comp1-eln comp2-eln) + (should (= (call-process "cmp" nil nil nil comp1-eln comp2-eln) 0)))))))) (comp-deftest provide () "Testing top level provide." @@ -350,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 () @@ -359,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.")) @@ -367,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. @@ -382,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 () "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-07/msg00418.html>." @@ -431,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))) @@ -452,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 @@ -492,12 +504,12 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (comp-deftest 45603-1 () "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-12/msg01994.html>" (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 () "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2021-02/msg01413.html>" (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 () @@ -727,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)))) @@ -784,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) @@ -798,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 (_) @@ -812,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) @@ -823,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) @@ -1403,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..8cc271b9e1c 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)))) @@ -433,26 +433,27 @@ comparing the subr with a much slower Lisp implementation." ;; More specifically, test the problem seen in bug#41029 where setting ;; the default value of a variable takes time proportional to the ;; number of buffers. - (let* ((fun #'error) - (test (lambda () - (with-temp-buffer - (let ((st (car (current-cpu-time)))) - (dotimes (_ 1000) - (let ((case-fold-search 'data-test)) - ;; Use an indirection through a mutable var - ;; to try and make sure the byte-compiler - ;; doesn't optimize away the let bindings. - (funcall fun))) - ;; FIXME: Handle the wraparound, if any. - (- (car (current-cpu-time)) st))))) - (_ (setq fun #'ignore)) - (time1 (funcall test)) - (bufs (mapcar (lambda (_) (generate-new-buffer " data-test")) - (make-list 1000 nil))) - (time2 (funcall test))) - (mapc #'kill-buffer bufs) - ;; Don't divide one time by the other since they may be 0. - (should (< time2 (* time1 5))))) + (when (fboundp 'current-cpu-time) ; silence byte-compiler + (let* ((fun #'error) + (test (lambda () + (with-temp-buffer + (let ((st (car (current-cpu-time)))) + (dotimes (_ 1000) + (let ((case-fold-search 'data-test)) + ;; Use an indirection through a mutable var + ;; to try and make sure the byte-compiler + ;; doesn't optimize away the let bindings. + (funcall fun))) + ;; FIXME: Handle the wraparound, if any. + (- (car (current-cpu-time)) st))))) + (_ (setq fun #'ignore)) + (time1 (funcall test)) + (bufs (mapcar (lambda (_) (generate-new-buffer " data-test")) + (make-list 1000 nil))) + (time2 (funcall test))) + (mapc #'kill-buffer bufs) + ;; Don't divide one time by the other since they may be 0. + (should (< time2 (* time1 5)))))) ;; More tests to write - ;; kill-local-variable @@ -690,7 +691,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/decompress-tests.el b/test/src/decompress-tests.el index 1d25cf2f66b..708d91487e5 100644 --- a/test/src/decompress-tests.el +++ b/test/src/decompress-tests.el @@ -23,6 +23,8 @@ (require 'ert) +(declare-function zlib-decompress-region "decompress.c") + (defvar zlib-tests-data-directory (expand-file-name "data/decompress" (getenv "EMACS_TEST_DIRECTORY")) "Directory containing zlib test data.") diff --git a/test/src/editfns-tests.el b/test/src/editfns-tests.el index a731a95ccf0..6b2eb32396e 100644 --- a/test/src/editfns-tests.el +++ b/test/src/editfns-tests.el @@ -23,16 +23,16 @@ (ert-deftest format-properties () ;; Bug #23730 - (should (ert-equal-including-properties + (should (equal-including-properties (format (propertize "%d" 'face '(:background "red")) 1) #("1" 0 1 (face (:background "red"))))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (propertize "%2d" 'face '(:background "red")) 1) #(" 1" 0 2 (face (:background "red"))))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (propertize "%02d" 'face '(:background "red")) 1) #("01" 0 2 (face (:background "red"))))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (concat (propertize "%2d" 'x 'X) (propertize "a" 'a 'A) (propertize "b" 'b 'B)) @@ -40,27 +40,27 @@ #(" 1ab" 0 2 (x X) 2 3 (a A) 3 4 (b B)))) ;; Bug #5306 - (should (ert-equal-including-properties + (should (equal-including-properties (format "%.10s" (concat "1234567890aaaa" (propertize "12345678901234567890" 'xxx 25))) "1234567890")) - (should (ert-equal-including-properties + (should (equal-including-properties (format "%.10s" (concat "123456789" (propertize "12345678901234567890" 'xxx 25))) #("1234567891" 9 10 (xxx 25)))) ;; Bug #23859 - (should (ert-equal-including-properties + (should (equal-including-properties (format "%4s" (propertize "hi" 'face 'bold)) #(" hi" 2 4 (face bold)))) ;; Bug #23897 - (should (ert-equal-including-properties + (should (equal-including-properties (format "%s" (concat (propertize "01234" 'face 'bold) "56789")) #("0123456789" 0 5 (face bold)))) - (should (ert-equal-including-properties + (should (equal-including-properties (format "%s" (concat (propertize "01" 'face 'bold) (propertize "23" 'face 'underline) "45")) @@ -68,63 +68,63 @@ ;; The last property range is extended to include padding on the ;; right, but the first range is not extended to the left to include ;; padding on the left! - (should (ert-equal-including-properties + (should (equal-including-properties (format "%12s" (concat (propertize "01234" 'face 'bold) "56789")) #(" 0123456789" 2 7 (face bold)))) - (should (ert-equal-including-properties + (should (equal-including-properties (format "%-12s" (concat (propertize "01234" 'face 'bold) "56789")) #("0123456789 " 0 5 (face bold)))) - (should (ert-equal-including-properties + (should (equal-including-properties (format "%10s" (concat (propertize "01" 'face 'bold) (propertize "23" 'face 'underline) "45")) #(" 012345" 4 6 (face bold) 6 8 (face underline)))) - (should (ert-equal-including-properties + (should (equal-including-properties (format "%-10s" (concat (propertize "01" 'face 'bold) (propertize "23" 'face 'underline) "45")) #("012345 " 0 2 (face bold) 2 4 (face underline)))) - (should (ert-equal-including-properties + (should (equal-including-properties (format "%-10s" (concat (propertize "01" 'face 'bold) (propertize "23" 'face 'underline) (propertize "45" 'face 'italic))) #("012345 " 0 2 (face bold) 2 4 (face underline) 4 10 (face italic)))) ;; Bug #38191 - (should (ert-equal-including-properties + (should (equal-including-properties (format (propertize "‘foo’ %s bar" 'face 'bold) "xxx") #("‘foo’ xxx bar" 0 13 (face bold)))) ;; Bug #32404 - (should (ert-equal-including-properties + (should (equal-including-properties (format (concat (propertize "%s" 'face 'bold) "" (propertize "%s" 'face 'error)) "foo" "bar") #("foobar" 0 3 (face bold) 3 6 (face error)))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (concat "%s" (propertize "%s" 'face 'error)) "foo" "bar") #("foobar" 3 6 (face error)))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (concat "%s " (propertize "%s" 'face 'error)) "foo" "bar") #("foo bar" 4 7 (face error)))) ;; Bug #46317 (let ((s (propertize "X" 'prop "val"))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (concat "%3s/" s) 12) #(" 12/X" 4 5 (prop "val")))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (concat "%3S/" s) 12) #(" 12/X" 4 5 (prop "val")))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (concat "%3d/" s) 12) #(" 12/X" 4 5 (prop "val")))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (concat "%-3s/" s) 12) #("12 /X" 4 5 (prop "val")))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (concat "%-3S/" s) 12) #("12 /X" 4 5 (prop "val")))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (concat "%-3d/" s) 12) #("12 /X" 4 5 (prop "val")))))) @@ -413,4 +413,17 @@ (translate-region-internal (point-min) (point-max) tt) (should (string-equal (buffer-string) "*"))))) +(ert-deftest find-fields () + (with-temp-buffer + (insert "foo" (propertize "bar" 'field 'bar) "zot") + (goto-char (point-min)) + (should (= (field-beginning) (point-min))) + (should (= (field-end) 4)) + (goto-char 5) + (should (= (field-beginning) 4)) + (should (= (field-end) 7)) + (goto-char 8) + (should (= (field-beginning) 7)) + (should (= (field-end) (point-max))))) + ;;; editfns-tests.el ends here diff --git a/test/src/emacs-module-tests.el b/test/src/emacs-module-tests.el index 646c7bb2705..988b311f5b5 100644 --- a/test/src/emacs-module-tests.el +++ b/test/src/emacs-module-tests.el @@ -32,6 +32,11 @@ (require 'help-fns) (require 'subr-x) +;; Catch information for bug#50902. +(when (getenv "EMACS_EMBA_CI") + (start-process-shell-command + "*timeout*" nil (format "sleep 60; kill -ABRT %d" (emacs-pid)))) + (defconst mod-test-emacs (expand-file-name invocation-name invocation-directory) "File name of the Emacs binary currently running.") @@ -206,20 +211,6 @@ changes." (should (equal (help-function-arglist #'mod-test-sum) '(arg1 arg2)))) -(defmacro module--with-temp-directory (name &rest body) - "Bind NAME to the name of a temporary directory and evaluate BODY. -NAME must be a symbol. Delete the temporary directory after BODY -exits normally or non-locally. NAME will be bound to the -directory name (not the directory file name) of the temporary -directory." - (declare (indent 1)) - (cl-check-type name symbol) - `(let ((,name (file-name-as-directory - (make-temp-file "emacs-module-test" :directory)))) - (unwind-protect - (progn ,@body) - (delete-directory ,name :recursive)))) - (defmacro module--test-assertion (pattern &rest body) "Test that PATTERN matches the assertion triggered by BODY. Run Emacs as a subprocess, load the test module `mod-test-file', @@ -228,7 +219,7 @@ assertion message that matches PATTERN. PATTERN is evaluated and must evaluate to a regular expression string." (declare (indent 1)) ;; To contain any core dumps. - `(module--with-temp-directory tempdir + `(ert-with-temp-directory tempdir (with-temp-buffer (let* ((default-directory tempdir) (status (call-process mod-test-emacs nil t nil @@ -256,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"))))) @@ -274,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"))))) @@ -290,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"))))) @@ -301,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/emacs-tests.el b/test/src/emacs-tests.el index ac08e055b55..a1a412423cb 100644 --- a/test/src/emacs-tests.el +++ b/test/src/emacs-tests.el @@ -25,6 +25,7 @@ (require 'cl-lib) (require 'ert) +(require 'ert-x) ; ert-with-temp-file (require 'rx) (require 'subr-x) @@ -46,22 +47,6 @@ "--seccomp=/does-not-exist.bpf") 0)))) -(cl-defmacro emacs-tests--with-temp-file - (var (prefix &optional suffix text) &rest body) - "Evaluate BODY while a new temporary file exists. -Bind VAR to the name of the file. Pass PREFIX, SUFFIX, and TEXT -to `make-temp-file', which see." - (declare (indent 2) (debug (symbolp (form form form) body))) - (cl-check-type var symbol) - ;; Use an uninterned symbol so that the code still works if BODY - ;; changes VAR. - (let ((filename (make-symbol "filename"))) - `(let ((,filename (make-temp-file ,prefix nil ,suffix ,text))) - (unwind-protect - (let ((,var ,filename)) - ,@body) - (delete-file ,filename))))) - (ert-deftest emacs-tests/seccomp/empty-file () (skip-unless (string-match-p (rx bow "SECCOMP" eow) system-configuration-features)) @@ -69,7 +54,8 @@ to `make-temp-file', which see." (expand-file-name invocation-name invocation-directory)) (process-environment nil)) (skip-unless (file-executable-p emacs)) - (emacs-tests--with-temp-file filter ("seccomp-invalid-" ".bpf") + (ert-with-temp-file filter + :prefix "seccomp-invalid-" :suffix ".bpf" ;; The --seccomp option is processed early, without filename ;; handlers. Therefore remote or quoted filenames wouldn't ;; work. @@ -94,9 +80,9 @@ to `make-temp-file', which see." ;; Either 8 or 16, but 16 should be large enough in all cases. (filter-size 16)) (skip-unless (file-executable-p emacs)) - (emacs-tests--with-temp-file - filter ("seccomp-too-large-" ".bpf" - (make-string (* (1+ ushort-max) filter-size) ?a)) + (ert-with-temp-file filter + :prefix "seccomp-too-large-" :suffix ".bpf" + :text (make-string (* (1+ ushort-max) filter-size) ?a) ;; The --seccomp option is processed early, without filename ;; handlers. Therefore remote or quoted filenames wouldn't ;; work. @@ -117,8 +103,8 @@ to `make-temp-file', which see." (expand-file-name invocation-name invocation-directory)) (process-environment nil)) (skip-unless (file-executable-p emacs)) - (emacs-tests--with-temp-file filter ("seccomp-invalid-" ".bpf" - "123456") + (ert-with-temp-file filter + :prefix "seccomp-invalid-" :suffix ".bpf" :text "123456" ;; The --seccomp option is processed early, without filename ;; handlers. Therefore remote or quoted filenames wouldn't ;; work. 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/filelock-tests.el b/test/src/filelock-tests.el index a96d6d67289..24dd37e5a4d 100644 --- a/test/src/filelock-tests.el +++ b/test/src/filelock-tests.el @@ -28,6 +28,7 @@ (require 'cl-macs) (require 'ert) +(require 'ert-x) (require 'seq) (defun filelock-tests--fixture (test-function) @@ -36,22 +37,20 @@ Create a test directory and a buffer whose `buffer-file-name' and `buffer-file-truename' are a file within it, then call TEST-FUNCTION. Finally, delete the buffer and the test directory." - (let* ((temp-dir (make-temp-file "filelock-tests" t)) - (name (concat (file-name-as-directory temp-dir) - "userfile")) - (create-lockfiles t)) - (unwind-protect - (with-temp-buffer - (setq buffer-file-name name - buffer-file-truename name) - (unwind-protect - (save-current-buffer - (funcall test-function)) - ;; Set `buffer-file-truename' nil to prevent unlocking, - ;; which might prompt the user and/or signal errors. - (setq buffer-file-name nil - buffer-file-truename nil))) - (delete-directory temp-dir t nil)))) + (ert-with-temp-directory temp-dir + (let ((name (concat (file-name-as-directory temp-dir) + "userfile")) + (create-lockfiles t)) + (with-temp-buffer + (setq buffer-file-name name + buffer-file-truename name) + (unwind-protect + (save-current-buffer + (funcall test-function)) + ;; Set `buffer-file-truename' nil to prevent unlocking, + ;; which might prompt the user and/or signal errors. + (setq buffer-file-name nil + buffer-file-truename nil)))))) (defun filelock-tests--make-lock-name (file-name) "Return the lock file name for FILE-NAME. @@ -124,7 +123,9 @@ the case)." (filelock-tests--spoil-lock-file buffer-file-truename) (let ((err (should-error (file-locked-p (buffer-file-name))))) (should (equal (seq-subseq err 0 2) - '(file-error "Testing file lock"))))))) + (if (eq system-type 'windows-nt) + '(permission-denied "Testing file lock") + '(file-error "Testing file lock")))))))) (ert-deftest filelock-tests-unlock-spoiled () "Check that `unlock-buffer' fails if the lockfile is \"spoiled\"." @@ -145,8 +146,11 @@ the case)." (lambda (err) (push err errors)))) (unlock-buffer)) (should (consp errors)) - (should (equal '(file-error "Unlocking file") - (seq-subseq (car errors) 0 2))) + (should (equal + (if (eq system-type 'windows-nt) + '(permission-denied "Unlocking file") + '(file-error "Unlocking file")) + (seq-subseq (car errors) 0 2))) (should (equal (length errors) 1)))))) (ert-deftest filelock-tests-kill-buffer-spoiled () @@ -175,8 +179,11 @@ the case)." (lambda (err) (push err errors)))) (kill-buffer)) (should (consp errors)) - (should (equal '(file-error "Unlocking file") - (seq-subseq (car errors) 0 2))) + (should (equal + (if (eq system-type 'windows-nt) + '(permission-denied "Unlocking file") + '(file-error "Unlocking file")) + (seq-subseq (car errors) 0 2))) (should (equal (length errors) 1)))))) (provide 'filelock-tests) diff --git a/test/src/floatfns-tests.el b/test/src/floatfns-tests.el index 47fa1941626..a066d2e15e2 100644 --- a/test/src/floatfns-tests.el +++ b/test/src/floatfns-tests.el @@ -21,6 +21,68 @@ (require 'ert) +(ert-deftest floatfns-tests-cos () + (should (= (cos 0) 1.0)) + (should (= (cos float-pi) -1.0))) + +(ert-deftest floatfns-tests-sin () + (should (= (sin 0) 0.0))) + +(ert-deftest floatfns-tests-tan () + (should (= (tan 0) 0.0))) + +(ert-deftest floatfns-tests-isnan () + (should (isnan 0.0e+NaN)) + (should (isnan -0.0e+NaN)) + (should-error (isnan "foo") :type 'wrong-type-argument)) + +(ert-deftest floatfns-tests-exp () + (should (= (exp 0) 1.0))) + +(ert-deftest floatfns-tests-expt () + (should (= (expt 2 8) 256))) + +(ert-deftest floatfns-tests-log () + (should (= (log 1000 10) 3.0))) + +(ert-deftest floatfns-tests-sqrt () + (should (= (sqrt 25) 5))) + +(ert-deftest floatfns-tests-abs () + (should (= (abs 10) 10)) + (should (= (abs -10) 10))) + +(ert-deftest floatfns-tests-logb () + (should (= (logb 10000) 13))) + +(ert-deftest floatfns-tests-ceiling () + (should (= (ceiling 0.5) 1))) + +(ert-deftest floatfns-tests-floor () + (should (= (floor 1.5) 1))) + +(ert-deftest floatfns-tests-round () + (should (= (round 1.49999999999) 1)) + (should (= (round 1.50000000000) 2)) + (should (= (round 1.50000000001) 2))) + +(ert-deftest floatfns-tests-truncate () + (should (= (truncate float-pi) 3))) + +(ert-deftest floatfns-tests-fceiling () + (should (= (fceiling 0.5) 1.0))) + +(ert-deftest floatfns-tests-ffloor () + (should (= (ffloor 1.5) 1.0))) + +(ert-deftest floatfns-tests-fround () + (should (= (fround 1.49999999999) 1.0)) + (should (= (fround 1.50000000000) 2.0)) + (should (= (fround 1.50000000001) 2.0))) + +(ert-deftest floatfns-tests-ftruncate () + (should (= (ftruncate float-pi) 3.0))) + (ert-deftest divide-extreme-sign () (should (= (ceiling most-negative-fixnum -1.0) (- most-negative-fixnum))) (should (= (floor most-negative-fixnum -1.0) (- most-negative-fixnum))) diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el index 57594572094..63423f622f8 100644 --- a/test/src/fns-tests.el +++ b/test/src/fns-tests.el @@ -23,6 +23,29 @@ (require 'cl-lib) +(ert-deftest fns-tests-identity () + (let ((num 12345)) (should (eq (identity num) num))) + (let ((str "foo")) (should (eq (identity str) str))) + (let ((lst '(11))) (should (eq (identity lst) lst)))) + +(ert-deftest fns-tests-random () + (should (integerp (random))) + (should (>= (random 10) 0)) + (should (< (random 10) 10))) + +(ert-deftest fns-tests-length () + (should (= (length nil) 0)) + (should (= (length '(1 2 3)) 3)) + (should (= (length '[1 2 3]) 3)) + (should (= (length "foo") 3)) + (should-error (length t))) + +(ert-deftest fns-tests-safe-length () + (should (= (safe-length '(1 2 3)) 3))) + +(ert-deftest fns-tests-string-bytes () + (should (= (string-bytes "abc") 3))) + ;; Test that equality predicates work correctly on NaNs when combined ;; with hash tables based on those predicates. This was not the case ;; for eql in Emacs 26. @@ -34,6 +57,33 @@ (puthash nan t h) (should (eq (funcall test nan -nan) (gethash -nan h)))))) +(ert-deftest fns-tests-equal-including-properties () + (should (equal-including-properties "" "")) + (should (equal-including-properties "foo" "foo")) + (should (equal-including-properties #("foo" 0 3 (a b)) + (propertize "foo" 'a 'b))) + (should (equal-including-properties #("foo" 0 3 (a b c d)) + (propertize "foo" 'a 'b 'c 'd))) + (should (equal-including-properties #("a" 0 1 (k v)) + #("a" 0 1 (k v)))) + (should-not (equal-including-properties #("a" 0 1 (k v)) + #("a" 0 1 (k x)))) + (should-not (equal-including-properties #("a" 0 1 (k v)) + #("b" 0 1 (k v)))) + (should-not (equal-including-properties #("foo" 0 3 (a b c e)) + (propertize "foo" 'a 'b 'c 'd)))) + +(ert-deftest fns-tests-equal-including-properties/string-prop-vals () + "Handle string property values. (Bug#6581)" + (should (equal-including-properties #("a" 0 1 (k "v")) + #("a" 0 1 (k "v")))) + (should (equal-including-properties #("foo" 0 3 (a (t))) + (propertize "foo" 'a (list t)))) + (should-not (equal-including-properties #("a" 0 1 (k "v")) + #("a" 0 1 (k "x")))) + (should-not (equal-including-properties #("a" 0 1 (k "v")) + #("b" 0 1 (k "v"))))) + (ert-deftest fns-tests-reverse () (should-error (reverse)) (should-error (reverse 1)) @@ -268,7 +318,10 @@ (should (equal (base64-encode-string "fooba") "Zm9vYmE=")) (should (equal (base64-encode-string "foobar") "Zm9vYmFy")) (should (equal (base64-encode-string "\x14\xfb\x9c\x03\xd9\x7e") "FPucA9l+")) - (should (equal (base64-encode-string "\x14\xfb\x9c\x03\xd9\x7f") "FPucA9l/"))) + (should (equal (base64-encode-string "\x14\xfb\x9c\x03\xd9\x7f") "FPucA9l/")) + + (should-error (base64-encode-string "ƒ")) + (should-error (base64-encode-string "ü"))) (ert-deftest fns-test-base64url-encode-region () ;; url variant with padding @@ -310,7 +363,11 @@ (should (equal (fns-tests--with-region base64url-encode-region (fns-tests--string-repeat "\x14\xfb\x9c\x03\xd9\x7e" 10) t) (fns-tests--string-repeat "FPucA9l-" 10))) (should (equal (fns-tests--with-region base64url-encode-region (fns-tests--string-repeat "\x14\xfb\x9c\x03\xd9\x7f" 10) t) - (fns-tests--string-repeat "FPucA9l_" 10)))) + (fns-tests--string-repeat "FPucA9l_" 10))) + + (should-error (fns-tests--with-region base64url-encode-region "ƒ")) + (should-error (fns-tests--with-region base64url-encode-region "ü"))) + (ert-deftest fns-test-base64url-encode-string () ;; url variant with padding @@ -344,7 +401,10 @@ (should (equal (base64url-encode-string (fns-tests--string-repeat "fooba" 15) t) (fns-tests--string-repeat "Zm9vYmFmb29iYWZvb2Jh" 5))) (should (equal (base64url-encode-string (fns-tests--string-repeat "foobar" 15) t) (concat (fns-tests--string-repeat "Zm9vYmFyZm9vYmFy" 7) "Zm9vYmFy"))) (should (equal (base64url-encode-string (fns-tests--string-repeat "\x14\xfb\x9c\x03\xd9\x7e" 10) t) (fns-tests--string-repeat "FPucA9l-" 10))) - (should (equal (base64url-encode-string (fns-tests--string-repeat "\x14\xfb\x9c\x03\xd9\x7f" 10) t) (fns-tests--string-repeat "FPucA9l_" 10)))) + (should (equal (base64url-encode-string (fns-tests--string-repeat "\x14\xfb\x9c\x03\xd9\x7f" 10) t) (fns-tests--string-repeat "FPucA9l_" 10))) + + (should-error (base64url-encode-string "ƒ")) + (should-error (base64url-encode-string "ü"))) (ert-deftest fns-tests-base64-decode-string () ;; standard variant RFC2045 @@ -430,6 +490,23 @@ (buffer-hash)) (sha1 "foo")))) +(ert-deftest fns-tests-mapconcat () + (should (string= (mapconcat #'identity '()) "")) + (should (string= (mapconcat #'identity '("a" "b")) "ab")) + (should (string= (mapconcat #'identity '() "_") "")) + (should (string= (mapconcat #'identity '("A") "_") "A")) + (should (string= (mapconcat #'identity '("A" "B") "_") "A_B")) + (should (string= (mapconcat #'identity '("A" "B" "C") "_") "A_B_C")) + ;; non-ASCII strings + (should (string= (mapconcat #'identity '("Ä" "ø" "☭" "தமிழ்") "_漢字_") + "Ä_漢字_ø_漢字_☭_漢字_தமிழ்")) + ;; vector + (should (string= (mapconcat #'identity ["a" "b"] "") "ab")) + ;; bool-vector + (should (string= (mapconcat #'identity [nil nil] "") "")) + (should-error (mapconcat #'identity [nil nil t]) + :type 'wrong-type-argument)) + (ert-deftest fns-tests-mapcan () (should-error (mapcan)) (should-error (mapcan #'identity)) diff --git a/test/src/image-tests.el b/test/src/image-tests.el new file mode 100644 index 00000000000..e54d0df71f1 --- /dev/null +++ b/test/src/image-tests.el @@ -0,0 +1,244 @@ +;;; image-tests.el --- Tests for image.c -*- lexical-binding: t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; Author: Stefan Kangas <stefan@marxist.se> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Most of these tests will only run in a GUI session, and not with +;; "make check". Run them manually in an interactive session with +;; `M-x eval-buffer' followed by `M-x ert'. + +;;; Code: + +(require 'ert) + +(defmacro image-skip-unless (format) + `(skip-unless (and (display-images-p) + (image-type-available-p ,format)))) + +;;;; Images + +(defconst image-tests--images + `((gif . ,(expand-file-name "test/data/image/black.gif" + source-directory)) + (jpeg . ,(expand-file-name "test/data/image/black.jpg" + source-directory)) + (pbm . ,(find-image '((:file "splash.svg" :type svg)))) + (png . ,(find-image '((:file "splash.png" :type png)))) + (svg . ,(find-image '((:file "splash.pbm" :type pbm)))) + (tiff . ,(expand-file-name + "nextstep/GNUstep/Emacs.base/Resources/emacs.tiff" + source-directory)) + (webp . ,(expand-file-name "test/data/image/black.webp" + source-directory)) + (xbm . ,(find-image '((:file "gnus/gnus.xbm" :type xbm)))) + (xpm . ,(find-image '((:file "splash.xpm" :type xpm)))))) + +;;;; image-test-size + +(ert-deftest image-tests-image-size/gif () + (image-skip-unless 'gif) + (pcase (image-size (create-image (cdr (assq 'gif image-tests--images)))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/jpeg () + (image-skip-unless 'jpeg) + (pcase (image-size (create-image (cdr (assq 'jpeg image-tests--images)))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/pbm () + (image-skip-unless 'pbm) + (pcase (image-size (cdr (assq 'pbm image-tests--images))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/png () + (image-skip-unless 'png) + (pcase (image-size (cdr (assq 'png image-tests--images))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/svg () + (image-skip-unless 'svg) + (pcase (image-size (cdr (assq 'svg image-tests--images))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/tiff () + (image-skip-unless 'tiff) + (pcase (image-size (create-image (cdr (assq 'tiff image-tests--images)))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/webp () + (image-skip-unless 'webp) + (pcase (image-size (create-image (cdr (assq 'webp image-tests--images)))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/xbm () + (image-skip-unless 'xbm) + (pcase (image-size (cdr (assq 'xbm image-tests--images))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/xpm () + (image-skip-unless 'xpm) + (pcase (image-size (cdr (assq 'xpm image-tests--images))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/error-on-invalid-spec () + (skip-unless (display-images-p)) + (should-error (image-size 'invalid-spec))) + +(ert-deftest image-tests-image-size/error-on-nongraphical-display () + (skip-unless (not (display-images-p))) + (should-error (image-size 'invalid-spec))) + +;;;; image-mask-p + +(ert-deftest image-tests-image-mask-p/gif () + (image-skip-unless 'gif) + (should-not (image-mask-p (create-image + (cdr (assq 'gif image-tests--images)))))) + +(ert-deftest image-tests-image-mask-p/jpeg () + (image-skip-unless 'jpeg) + (should-not (image-mask-p (create-image + (cdr (assq 'jpeg image-tests--images)))))) + +(ert-deftest image-tests-image-mask-p/pbm () + (image-skip-unless 'pbm) + (should-not (image-mask-p (cdr (assq 'pbm image-tests--images))))) + +(ert-deftest image-tests-image-mask-p/png () + (image-skip-unless 'png) + (should-not (image-mask-p (cdr (assq 'png image-tests--images))))) + +(ert-deftest image-tests-image-mask-p/svg () + (image-skip-unless 'svg) + (should-not (image-mask-p (cdr (assq 'svg image-tests--images))))) + +(ert-deftest image-tests-image-mask-p/tiff () + (image-skip-unless 'tiff) + (should-not (image-mask-p (create-image + (cdr (assq 'tiff image-tests--images)))))) + +(ert-deftest image-tests-image-mask-p/webp () + (image-skip-unless 'webp) + (should-not (image-mask-p (create-image + (cdr (assq 'webp image-tests--images)))))) + +(ert-deftest image-tests-image-mask-p/xbm () + (image-skip-unless 'xbm) + (should-not (image-mask-p (cdr (assq 'xbm image-tests--images))))) + +(ert-deftest image-tests-image-mask-p/xpm () + (image-skip-unless 'xpm) + (should-not (image-mask-p (cdr (assq 'xpm image-tests--images))))) + +(ert-deftest image-tests-image-mask-p/error-on-invalid-spec () + (skip-unless (display-images-p)) + (should-error (image-mask-p 'invalid-spec))) + +(ert-deftest image-tests-image-mask-p/error-on-nongraphical-display () + (skip-unless (not (display-images-p))) + (should-error (image-mask-p (cdr (assq 'xpm image-tests--images))))) + +;;;; image-metadata + +;; TODO: These tests could be expanded with files that actually +;; contain metadata. + +(ert-deftest image-tests-image-metadata/gif () + (image-skip-unless 'gif) + (should-not (image-metadata + (create-image (cdr (assq 'gif image-tests--images)))))) + +(ert-deftest image-tests-image-metadata/jpeg () + (image-skip-unless 'jpeg) + (should-not (image-metadata + (create-image (cdr (assq 'jpeg image-tests--images)))))) + +(ert-deftest image-tests-image-metadata/pbm () + (image-skip-unless 'pbm) + (should-not (image-metadata (cdr (assq 'pbm image-tests--images))))) + +(ert-deftest image-tests-image-metadata/png () + (image-skip-unless 'png) + (should-not (image-metadata (cdr (assq 'png image-tests--images))))) + +(ert-deftest image-tests-image-metadata/svg () + (image-skip-unless 'svg) + (should-not (image-metadata (cdr (assq 'svg image-tests--images))))) + +(ert-deftest image-tests-image-metadata/tiff () + (image-skip-unless 'tiff) + (should-not (image-metadata + (create-image (cdr (assq 'tiff image-tests--images)))))) + +(ert-deftest image-tests-image-metadata/webp () + (image-skip-unless 'webp) + (should-not (image-metadata + (create-image (cdr (assq 'webp image-tests--images)))))) + +(ert-deftest image-tests-image-metadata/xbm () + (image-skip-unless 'xbm) + (should-not (image-metadata (cdr (assq 'xbm image-tests--images))))) + +(ert-deftest image-tests-image-metadata/xpm () + (image-skip-unless 'xpm) + (should-not (image-metadata (cdr (assq 'xpm image-tests--images))))) + +(ert-deftest image-tests-image-metadata/nil-on-invalid-spec () + (skip-unless (display-images-p)) + (should-not (image-metadata 'invalid-spec))) + +(ert-deftest image-tests-image-metadata/error-on-nongraphical-display () + (skip-unless (not (display-images-p))) + (should-error (image-metadata (cdr (assq 'xpm image-tests--images))))) + +;;;; ImageMagick + +(ert-deftest image-tests-imagemagick-types () + (skip-unless (fboundp 'imagemagick-types)) + (when (fboundp 'imagemagick-types) + (should (listp (imagemagick-types))))) + +;;;; Initialization + +(ert-deftest image-tests-init-image-library () + (skip-unless (fboundp 'init-image-library)) + (should (init-image-library 'pbm)) ; built-in + (should-not (init-image-library 'invalid-image-type))) + +;;; image-tests.el ends here diff --git a/test/src/inotify-tests.el b/test/src/inotify-tests.el index 8aab7eeb30a..ea1951b8898 100644 --- a/test/src/inotify-tests.el +++ b/test/src/inotify-tests.el @@ -24,9 +24,11 @@ ;;; Code: (require 'ert) +(require 'ert-x) (declare-function inotify-add-watch "inotify.c" (file-name aspect callback)) (declare-function inotify-rm-watch "inotify.c" (watch-descriptor)) +(declare-function inotify-valid-p "inotify.c" (watch-descriptor)) (ert-deftest inotify-valid-p-simple () "Simple tests for `inotify-valid-p'." @@ -37,8 +39,7 @@ ;; (ert-deftest filewatch-file-watch-aspects-check () ;; "Test whether `file-watch' properly checks the aspects." -;; (let ((temp-file (make-temp-file "filewatch-aspects"))) -;; (should (stringp temp-file)) +;; (ert-with-temp-file temp-file ;; (should-error (file-watch temp-file 'wrong nil) ;; :type 'error) ;; (should-error (file-watch temp-file '(modify t) nil) @@ -50,23 +51,21 @@ (ert-deftest inotify-file-watch-simple () "Test if watching a normal file works." - (skip-unless (featurep 'inotify)) - (let ((temp-file (make-temp-file "inotify-simple")) - (events 0)) - (let ((wd - (inotify-add-watch temp-file t (lambda (_ev) - (setq events (1+ events)))))) - (unwind-protect - (progn - (with-temp-file temp-file - (insert "Foo\n")) - (read-event nil nil 5) - (should (> events 0))) - (should (inotify-valid-p wd)) - (inotify-rm-watch wd) - (should-not (inotify-valid-p wd)) - (delete-file temp-file))))) + (ert-with-temp-file temp-file + (let ((events 0)) + (let ((wd + (inotify-add-watch temp-file t (lambda (_ev) + (setq events (1+ events)))))) + (unwind-protect + (progn + (with-temp-file temp-file + (insert "Foo\n")) + (read-event nil nil 5) + (should (> events 0))) + (should (inotify-valid-p wd)) + (inotify-rm-watch wd) + (should-not (inotify-valid-p wd))))))) (provide 'inotify-tests) diff --git a/test/src/keymap-tests.el b/test/src/keymap-tests.el index 1943e719ab2..71fd9724295 100644 --- a/test/src/keymap-tests.el +++ b/test/src/keymap-tests.el @@ -134,6 +134,45 @@ (define-key map [menu-bar i-bar] 'foo) (should (eq (lookup-key map [menu-bar I-bar]) 'foo)))) +(ert-deftest keymap-lookup-key/mixed-case-multibyte () + "Backwards compatibility behaviour (Bug#50752)." + (let ((map (make-keymap))) + ;; (downcase "Åäö") => "åäö" + (define-key map [menu-bar åäö bar] 'foo) + (should (eq (lookup-key map [menu-bar åäö bar]) 'foo)) + (should (eq (lookup-key map [menu-bar Åäö Bar]) 'foo)) + ;; (downcase "Γ") => "γ" + (define-key map [menu-bar γ bar] 'baz) + (should (eq (lookup-key map [menu-bar γ bar]) 'baz)) + (should (eq (lookup-key map [menu-bar Γ Bar]) 'baz)))) + +(ert-deftest keymap-lookup-key/menu-non-symbol () + "Test for Bug#51527." + (let ((map (make-keymap))) + (define-key map [menu-bar buffer 1] 'foo) + (should (eq (lookup-key map [menu-bar buffer 1]) 'foo)))) + +(ert-deftest keymap-lookup-keymap/with-spaces () + "Backwards compatibility behaviour (Bug#50752)." + (let ((map (make-keymap))) + (define-key map [menu-bar foo-bar] 'foo) + (should (eq (lookup-key map [menu-bar Foo\ Bar]) 'foo)))) + +(ert-deftest keymap-lookup-keymap/with-spaces-multibyte () + "Backwards compatibility behaviour (Bug#50752)." + (let ((map (make-keymap))) + (define-key map [menu-bar åäö-bar] 'foo) + (should (eq (lookup-key map [menu-bar Åäö\ Bar]) 'foo)))) + +(ert-deftest keymap-lookup-keymap/with-spaces-multibyte-lang-env () + "Backwards compatibility behaviour (Bug#50752)." + (let ((lang-env current-language-environment)) + (set-language-environment "Turkish") + (let ((map (make-keymap))) + (define-key map [menu-bar i-bar] 'foo) + (should (eq (lookup-key map [menu-bar I-bar]) 'foo))) + (set-language-environment lang-env))) + (ert-deftest describe-buffer-bindings/header-in-current-buffer () "Header should be inserted into the current buffer. https://debbugs.gnu.org/39149#31" @@ -237,15 +276,11 @@ commit 86c19714b097aa477d339ed99ffb5136c755a046." (should (equal (where-is-internal 'foo map t) [?y])) (should (equal (where-is-internal 'bar map t) [?y])))) -(defvar keymap-tests-minor-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "x" 'keymap-tests--command-2) - map)) +(defvar-keymap keymap-tests-minor-mode-map + "x" 'keymap-tests--command-2) -(defvar keymap-tests-major-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "x" 'keymap-tests--command-1) - map)) +(defvar-keymap keymap-tests-major-mode-map + "x" 'keymap-tests--command-1) (define-minor-mode keymap-tests-minor-mode "Test.") @@ -284,12 +319,12 @@ commit 86c19714b097aa477d339ed99ffb5136c755a046." (with-temp-buffer (help--describe-vector (cadr orig-map) nil #'help--describe-command t shadow-map orig-map t) - (should (equal (buffer-string) - " + (should (equal (buffer-substring-no-properties (point-min) (point-max)) + (string-replace "\t" "" " e foo f foo (currently shadowed by `bar') g .. h foo -"))))) +")))))) (ert-deftest help--describe-vector/bug-9293-same-command-does-not-shadow () "Check that a command can't be shadowed by the same command." @@ -310,10 +345,10 @@ g .. h foo (with-temp-buffer (help--describe-vector (cadr range-map) nil #'help--describe-command t shadow-map range-map t) - (should (equal (buffer-string) - " + (should (equal (buffer-substring-no-properties (point-min) (point-max)) + (string-replace "\t" "" " 0 .. 3 foo -"))))) +")))))) (ert-deftest keymap--key-description () (should (equal (key-description [right] [?\C-x]) @@ -327,6 +362,62 @@ g .. h foo (should (equal (single-key-description 'C-s-home) "C-s-<home>"))) +(ert-deftest keymap-test-lookups () + (should (eq (lookup-key (current-global-map) "\C-x\C-f") 'find-file)) + (should (eq (lookup-key (current-global-map) [(control x) (control f)]) + 'find-file)) + (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)))) + +(ert-deftest keymap-text-char-description () + (should (equal (text-char-description ?a) "a")) + (should (equal (text-char-description ?\s) " ")) + (should (equal (text-char-description ?\t) "^I")) + (should (equal (text-char-description ?\^C) "^C")) + (should (equal (text-char-description ?\^?) "^?")) + (should (equal (text-char-description #x80) "")) + (should (equal (text-char-description ?å) "å")) + (should (equal (text-char-description ?Ş) "Ş")) + (should (equal (text-char-description ?Ā) "Ā")) + (should-error (text-char-description "c")) + (should-error (text-char-description [?\C-x ?l])) + (should-error (text-char-description ?\M-c)) + (should-error (text-char-description ?\s-c))) + (provide 'keymap-tests) ;;; keymap-tests.el ends here diff --git a/test/src/lcms-tests.el b/test/src/lcms-tests.el index d2d137e9bd5..bffeba762ac 100644 --- a/test/src/lcms-tests.el +++ b/test/src/lcms-tests.el @@ -35,6 +35,13 @@ (require 'ert) (require 'color) +(declare-function lcms-jab->jch "lcms.c") +(declare-function lcms-jch->jab "lcms.c") +(declare-function lcms-xyz->jch "lcms.c") +(declare-function lcms-jch->xyz "lcms.c") +(declare-function lcms-temp->white-point "lcms.c") +(declare-function lcms-cam02-ucs "lcms.c") + (defconst lcms-colorspacious-d65 '(0.95047 1.0 1.08883) "D65 white point from colorspacious.") diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el index dac8f95bc4d..c635c592b28 100644 --- a/test/src/lread-tests.el +++ b/test/src/lread-tests.el @@ -115,18 +115,14 @@ (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#)")))) -(defmacro lread-tests--with-temp-file (file-name-var &rest body) - (declare (indent 1)) - (cl-check-type file-name-var symbol) - `(let ((,file-name-var (make-temp-file "emacs"))) - (unwind-protect - (progn ,@body) - (delete-file ,file-name-var)))) - (defun lread-tests--last-message () (with-current-buffer "*Messages*" (save-excursion @@ -137,7 +133,7 @@ (ert-deftest lread-tests--unescaped-char-literals () "Check that loading warns about unescaped character literals (Bug#20852)." - (lread-tests--with-temp-file file-name + (ert-with-temp-file file-name (write-region "?) ?( ?; ?\" ?[ ?]" nil file-name) (should (equal (load file-name nil :nomessage :nosuffix) t)) (should (equal (lread-tests--last-message) diff --git a/test/src/process-tests.el b/test/src/process-tests.el index 44f3ea2fbb4..baa825778a4 100644 --- a/test/src/process-tests.el +++ b/test/src/process-tests.el @@ -25,11 +25,16 @@ (require 'cl-lib) (require 'ert) +(require 'ert-x) ; ert-with-temp-directory (require 'puny) (require 'subr-x) (require 'dns) (require 'url-http) +(declare-function thread-last-error "thread.c") +(declare-function thread-join "thread.c") +(declare-function make-thread "thread.c") + ;; Timeout in seconds; the test fails if the timeout is reached. (defvar process-test-sentinel-wait-timeout 2.0) @@ -64,24 +69,22 @@ (when (eq system-type 'windows-nt) (ert-deftest process-test-quoted-batfile () "Check that Emacs hides CreateProcess deficiency (bug#18745)." - (let (batfile) - (unwind-protect - (progn - ;; CreateProcess will fail when both the bat file and 1st - ;; argument are quoted, so include spaces in both of those - ;; to force quoting. - (setq batfile (make-temp-file "echo args" nil ".bat")) - (with-temp-file batfile - (insert "@echo arg1=%1, arg2=%2\n")) - (with-temp-buffer - (call-process batfile nil '(t t) t "x &y") - (should (string= (buffer-string) "arg1=\"x &y\", arg2=\n"))) - (with-temp-buffer - (call-process-shell-command - (mapconcat #'shell-quote-argument (list batfile "x &y") " ") - nil '(t t) t) - (should (string= (buffer-string) "arg1=\"x &y\", arg2=\n")))) - (when batfile (delete-file batfile)))))) + (ert-with-temp-file batfile + ;; CreateProcess will fail when both the bat file and 1st + ;; argument are quoted, so include spaces in both of those + ;; to force quoting. + :prefix "echo args" + :suffix ".bat" + (with-temp-file batfile + (insert "@echo arg1=%1, arg2=%2\n")) + (with-temp-buffer + (call-process batfile nil '(t t) t "x &y") + (should (string= (buffer-string) "arg1=\"x &y\", arg2=\n"))) + (with-temp-buffer + (call-process-shell-command + (mapconcat #'shell-quote-argument (list batfile "x &y") " ") + nil '(t t) t) + (should (string= (buffer-string) "arg1=\"x &y\", arg2=\n")))))) (ert-deftest process-test-stderr-buffer () (skip-unless (executable-find "bash")) @@ -531,18 +534,6 @@ FD_SETSIZE." (delete-process (pop ,processes)) ,@body))))) -(defmacro process-tests--with-temp-directory (var &rest body) - "Bind VAR to the name of a new directory and evaluate BODY. -Afterwards, delete the directory." - (declare (indent 1) (debug (symbolp body))) - (cl-check-type var symbol) - (let ((dir (make-symbol "dir"))) - `(let ((,dir (make-temp-file "emacs-test-" :dir))) - (unwind-protect - (let ((,var ,dir)) - ,@body) - (delete-directory ,dir :recursive))))) - ;; Tests for FD_SETSIZE overflow (Bug#24325). The following tests ;; generate lots of process objects of the various kinds. Running the ;; tests with assertions enabled should not result in any crashes due @@ -630,7 +621,7 @@ FD_SETSIZE file descriptors (Bug#24325)." ;; Avoid hang due to connect/accept handshake on Cygwin (bug#49496). (skip-unless (not (eq system-type 'cygwin))) (with-timeout (60 (ert-fail "Test timed out")) - (process-tests--with-temp-directory directory + (ert-with-temp-directory directory (process-tests--with-processes processes (let* ((num-clients 10) (socket-name (expand-file-name "socket" directory)) @@ -800,6 +791,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/search-tests.el b/test/src/search-tests.el index b7b4ab9a8ff..b5f4730f265 100644 --- a/test/src/search-tests.el +++ b/test/src/search-tests.el @@ -28,7 +28,7 @@ (setq ov-set (make-overlay 3 5)) (overlay-put ov-set 'modification-hooks - (list (lambda (o after &rest _args) + (list (lambda (_o after &rest _args) (when after (let ((inhibit-modification-hooks t)) (save-excursion diff --git a/test/src/sqlite-tests.el b/test/src/sqlite-tests.el new file mode 100644 index 00000000000..d7100537a4e --- /dev/null +++ b/test/src/sqlite-tests.el @@ -0,0 +1,219 @@ +;;; sqlite-tests.el --- Tests for sqlite.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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert) +(require 'ert-x) + +(declare-function sqlite-execute "sqlite.c") +(declare-function sqlite-close "sqlite.c") +(declare-function sqlitep "sqlite.c") +(declare-function sqlite-available-p "sqlite.c") +(declare-function sqlite-finalize "sqlite.c") +(declare-function sqlite-next "sqlite.c") +(declare-function sqlite-more-p "sqlite.c") +(declare-function sqlite-select "sqlite.c") +(declare-function sqlite-open "sqlite.c") +(declare-function sqlite-load-extension "sqlite.c") + +(ert-deftest sqlite-select () + (skip-unless (sqlite-available-p)) + (let ((db (sqlite-open))) + (should (eq (type-of db) 'sqlite)) + (should (sqlitep db)) + (should-not (sqlitep 'foo)) + + (should + (zerop + (sqlite-execute + db "create table if not exists test1 (col1 text, col2 integer, col3 float, col4 blob)"))) + + (should-error + (sqlite-execute + db "insert into test1 (col1, col2, col3, col4) values ('foo', 2, 9.45, 'bar', 'zot')")) + + (should + (= + (sqlite-execute + db "insert into test1 (col1, col2, col3, col4) values ('foo', 2, 9.45, 'bar')") + 1)) + + (should + (equal + (sqlite-select db "select * from test1" nil 'full) + '(("col1" "col2" "col3" "col4") ("foo" 2 9.45 "bar")))))) + +(ert-deftest sqlite-set () + (skip-unless (sqlite-available-p)) + (let ((db (sqlite-open)) + set) + (should + (zerop + (sqlite-execute + db "create table if not exists test1 (col1 text, col2 integer)"))) + + (should + (= + (sqlite-execute db "insert into test1 (col1, col2) values ('foo', 1)") + 1)) + (should + (= + (sqlite-execute db "insert into test1 (col1, col2) values ('bar', 2)") + 1)) + + (setq set (sqlite-select db "select * from test1" nil 'set)) + (should (sqlitep set)) + (should (sqlite-more-p set)) + (should (equal (sqlite-next set) + '("foo" 1))) + (should (equal (sqlite-next set) + '("bar" 2))) + (should-not (sqlite-next set)) + (should-not (sqlite-more-p set)) + (sqlite-finalize set) + (should-error (sqlite-next set)))) + +(ert-deftest sqlite-chars () + (skip-unless (sqlite-available-p)) + (let (db) + (setq db (sqlite-open)) + (sqlite-execute + db "create table if not exists test2 (col1 text, col2 integer)") + (sqlite-execute + db "insert into test2 (col1, col2) values ('fóo', 3)") + (sqlite-execute + db "insert into test2 (col1, col2) values ('fóo', 3)") + (sqlite-execute + db "insert into test2 (col1, col2) values ('fo', 4)") + (should + (equal (sqlite-select db "select * from test2" nil 'full) + '(("col1" "col2") ("fóo" 3) ("fóo" 3) ("fo" 4)))))) + +(ert-deftest sqlite-numbers () + (skip-unless (sqlite-available-p)) + (let (db) + (setq db (sqlite-open)) + (sqlite-execute + db "create table if not exists test3 (col1 integer)") + (let ((big (expt 2 50)) + (small (expt 2 10))) + (sqlite-execute db (format "insert into test3 values (%d)" small)) + (sqlite-execute db (format "insert into test3 values (%d)" big)) + (should + (equal + (sqlite-select db "select * from test3") + (list (list small) (list big))))))) + +(ert-deftest sqlite-param () + (skip-unless (sqlite-available-p)) + (let (db) + (setq db (sqlite-open)) + (sqlite-execute + db "create table if not exists test4 (col1 text, col2 number)") + (sqlite-execute db "insert into test4 values (?, ?)" (list "foo" 1)) + (should + (equal + (sqlite-select db "select * from test4 where col2 = ?" '(1)) + '(("foo" 1)))) + (should + (equal + (sqlite-select db "select * from test4 where col2 = ?" [1]) + '(("foo" 1)))))) + +(ert-deftest sqlite-binary () + (skip-unless (sqlite-available-p)) + (let (db) + (setq db (sqlite-open)) + (sqlite-execute + db "create table if not exists test5 (col1 text, col2 number)") + (let ((string (with-temp-buffer + (set-buffer-multibyte nil) + (insert 0 1 2) + (buffer-string)))) + (should-not (multibyte-string-p string)) + (sqlite-execute + db "insert into test5 values (?, ?)" (list string 2)) + (let ((out (caar + (sqlite-select db "select col1 from test5 where col2 = 2")))) + (should (equal out string)))))) + +(ert-deftest sqlite-different-dbs () + (skip-unless (sqlite-available-p)) + (let (db1 db2) + (setq db1 (sqlite-open)) + (setq db2 (sqlite-open)) + (sqlite-execute + db1 "create table if not exists test6 (col1 text, col2 number)") + (sqlite-execute + db2 "create table if not exists test6 (col1 text, col2 number)") + (sqlite-execute + db1 "insert into test6 values (?, ?)" '("foo" 2)) + (should (sqlite-select db1 "select * from test6")) + (should-not (sqlite-select db2 "select * from test6")))) + +(ert-deftest sqlite-close-dbs () + (skip-unless (sqlite-available-p)) + (let (db) + (setq db (sqlite-open)) + (sqlite-execute + db "create table if not exists test6 (col1 text, col2 number)") + (sqlite-execute db "insert into test6 values (?, ?)" '("foo" 2)) + (should (sqlite-select db "select * from test6")) + (sqlite-close db) + (should-error (sqlite-select db "select * from test6")))) + +(ert-deftest sqlite-load-extension () + (skip-unless (sqlite-available-p)) + (skip-unless (fboundp 'sqlite-load-extension)) + (let (db) + (setq db (sqlite-open)) + (should-error + (sqlite-load-extension db "/usr/lib/sqlite3/notpcre.so")) + (should-error + (sqlite-load-extension db "/usr/lib/sqlite3/n")) + (should-error + (sqlite-load-extension db "/usr/lib/sqlite3/")) + (should-error + (sqlite-load-extension db "/usr/lib/sqlite3")) + (should + (memq + (sqlite-load-extension db "/usr/lib/sqlite3/pcre.so") + '(nil t))) + + (should-error + (sqlite-load-extension + db "/usr/lib/x86_64-linux-gnu/libsqlite3_mod_notcsvtable.so")) + (should-error + (sqlite-load-extension + db "/usr/lib/x86_64-linux-gnu/libsqlite3_mod_csvtablen.so")) + (should-error + (sqlite-load-extension + db "/usr/lib/x86_64-linux-gnu/libsqlite3_mod_csvtable")) + (should + (memq + (sqlite-load-extension + db "/usr/lib/x86_64-linux-gnu/libsqlite3_mod_csvtable.so") + '(nil t))))) + +;;; sqlite-tests.el ends here diff --git a/test/src/thread-tests.el b/test/src/thread-tests.el index 52eace7e9d2..f1a8baedadd 100644 --- a/test/src/thread-tests.el +++ b/test/src/thread-tests.el @@ -389,6 +389,7 @@ (should (equal (thread-last-error) '(error "Die, die, die!"))))) (ert-deftest threads-test-bug33073 () + (skip-unless (fboundp 'make-thread)) (let ((th (make-thread 'ignore))) (should-not (equal th main-thread)))) diff --git a/test/src/timefns-tests.el b/test/src/timefns-tests.el index bba9b3fcd8c..f801478a9a1 100644 --- a/test/src/timefns-tests.el +++ b/test/src/timefns-tests.el @@ -242,4 +242,16 @@ a fixed place on the right and are padded on the left." (should (= xdiv (float-time (time-convert xdiv t)))))) (setq x (* x 2))))) +(ert-deftest time-convert-forms () + ;; These computations involve numbers that should have exact + ;; representations on any Emacs platform. + (dolist (time '(-86400 -1 0 1 86400)) + (dolist (delta '(0 0.0 0.25 3.25 1000 1000.25)) + (let ((time+ (+ time delta)) + (time- (- time delta))) + (dolist (form '(nil t list 4 1000 1000000 1000000000)) + (should (time-equal-p time (time-convert time form))) + (should (time-equal-p time- (time-convert time- form))) + (should (time-equal-p time+ (time-convert time+ form)))))))) + ;;; timefns-tests.el ends here diff --git a/test/src/undo-tests.el b/test/src/undo-tests.el index a658bccf6dc..88fcfad14cc 100644 --- a/test/src/undo-tests.el +++ b/test/src/undo-tests.el @@ -46,6 +46,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'facemenu) (ert-deftest undo-test0 () @@ -218,17 +219,14 @@ (ert-deftest undo-test-file-modified () "Test undoing marks buffer visiting file unmodified." - (let ((tempfile (make-temp-file "undo-test"))) - (unwind-protect - (progn - (with-current-buffer (find-file-noselect tempfile) - (insert "1") - (undo-boundary) - (set-buffer-modified-p nil) - (insert "2") - (undo) - (should-not (buffer-modified-p)))) - (delete-file tempfile)))) + (ert-with-temp-file tempfile + (with-current-buffer (find-file-noselect tempfile) + (insert "1") + (undo-boundary) + (set-buffer-modified-p nil) + (insert "2") + (undo) + (should-not (buffer-modified-p))))) (ert-deftest undo-test-region-not-most-recent () "Test undo in region of an edit not the most recent." diff --git a/test/src/xdisp-tests.el b/test/src/xdisp-tests.el index 4e7d2ad8ab2..ae4aacd9c7c 100644 --- a/test/src/xdisp-tests.el +++ b/test/src/xdisp-tests.el @@ -99,4 +99,75 @@ (width-in-chars (/ (car size) char-width))) (should (equal width-in-chars 3))))) +(ert-deftest xdisp-tests--find-directional-overrides-case-1 () + (with-temp-buffer + (insert "\ +int main() { + bool isAdmin = false; + /* }if (isAdmin) begin admins only */ + printf(\"You are an admin.\\n\"); + /* end admins only { */ + return 0; +}") + (goto-char (point-min)) + (should (eq (bidi-find-overridden-directionality (point-min) (point-max) + nil) + 46)))) + +(ert-deftest xdisp-tests--find-directional-overrides-case-2 () + (with-temp-buffer + (insert "\ +#define is_restricted_user(user) \\ + !strcmp (user, \"root\") ? 0 : \\ + !strcmp (user, \"admin\") ? 0 : \\ + !strcmp (user, \"superuser? 0 : 1 \") + +int main () { + printf (\"root: %d\\n\", is_restricted_user (\"root\")); + printf (\"admin: %d\\n\", is_restricted_user (\"admin\")); + printf (\"superuser: %d\\n\", is_restricted_user (\"superuser\")); + printf (\"luser: %d\\n\", is_restricted_user (\"luser\")); + printf (\"nobody: %d\\n\", is_restricted_user (\"nobody\")); +}") + (goto-char (point-min)) + (should (eq (bidi-find-overridden-directionality (point-min) (point-max) + nil) + 138)))) + +(ert-deftest xdisp-tests--find-directional-overrides-case-3 () + (with-temp-buffer + (insert "\ +#define is_restricted_user(user) \\ + !strcmp (user, \"root\") ? 0 : \\ + !strcmp (user, \"admin\") ? 0 : \\ + !strcmp (user, \"superuser? '#' : '!' \") + +int main () { + printf (\"root: %d\\n\", is_restricted_user (\"root\")); + printf (\"admin: %d\\n\", is_restricted_user (\"admin\")); + printf (\"superuser: %d\\n\", is_restricted_user (\"superuser\")); + printf (\"luser: %d\\n\", is_restricted_user (\"luser\")); + printf (\"nobody: %d\\n\", is_restricted_user (\"nobody\")); +}") + (goto-char (point-min)) + (should (eq (bidi-find-overridden-directionality (point-min) (point-max) + 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 diff --git a/test/src/xml-tests.el b/test/src/xml-tests.el index 7c4ca396f70..62d9e3ff7e7 100644 --- a/test/src/xml-tests.el +++ b/test/src/xml-tests.el @@ -27,6 +27,8 @@ (require 'ert) +(declare-function libxml-parse-xml-region "xml.c") + (defvar libxml-tests--data-comments-preserved `(;; simple case ("<?xml version=\"1.0\"?><foo baz=\"true\">bar</foo>" |