diff --git a/.gitignore b/.gitignore index dd4eab759cb..7e3e4341814 100644 --- a/.gitignore +++ b/.gitignore @@ -298,3 +298,4 @@ nt/emacs.rc nt/emacsclient.rc src/gdb.ini /var/ +src/fingerprint.c diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index bc18137a439..3138f4184e6 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -1,4 +1,4 @@ -# Copyright (C) 2017-2021 Free Software Foundation, Inc. +# Copyright (C) 2021 Free Software Foundation, Inc. # # This file is part of GNU Emacs. # @@ -24,89 +24,5 @@ # Maintainer: Ted Zlatanov # URL: https://emba.gnu.org/emacs/emacs -image: debian:stretch - -variables: - GIT_STRATEGY: fetch - EMACS_EMBA_CI: 1 - -before_script: - - apt update -qq - - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libc-dev gcc g++ make autoconf automake libncurses-dev gnutls-dev git - -stages: - - test - -test-all: - # This tests also file monitor libraries inotify and inotifywatch. - stage: test - only: - changes: - - "Makefile.in" - - .gitlab-ci.yml - - aclocal.m4 - - autogen.sh - - configure.ac - - lib/*.{h,c} - - lisp/*.el - - lisp/**/*.el - - src/*.{h,c} - - test/lisp/*.el - - test/lisp/**/*.el - - test/src/*.el - except: - changes: - # gfilemonitor, kqueue - - src/gfilenotify.c - - src/kqueue.c - # MS Windows - - lisp/w32*.el - - lisp/term/w32*.el - - src/w32*.{h,c} - # GNUstep - - lisp/term/ns-win.el - - src/ns*.{h,m} - - src/macfont.{h,m} - script: - - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 inotify-tools - - ./autogen.sh autoconf - - ./configure --without-makeinfo - - make bootstrap - - make check-expensive - -test-filenotify-gio: - stage: test - # This tests file monitor libraries gfilemonitor and gio. - only: - changes: - - .gitlab-ci.yml - - lisp/autorevert.el - - lisp/filenotify.el - - lisp/net/tramp-sh.el - - src/gfilenotify.c - - test/lisp/autorevert-tests.el - - test/lisp/filenotify-tests.el - script: - - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libglib2.0-dev libglib2.0-bin libglib2.0-0 - - ./autogen.sh autoconf - - ./configure --without-makeinfo --with-file-notification=gfile - - make bootstrap - - make -k -C test autorevert-tests filenotify-tests - -test-gnustep: - stage: test - # This tests the GNUstep build process - only: - changes: - - .gitlab-ci.yml - - configure.ac - - src/ns*.{h,m} - - src/macfont.{h,m} - - lisp/term/ns-win.el - - nextstep/**/* - script: - - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 gnustep-devel - - ./autogen.sh autoconf - - ./configure --without-makeinfo --with-ns - - make bootstrap - - make install +# Just load from test/infra, to keep build automation files there. +include: '/test/infra/gitlab-ci.yml' diff --git a/admin/notes/elpa b/admin/notes/elpa index ea6c132fe19..1e9e7a9f52b 100644 --- a/admin/notes/elpa +++ b/admin/notes/elpa @@ -5,17 +5,31 @@ repository named "elpa", hosted on Savannah. To check it out: git clone git://git.sv.gnu.org/emacs/elpa cd elpa - git remote set-url --push origin git+ssh://git.sv.gnu.org/srv/git/emacs/elpa - [create task branch for edits, etc.] + make setup -Changes to this branch propagate to elpa.gnu.org via a "deployment" script run -daily. This script (which is kept in elpa/admin/update-archive.sh) generates -the content visible at https://elpa.gnu.org/packages. +That leaves the elpa/packages directory empty; you must check out the +ones you want. -A new package is released as soon as the "version number" of that package is -changed. So you can use 'elpa' to work on a package without fear of releasing -those changes prematurely. And once the code is ready, just bump the -version number to make a new release of the package. +If you wish to check out all the packages into the packages directory, +you can run the command: + + make worktrees + +You can check out a specific package into the packages +directory with: + + make packages/ + + +Changes to this repository propagate to elpa.gnu.org via a +"deployment" script run daily. This script generates the content +visible at https://elpa.gnu.org/packages. + +A new package is released as soon as the "version number" of that +package is changed. So you can use 'elpa' to work on a package +without fear of releasing those changes prematurely. And once the +code is ready, just bump the version number to make a new release of +the package. It is easy to use the elpa branch to deploy a "local" copy of the package archive. For details, see the README file in the elpa branch. diff --git a/admin/nt/dist-build/README-scripts b/admin/nt/dist-build/README-scripts index 4c3554e8df5..f27bcd3bd66 100644 --- a/admin/nt/dist-build/README-scripts +++ b/admin/nt/dist-build/README-scripts @@ -33,26 +33,21 @@ build-zips.sh file will create this for you. A location for the dependencies. This needs to contain two zip files with the dependencies. build-dep-zips.py will create these files for you. -~/emacs-build/deps/libXpm/i686 -~/emacs-build/deps/libXpm/x86_64 +~/emacs-build/deps/libXpm Contain libXpm-noX4.dll. This file is used to load images for the splash screen, menu items and so on. Emacs runs without it, but looks -horrible. The x86_64 comes from msys2, while the i686 comes from -ezwinports because it itself has no dependencies. These have to be -placed manually (but probably never need updating). +horrible. The files came original from msys2, and contains no +dependencies. It has to be placed manually (but probably never +need updating). - -~/emacs-build/build/$version/i686 -~/emacs-build/build/$version/x86_64 +~/emacs-build/build/$version We build Emacs out-of-source here. This directory is created by build-zips.sh. This directory can be freely deleted after zips have been created - -~/emacs-build/install/$version/i686 -~/emacs-build/install/$version/x86_64 +~/emacs-build/install/$version We install Emacs here. This directory is created by build-zips.sh. This directory can and *should* be deleted after zips have been @@ -79,9 +74,9 @@ To do this: Update msys to the latest version with `pacman -Syu`. -Then run build-dep-zips.py, in the ~/emacs-build/deps directory. Three -zips will be created, containing the 64bit and 32bit dependencies, as -well as the source for these. +Then run build-dep-zips.py, in the ~/emacs-build/deps directory. Two +zips will be created, containing the dependencies, as well as the +source for these. For emacs release or pre-test version: @@ -105,12 +100,12 @@ To do this: Update msys to the latest version with `pacman -Syu`. -Then run build-dep-zips.py, in ~/emacs-build/deps directory. Three -zips will be created, containing the 64bit and 32bit dependencies, as -well as the source for these. These deps files contain the date of -creation in their name. The deps file can be reused as desired, or a -new version created. Where multiple deps files exist, the most -recent will be used. +Then run build-dep-zips.py, in ~/emacs-build/deps directory. Two zips +will be created, containing the dependencies, as well as the source +for these. These deps files contain the date of creation in their +name. The deps file can be reused as desired, or a new version +created. Where multiple deps files exist, the most recent will be +used. Now, run `build-zips.sh -s` to build a snapshot release. @@ -134,4 +129,5 @@ For snapshots from another branch Snapshots can be build from any other branch. There is rarely a need to do this, except where some significant, wide-ranging feature is being added on a feature branch. In this case, the branch can be -given using `build-zips.sh -b pdumper -s` for example. +given using `build-zips.sh -b pdumper -s` for example. Any "/" +characters in the branch title are replaced. diff --git a/admin/nt/dist-build/README-windows-binaries b/admin/nt/dist-build/README-windows-binaries index 001bdd73f7b..b6f6e55d8c6 100644 --- a/admin/nt/dist-build/README-windows-binaries +++ b/admin/nt/dist-build/README-windows-binaries @@ -4,7 +4,7 @@ See the end of the file for license conditions. Precompiled Distributions of Emacs for Windows - Jan 1, 2020 + Jan 14, 2021 This directory contains precompiled distributions for GNU Emacs on Windows @@ -25,51 +25,33 @@ old binaries. Windows Binaries ================ -Currently, we provide six different binary packages for Emacs, which +Currently, we provide three different binary packages for Emacs, which are: -emacs-$VERSION-x86_64-installer.exe +emacs-$VERSION-installer.exe -Contains a 64-bit build of Emacs with dependencies as an installer +Contains Emacs with dependencies as an installer package. Mostly, this is the best one to install. -emacs-$VERSION-x86_64.zip +emacs-$VERSION.zip -Contains a 64-bit build of Emacs with dependencies. This contains the -same files as the installer but as a zip file which some users may -prefer. +Contains Emacs with dependencies. This contains the same files as the +installer but as a zip file which some users may prefer. -emacs-$VERSION-x86_64-no-deps.zip +emacs-$VERSION-no-deps.zip -Contains a 64-bit build of Emacs without any dependencies. This may be -useful if you wish to install where the dependencies are already -available, or if you want the small possible Emacs. - -emacs-$VERSION-i686-installer.exe - -Contains a 32-bit build of Emacs with dependencies as an installer -package. This is useful for running on a 32-bit machine. - -emacs-$VERSION-i686.zip - -Contains a 32-bit build of Emacs with dependencies. - -emacs-$VERSION-i686-no-deps.zip - -Contains a 32-bit build of Emacs without dependencies +Contains Emacs without any dependencies. This may be useful if you +wish to install where the dependencies are already available, or if +you want the small possible Emacs. In addition, we provide the following files which will not be useful for most end-users. -emacs-$VERSION-x86_64-deps.zip +emacs-$VERSION-deps.zip The dependencies. Unzipping this file on top of -emacs-$VERSION-x86_64-no-deps.zip should result in the same install as -emacs-$VERSION-x86_64.zip. - -emacs-$VERSION-i686-deps.zip - -The 32-bit version of the dependencies. +emacs-$VERSION-no-deps.zip should result in the same install as +emacs-$VERSION.zip. emacs-$VERSION-deps-mingw-w64-src.zip @@ -85,7 +67,8 @@ Snapshots We also distribute "snapshots" of Emacs built at points throughout the development cycle, for those interested in following this cycle. They -are not recommended for normal users. +are not recommended for normal users; however, they are useful for +people who want to report bugs against the current master. The files follow the same naming convention, but also include a date (and sometimes information about their branch). The Emacs source at diff --git a/admin/nt/dist-build/build-dep-zips.py b/admin/nt/dist-build/build-dep-zips.py index 47185dbb1ba..19168e7ff25 100755 --- a/admin/nt/dist-build/build-dep-zips.py +++ b/admin/nt/dist-build/build-dep-zips.py @@ -17,7 +17,6 @@ ## You should have received a copy of the GNU General Public License ## along with GNU Emacs. If not, see . import argparse -import multiprocessing as mp import os import shutil import re @@ -40,27 +39,22 @@ mingw-w64-x86_64-libxml2 mingw-w64-x86_64-xpm-nox'''.split() +DLL_REQ='''libgif +libgnutls +libharfbuzz +libjansson +liblcms2 +libturbojpeg +libpng +librsvg +libtiff +libxml +libXpm'''.split() + ## Options DRY_RUN=False -## Packages to fiddle with -## Source for gcc-libs is part of gcc -SKIP_SRC_PKGS=["mingw-w64-gcc-libs"] -SKIP_DEP_PKGS=["mingw-w64-x86_64-glib2"] -MUNGE_SRC_PKGS={"mingw-w64-libwinpthread-git":"mingw-w64-winpthreads-git"} -MUNGE_DEP_PKGS={ - "mingw-w64-i686-libwinpthread":"mingw-w64-i686-libwinpthread-git", - "mingw-w64-x86_64-libwinpthread":"mingw-w64-x86_64-libwinpthread-git", - - "mingw-w64-x86_64-libtre": "mingw-w64-x86_64-libtre-git", - "mingw-w64-i686-libtre": "mingw-w64-i686-libtre-git" -} - -## Currently no packages seem to require this! -ARCH_PKGS=[] -SRC_REPO="https://sourceforge.net/projects/msys2/files/REPOS/MINGW/Sources" - def check_output_maybe(*args,**kwargs): if(DRY_RUN): @@ -68,6 +62,68 @@ def check_output_maybe(*args,**kwargs): else: return check_output(*args,**kwargs) +## DLL Capture +def gather_deps(): + + os.mkdir("x86_64") + os.chdir("x86_64") + + for dep in full_dll_dependency(): + check_output_maybe(["cp /mingw64/bin/{}*.dll .".format(dep)], + shell=True) + + print("Zipping") + check_output_maybe("zip -9r ../emacs-{}-{}deps.zip *" + .format(EMACS_MAJOR_VERSION, DATE), + shell=True) + os.chdir("../") + +## Return all Emacs dependencies +def full_dll_dependency(): + deps = [dll_dependency(dep) for dep in DLL_REQ] + return set(sum(deps, []) + DLL_REQ) + +## Dependencies for a given DLL +def dll_dependency(dll): + output = check_output(["/mingw64/bin/ntldd", "--recursive", + "/mingw64/bin/{}*.dll".format(dll)]).decode("utf-8") + ## munge output + return ntldd_munge(output) + +def ntldd_munge(out): + deps = out.splitlines() + rtn = [] + for dep in deps: + ## Output looks something like this + + ## KERNEL32.dll => C:\Windows\SYSTEM32\KERNEL32.dll (0x0000000002a30000) + ## libwinpthread-1.dll => C:\msys64\mingw64\bin\libwinpthread-1.dll (0x0000000000090000) + + ## if it's the former, we want it, if its the later we don't + splt = dep.split() + if len(splt) > 2 and "msys64" in splt[2]: + print("Adding dep", splt[0]) + rtn.append(splt[0].split(".")[0]) + + return rtn + +#### Source Capture + +## 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"] +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", + "mingw-w64-x86_64-libtre": "mingw-w64-x86_64-libtre-git", +} + +## Currently no packages seem to require this! +ARCH_PKGS=[] +SRC_REPO="https://sourceforge.net/projects/msys2/files/REPOS/MINGW/Sources" + + def immediate_deps(pkg): package_info = check_output(["pacman", "-Si", pkg]).decode("utf-8").split("\n") @@ -87,92 +143,50 @@ def immediate_deps(pkg): return dependencies +## Extract all the msys2 packages that are dependencies of our direct dependencies def extract_deps(): print( "Extracting deps" ) # Get a list of all dependencies needed for packages mentioned above. pkgs = PKG_REQ[:] - print("Initial pkgs", pkgs) 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): - print("adding", p) pkgs.append(p) n = n + 1 return sorted(pkgs) -def gather_deps(deps, arch, directory): - - os.mkdir(arch) - os.chdir(arch) - - ## Replace the architecture with the correct one - deps = [re.sub(r"x86_64",arch,x) for x in deps] - - ## find all files the transitive dependencies - deps_files = check_output( - ["pacman", "-Ql"] + deps - ).decode("utf-8").split("\n") - - ## Produces output like - ## mingw-w64-x86_64-zlib /mingw64/lib/libminizip.a - - ## drop the package name - tmp = deps_files.copy() - deps_files=[] - for d in tmp: - slt = d.split() - if(not slt==[]): - deps_files.append(slt[1]) - - ## sort uniq - deps_files = sorted(list(set(deps_files))) - ## copy all files into local - print("Copying dependencies: {}".format(arch)) - check_output_maybe(["rsync", "-R"] + deps_files + ["."]) - - ## And package them up - os.chdir(directory) - print("Zipping: {}".format(arch)) - check_output_maybe("zip -9r ../../emacs-{}-{}{}-deps.zip *" - .format(EMACS_MAJOR_VERSION, DATE, arch), - shell=True) - os.chdir("../../") - def download_source(tarball): print("Acquiring {}...".format(tarball)) - if os.path.exists("../emacs-src-cache/{}".format(tarball)): - print("Copying {} from local".format(tarball)) - shutil.copyfile("../emacs-src-cache/{}".format(tarball), - "{}".format(tarball)) - else: + if not os.path.exists("../emacs-src-cache/{}".format(tarball)): print("Downloading {}...".format(tarball)) check_output_maybe( - "wget -a ../download.log -O {} {}/{}/download" + "wget -a ../download.log -O ../emacs-src-cache/{} {}/{}/download" .format(tarball, SRC_REPO, tarball), shell=True ) print("Downloading {}... done".format(tarball)) + print("Copying {} from local".format(tarball)) + shutil.copyfile("../emacs-src-cache/{}".format(tarball), + "{}".format(tarball)) + + +## Fetch all the source code def gather_source(deps): + if not os.path.exists("emacs-src-cache"): + os.mkdir("emacs-src-cache") - ## Source for gcc-libs is part of gcc - ## Source for libwinpthread is in libwinpthreads - ## mpc, termcap, xpm -- has x86_64, and i686 versions - - ## This needs to have been run first at the same time as the - ## system was updated. os.mkdir("emacs-src") os.chdir("emacs-src") - to_download = [] for pkg in deps: pkg_name_and_version= \ check_output(["pacman","-Q", pkg]).decode("utf-8").strip() @@ -183,31 +197,18 @@ def gather_source(deps): pkg_name=pkg_name_components[0] pkg_version=pkg_name_components[1] - ## make a simple name to make lookup easier - simple_pkg_name = re.sub(r"x86_64-","",pkg_name) + ## source pkgs don't have an architecture in them + pkg_name = re.sub(r"x86_64-","",pkg_name) - if(simple_pkg_name in SKIP_SRC_PKGS): + if(pkg_name in SKIP_SRC_PKGS): continue - ## Some packages have different source files for different - ## architectures. For these we need two downloads. - if(simple_pkg_name in ARCH_PKGS): - downloads = [pkg_name, - re.sub(r"x86_64","i686",pkg_name)] - else: - downloads = [simple_pkg_name] + ## Switch names if necessary + pkg_name = MUNGE_SRC_PKGS.get(pkg_name,pkg_name) - for d in downloads: - ## Switch names if necessary - d = MUNGE_SRC_PKGS.get(d,d) + tarball = "{}-{}.src.tar.gz".format(pkg_name,pkg_version) - tarball = "{}-{}.src.tar.gz".format(d,pkg_version) - - to_download.append(tarball) - - ## Download in parallel or it is just too slow - p = mp.Pool(16) - p.map(download_source,to_download) + download_source(tarball) print("Zipping") check_output_maybe("zip -9 ../emacs-{}-{}deps-mingw-w64-src.zip *" @@ -220,7 +221,6 @@ def gather_source(deps): def clean(): print("Cleaning") os.path.isdir("emacs-src") and shutil.rmtree("emacs-src") - os.path.isdir("i686") and shutil.rmtree("i686") os.path.isdir("x86_64") and shutil.rmtree("x86_64") os.path.isfile("download.log") and os.remove("download.log") @@ -234,12 +234,6 @@ def clean(): parser.add_argument("-s", help="snapshot build", action="store_true") -parser.add_argument("-t", help="32 bit deps only", - action="store_true") - -parser.add_argument("-f", help="64 bit deps only", - action="store_true") - parser.add_argument("-r", help="source code only", action="store_true") @@ -253,9 +247,9 @@ def clean(): action="store_true") args = parser.parse_args() -do_all=not (args.c or args.r or args.f or args.t) +do_all=not (args.c or args.r) + -deps=extract_deps() DRY_RUN=args.d @@ -269,13 +263,11 @@ def clean(): else: DATE="" -if( do_all or args.t ): - gather_deps(deps,"i686","mingw32") - -if( do_all or args.f ): - gather_deps(deps,"x86_64","mingw64") +if( do_all): + gather_deps() if( do_all or args.r ): + deps=extract_deps() gather_source(deps) if( args.c ): diff --git a/admin/nt/dist-build/build-zips.sh b/admin/nt/dist-build/build-zips.sh index 4a9a7b596e7..7bc6ea6a9e5 100755 --- a/admin/nt/dist-build/build-zips.sh +++ b/admin/nt/dist-build/build-zips.sh @@ -29,72 +29,62 @@ function git_up { } function build_zip { - - ARCH=$1 - PKG=$2 - HOST=$3 - - echo [build] Building Emacs-$VERSION for $ARCH - if [ $ARCH == "i686" ] - then - PATH=/mingw32/bin:$PATH - MSYSTEM=MINGW32 - fi + echo [build] Building Emacs-$VERSION ## Clean the install location because we use it twice - rm -rf $HOME/emacs-build/install/emacs-$VERSION/$ARCH - mkdir --parents $HOME/emacs-build/build/emacs-$VERSION/$ARCH - cd $HOME/emacs-build/build/emacs-$VERSION/$ARCH + rm -rf $HOME/emacs-build/install/emacs-$VERSION + mkdir --parents $HOME/emacs-build/build/emacs-$VERSION + cd $HOME/emacs-build/build/emacs-$VERSION + + ## Do we need this or is it the default? + export PKG_CONFIG_PATH=/mingw64/lib/pkgconfig - export PKG_CONFIG_PATH=$PKG ## Running configure forces a rebuild of the C core which takes ## time that is not always needed, so do not do it unless we have ## to. if [ ! -f Makefile ] || (($CONFIG)) then - echo [build] Configuring Emacs $ARCH + echo [build] Configuring Emacs $REPO_DIR/$BRANCH/configure \ --without-dbus \ - --host=$HOST --without-compress-install \ + --without-compress-install \ $CACHE \ CFLAGS="$CFLAGS" fi make -j 4 $INSTALL_TARGET \ - prefix=$HOME/emacs-build/install/emacs-$VERSION/$ARCH - cd $HOME/emacs-build/install/emacs-$VERSION/$ARCH - cp $HOME/emacs-build/deps/libXpm/$ARCH/libXpm-noX4.dll bin - zip -r -9 emacs-$OF_VERSION-$ARCH-no-deps.zip * - mv emacs-$OF_VERSION-$ARCH-no-deps.zip $HOME/emacs-upload - rm bin/libXpm-noX4.dll + prefix=$HOME/emacs-build/install/emacs-$VERSION + cd $HOME/emacs-build/install/emacs-$VERSION + zip -r -9 emacs-$OF_VERSION-no-deps.zip * + mv emacs-$OF_VERSION-no-deps.zip $HOME/emacs-upload if [ -z $SNAPSHOT ]; then - DEPS_FILE=$HOME/emacs-build/deps/emacs-$MAJOR_VERSION-$ARCH-deps.zip + DEPS_FILE=$HOME/emacs-build/deps/emacs-$MAJOR_VERSION-deps.zip else ## Pick the most recent snapshot whatever that is - DEPS_FILE=`ls $HOME/emacs-build/deps/emacs-$MAJOR_VERSION-*-$ARCH-deps.zip | tail -n 1` + DEPS_FILE=`ls $HOME/emacs-build/deps/emacs-$MAJOR_VERSION-*-deps.zip | tail -n 1` fi echo [build] Using $DEPS_FILE - unzip $DEPS_FILE + unzip -d bin $DEPS_FILE - zip -r -9 emacs-$OF_VERSION-$ARCH.zip * - mv emacs-$OF_VERSION-$ARCH.zip ~/emacs-upload + zip -r -9 emacs-$OF_VERSION.zip * + mv emacs-$OF_VERSION.zip ~/emacs-upload } function build_installer { - ARCH=$1 - cd $HOME/emacs-build/install/emacs-$VERSION + cd $HOME/emacs-build/install/ echo [build] Calling makensis in `pwd` cp $REPO_DIR/$BRANCH/admin/nt/dist-build/emacs.nsi . makensis -v4 \ - -DARCH=$ARCH -DEMACS_VERSION=$ACTUAL_VERSION \ + -DEMACS_VERSION=$ACTUAL_VERSION \ + -DVERSION_BRANCH=$VERSION \ -DOUT_VERSION=$OF_VERSION emacs.nsi rm emacs.nsi - mv emacs-$OF_VERSION-$ARCH-installer.exe ~/emacs-upload + mv emacs-$OF_VERSION-installer.exe ~/emacs-upload } set -o errexit @@ -103,7 +93,6 @@ SNAPSHOT= CACHE= BUILD=1 -BUILD_32=1 BUILD_64=1 GIT_UP=0 CONFIG=1 @@ -114,19 +103,8 @@ INSTALL_TARGET="install-strip" REPO_DIR=$HOME/emacs-build/git/ -while getopts "36gb:hnsiV:" opt; do +while getopts "gb:hnsiV:" opt; do case $opt in - 3) - BUILD_32=1 - BUILD_64=0 - GIT_UP=0 - ;; - 6) - BUILD_32=0 - BUILD_64=1 - GIT_UP=0 - ;; - g) BUILD_32=0 BUILD_64=0 @@ -152,10 +130,11 @@ while getopts "36gb:hnsiV:" opt; do ;; h) echo "build-zips.sh" - echo " -3 32 bit build only" - echo " -6 64 bit build only" + echo " -b args -- build args branch" echo " -g git update and worktree only" echo " -i build installer only" + echo " -n do not configure" + echo " -s snaphot build" exit 0 ;; \?) @@ -208,7 +187,7 @@ then else BRANCH=$REQUIRED_BRANCH echo [build] Building from Branch $BRANCH - VERSION=$VERSION-$BRANCH + VERSION=$VERSION-${BRANCH/\//_} OF_VERSION="$VERSION-`date +%Y-%m-%d`" ## Use snapshot dependencies SNAPSHOT=1 @@ -225,18 +204,7 @@ if (($BUILD_64)) then if (($BUILD)) then - build_zip x86_64 /mingw64/lib/pkgconfig x86_64-w64-mingw32 + build_zip fi - build_installer x86_64 -fi - -## Do the 64 bit build first, because we reset some environment -## variables during the 32 bit which will break the build. -if (($BUILD_32)) -then - if (($BUILD)) - then - build_zip i686 /mingw32/lib/pkgconfig i686-w64-mingw32 - fi - build_installer i686 + build_installer fi diff --git a/admin/nt/dist-build/emacs.nsi b/admin/nt/dist-build/emacs.nsi index dce8f3db4a3..557bb106dde 100644 --- a/admin/nt/dist-build/emacs.nsi +++ b/admin/nt/dist-build/emacs.nsi @@ -2,7 +2,7 @@ !include LogicLib.nsh !include x64.nsh -Outfile "emacs-${OUT_VERSION}-${ARCH}-installer.exe" +Outfile "emacs-${OUT_VERSION}-installer.exe" SetCompressor /solid lzma @@ -14,15 +14,15 @@ Var StartMenuFolder !define MUI_WELCOMEPAGE_TITLE_3LINES !define MUI_WELCOMEPAGE_TEXT "Welcome to Emacs -- the editor of a lifetime." -!define MUI_WELCOMEFINISHPAGE_BITMAP "${ARCH}\share\emacs\${EMACS_VERSION}\etc\images\splash.bmp" -!define MUI_ICON "${ARCH}\share\emacs\${EMACS_VERSION}\etc\images\icons\hicolor\scalable\apps\emacs.ico" -!define MUI_UNICON "${ARCH}\share\emacs\${EMACS_VERSION}\etc\images\icons\hicolor\scalable\apps\emacs.ico" +!define MUI_WELCOMEFINISHPAGE_BITMAP "emacs-${VERSION_BRANCH}\share\emacs\${EMACS_VERSION}\etc\images\splash.bmp" +!define MUI_ICON "emacs-${VERSION_BRANCH}\share\emacs\${EMACS_VERSION}\etc\images\icons\hicolor\scalable\apps\emacs.ico" +!define MUI_UNICON "emacs-${VERSION_BRANCH}\share\emacs\${EMACS_VERSION}\etc\images\icons\hicolor\scalable\apps\emacs.ico" !insertmacro MUI_PAGE_WELCOME !define MUI_LICENSEPAGE_TEXT_TOP "The GNU General Public License" -!insertmacro MUI_PAGE_LICENSE "${ARCH}\share\emacs\${EMACS_VERSION}\lisp\COPYING" +!insertmacro MUI_PAGE_LICENSE "emacs-${VERSION_BRANCH}\share\emacs\${EMACS_VERSION}\lisp\COPYING" !insertmacro MUI_PAGE_DIRECTORY !insertmacro MUI_PAGE_INSTFILES @@ -36,19 +36,7 @@ Var StartMenuFolder Name Emacs-${EMACS_VERSION} function .onInit - ${If} ${RunningX64} - ${If} ${ARCH} == "x86_64" - StrCpy $INSTDIR "$PROGRAMFILES64\Emacs" - ${Else} - StrCpy $INSTDIR "$PROGRAMFILES32\Emacs" - ${Endif} - ${Else} - ${If} ${ARCH} == "x86_64" - Quit - ${Else} - StrCpy $INSTDIR "$PROGRAMFILES\Emacs" - ${Endif} - ${EndIf} + StrCpy $INSTDIR "$PROGRAMFILES64\Emacs" functionend @@ -56,7 +44,8 @@ Section SetOutPath $INSTDIR - File /r ${ARCH} + File /r emacs-${VERSION_BRANCH} + # define uninstaller name WriteUninstaller $INSTDIR\Uninstall.exe @@ -66,7 +55,7 @@ Section CreateShortcut "$SMPROGRAMS\$StartMenuFolder\Uninstall.lnk" "$INSTDIR\Uninstall.exe" !insertmacro MUI_STARTMENU_WRITE_END - CreateShortCut "$SMPROGRAMS\$StartMenuFolder\Emacs.lnk" "$INSTDIR\${ARCH}\bin\runemacs.exe" + CreateShortCut "$SMPROGRAMS\$StartMenuFolder\Emacs.lnk" "$INSTDIR\emacs-${VERSION_BRANCH}\bin\runemacs.exe" SectionEnd @@ -78,7 +67,7 @@ Section "Uninstall" Delete "$INSTDIR\Uninstall.exe" # now delete installed directory - RMDir /r "$INSTDIR\${ARCH}" + RMDir /r "$INSTDIR" RMDir "$INSTDIR" !insertmacro MUI_STARTMENU_GETFOLDER Application $StartMenuFolder diff --git a/configure.ac b/configure.ac index 66c660696b7..bea28338090 100644 --- a/configure.ac +++ b/configure.ac @@ -5657,6 +5657,12 @@ else ACL_SUMMARY=no fi +if test -z "$GMP_H"; then + HAVE_GMP=yes +else + HAVE_GMP=no +fi + emacs_standard_dirs='Standard dirs' AS_ECHO([" Configured for '${canonical}'. @@ -5671,12 +5677,14 @@ Configured for '${canonical}'. Where do we find X Windows header files? ${x_includes:-$emacs_standard_dirs} Where do we find X Windows libraries? ${x_libraries:-$emacs_standard_dirs}"]) +#### Please respect alphabetical ordering when making additions. optsep= emacs_config_features= -for opt in XAW3D XPM JPEG TIFF GIF PNG RSVG CAIRO IMAGEMAGICK SOUND GPM DBUS \ - GCONF GSETTINGS GLIB NOTIFY ACL LIBSELINUX GNUTLS LIBXML2 FREETYPE HARFBUZZ M17N_FLT \ - LIBOTF XFT ZLIB TOOLKIT_SCROLL_BARS X_TOOLKIT OLDXMENU X11 XDBE XIM \ - NS MODULES THREADS XWIDGETS LIBSYSTEMD JSON PDUMPER UNEXEC LCMS2 GMP; do +for opt in ACL CAIRO DBUS FREETYPE GCONF GIF GLIB GMP GNUTLS GPM GSETTINGS \ + HARFBUZZ IMAGEMAGICK JPEG JSON LCMS2 LIBOTF LIBSELINUX LIBSYSTEMD LIBXML2 \ + M17N_FLT MODULES NOTIFY NS OLDXMENU PDUMPER PNG RSVG SOUND THREADS TIFF \ + TOOLKIT_SCROLL_BARS UNEXEC X11 XAW3D XDBE XFT XIM XPM XWIDGETS X_TOOLKIT \ + ZLIB; do case $opt in PDUMPER) val=${with_pdumper} ;; @@ -5713,11 +5721,6 @@ done AC_DEFINE_UNQUOTED(EMACS_CONFIG_FEATURES, "${emacs_config_features}", [Summary of some of the main features enabled by configure.]) -if test -z "$GMP_H"; then - HAVE_GMP=yes -else - HAVE_GMP=no -fi AS_ECHO([" Does Emacs use -lXaw3d? ${HAVE_XAW3D} Does Emacs use -lXpm? ${HAVE_XPM} Does Emacs use -ljpeg? ${HAVE_JPEG} diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi index 6c68f70482a..3a2c7d019ef 100644 --- a/doc/lispref/commands.texi +++ b/doc/lispref/commands.texi @@ -2696,9 +2696,11 @@ from the terminal---not counting those generated by keyboard macros. @code{read-event}, @code{read-char}, and @code{read-char-exclusive} do not perform the translations described in @ref{Translation Keymaps}. If you wish to read a single key taking these translations into -account, use the function @code{read-key}: +account (for example, to read @ref{Function Keys} in a terminal or +@ref{Mouse Events} from @code{xterm-mouse-mode}), use the function +@code{read-key}: -@defun read-key &optional prompt +@defun read-key &optional prompt disable-fallbacks This function reads a single key. It is intermediate between @code{read-key-sequence} and @code{read-event}. Unlike the former, it reads a single key, not a key sequence. Unlike the latter, it does @@ -2708,6 +2710,14 @@ and @code{key-translation-map} (@pxref{Translation Keymaps}). The argument @var{prompt} is either a string to be displayed in the echo area as a prompt, or @code{nil}, meaning not to display a prompt. + +If argument @var{disable-fallbacks} is non-@code{nil} then the usual +fallback logic for unbound keys in @code{read-key-sequence} is not +applied. This means that mouse button-down and multi-click events +will not be discarded and @code{local-function-key-map} and +@code{key-translation-map} will not get applied. If @code{nil} or +unspecified, the only fallback disabled is downcasing of the last +event. @end defun @defun read-char-choice prompt chars &optional inhibit-quit diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi index 55bcddb31aa..80e9eb7dd8e 100644 --- a/doc/lispref/control.texi +++ b/doc/lispref/control.texi @@ -557,8 +557,9 @@ Likewise, it makes no sense to bind keyword symbols @item (pred @var{function}) Matches if the predicate @var{function} returns non-@code{nil} -when called on @var{expval}. -the predicate @var{function} can have one of the following forms: +when called on @var{expval}. The test can be negated with the syntax +@code{(pred (not @var{function}))}. +The predicate @var{function} can have one of the following forms: @table @asis @item function name (a symbol) diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi index fa548b503aa..12255d122f9 100644 --- a/doc/lispref/elisp.texi +++ b/doc/lispref/elisp.texi @@ -739,6 +739,7 @@ Minibuffers * Minibuffer Windows:: Operating on the special minibuffer windows. * Minibuffer Contents:: How such commands access the minibuffer text. * Recursive Mini:: Whether recursive entry to minibuffer is allowed. +* Inhibiting Interaction:: Running Emacs when no interaction is possible. * Minibuffer Misc:: Various customization hooks and variables. Completion diff --git a/doc/lispref/errors.texi b/doc/lispref/errors.texi index 9ec12714991..fb393b951f1 100644 --- a/doc/lispref/errors.texi +++ b/doc/lispref/errors.texi @@ -230,6 +230,11 @@ The message is @samp{Wrong type argument}. @xref{Type Predicates}. @item unknown-image-type The message is @samp{Cannot determine image type}. @xref{Images}. + +@item inhibited-interaction +The message is @samp{User interaction while inhibited}. This error is +signalled when @code{inhibit-interaction} is non-@code{nil} and a user +interaction function (like @code{read-from-minibuffer}) is called. @end table @ignore The following seem to be unused now. diff --git a/doc/lispref/minibuf.texi b/doc/lispref/minibuf.texi index d316c1f0602..0ce17ed571a 100644 --- a/doc/lispref/minibuf.texi +++ b/doc/lispref/minibuf.texi @@ -32,6 +32,7 @@ argument. * Minibuffer Windows:: Operating on the special minibuffer windows. * Minibuffer Contents:: How such commands access the minibuffer text. * Recursive Mini:: Whether recursive entry to minibuffer is allowed. +* Inhibiting Interaction:: Running Emacs when no interaction is possible. * Minibuffer Misc:: Various customization hooks and variables. @end menu @@ -2617,6 +2618,38 @@ to @code{t} in the interactive declaration (@pxref{Using Interactive}). The minibuffer command @code{next-matching-history-element} (normally @kbd{M-s} in the minibuffer) does the latter. +@node Inhibiting Interaction +@section Inhibiting Interaction + +It's sometimes useful to be able to run Emacs as a headless server +process that responds to commands given over a network connection. +However, Emacs is primarily a platform for interactive usage, so many +commands prompt the user for feedback in certain anomalous situations. +This makes this use case more difficult, since the server process will +just hang waiting for user input. + +@vindex inhibit-interaction +Binding the @code{inhibit-interaction} variable to something +non-@code{nil} makes Emacs signal a @code{inhibited-interaction} error +instead of prompting, which can then be used by the server process to +handle these situations. + +Here's a typical use case: + +@lisp +(let ((inhibit-interaction t)) + (respond-to-client + (condition-case err + (my-client-handling-function) + (inhibited-interaction err)))) +@end lisp + +If @code{my-client-handling-function} ends up calling something that +asks the user for something (via @code{y-or-n-p} or +@code{read-from-minibuffer} or the like), an +@code{inhibited-interaction} error is signalled instead. The server +code then catches that error and reports it to the client. + @node Minibuffer Misc @section Minibuffer Miscellany diff --git a/doc/lispref/modes.texi b/doc/lispref/modes.texi index 9d38fe6af95..abc12546410 100644 --- a/doc/lispref/modes.texi +++ b/doc/lispref/modes.texi @@ -4241,7 +4241,7 @@ Here is an example of an indentation function: (`(:elem . basic) sample-indent-basic) (`(,_ . ",") (smie-rule-separator kind)) (`(:after . ":=") sample-indent-basic) - (`(:before . ,(or `"begin" `"(" `"@{"))) + (`(:before . ,(or `"begin" `"(" `"@{")) (if (smie-rule-hanging-p) (smie-rule-parent))) (`(:before . "if") (and (not (smie-rule-bolp)) (smie-rule-prev-p "else") diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index 358f6fc542e..2c4b792cc21 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -443,7 +443,7 @@ are optional, in case of a missing part a default value is assumed. The default value for an empty local file name part is the remote user's home directory. The shortest remote file name is @file{@trampfn{-,,}}, therefore. The @samp{-} notation for the -default host is used for syntactical reasons, @ref{Default Host}. +default method is used for syntactical reasons, @ref{Default Method}. The @code{method} part describes the connection method used to reach the remote host, see below. @@ -1622,6 +1622,7 @@ support this command. @subsection Tunneling with ssh +@vindex ProxyCommand@r{, ssh option} With @command{ssh}, you could use the @option{ProxyCommand} entry in @file{~/.ssh/config}: @@ -2056,9 +2057,11 @@ default value is @t{"/data/local/tmp"} for the @option{adb} method, @item @t{"direct-async-process"} When this property is non-@code{nil}, an alternative, more performant -implementation of @code{make-process} and -@code{start-file-process} is applied. @ref{Improving performance of -asynchronous remote processes} for a discussion of constraints. +implementation of @code{make-process} and @code{start-file-process} is +applied. The connection method must also be marked with a +non-@code{nil} @code{tramp-direct-async} parameter in +@code{tramp-methods}. @ref{Improving performance of asynchronous +remote processes} for a discussion of constraints. @item @t{"posix"} @@ -2214,6 +2217,11 @@ overwrite this, you might apply This uses also the settings in @code{tramp-sh-extra-args}. +@vindex RemoteCommand@r{, ssh option} +@strong{Note}: If you use an @option{ssh}-based method for connection, +do @emph{not} set the @option{RemoteCommand} option in your +@command{ssh} configuration, for example to @command{screen}. + @subsection Other remote shell setup hints @cindex remote shell setup @@ -3304,6 +3312,8 @@ whatever reason, then replace @code{(getenv "DISPLAY")} with a hard-coded, fixed name. Note that using @code{:0} for X11 display name here will not work as expected. +@vindex ForwardX11@r{, ssh option} +@vindex ForwardX11Trusted@r{, ssh option} An alternate approach is specify @option{ForwardX11 yes} or @option{ForwardX11Trusted yes} in @file{~/.ssh/config} on the local host. @@ -3566,6 +3576,7 @@ Furthermore, this approach has the following limitations: It works only for connection methods defined in @file{tramp-sh.el} and @file{tramp-adb.el}. +@vindex ControlMaster@r{, ssh option} @item It does not support interactive user authentication. With @option{ssh}-based methods, this can be avoided by using a password @@ -4269,6 +4280,7 @@ In order to disable those optimizations, set user option @item @value{tramp} does not recognize if a @command{ssh} session hangs +@vindex ServerAliveInterval@r{, ssh option} @command{ssh} sessions on the local host hang when the network is down. @value{tramp} cannot safely detect such hangs. The network configuration for @command{ssh} can be configured to kill such hangs @@ -4285,6 +4297,8 @@ Host * @item @value{tramp} does not use default @command{ssh} @option{ControlPath} +@vindex ControlPath@r{, ssh option} +@vindex ControlPersist@r{, ssh option} @value{tramp} overwrites @option{ControlPath} settings when initiating @command{ssh} sessions. @value{tramp} does this to fend off a stall if a master session opened outside the Emacs session is no longer @@ -4306,8 +4320,8 @@ which allows you to set the @option{ControlPath} provided the variable @end group @end lisp -Note how "%r", "%h" and "%p" must be encoded as "%%r", "%%h" and -"%%p". +Note how @samp{%r}, @samp{%h} and @samp{%p} must be encoded as +@samp{%%r}, @samp{%%h} and @samp{%%p}. @vindex tramp-use-ssh-controlmaster-options If the @file{~/.ssh/config} is configured appropriately for the above @@ -4318,6 +4332,8 @@ this @code{nil} setting: (customize-set-variable 'tramp-use-ssh-controlmaster-options nil) @end lisp +@vindex ProxyCommand@r{, ssh option} +@vindex ProxyJump@r{, ssh option} This shall also be set to @code{nil} if you use the @option{ProxyCommand} or @option{ProxyJump} options in your @command{ssh} configuration. diff --git a/doc/misc/trampver.texi b/doc/misc/trampver.texi index 6970c46aef4..827c4773285 100644 --- a/doc/misc/trampver.texi +++ b/doc/misc/trampver.texi @@ -8,7 +8,7 @@ @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.0 +@set trampver 2.5.1-pre @set trampurl https://www.gnu.org/software/tramp/ @set tramp-bug-report-address tramp-devel@@gnu.org @set emacsver 25.1 diff --git a/etc/HELLO b/etc/HELLO index dec3a775afb..9a1f5d30edd 100644 --- a/etc/HELLO +++ b/etc/HELLO @@ -30,6 +30,8 @@ Bengali (বাংলা) নমস্কার Braille ⠓⠑⠇⠇⠕ Burmese (မြန်မာ) မင်္ဂလာပါ C printf ("Hello, world!\n"); +Cham (ꨌꩌ) ꨦꨤꩌ ꨦꨰꨁ + Cherokee (ᏣᎳᎩ ᎦᏬᏂᎯᏍᏗ) ᎣᏏᏲ / ᏏᏲ Comanche /kəˈmæntʃiː/ Haa marʉ́awe diff --git a/etc/NEWS b/etc/NEWS index 7e84d695089..359d308bf19 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -326,6 +326,12 @@ the buffer cycles the whole buffer between "only top-level headings", * Changes in Specialized Modes and Packages in Emacs 28.1 +** pcase ++++ +*** 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. + +++ ** profiler.el The results displayed by 'profiler-report' now have the usage figures @@ -1371,6 +1377,15 @@ https://www.w3.org/TR/xml/#charsets). Now it rejects such strings. ** erc +--- +*** erc-services.el now supports NickServ passwords from auth-source. +The 'erc-use-auth-source-for-nickserv-password' variable enables querying +auth-source for NickServ passwords. To enable this, add the following +to your init file: + + (setq erc-prompt-for-nickserv-password nil + erc-use-auth-source-for-nickserv-password t) + --- *** The '/ignore' command will now ask for a timeout to stop ignoring the user. Allowed inputs are seconds or ISO8601-like periods like "1h" or "4h30m". @@ -1528,6 +1543,15 @@ that makes it a valid button. ** Miscellaneous +*** New function 'buffer-line-statistics'. +This function returns some statistics about the line lengths in a buffer. + ++++ +*** 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. + --- *** 'process-attributes' now works under OpenBSD, too. diff --git a/etc/PROBLEMS b/etc/PROBLEMS index 25e129bcd99..15e34ea06f8 100644 --- a/etc/PROBLEMS +++ b/etc/PROBLEMS @@ -746,6 +746,11 @@ versions of gnutls-cli, or use Emacs's built-in gnutls support. ** Characters are displayed as empty boxes or with wrong font under X. +*** This may be due to your local fontconfig customization. +Try removing or moving aside "$XDG_CONFIG_HOME/fontconfig/conf.d" and +"$XDG_CONFIG_HOME/fontconfig/fonts.conf" +($XDG_CONFIG_HOME is treated as "~/.config" if not set) + *** This can occur when two different versions of FontConfig are used. For example, XFree86 4.3.0 has one version and Gnome usually comes with a newer version. Emacs compiled with Gtk+ will then use the diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el index 68ae4685898..d684c7ba97f 100644 --- a/lisp/calc/calc.el +++ b/lisp/calc/calc.el @@ -1095,15 +1095,7 @@ Used by `calc-user-invocation'.") (ignore-errors (define-key calc-digit-map x 'calcDigit-delchar) (define-key calc-mode-map x 'calc-pop) - (define-key calc-mode-map - (if (and (vectorp x) (featurep 'xemacs)) - (if (= (length x) 1) - (vector (if (consp (aref x 0)) - (cons 'meta (aref x 0)) - (list 'meta (aref x 0)))) - "\e\C-d") - (vconcat "\e" x)) - 'calc-pop-above))) + (define-key calc-mode-map (vconcat "\e" x) 'calc-pop-above))) (if calc-scan-for-dels (append (where-is-internal 'delete-forward-char global-map) '("\C-d")) diff --git a/lisp/cedet/ede/auto.el b/lisp/cedet/ede/auto.el index ee75e297993..e1417d7806c 100644 --- a/lisp/cedet/ede/auto.el +++ b/lisp/cedet/ede/auto.el @@ -64,24 +64,22 @@ location is varied dependent on other complex criteria, this class can be used to define that match without loading the specific project into memory.") +(cl-defmethod ede-calc-fromconfig ((dirmatch ede-project-autoload-dirmatch)) + "Calculate the value of :fromconfig from DIRMATCH." + (let* ((fc (oref dirmatch fromconfig)) + (found (cond ((stringp fc) fc) + ((functionp fc) (funcall fc)) + (t (error "Unknown dirmatch object match style."))))) + (expand-file-name found) + )) + (cl-defmethod ede-dirmatch-installed ((dirmatch ede-project-autoload-dirmatch)) "Return non-nil if the tool DIRMATCH might match is installed on the system." - (let ((fc (oref dirmatch fromconfig))) - - (cond - ;; If the thing to match is stored in a config file. - ((stringp fc) - (file-exists-p fc)) - - ;; Add new types of dirmatches here. - - ;; Error for weird stuff - (t (error "Unknown dirmatch type."))))) - + (file-exists-p (ede-calc-fromconfig dirmatch))) (cl-defmethod ede-do-dirmatch ((dirmatch ede-project-autoload-dirmatch) file) "Does DIRMATCH match the filename FILE." - (let ((fc (oref dirmatch fromconfig))) + (let ((fc (ede-calc-fromconfig dirmatch))) (cond ;; If the thing to match is stored in a config file. diff --git a/lisp/comint.el b/lisp/comint.el index 2e683a75724..53153af7d27 100644 --- a/lisp/comint.el +++ b/lisp/comint.el @@ -979,6 +979,7 @@ See also `comint-input-ignoredups' and `comint-write-input-ring'." (ring (make-ring ring-size)) ;; Use possibly buffer-local values of these variables. (ring-separator comint-input-ring-separator) + (ring-file-prefix comint-input-ring-file-prefix) (history-ignore comint-input-history-ignore) (ignoredups comint-input-ignoredups)) (with-temp-buffer @@ -990,24 +991,15 @@ See also `comint-input-ignoredups' and `comint-write-input-ring'." (while (and (< count comint-input-ring-size) (re-search-backward ring-separator nil t) (setq end (match-beginning 0))) - (setq start - (if (re-search-backward ring-separator nil t) - (progn - (when (and comint-input-ring-file-prefix - (looking-at - comint-input-ring-file-prefix)) - ;; Skip zsh extended_history stamps - (goto-char (match-end 0))) - (match-end 0)) - (progn - (goto-char (point-min)) - (when (and comint-input-ring-file-prefix - (looking-at - comint-input-ring-file-prefix)) - (goto-char (match-end 0))) - (point)))) + (goto-char (if (re-search-backward ring-separator nil t) + (match-end 0) + (point-min))) + (when (and ring-file-prefix + (looking-at ring-file-prefix)) + ;; Skip zsh extended_history stamps + (goto-char (match-end 0))) + (setq start (point)) (setq history (buffer-substring start end)) - (goto-char start) (when (and (not (string-match history-ignore history)) (or (null ignoredups) (ring-empty-p ring) diff --git a/lisp/cus-face.el b/lisp/cus-face.el index 5dcb2842a21..21fe89c6214 100644 --- a/lisp/cus-face.el +++ b/lisp/cus-face.el @@ -175,6 +175,7 @@ (choice :tag "Style" (const :tag "Raised" released-button) (const :tag "Sunken" pressed-button) + (const :tag "Flat" flat-button) (const :tag "None" nil)))) ;; filter to make value suitable for customize (lambda (real-value) diff --git a/lisp/custom.el b/lisp/custom.el index 0c82df9b45e..58ecd0439ad 100644 --- a/lisp/custom.el +++ b/lisp/custom.el @@ -136,6 +136,9 @@ to include all of it." ; see eg vc-sccs-search-project-dir ;; No longer true: ;; "See `send-mail-function' in sendmail.el for an example." + ;; Defvar it so as to mark it special, etc (bug#25770). + (internal--define-uninitialized-variable symbol) + ;; Until the var is actually initialized, it is kept unbound. ;; This seemed to be at least as good as setting it to an arbitrary ;; value like nil (evaluating `value' is not an option because it @@ -780,8 +783,7 @@ Return non-nil if the `customized-value' property actually changed." Use the :set function to do so. This is useful for customizable options that are defined before their standard value can really be computed. E.g. dumped variables whose default depends on run-time information." - ;; If it has never been set at all, defvar it so as to mark it - ;; special, etc (bug#25770). This means we are initializing + ;; We are initializing ;; the variable, and normally any :set function would not apply. ;; For custom-initialize-delay, however, it is documented that "the ;; (delayed) initialization is performed with the :set function". @@ -789,11 +791,10 @@ E.g. dumped variables whose default depends on run-time information." ;; custom-initialize-delay but needs the :set function custom-set-minor-mode ;; to also run during initialization. So, long story short, we ;; always do the funcall step, even if symbol was not bound before. - (or (default-boundp symbol) - (eval `(defvar ,symbol nil))) ; reset below, so any value is fine (funcall (or (get symbol 'custom-set) #'set-default) symbol - (eval (car (or (get symbol 'saved-value) (get symbol 'standard-value)))))) + (eval (car (or (get symbol 'saved-value) + (get symbol 'standard-value)))))) ;;; Custom Themes diff --git a/lisp/dired-x.el b/lisp/dired-x.el index 5a52eccbbe3..aebffe339eb 100644 --- a/lisp/dired-x.el +++ b/lisp/dired-x.el @@ -1483,7 +1483,7 @@ 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 +(define-obsolete-function-alias 'dired-file-name-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. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index cf89456541e..f29f85b9650 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -374,185 +374,184 @@ ;; the important aspect is that they are subrs that don't evaluate all of ;; their args.) ;; - (let ((fn (car-safe form)) - tmp) - (cond ((not (consp form)) - (if (not (and for-effect - (or byte-compile-delete-errors - (not (symbolp form)) - (eq form t)))) - form)) - ((eq fn 'quote) - (if (cdr (cdr form)) - (byte-compile-warn "malformed quote form: `%s'" - (prin1-to-string form))) - ;; map (quote nil) to nil to simplify optimizer logic. - ;; map quoted constants to nil if for-effect (just because). - (and (nth 1 form) - (not for-effect) - form)) - ((memq fn '(let let*)) - ;; recursively enter the optimizer for the bindings and body - ;; of a let or let*. This for depth-firstness: forms that - ;; are more deeply nested are optimized first. - (cons fn + ;; FIXME: There are a bunch of `byte-compile-warn' here which arguably + ;; have no place in an optimizer: the corresponding tests should be + ;; performed in `macroexpand-all', or in `cconv', or in `bytecomp'. + (let ((fn (car-safe form))) + (pcase form + ((pred (not consp)) + (if (not (and for-effect + (or byte-compile-delete-errors + (not (symbolp form)) + (eq form t)))) + form)) + (`(quote . ,v) + (if (cdr v) + (byte-compile-warn "malformed quote form: `%s'" + (prin1-to-string form))) + ;; Map (quote nil) to nil to simplify optimizer logic. + ;; Map quoted constants to nil if for-effect (just because). + (and (car v) + (not for-effect) + form)) + (`(,(or 'let 'let*) . ,(or `(,bindings . ,exps) pcase--dontcare)) + ;; Recursively enter the optimizer for the bindings and body + ;; of a let or let*. This for depth-firstness: forms that + ;; are more deeply nested are optimized first. + (cons fn (cons (mapcar (lambda (binding) - (if (symbolp binding) - binding - (if (cdr (cdr binding)) - (byte-compile-warn "malformed let binding: `%s'" - (prin1-to-string binding))) - (list (car binding) - (byte-optimize-form (nth 1 binding) nil)))) - (nth 1 form)) - (byte-optimize-body (cdr (cdr form)) for-effect)))) - ((eq fn 'cond) - (cons fn - (mapcar (lambda (clause) - (if (consp clause) - (cons - (byte-optimize-form (car clause) nil) - (byte-optimize-body (cdr clause) for-effect)) - (byte-compile-warn "malformed cond form: `%s'" - (prin1-to-string clause)) - clause)) - (cdr form)))) - ((eq fn 'progn) - ;; As an extra added bonus, this simplifies (progn ) --> . - (if (cdr (cdr form)) - (macroexp-progn (byte-optimize-body (cdr form) for-effect)) - (byte-optimize-form (nth 1 form) for-effect))) - ((eq fn 'prog1) - (if (cdr (cdr form)) - (cons 'prog1 - (cons (byte-optimize-form (nth 1 form) for-effect) - (byte-optimize-body (cdr (cdr form)) t))) - (byte-optimize-form (nth 1 form) for-effect))) + (if (symbolp binding) + binding + (if (cdr (cdr binding)) + (byte-compile-warn "malformed let binding: `%s'" + (prin1-to-string binding))) + (list (car binding) + (byte-optimize-form (nth 1 binding) nil)))) + bindings) + (byte-optimize-body exps for-effect)))) + (`(cond . ,clauses) + (cons fn + (mapcar (lambda (clause) + (if (consp clause) + (cons + (byte-optimize-form (car clause) nil) + (byte-optimize-body (cdr clause) for-effect)) + (byte-compile-warn "malformed cond form: `%s'" + (prin1-to-string clause)) + clause)) + clauses))) + (`(progn . ,exps) + ;; As an extra added bonus, this simplifies (progn ) --> . + (if (cdr exps) + (macroexp-progn (byte-optimize-body exps for-effect)) + (byte-optimize-form (car exps) for-effect))) + (`(prog1 . ,(or `(,exp . ,exps) pcase--dontcare)) + (if exps + `(prog1 ,(byte-optimize-form exp for-effect) + . ,(byte-optimize-body exps t)) + (byte-optimize-form exp for-effect))) - ((memq fn '(save-excursion save-restriction save-current-buffer)) - ;; those subrs which have an implicit progn; it's not quite good - ;; enough to treat these like normal function calls. - ;; This can turn (save-excursion ...) into (save-excursion) which - ;; will be optimized away in the lap-optimize pass. - (cons fn (byte-optimize-body (cdr form) for-effect))) + (`(,(or `save-excursion `save-restriction `save-current-buffer) . ,exps) + ;; Those subrs which have an implicit progn; it's not quite good + ;; enough to treat these like normal function calls. + ;; This can turn (save-excursion ...) into (save-excursion) which + ;; will be optimized away in the lap-optimize pass. + (cons fn (byte-optimize-body exps for-effect))) - ((eq fn 'if) - (when (< (length form) 3) - (byte-compile-warn "too few arguments for `if'")) - (cons fn - (cons (byte-optimize-form (nth 1 form) nil) - (cons - (byte-optimize-form (nth 2 form) for-effect) - (byte-optimize-body (nthcdr 3 form) for-effect))))) + (`(if ,test ,then . ,else) + `(if ,(byte-optimize-form test nil) + ,(byte-optimize-form then for-effect) + . ,(byte-optimize-body else for-effect))) + (`(if . ,_) + (byte-compile-warn "too few arguments for `if'")) - ((memq fn '(and or)) ; Remember, and/or are control structures. - ;; Take forms off the back until we can't any more. - ;; In the future it could conceivably be a problem that the - ;; subexpressions of these forms are optimized in the reverse - ;; order, but it's ok for now. - (if for-effect - (let ((backwards (reverse (cdr form)))) - (while (and backwards - (null (setcar backwards - (byte-optimize-form (car backwards) - for-effect)))) - (setq backwards (cdr backwards))) - (if (and (cdr form) (null backwards)) - (byte-compile-log - " all subforms of %s called for effect; deleted" form)) - (and backwards - (cons fn (nreverse (mapcar 'byte-optimize-form - backwards))))) - (cons fn (mapcar 'byte-optimize-form (cdr form))))) + (`(,(or 'and 'or) . ,exps) ; Remember, and/or are control structures. + ;; Take forms off the back until we can't any more. + ;; In the future it could conceivably be a problem that the + ;; subexpressions of these forms are optimized in the reverse + ;; order, but it's ok for now. + (if for-effect + (let ((backwards (reverse exps))) + (while (and backwards + (null (setcar backwards + (byte-optimize-form (car backwards) + for-effect)))) + (setq backwards (cdr backwards))) + (if (and exps (null backwards)) + (byte-compile-log + " all subforms of %s called for effect; deleted" form)) + (and backwards + (cons fn (nreverse (mapcar #'byte-optimize-form + backwards))))) + (cons fn (mapcar #'byte-optimize-form exps)))) - ((eq fn 'while) - (unless (consp (cdr form)) - (byte-compile-warn "too few arguments for `while'")) - (cons fn - (cons (byte-optimize-form (cadr form) nil) - (byte-optimize-body (cddr form) t)))) + (`(while ,exp . ,exps) + `(while ,(byte-optimize-form exp nil) + . ,(byte-optimize-body exps t))) + (`(while . ,_) + (byte-compile-warn "too few arguments for `while'")) - ((eq fn 'interactive) - (byte-compile-warn "misplaced interactive spec: `%s'" - (prin1-to-string form)) - nil) + (`(interactive . ,_) + (byte-compile-warn "misplaced interactive spec: `%s'" + (prin1-to-string form)) + nil) - ((eq fn 'function) - ;; This forms is compiled as constant or by breaking out - ;; all the subexpressions and compiling them separately. - form) + (`(function . ,_) + ;; This forms is compiled as constant or by breaking out + ;; all the subexpressions and compiling them separately. + form) - ((eq fn 'condition-case) - `(condition-case ,(nth 1 form) ;Not evaluated. - ,(byte-optimize-form (nth 2 form) for-effect) - ,@(mapcar (lambda (clause) - `(,(car clause) - ,@(byte-optimize-body (cdr clause) for-effect))) - (nthcdr 3 form)))) + (`(condition-case . ,(or `(,var ,exp . ,clauses) pcase--dontcare)) + `(condition-case ,var ;Not evaluated. + ,(byte-optimize-form exp for-effect) + ,@(mapcar (lambda (clause) + `(,(car clause) + ,@(byte-optimize-body (cdr clause) for-effect))) + clauses))) - ((eq fn 'unwind-protect) - ;; the "protected" part of an unwind-protect is compiled (and thus - ;; optimized) as a top-level form, so don't do it here. But the - ;; non-protected part has the same for-effect status as the - ;; unwind-protect itself. (The protected part is always for effect, - ;; but that isn't handled properly yet.) - (cons fn - (cons (byte-optimize-form (nth 1 form) for-effect) - (cdr (cdr form))))) + (`(unwind-protect . ,(or `(,exp . ,exps) pcase--dontcare)) + ;; The "protected" part of an unwind-protect is compiled (and thus + ;; optimized) as a top-level form, so don't do it here. But the + ;; non-protected part has the same for-effect status as the + ;; unwind-protect itself. (The protected part is always for effect, + ;; but that isn't handled properly yet.) + `(unwind-protect ,(byte-optimize-form exp for-effect) . ,exps)) - ((eq fn 'catch) - (cons fn - (cons (byte-optimize-form (nth 1 form) nil) - (byte-optimize-body (cdr form) for-effect)))) + (`(catch . ,(or `(,tag . ,exps) pcase--dontcare)) + `(catch ,(byte-optimize-form tag nil) + . ,(byte-optimize-body exps for-effect))) - ((eq fn 'ignore) - ;; Don't treat the args to `ignore' as being - ;; computed for effect. We want to avoid the warnings - ;; that might occur if they were treated that way. - ;; However, don't actually bother calling `ignore'. - `(prog1 nil . ,(mapcar 'byte-optimize-form (cdr form)))) + (`(ignore . ,exps) + ;; Don't treat the args to `ignore' as being + ;; computed for effect. We want to avoid the warnings + ;; that might occur if they were treated that way. + ;; However, don't actually bother calling `ignore'. + `(prog1 nil . ,(mapcar #'byte-optimize-form exps))) - ;; Needed as long as we run byte-optimize-form after cconv. - ((eq fn 'internal-make-closure) form) + ;; Needed as long as we run byte-optimize-form after cconv. + (`(internal-make-closure . ,_) form) - ((eq (car-safe fn) 'lambda) - (let ((newform (byte-compile-unfold-lambda form))) - (if (eq newform form) - ;; Some error occurred, avoid infinite recursion - form - (byte-optimize-form newform for-effect)))) + (`((lambda . ,_) . ,_) + (let ((newform (byte-compile-unfold-lambda form))) + (if (eq newform form) + ;; Some error occurred, avoid infinite recursion. + form + (byte-optimize-form newform for-effect)))) - ((eq (car-safe fn) 'closure) form) + ;; FIXME: Strictly speaking, I think this is a bug: (closure...) + ;; is a *value* and shouldn't appear in the car. + (`((closure . ,_) . ,_) form) - ((byte-code-function-p fn) - (cons fn (mapcar #'byte-optimize-form (cdr form)))) + (`(,(pred byte-code-function-p) . ,exps) + (cons fn (mapcar #'byte-optimize-form exps))) - ((not (symbolp fn)) - (byte-compile-warn "`%s' is a malformed function" - (prin1-to-string fn)) - form) + (`(,(pred (not symbolp)) . ,_) + (byte-compile-warn "`%s' is a malformed function" + (prin1-to-string fn)) + form) - ((and for-effect (setq tmp (get fn 'side-effect-free)) - (or byte-compile-delete-errors - (eq tmp 'error-free) - (progn - (byte-compile-warn "value returned from %s is unused" - (prin1-to-string form)) - nil))) - (byte-compile-log " %s called for effect; deleted" fn) - ;; appending a nil here might not be necessary, but it can't hurt. - (byte-optimize-form - (cons 'progn (append (cdr form) '(nil))) t)) + ((guard (when for-effect + (if-let ((tmp (get fn 'side-effect-free))) + (or byte-compile-delete-errors + (eq tmp 'error-free) + (progn + (byte-compile-warn "value returned from %s is unused" + (prin1-to-string form)) + nil))))) + (byte-compile-log " %s called for effect; deleted" fn) + ;; appending a nil here might not be necessary, but it can't hurt. + (byte-optimize-form + (cons 'progn (append (cdr form) '(nil))) t)) - (t - ;; Otherwise, no args can be considered to be for-effect, - ;; even if the called function is for-effect, because we - ;; don't know anything about that function. - (let ((form (cons fn (mapcar #'byte-optimize-form (cdr form))))) - (if (get fn 'pure) - (byte-optimize-constant-args form) - form)))))) + (_ + ;; Otherwise, no args can be considered to be for-effect, + ;; even if the called function is for-effect, because we + ;; don't know anything about that function. + (let ((form (cons fn (mapcar #'byte-optimize-form (cdr form))))) + (if (get fn 'pure) + (byte-optimize-constant-args form) + form)))))) (defun byte-optimize-form (form &optional for-effect) "The source-level pass of the optimizer." diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index 4ba72aea56d..ec1077d447e 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -162,6 +162,59 @@ only one object ever exists." old))) +;;; Named object + +(defclass eieio-named () + ((object-name :initarg :object-name :initform nil)) + "Object with a name." + :abstract t) + +(cl-defmethod eieio-object-name-string ((obj eieio-named)) + "Return a string which is OBJ's name." + (or (slot-value obj 'object-name) + (cl-call-next-method))) + +(cl-defgeneric eieio-object-set-name-string (obj name) + "Set the string which is OBJ's NAME." + (declare (obsolete "inherit from `eieio-named' and use (setf (slot-value OBJ \\='object-name) NAME) instead" "25.1")) + (cl-check-type name string) + (setf (gethash obj eieio--object-names) name)) +(define-obsolete-function-alias + 'object-set-name-string 'eieio-object-set-name-string "24.4") + +(with-suppressed-warnings ((obsolete eieio-object-set-name-string)) + (cl-defmethod eieio-object-set-name-string ((obj eieio-named) name) + "Set the string which is OBJ's NAME." + (cl-check-type name string) + (eieio-oset obj 'object-name name))) + +(cl-defmethod clone ((obj eieio-named) &rest params) + "Clone OBJ, initializing `:parent' to OBJ. +All slots are unbound, except those initialized with PARAMS." + (let* ((newname (and (stringp (car params)) (pop params))) + (nobj (apply #'cl-call-next-method obj params)) + (nm (slot-value nobj 'object-name))) + (eieio-oset nobj 'object-name + (or newname + (if (equal nm (slot-value obj 'object-name)) + (save-match-data + (if (and nm (string-match "-\\([0-9]+\\)" nm)) + (let ((num (1+ (string-to-number + (match-string 1 nm))))) + (concat (substring nm 0 (match-beginning 0)) + "-" (int-to-string num))) + (concat nm "-1"))) + nm))) + nobj)) + +(cl-defmethod make-instance ((class (subclass eieio-named)) &rest args) + (if (not (stringp (car args))) + (cl-call-next-method) + (funcall (if eieio-backward-compatibility #'ignore #'message) + "Obsolete: name passed without :object-name to %S constructor" + class) + (apply #'cl-call-next-method class :object-name args))) + ;;; eieio-persistent ;; ;; For objects which must save themselves to disk. Provides an @@ -264,12 +317,17 @@ objects found there." (:method ((objclass (subclass eieio-default-superclass)) inputlist) - (let ((slots (if (stringp (car inputlist)) - ;; Earlier versions of `object-write' added a - ;; string name for the object, now obsolete. - (cdr inputlist) - inputlist)) - (createslots nil)) + (let* ((name nil) + (slots (if (stringp (car inputlist)) + (progn + ;; Earlier versions of `object-write' added a + ;; string name for the object, now obsolete. + ;; Save as 'name' in case this object is subclass + ;; of eieio-named with no :object-name slot specified. + (setq name (car inputlist)) + (cdr inputlist)) + inputlist)) + (createslots nil)) ;; If OBJCLASS is an eieio autoload object, then we need to ;; load it (we don't need the return value). (eieio--full-class-object objclass) @@ -286,7 +344,17 @@ objects found there." (setq slots (cdr (cdr slots)))) - (apply #'make-instance objclass (nreverse createslots))))) + (let ((newobj (apply #'make-instance objclass (nreverse createslots)))) + + ;; Check for special case of subclass of `eieio-named', and do + ;; name assignment. + (when (and eieio-backward-compatibility + (object-of-class-p newobj 'eieio-named) + (not (oref newobj object-name)) + name) + (oset newobj object-name name)) + + newobj)))) (defun eieio-persistent-fix-value (proposed-value) "Fix PROPOSED-VALUE. @@ -408,59 +476,6 @@ instance." ;; It should also set up some hooks to help it keep itself up to date. -;;; Named object - -(defclass eieio-named () - ((object-name :initarg :object-name :initform nil)) - "Object with a name." - :abstract t) - -(cl-defmethod eieio-object-name-string ((obj eieio-named)) - "Return a string which is OBJ's name." - (or (slot-value obj 'object-name) - (cl-call-next-method))) - -(cl-defgeneric eieio-object-set-name-string (obj name) - "Set the string which is OBJ's NAME." - (declare (obsolete "inherit from `eieio-named' and use (setf (slot-value OBJ \\='object-name) NAME) instead" "25.1")) - (cl-check-type name string) - (setf (gethash obj eieio--object-names) name)) -(define-obsolete-function-alias - 'object-set-name-string 'eieio-object-set-name-string "24.4") - -(with-suppressed-warnings ((obsolete eieio-object-set-name-string)) - (cl-defmethod eieio-object-set-name-string ((obj eieio-named) name) - "Set the string which is OBJ's NAME." - (cl-check-type name string) - (eieio-oset obj 'object-name name))) - -(cl-defmethod clone ((obj eieio-named) &rest params) - "Clone OBJ, initializing `:parent' to OBJ. -All slots are unbound, except those initialized with PARAMS." - (let* ((newname (and (stringp (car params)) (pop params))) - (nobj (apply #'cl-call-next-method obj params)) - (nm (slot-value nobj 'object-name))) - (eieio-oset nobj 'object-name - (or newname - (if (equal nm (slot-value obj 'object-name)) - (save-match-data - (if (and nm (string-match "-\\([0-9]+\\)" nm)) - (let ((num (1+ (string-to-number - (match-string 1 nm))))) - (concat (substring nm 0 (match-beginning 0)) - "-" (int-to-string num))) - (concat nm "-1"))) - nm))) - nobj)) - -(cl-defmethod make-instance ((class (subclass eieio-named)) &rest args) - (if (not (stringp (car args))) - (cl-call-next-method) - (funcall (if eieio-backward-compatibility #'ignore #'message) - "Obsolete: name passed without :object-name to %S constructor" - class) - (apply #'cl-call-next-method class :object-name args))) - (provide 'eieio-base) diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 58517549454..fdbf95319ff 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -487,7 +487,7 @@ Errors during evaluation are caught and handled like nil." Returns nil if they are." (if (not (eq (type-of a) (type-of b))) `(different-types ,a ,b) - (pcase-exhaustive a + (pcase a ((pred consp) (let ((a-length (proper-list-p a)) (b-length (proper-list-p b))) @@ -538,7 +538,7 @@ Returns nil if they are." for xi = (ert--explain-equal-rec ai bi) do (when xi (cl-return `(array-elt ,i ,xi))) finally (cl-assert (equal a b) t)))) - ((pred atom) + (_ (if (not (equal a b)) (if (and (symbolp a) (symbolp b) (string= a b)) `(different-symbols-with-the-same-name ,a ,b) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 72ea1ba0188..bfd577c5d14 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -39,10 +39,10 @@ ;; - along these lines, provide patterns to match CL structs. ;; - provide something like (setq VAR) so a var can be set rather than ;; let-bound. -;; - provide a way to fallthrough to subsequent cases (not sure what I meant by -;; this :-() +;; - provide a way to fallthrough to subsequent cases +;; (e.g. Like Racket's (=> ID). ;; - try and be more clever to reduce the size of the decision tree, and -;; to reduce the number of leaves that need to be turned into function: +;; to reduce the number of leaves that need to be turned into functions: ;; - first, do the tests shared by all remaining branches (it will have ;; to be performed anyway, so better do it first so it's shared). ;; - then choose the test that discriminates more (?). @@ -97,11 +97,15 @@ (declare-function get-edebug-spec "edebug" (symbol)) (declare-function edebug-match "edebug" (cursor specs)) +(defun pcase--get-macroexpander (s) + "Return the macroexpander for pcase pattern head S, or nil" + (get s 'pcase-macroexpander)) + (defun pcase--edebug-match-macro (cursor) (let (specs) (mapatoms (lambda (s) - (let ((m (get s 'pcase-macroexpander))) + (let ((m (pcase--get-macroexpander s))) (when (and m (get-edebug-spec m)) (push (cons (symbol-name s) (get-edebug-spec m)) specs))))) @@ -128,6 +132,7 @@ PATTERN matches. PATTERN can take one of the forms: If a SYMBOL is used twice in the same pattern the second occurrence becomes an `eq'uality test. (pred FUN) matches if FUN called on EXPVAL returns non-nil. + (pred (not FUN)) matches if FUN called on EXPVAL returns nil. (app FUN PAT) matches if FUN called on EXPVAL matches PAT. (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil. (let PAT EXPR) matches if EXPR matches PAT. @@ -193,7 +198,7 @@ Emacs Lisp manual for more information and examples." (let (more) ;; Collect all the extensions. (mapatoms (lambda (symbol) - (let ((me (get symbol 'pcase-macroexpander))) + (let ((me (pcase--get-macroexpander symbol))) (when me (push (cons symbol me) more))))) @@ -424,7 +429,7 @@ of the elements of LIST is performed as if by `pcase-let'. ((eq head 'let) `(let ,(pcase--macroexpand (cadr pat)) ,@(cddr pat))) ((eq head 'app) `(app ,(nth 1 pat) ,(pcase--macroexpand (nth 2 pat)))) (t - (let* ((expander (get head 'pcase-macroexpander)) + (let* ((expander (pcase--get-macroexpander head)) (npat (if expander (apply expander (cdr pat))))) (if (null npat) (error (if expander @@ -658,6 +663,14 @@ MATCH is the pattern that needs to be matched, of the form: '(:pcase--succeed . nil)))) (defun pcase--split-pred (vars upat pat) + "Indicate the overlap or mutual-exclusion between UPAT and PAT. +More specifically retuns a pair (A . B) where A indicates whether PAT +can match when UPAT has matched, and B does the same for the case +where UPAT failed to match. +A and B can be one of: +- nil if we don't know +- `:pcase--fail' if UPAT match's result implies that PAT can't match +- `:pcase--succeed' if UPAT match's result implies that PAT matches" (let (test) (cond ((and (equal upat pat) @@ -670,6 +683,19 @@ MATCH is the pattern that needs to be matched, of the form: ;; and catch at least the easy cases such as (bug#14773). (not (macroexp--fgrep (mapcar #'car vars) (cadr upat))))) '(:pcase--succeed . :pcase--fail)) + ;; In case UPAT is of the form (pred (not PRED)) + ((and (eq 'pred (car upat)) (eq 'not (car-safe (cadr upat)))) + (let* ((test (cadr (cadr upat))) + (res (pcase--split-pred vars `(pred ,test) pat))) + (cons (cdr res) (car res)))) + ;; In case PAT is of the form (pred (not PRED)) + ((and (eq 'pred (car-safe pat)) (eq 'not (car-safe (cadr pat)))) + (let* ((test (cadr (cadr pat))) + (res (pcase--split-pred vars upat `(pred ,test))) + (reverse (lambda (x) (cond ((eq x :pcase--succeed) :pcase--fail) + ((eq x :pcase--fail) :pcase--succeed))))) + (cons (funcall reverse (car res)) + (funcall reverse (cdr res))))) ((and (eq 'pred (car upat)) (let ((otherpred (cond ((eq 'pred (car-safe pat)) (cadr pat)) @@ -728,8 +754,10 @@ MATCH is the pattern that needs to be matched, of the form: (defun pcase--funcall (fun arg vars) "Build a function call to FUN with arg ARG." - (if (symbolp fun) - `(,fun ,arg) + (cond + ((symbolp fun) `(,fun ,arg)) + ((eq 'not (car-safe fun)) `(not ,(pcase--funcall (cadr fun) arg vars))) + (t (let* (;; `env' is an upper bound on the bindings we need. (env (mapcar (lambda (x) (list (car x) (cdr x))) (macroexp--fgrep vars fun))) @@ -747,7 +775,7 @@ MATCH is the pattern that needs to be matched, of the form: ;; Let's not replace `vars' in `fun' since it's ;; too difficult to do it right, instead just ;; let-bind `vars' around `fun'. - `(let* ,env ,call))))) + `(let* ,env ,call)))))) (defun pcase--eval (exp vars) "Build an expression that will evaluate EXP." diff --git a/lisp/emacs-lisp/radix-tree.el b/lisp/emacs-lisp/radix-tree.el index 6a483a6d498..0905ac608bb 100644 --- a/lisp/emacs-lisp/radix-tree.el +++ b/lisp/emacs-lisp/radix-tree.el @@ -198,9 +198,10 @@ If not found, return nil." (pcase-defmacro radix-tree-leaf (vpat) "Pattern which matches a radix-tree leaf. The pattern VPAT is matched against the leaf's carried value." - ;; FIXME: We'd like to use a negative pattern (not consp), but pcase - ;; doesn't support it. Using `atom' works but generates sub-optimal code. - `(or `(t . ,,vpat) (and (pred atom) ,vpat)))) + ;; We used to use `(pred atom)', but `pcase' doesn't understand that + ;; `atom' is equivalent to the negation of `consp' and hence generates + ;; suboptimal code. + `(or `(t . ,,vpat) (and (pred (not consp)) ,vpat)))) (defun radix-tree-iter-subtrees (tree fun) "Apply FUN to every immediate subtree of radix TREE. diff --git a/lisp/erc/erc-services.el b/lisp/erc/erc-services.el index 4f9b0b199f9..9ef8b7f46ab 100644 --- a/lisp/erc/erc-services.el +++ b/lisp/erc/erc-services.el @@ -168,8 +168,19 @@ You can also use \\[erc-nickserv-identify-mode] to change modes." :group 'erc-services :type 'boolean) +(defcustom erc-use-auth-source-for-nickserv-password nil + "Query auth-source for a password when identifiying to NickServ. +This option has an no effect if `erc-prompt-for-nickserv-password' +is non-nil, and passwords from `erc-nickserv-passwords' take +precedence." + :version "28.1" + :group 'erc-services + :type 'boolean) + (defcustom erc-nickserv-passwords nil "Passwords used when identifying to NickServ automatically. +`erc-prompt-for-nickserv-password' must be nil for these +passwords to be used. Example of use: (setq erc-nickserv-passwords @@ -375,7 +386,8 @@ Make sure it is the real NickServ for this network. If `erc-prompt-for-nickserv-password' is non-nil, prompt the user for the password for this nickname, otherwise try to send it automatically." (unless (and (null erc-nickserv-passwords) - (null erc-prompt-for-nickserv-password)) + (null erc-prompt-for-nickserv-password) + (null erc-use-auth-source-for-nickserv-password)) (let* ((network (erc-network)) (sender (erc-nickserv-alist-sender network)) (identify-regex (erc-nickserv-alist-regexp network)) @@ -394,30 +406,49 @@ password for this nickname, otherwise try to send it automatically." (defun erc-nickserv-identify-on-connect (_server nick) "Identify to Nickserv after the connection to the server is established." (unless (or (and (null erc-nickserv-passwords) - (null erc-prompt-for-nickserv-password)) - (and (eq erc-nickserv-identify-mode 'both) - (erc-nickserv-alist-regexp (erc-network)))) + (null erc-prompt-for-nickserv-password) + (null erc-use-auth-source-for-nickserv-password)) + (and (eq erc-nickserv-identify-mode 'both) + (erc-nickserv-alist-regexp (erc-network)))) (erc-nickserv-call-identify-function nick))) (defun erc-nickserv-identify-on-nick-change (nick _old-nick) "Identify to Nickserv whenever your nick changes." (unless (or (and (null erc-nickserv-passwords) - (null erc-prompt-for-nickserv-password)) - (and (eq erc-nickserv-identify-mode 'both) - (erc-nickserv-alist-regexp (erc-network)))) + (null erc-prompt-for-nickserv-password) + (null erc-use-auth-source-for-nickserv-password)) + (and (eq erc-nickserv-identify-mode 'both) + (erc-nickserv-alist-regexp (erc-network)))) (erc-nickserv-call-identify-function nick))) +(defun erc-nickserv-get-password (nickname) + "Return the password for NICKNAME from configured sources. + +It uses `erc-nickserv-passwords' and additionally auth-source +when `erc-use-auth-source-for-nickserv-password' is not nil." + (or + (when erc-nickserv-passwords + (cdr (assoc nickname + (nth 1 (assoc (erc-network) + erc-nickserv-passwords))))) + (when erc-use-auth-source-for-nickserv-password + (let* ((secret (nth 0 (auth-source-search + :max 1 :require '(:secret) + :host (erc-with-server-buffer erc-session-server) + :port (format ; ensure we have a string + "%s" (erc-with-server-buffer erc-session-port)) + :user nickname)))) + (when secret + (let ((passwd (plist-get secret :secret))) + (if (functionp passwd) (funcall passwd) passwd))))))) + (defun erc-nickserv-call-identify-function (nickname) "Call `erc-nickserv-identify'. Either call it interactively or run it with NICKNAME's password, depending on the value of `erc-prompt-for-nickserv-password'." (if erc-prompt-for-nickserv-password (call-interactively 'erc-nickserv-identify) - (when erc-nickserv-passwords - (erc-nickserv-identify - (cdr (assoc nickname - (nth 1 (assoc (erc-network) - erc-nickserv-passwords)))))))) + (erc-nickserv-identify (erc-nickserv-get-password nickname)))) (defvar erc-auto-discard-away) @@ -451,6 +482,7 @@ When called interactively, read the password using `read-passwd'." (provide 'erc-services) + ;;; erc-services.el ends here ;; ;; Local Variables: diff --git a/lisp/foldout.el b/lisp/foldout.el index 771b81e5be5..4c479d68e9a 100644 --- a/lisp/foldout.el +++ b/lisp/foldout.el @@ -487,7 +487,7 @@ What happens depends on the number of mouse clicks:- Signal an error if the final event isn't the same type as the first one." (let ((initial-event-type (event-basic-type event))) (while (null (sit-for (/ double-click-time 1000.0) 'nodisplay)) - (setq event (read-event))) + (setq event (read--potential-mouse-event))) (or (eq initial-event-type (event-basic-type event)) (error ""))) event) diff --git a/lisp/frame.el b/lisp/frame.el index c71276287aa..e2d7f21a498 100644 --- a/lisp/frame.el +++ b/lisp/frame.el @@ -2557,7 +2557,7 @@ command starts, by installing a pre-command hook." ;; blink-cursor-end is not added to pre-command-hook. (setq blink-cursor-blinks-done 1) (blink-cursor--start-timer) - (add-hook 'pre-command-hook 'blink-cursor-end) + (add-hook 'pre-command-hook #'blink-cursor-end) (internal-show-cursor nil nil))) (defun blink-cursor-timer-function () @@ -2572,14 +2572,14 @@ command starts, by installing a pre-command hook." (when (and (> blink-cursor-blinks 0) (<= (* 2 blink-cursor-blinks) blink-cursor-blinks-done)) (blink-cursor-suspend) - (add-hook 'post-command-hook 'blink-cursor-check))) + (add-hook 'post-command-hook #'blink-cursor-check))) (defun blink-cursor-end () "Stop cursor blinking. This is installed as a pre-command hook by `blink-cursor-start'. When run, it cancels the timer `blink-cursor-timer' and removes itself as a pre-command hook." - (remove-hook 'pre-command-hook 'blink-cursor-end) + (remove-hook 'pre-command-hook #'blink-cursor-end) (internal-show-cursor nil t) (when blink-cursor-timer (cancel-timer blink-cursor-timer) @@ -2648,7 +2648,7 @@ terminals, cursor blinking is controlled by the terminal." (when blink-cursor-mode (add-function :after after-focus-change-function #'blink-cursor--rescan-frames) (add-hook 'after-delete-frame-functions #'blink-cursor--rescan-frames) - (blink-cursor--start-idle-timer))) + (blink-cursor-check))) ;; Frame maximization/fullscreen diff --git a/lisp/gnus/gnus-search.el b/lisp/gnus/gnus-search.el index 44f43b073c8..5c6a5b9efd0 100644 --- a/lisp/gnus/gnus-search.el +++ b/lisp/gnus/gnus-search.el @@ -1036,7 +1036,7 @@ Responsible for handling and, or, and parenthetical expressions.") '(body cc bcc from header keyword larger smaller subject text to uid x-gm-raw answered before deleted draft flagged on since recent seen sentbefore senton sentsince unanswered undeleted undraft unflagged unkeyword - unseen all) + unseen all old new or not) "Known IMAP search keys.") ;; imap interface @@ -1072,10 +1072,11 @@ Responsible for handling and, or, and parenthetical expressions.") ;; A bit of backward-compatibility slash convenience: if the ;; query string doesn't start with any known IMAP search ;; keyword, assume it is a "TEXT" search. - (unless (and (string-match "\\`[^[:blank:]]+" q-string) - (memql (intern-soft (downcase - (match-string 0 q-string))) - gnus-search-imap-search-keys)) + (unless (or (looking-at "(") + (and (string-match "\\`[^[:blank:]]+" q-string) + (memql (intern-soft (downcase + (match-string 0 q-string))) + gnus-search-imap-search-keys))) (setq q-string (concat "TEXT " q-string))) ;; If it's a thread query, make sure that all message-id diff --git a/lisp/gnus/nnmaildir.el b/lisp/gnus/nnmaildir.el index e4fd976742c..2a4c74db5e8 100644 --- a/lisp/gnus/nnmaildir.el +++ b/lisp/gnus/nnmaildir.el @@ -1351,7 +1351,8 @@ This variable is set by `nnmaildir-request-article'.") (throw 'return nil)) (with-current-buffer (or to-buffer nntp-server-buffer) (erase-buffer) - (nnheader-insert-file-contents nnmaildir-article-file-name)) + (let ((coding-system-for-read mm-text-coding-system)) + (mm-insert-file-contents nnmaildir-article-file-name))) (cons gname num-msgid)))) (defun nnmaildir-request-post (&optional _server) diff --git a/lisp/info.el b/lisp/info.el index 62d7b583ff2..dec93928b38 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -1973,7 +1973,6 @@ If DIRECTION is `backward', search in the reverse direction." "Regexp search%s" (car Info-search-history) (if case-fold-search "" " case-sensitively")) nil 'Info-search-history))) - (deactivate-mark) (when (equal regexp "") (setq regexp (car Info-search-history))) (when regexp @@ -2066,6 +2065,7 @@ If DIRECTION is `backward', search in the reverse direction." (< found opoint-max)) ;; Search landed in the same node (goto-char found) + (deactivate-mark) (widen) (goto-char found) (save-match-data (Info-select-node))) diff --git a/lisp/isearch.el b/lisp/isearch.el index 67cc7bed15b..c6f7fe7bd4a 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -838,10 +838,6 @@ This is like `describe-bindings', but displays only Isearch keys." :image '(isearch-tool-bar-image "left-arrow"))) map)) -;; Note: Before adding more key bindings to this map, please keep in -;; mind that any unbound key exits Isearch and runs the command bound -;; to it in the local or global map. So in effect every key unbound -;; in this map is implicitly bound. (defvar minibuffer-local-isearch-map (let ((map (make-sparse-keymap))) (set-keymap-parent map minibuffer-local-map) @@ -2498,6 +2494,21 @@ If search string is empty, just beep." (unless isearch-mode (isearch-mode t)) (isearch-yank-string (current-kill 0))) +(defun isearch-yank-from-kill-ring () + "Read a string from the `kill-ring' and append it to the search string." + (interactive) + (with-isearch-suspended + (let ((string (read-from-kill-ring))) + (if (and isearch-case-fold-search + (eq 'not-yanks search-upper-case)) + (setq string (downcase string))) + (if isearch-regexp (setq string (regexp-quote string))) + (setq isearch-yank-flag t) + (setq isearch-new-string (concat isearch-string string) + isearch-new-message (concat isearch-message + (mapconcat 'isearch-text-char-description + string "")))))) + (defun isearch-yank-pop () "Replace just-yanked search string with previously killed string. Unlike `isearch-yank-pop-only', when this command is called not immediately @@ -2506,37 +2517,31 @@ minibuffer to read a string from the `kill-ring' as `yank-pop' does." (interactive) (if (not (memq last-command '(isearch-yank-kill isearch-yank-pop isearch-yank-pop-only))) - ;; Yank string from kill-ring-browser. - (with-isearch-suspended - (let ((string (read-from-kill-ring))) - (if (and isearch-case-fold-search - (eq 'not-yanks search-upper-case)) - (setq string (downcase string))) - (if isearch-regexp (setq string (regexp-quote string))) - (setq isearch-yank-flag t) - (setq isearch-new-string (concat isearch-string string) - isearch-new-message (concat isearch-message - (mapconcat 'isearch-text-char-description - string ""))))) + (isearch-yank-from-kill-ring) (isearch-pop-state) (isearch-yank-string (current-kill 1)))) -(defun isearch-yank-pop-only () +(defun isearch-yank-pop-only (&optional arg) "Replace just-yanked search string with previously killed string. Unlike `isearch-yank-pop', when this command is called not immediately after a `isearch-yank-kill' or a `isearch-yank-pop-only', it only pops the last killed string instead of activating the minibuffer to read -a string from the `kill-ring' as `yank-pop' does." - (interactive) - (if (not (memq last-command '(isearch-yank-kill - isearch-yank-pop isearch-yank-pop-only))) - ;; Fall back on `isearch-yank-kill' for the benefits of people - ;; who are used to the old behavior of `M-y' in isearch mode. - ;; In future, `M-y' could be changed from `isearch-yank-pop-only' - ;; to `isearch-yank-pop' that uses the kill-ring-browser. - (isearch-yank-kill) +a string from the `kill-ring' as `yank-pop' does. The prefix arg C-u +always reads a string from the `kill-ring' using the minibuffer." + (interactive "P") + (cond + ((equal arg '(4)) + (isearch-yank-from-kill-ring)) + ((not (memq last-command '(isearch-yank-kill + isearch-yank-pop isearch-yank-pop-only))) + ;; Fall back on `isearch-yank-kill' for the benefits of people + ;; who are used to the old behavior of `M-y' in isearch mode. + ;; In future, `M-y' could be changed from `isearch-yank-pop-only' + ;; to `isearch-yank-pop' that uses the kill-ring-browser. + (isearch-yank-kill)) + (t (isearch-pop-state) - (isearch-yank-string (current-kill 1)))) + (isearch-yank-string (current-kill 1))))) (defun isearch-yank-x-selection () "Pull current X selection into search string." @@ -2997,7 +3002,7 @@ See more for options in `search-exit-option'." ((and (eq (car-safe main-event) 'down-mouse-1) (window-minibuffer-p (posn-window (event-start main-event)))) ;; Swallow the up-event. - (read-event) + (read--potential-mouse-event) (setq this-command 'isearch-edit-string)) ;; Don't terminate the search for motion commands. ((and isearch-yank-on-move diff --git a/lisp/language/cham.el b/lisp/language/cham.el index eef6d6f8f9f..194574f6a8e 100644 --- a/lisp/language/cham.el +++ b/lisp/language/cham.el @@ -34,6 +34,11 @@ (set-language-info-alist "Cham" '((charset unicode) (coding-system utf-8) - (coding-priority utf-8))) + (coding-priority utf-8) + (sample-text . "Cham (ꨌꩌ)\tꨦꨤꩌ ꨦꨰꨁ") + (documentation . "\ +The Cham script is a Brahmic script used to write Cham, +an Austronesian language spoken by some 245,000 Chams +in Vietnam and Cambodia."))) (provide 'cham) diff --git a/lisp/mail/rmailsum.el b/lisp/mail/rmailsum.el index 60b67edf85a..d29115a9570 100644 --- a/lisp/mail/rmailsum.el +++ b/lisp/mail/rmailsum.el @@ -51,10 +51,10 @@ Setting this option to nil might speed up the generation of summaries." :group 'rmail-summary) (defvar rmail-summary-font-lock-keywords - '(("^.....D.*" . font-lock-string-face) ; Deleted. - ("^.....-.*" . font-lock-type-face) ; Unread. + '(("^ *[0-9]+D.*" . font-lock-string-face) ; Deleted. + ("^ *[0-9]+-.*" . font-lock-type-face) ; Unread. ;; Neither of the below will be highlighted if either of the above are: - ("^.....[^D-] \\(......\\)" 1 font-lock-keyword-face) ; Date. + ("^ *[0-9]+[^D-] \\(......\\)" 1 font-lock-keyword-face) ; Date. ("{ \\([^\n}]+\\) }" 1 font-lock-comment-face)) ; Labels. "Additional expressions to highlight in Rmail Summary mode.") diff --git a/lisp/mouse-drag.el b/lisp/mouse-drag.el index f6612600bdd..907ef061594 100644 --- a/lisp/mouse-drag.el +++ b/lisp/mouse-drag.el @@ -225,7 +225,7 @@ To test this function, evaluate: ;; Don't change the mouse pointer shape while we drag. (setq track-mouse 'dragging) (while (progn - (setq event (read-event) + (setq event (read--potential-mouse-event) end (event-end event) row (cdr (posn-col-row end)) col (car (posn-col-row end))) @@ -286,7 +286,7 @@ To test this function, evaluate: window-last-col (- (window-width) 2)) (track-mouse (while (progn - (setq event (read-event) + (setq event (read--potential-mouse-event) end (event-end event) row (cdr (posn-col-row end)) col (car (posn-col-row end))) diff --git a/lisp/mouse.el b/lisp/mouse.el index 0da82882fc1..8732fb80866 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -1792,7 +1792,7 @@ The function returns a non-nil value if it creates a secondary selection." (let (event end end-point) (track-mouse (while (progn - (setq event (read-event)) + (setq event (read--potential-mouse-event)) (or (mouse-movement-p event) (memq (car-safe event) '(switch-frame select-window)))) diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el index 3f3e7133713..0ce65a35ead 100644 --- a/lisp/net/nsm.el +++ b/lisp/net/nsm.el @@ -239,7 +239,7 @@ otherwise." (mapc (lambda (info) (let ((local-ip (nth 1 info)) - (mask (nth 2 info))) + (mask (nth 3 info))) (when (nsm-network-same-subnet (substring local-ip 0 -1) (substring mask 0 -1) diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index c0c215de877..2c4ef2acaef 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -98,6 +98,7 @@ It is used for TCP/IP devices." `(,tramp-adb-method (tramp-login-program ,tramp-adb-program) (tramp-login-args (("shell"))) + (tramp-direct-async t) (tramp-tmpdir "/data/local/tmp") (tramp-default-port 5555))) @@ -895,8 +896,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; terminated. (defun tramp-adb-handle-make-process (&rest args) "Like `make-process' for Tramp files. -If connection property \"direct-async-process\" is non-nil, an -alternative implementation will be used." +If method parameter `tramp-direct-async' and connection property +\"direct-async-process\" are non-nil, an alternative +implementation will be used." (if (tramp-direct-async-process-p args) (apply #'tramp-handle-make-process args) (when args diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 72873157f08..e8ee372cb25 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -168,6 +168,7 @@ The string is used in `tramp-methods'.") (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") ("-e" "none") ("%h"))) (tramp-async-args (("-q"))) + (tramp-direct-async t) (tramp-remote-shell ,tramp-default-remote-shell) (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")) @@ -183,6 +184,7 @@ The string is used in `tramp-methods'.") ("-e" "none") ("-t" "-t") ("%h") ("%l"))) (tramp-async-args (("-q"))) + (tramp-direct-async t) (tramp-remote-shell ,tramp-default-remote-shell) (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")) @@ -197,6 +199,7 @@ The string is used in `tramp-methods'.") (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") ("-e" "none") ("%h"))) (tramp-async-args (("-q"))) + (tramp-direct-async t) (tramp-remote-shell ,tramp-default-remote-shell) (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")) @@ -227,6 +230,7 @@ The string is used in `tramp-methods'.") (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") ("-e" "none") ("%h"))) (tramp-async-args (("-q"))) + (tramp-direct-async t) (tramp-remote-shell ,tramp-default-remote-shell) (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")))) @@ -237,6 +241,7 @@ The string is used in `tramp-methods'.") ("-e" "none") ("-t" "-t") ("%h") ("%l"))) (tramp-async-args (("-q"))) + (tramp-direct-async t) (tramp-remote-shell ,tramp-default-remote-shell) (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")))) @@ -2668,11 +2673,9 @@ The method used must be an out-of-band method." #'file-name-nondirectory (list localname)))) (tramp-get-remote-null-device v)))) - (let ((beg-marker (point-marker)) - (end-marker (point-marker)) + (let ((beg-marker (copy-marker (point) nil)) + (end-marker (copy-marker (point) t)) (emc enable-multibyte-characters)) - (set-marker-insertion-type beg-marker nil) - (set-marker-insertion-type end-marker t) ;; We cannot use `insert-buffer-substring' because the Tramp ;; buffer changes its contents before insertion due to calling ;; `expand-file-name' and alike. @@ -2837,9 +2840,9 @@ the result will be a local, non-Tramp, file name." ;; terminated. (defun tramp-sh-handle-make-process (&rest args) "Like `make-process' for Tramp files. -STDERR can also be a file name. If connection property -\"direct-async-process\" is non-nil, an alternative -implementation will be used." +STDERR can also be a file name. If method parameter `tramp-direct-async' +and connection property \"direct-async-process\" are non-nil, an +alternative implementation will be used." (if (tramp-direct-async-process-p args) (apply #'tramp-handle-make-process args) (when args diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index cc8dda809e2..2816c58fe7f 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -259,9 +259,9 @@ pair of the form (KEY VALUE). The following KEYs are defined: parameters to suppress diagnostic messages, in order not to tamper the process output. - * `tramp-direct-async-args' - An additional argument when a direct asynchronous process is - started. Used so far only in the \"mock\" method of tramp-tests.el. + * `tramp-direct-async' + Whether the method supports direct asynchronous processes. + Until now, just \"ssh\"-based and \"adb\"-based methods do. * `tramp-copy-program' This specifies the name of the program to use for remotely copying @@ -1755,7 +1755,8 @@ The outline level is equal to the verbosity of the Tramp message." Message is formatted with FMT-STRING as control string and the remaining ARGUMENTS to actually emit the message (if applicable)." (let ((inhibit-message t) - file-name-handler-alist message-log-max signal-hook-function) + create-lockfiles file-name-handler-alist message-log-max + signal-hook-function) (with-current-buffer (tramp-get-debug-buffer vec) (goto-char (point-max)) (let ((point (point))) @@ -1982,6 +1983,13 @@ the resulting error message." (put #'tramp-with-demoted-errors 'tramp-suppress-trace t) +(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))) + ;; This function provides traces in case of errors not triggered by ;; Tramp functions. (defun tramp-signal-hook-function (error-symbol data) @@ -3741,7 +3749,9 @@ User is always nil." (let ((v (tramp-dissect-file-name default-directory)) (buffer (plist-get args :buffer)) (stderr (plist-get args :stderr))) - (and ;; It has been indicated. + (and ;; The method supports it. + (tramp-get-method-parameter v 'tramp-direct-async) + ;; It has been indicated. (tramp-get-connection-property v "direct-async-process" nil) ;; There's no multi-hop. (or (not (tramp-multi-hop-p v)) @@ -3821,8 +3831,6 @@ It does not support `:stderr'." (tramp-get-method-parameter v 'tramp-login-args)) (async-args (tramp-get-method-parameter v 'tramp-async-args)) - (direct-async-args - (tramp-get-method-parameter v 'tramp-direct-async-args)) ;; We don't create the temporary file. In fact, it ;; is just a prefix for the ControlPath option of ;; ssh; the real temporary file has another name, and @@ -3850,7 +3858,7 @@ It does not support `:stderr'." ?h (or host "") ?u (or user "") ?p (or port "") ?c options ?l "") ;; Add arguments for asynchronous processes. - login-args (append async-args direct-async-args login-args) + login-args (append async-args login-args) ;; Expand format spec. login-args (tramp-compat-flatten-tree diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index 714b3f9bb01..ced3e93fc09 100644 --- a/lisp/net/trampver.el +++ b/lisp/net/trampver.el @@ -7,7 +7,7 @@ ;; Maintainer: Michael Albinus ;; Keywords: comm, processes ;; Package: tramp -;; Version: 2.5.0 +;; Version: 2.5.1-pre ;; Package-Requires: ((emacs "25.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.0" +(defconst tramp-version "2.5.1-pre" "This version of Tramp.") ;;;###tramp-autoload @@ -76,7 +76,7 @@ ;; Check for Emacs version. (let ((x (if (not (string-lessp emacs-version "25.1")) "ok" - (format "Tramp 2.5.0 is not fit for %s" + (format "Tramp 2.5.1-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/pixel-scroll.el b/lisp/pixel-scroll.el index cc0e159faef..68dc0fb94b3 100644 --- a/lisp/pixel-scroll.el +++ b/lisp/pixel-scroll.el @@ -132,8 +132,10 @@ This is an alternative of `scroll-up'. Scope moves downward." (pixel-line-height)))) (if (pixel-eob-at-top-p) ; when end-of-the-buffer is close (scroll-up 1) ; relay on robust method - (while (pixel-point-at-top-p amt) ; prevent too late (multi tries) - (vertical-motion 1)) ; move point downward + (catch 'no-movement + (while (pixel-point-at-top-p amt) ; prevent too late (multi tries) + (unless (>= (vertical-motion 1) 1) ; move point downward + (throw 'no-movement nil)))) ; exit loop when point did not move (pixel-scroll-pixel-up amt)))))) ; move scope downward (defun pixel-scroll-down (&optional arg) @@ -149,8 +151,10 @@ This is and alternative of `scroll-down'. Scope moves upward." pixel-resolution-fine-flag (frame-char-height)) (pixel-line-height -1)))) - (while (pixel-point-at-bottom-p amt) ; prevent too late (multi tries) - (vertical-motion -1)) ; move point upward + (catch 'no-movement + (while (pixel-point-at-bottom-p amt) ; prevent too late (multi tries) + (unless (<= (vertical-motion -1) -1) ; move point upward + (throw 'no-movement nil)))) ; exit loop when point did not move (if (or (pixel-bob-at-top-p amt) ; when beginning-of-the-buffer is seen (pixel-eob-at-top-p)) ; for file with a long line (scroll-down 1) ; relay on robust method diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 62c3cf44cb6..06966f33b72 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -970,20 +970,11 @@ loop using the command \\[fileloop-continue]." (declare-function compilation-read-command "compile") ;;;###autoload -(defun project-compile (command &optional comint) - "Run `compile' in the project root. -Arguments the same as in `compile'." - (interactive - (list - (let ((command (eval compile-command))) - (require 'compile) - (if (or compilation-read-command current-prefix-arg) - (compilation-read-command command) - command)) - (consp current-prefix-arg))) - (let* ((pr (project-current t)) - (default-directory (project-root pr))) - (compile command comint))) +(defun project-compile () + "Run `compile' in the project root." + (interactive) + (let ((default-directory (project-root (project-current t)))) + (call-interactively #'compile))) (defun project--read-project-buffer () (let* ((pr (project-current t)) diff --git a/lisp/ruler-mode.el b/lisp/ruler-mode.el index 7cda6c96aff..1e819044194 100644 --- a/lisp/ruler-mode.el +++ b/lisp/ruler-mode.el @@ -429,7 +429,7 @@ dragging. See also the variable `ruler-mode-dragged-symbol'." ;; `ding' flushes the next messages about setting goal ;; column. So here I force fetch the event(mouse-2) and ;; throw away. - (read-event) + (read--potential-mouse-event) ;; Ding BEFORE `message' is OK. (when ruler-mode-set-goal-column-ding-flag (ding)) @@ -460,7 +460,7 @@ the mouse has been clicked." (track-mouse ;; Signal the display engine to freeze the mouse pointer shape. (setq track-mouse 'dragging) - (while (mouse-movement-p (setq event (read-event))) + (while (mouse-movement-p (setq event (read--potential-mouse-event))) (setq drags (1+ drags)) (when (eq window (posn-window (event-end event))) (ruler-mode-mouse-drag-any-column event) diff --git a/lisp/shell.el b/lisp/shell.el index c179dd24d3f..0f866158fe3 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -603,6 +603,7 @@ buffer." (or hfile (cond ((string-equal shell "bash") "~/.bash_history") ((string-equal shell "ksh") "~/.sh_history") + ((string-equal shell "zsh") "~/.zsh_history") (t "~/.history"))))) (if (or (equal comint-input-ring-file-name "") (equal (file-truename comint-input-ring-file-name) diff --git a/lisp/simple.el b/lisp/simple.el index 54c35c04bea..37c0885dcc5 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -5606,7 +5606,9 @@ See also `zap-up-to-char'." ;; kill-line and its subroutines. (defcustom kill-whole-line nil - "If non-nil, `kill-line' with no arg at start of line kills the whole line." + "If non-nil, `kill-line' with no arg at start of line kills the whole line. +This variable also affects `kill-visual-line' in the same way as +it does `kill-line'." :type 'boolean :group 'killing) @@ -7319,6 +7321,10 @@ If ARG is negative, kill visual lines backward. If ARG is zero, kill the text before point on the current visual line. +If the variable `kill-whole-line' is non-nil, and this command is +invoked at start of a line that ends in a newline, kill the newline +as well. + If you want to append the killed line to the last killed text, use \\[append-next-kill] before \\[kill-line]. @@ -7331,18 +7337,30 @@ even beep.)" ;; Like in `kill-line', it's better to move point to the other end ;; of the kill before killing. (let ((opoint (point)) - (kill-whole-line (and kill-whole-line (bolp)))) + (kill-whole-line (and kill-whole-line (bolp))) + (orig-y (cdr (nth 2 (posn-at-point)))) + ;; FIXME: This tolerance should be zero! It isn't due to a + ;; bug in posn-at-point, see bug#45837. + (tol (/ (line-pixel-height) 2))) (if arg (vertical-motion (prefix-numeric-value arg)) (end-of-visual-line 1) (if (= (point) opoint) (vertical-motion 1) - ;; Skip any trailing whitespace at the end of the visual line. - ;; We used to do this only if `show-trailing-whitespace' is - ;; nil, but that's wrong; the correct thing would be to check - ;; whether the trailing whitespace is highlighted. But, it's - ;; OK to just do this unconditionally. - (skip-chars-forward " \t"))) + ;; The first condition below verifies we are still on the same + ;; screen line, i.e. that the line isn't continued, and that + ;; end-of-visual-line didn't overshoot due to complications + ;; like display or overlay strings, intangible text, etc.: + ;; otherwise, we don't want to kill a character that's + ;; unrelated to the place where the visual line wrapped. + (and (< (abs (- (cdr (nth 2 (posn-at-point))) orig-y)) tol) + ;; Make sure we delete the character where the line wraps + ;; under visual-line-mode, be it whitespace or a + ;; character whose category set allows to wrap at it. + (or (looking-at-p "[ \t]") + (and word-wrap-by-category + (aref (char-category-set (following-char)) ?\|))) + (forward-char)))) (kill-region opoint (if (and kill-whole-line (= (following-char) ?\n)) (1+ (point)) (point))))) diff --git a/lisp/startup.el b/lisp/startup.el index 57fd87f20f9..552802a38d7 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -921,7 +921,8 @@ the name of the init-file to load. If this file cannot be loaded, and ALTERNATE-FILENAME-FUNCTION is non-nil, then it is called with no arguments and should return the name of an alternate init-file to load. If LOAD-DEFAULTS is non-nil, then -load default.el after the init-file. +load default.el after the init-file, unless `inhibit-default-init' +is non-nil. This function sets `user-init-file' to the name of the loaded init-file, or to a default value if loading is not possible." @@ -977,8 +978,8 @@ init-file, or to a default value if loading is not possible." (sit-for 1)) (setq user-init-file source)))) - (when load-defaults - + (when (and load-defaults + (not inhibit-default-init)) ;; Prevent default.el from changing the value of ;; `inhibit-startup-screen'. (let ((inhibit-startup-screen nil)) @@ -1166,12 +1167,11 @@ please check its value") ;; Re-evaluate predefined variables whose initial value depends on ;; the runtime context. - (let (current-load-list) ; c-r-s may call defvar, and hence LOADHIST_ATTACH - (setq custom-delayed-init-variables - ;; Initialize them in the same order they were loaded, in case there - ;; are dependencies between them. - (nreverse custom-delayed-init-variables)) - (mapc 'custom-reevaluate-setting custom-delayed-init-variables)) + (setq custom-delayed-init-variables + ;; Initialize them in the same order they were loaded, in case there + ;; are dependencies between them. + (nreverse custom-delayed-init-variables)) + (mapc #'custom-reevaluate-setting custom-delayed-init-variables) ;; Warn for invalid user name. (when init-file-user @@ -1288,8 +1288,7 @@ please check its value") (if (or noninteractive emacs-basic-display) (setq menu-bar-mode nil tab-bar-mode nil - tool-bar-mode nil - no-blinking-cursor t)) + tool-bar-mode nil)) (frame-initialize)) (when (fboundp 'x-create-frame) @@ -1298,15 +1297,6 @@ please check its value") (unless noninteractive (tool-bar-setup))) - ;; Turn off blinking cursor if so specified in X resources. This is here - ;; only because all other settings of no-blinking-cursor are here. - (unless (or noninteractive - emacs-basic-display - (and (memq window-system '(x w32 ns)) - (not (member (x-get-resource "cursorBlink" "CursorBlink") - '("no" "off" "false" "0"))))) - (setq no-blinking-cursor t)) - (unless noninteractive (startup--setup-quote-display) (setq internal--text-quoting-flag t)) @@ -1314,9 +1304,8 @@ please check its value") ;; Re-evaluate again the predefined variables whose initial value ;; depends on the runtime context, in case some of them depend on ;; the window-system features. Example: blink-cursor-mode. - (let (current-load-list) ; c-r-s may call defvar, and hence LOADHIST_ATTACH - (mapc 'custom-reevaluate-setting custom-delayed-init-variables) - (setq custom-delayed-init-variables nil)) + (mapc #'custom-reevaluate-setting custom-delayed-init-variables) + (setq custom-delayed-init-variables nil) (normal-erase-is-backspace-setup-frame) @@ -1374,7 +1363,7 @@ please check its value") (expand-file-name "init.el" startup-init-directory)) - (not inhibit-default-init)) + t) (when (and deactivate-mark transient-mark-mode) (with-current-buffer (window-buffer) diff --git a/lisp/strokes.el b/lisp/strokes.el index b0ab4f990f6..55f2ae8cc47 100644 --- a/lisp/strokes.el +++ b/lisp/strokes.el @@ -756,12 +756,12 @@ Optional EVENT is acceptable as the starting event of the stroke." (strokes-fill-current-buffer-with-whitespace)) (when prompt (message "%s" prompt) - (setq event (read-event)) + (setq event (read--potential-mouse-event)) (or (strokes-button-press-event-p event) (error "You must draw with the mouse"))) (unwind-protect (track-mouse - (or event (setq event (read-event) + (or event (setq event (read--potential-mouse-event) safe-to-draw-p t)) (while (not (strokes-button-release-event-p event)) (if (strokes-mouse-event-p event) @@ -776,7 +776,7 @@ Optional EVENT is acceptable as the starting event of the stroke." (setq safe-to-draw-p t)) (push (cdr (mouse-pixel-position)) pix-locs))) - (setq event (read-event))))) + (setq event (read--potential-mouse-event))))) ;; protected ;; clean up strokes buffer and then bury it. (when (equal (buffer-name) strokes-buffer-name) @@ -787,16 +787,16 @@ Optional EVENT is acceptable as the starting event of the stroke." ;; Otherwise, don't use strokes buffer and read stroke silently (when prompt (message "%s" prompt) - (setq event (read-event)) + (setq event (read--potential-mouse-event)) (or (strokes-button-press-event-p event) (error "You must draw with the mouse"))) (track-mouse - (or event (setq event (read-event))) + (or event (setq event (read--potential-mouse-event))) (while (not (strokes-button-release-event-p event)) (if (strokes-mouse-event-p event) (push (cdr (mouse-pixel-position)) pix-locs)) - (setq event (read-event)))) + (setq event (read--potential-mouse-event)))) (setq grid-locs (strokes-renormalize-to-grid (nreverse pix-locs))) (strokes-fill-stroke (strokes-eliminate-consecutive-redundancies grid-locs))))) @@ -817,10 +817,10 @@ Optional EVENT is acceptable as the starting event of the stroke." (if prompt (while (not (strokes-button-press-event-p event)) (message "%s" prompt) - (setq event (read-event)))) + (setq event (read--potential-mouse-event)))) (unwind-protect (track-mouse - (or event (setq event (read-event))) + (or event (setq event (read--potential-mouse-event))) (while (not (and (strokes-button-press-event-p event) (eq 'mouse-3 (car (get (car event) @@ -834,14 +834,15 @@ Optional EVENT is acceptable as the starting event of the stroke." ?\s strokes-character)) (push (cdr (mouse-pixel-position)) pix-locs))) - (setq event (read-event))) + (setq event (read--potential-mouse-event))) (push strokes-lift pix-locs) (while (not (strokes-button-press-event-p event)) - (setq event (read-event)))) + (setq event (read--potential-mouse-event)))) ;; ### KLUDGE! ### sit and wait ;; for some useless event to ;; happen to fix the minibuffer bug. - (while (not (strokes-button-release-event-p (read-event)))) + (while (not (strokes-button-release-event-p + (read--potential-mouse-event)))) (setq pix-locs (nreverse (cdr pix-locs)) grid-locs (strokes-renormalize-to-grid pix-locs)) (strokes-fill-stroke diff --git a/lisp/subr.el b/lisp/subr.el index 6d3ea45c1ab..f249ec3578c 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -1178,6 +1178,30 @@ KEY is a string or vector representing a sequence of keystrokes." (if (current-local-map) (local-set-key key nil)) nil) + +(defun local-key-binding (keys &optional accept-default) + "Return the binding for command KEYS in current local keymap only. +KEYS is a string or vector, a sequence of keystrokes. +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 `lookup-key' for more details +about this." + (let ((map (current-local-map))) + (when map (lookup-key map keys accept-default)))) + +(defun global-key-binding (keys &optional accept-default) + "Return the binding for command KEYS in current global keymap only. +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' +\(which see). + +If optional argument ACCEPT-DEFAULT is non-nil, recognize default +bindings; see the description of `lookup-key' for more details +about this." + (lookup-key (current-global-map) keys accept-default)) + ;;;; substitute-key-definition and its subroutines. @@ -2545,23 +2569,52 @@ It can be retrieved with `(process-get PROCESS PROPNAME)'." ;;;; Input and display facilities. -(defconst read-key-empty-map (make-sparse-keymap)) +;; The following maps are used by `read-key' to remove all key +;; bindings while calling `read-key-sequence'. This way the keys +;; returned are independent of the key binding state. + +(defconst read-key-empty-map (make-sparse-keymap) + "Used internally by `read-key'.") + +(defconst read-key-full-map + (let ((map (make-sparse-keymap))) + (define-key map [t] 'dummy) + + ;; ESC needs to be unbound so that escape sequences in + ;; `input-decode-map' are still processed by `read-key-sequence'. + (define-key map [?\e] nil) + map) + "Used internally by `read-key'.") (defvar read-key-delay 0.01) ;Fast enough for 100Hz repeat rate, hopefully. -(defun read-key (&optional prompt) +(defun read-key (&optional prompt disable-fallbacks) "Read a key from the keyboard. Contrary to `read-event' this will not return a raw event but instead will obey the input decoding and translations usually done by `read-key-sequence'. So escape sequences and keyboard encoding are taken into account. When there's an ambiguity because the key looks like the prefix of -some sort of escape sequence, the ambiguity is resolved via `read-key-delay'." +some sort of escape sequence, the ambiguity is resolved via `read-key-delay'. + +If the optional argument PROMPT is non-nil, display that as a +prompt. + +If the optional argument DISABLE-FALLBACKS is non-nil, all +unbound fallbacks usually done by `read-key-sequence' are +disabled such as discarding mouse down events. This is generally +what you want as `read-key' temporarily removes all bindings +while calling `read-key-sequence'. If nil or unspecified, the +only unbound fallback disabled is downcasing of the last event." ;; This overriding-terminal-local-map binding also happens to ;; disable quail's input methods, so although read-key-sequence ;; always inherits the input method, in practice read-key does not ;; inherit the input method (at least not if it's based on quail). (let ((overriding-terminal-local-map nil) - (overriding-local-map read-key-empty-map) + (overriding-local-map + ;; FIXME: Audit existing uses of `read-key' to see if they + ;; should always specify disable-fallbacks to be more in line + ;; with `read-event'. + (if disable-fallbacks read-key-full-map read-key-empty-map)) (echo-keystrokes 0) (old-global-map (current-global-map)) (timer (run-with-idle-timer @@ -2615,6 +2668,23 @@ some sort of escape sequence, the ambiguity is resolved via `read-key-delay'." (message nil) (use-global-map old-global-map)))) +;; FIXME: Once there's a safe way to transition away from read-event, +;; callers to this function should be updated to that way and this +;; function should be deleted. +(defun read--potential-mouse-event () + "Read an event that might be a mouse event. + +This function exists for backward compatibility in code packaged +with Emacs. Do not call it directly in your own packages." + ;; `xterm-mouse-mode' events must go through `read-key' as they + ;; are decoded via `input-decode-map'. + (if xterm-mouse-mode + (read-key nil + ;; Normally `read-key' discards all mouse button + ;; down events. However, we want them here. + t) + (read-event))) + (defvar read-passwd-map ;; BEWARE: `defconst' would purecopy it, breaking the sharing with ;; minibuffer-local-map along the way! diff --git a/lisp/textmodes/artist.el b/lisp/textmodes/artist.el index ce620821d65..50c00c95320 100644 --- a/lisp/textmodes/artist.el +++ b/lisp/textmodes/artist.el @@ -5004,7 +5004,7 @@ The event, EV, is the mouse event." (setq timer (run-at-time interval interval draw-fn x1 y1)))) ;; Read next event - (setq ev (read-event)))) + (setq ev (read--potential-mouse-event)))) ;; Cleanup: get rid of any active timer. (if timer (cancel-timer timer))) @@ -5212,7 +5212,7 @@ The event, EV, is the mouse event." ;; Read next event (only if we should not stop) (if (not done) - (setq ev (read-event))))) + (setq ev (read--potential-mouse-event))))) ;; Reverse point-list (last points are cond'ed first) (setq point-list (reverse point-list)) @@ -5339,7 +5339,7 @@ The event, EV, is the mouse event." ;; Read next event - (setq ev (read-event)))) + (setq ev (read--potential-mouse-event)))) ;; If we are not rubber-banding (that is, we were moving around the `2') ;; draw the shape diff --git a/lisp/textmodes/reftex-vars.el b/lisp/textmodes/reftex-vars.el index d4c1b87262e..1b29eafabf7 100644 --- a/lisp/textmodes/reftex-vars.el +++ b/lisp/textmodes/reftex-vars.el @@ -900,7 +900,7 @@ DOWNCASE t: Downcase words before using them." ,(concat ;; Make sure we search only for optional arguments of ;; environments/macros and don't match any other [. ctable - ;; provides a macro called \ctable, listings/breqn have + ;; provides a macro called \ctable, beamer/breqn/listings have ;; environments. Start with a backslash and a group for names "\\\\\\(?:" ;; begin, optional spaces and opening brace @@ -936,8 +936,9 @@ The default value matches usual \\label{...} definitions and keyval style [..., label = {...}, ...] label definitions. The regexp for keyval style explicitly looks for environments provided by the packages \"listings\" (\"lstlisting\"), -\"breqn\" (\"dmath\", \"dseries\", \"dgroup\", \"darray\") and -the macro \"\\ctable\" provided by the package of the same name. +\"beamer\" (\"frame\"), \"breqn\" (\"dmath\", \"dseries\", +\"dgroup\", \"darray\") and the macro \"\\ctable\" provided by +the package of the same name. It is assumed that the regexp group 1 matches the label text, so you have to define it using \\(?1:...\\) when adding new regexps. diff --git a/lisp/vc/ediff-wind.el b/lisp/vc/ediff-wind.el index 72b345874f9..47ef37a19ee 100644 --- a/lisp/vc/ediff-wind.el +++ b/lisp/vc/ediff-wind.el @@ -262,11 +262,12 @@ keyboard input to go into icons." (let (event) (message "Select windows by clicking. Please click on Window %d " wind-number) - (while (not (ediff-mouse-event-p (setq event (read-event)))) + (while (not (ediff-mouse-event-p (setq event + (read--potential-mouse-event)))) (if (sit-for 1) ; if sequence of events, wait till the final word (beep 1)) (message "Please click on Window %d " wind-number)) - (read-event) ; discard event + (read--potential-mouse-event) ; discard event (posn-window (event-start event)))) diff --git a/lisp/vc/ediff.el b/lisp/vc/ediff.el index e3612dd8e34..ed375738b47 100644 --- a/lisp/vc/ediff.el +++ b/lisp/vc/ediff.el @@ -939,7 +939,7 @@ arguments after setting up the Ediff buffers." ;; If WIND-A is nil, use selected window. ;; If WIND-B is nil, use window next to WIND-A. (defun ediff-windows (dumb-mode wind-A wind-B startup-hooks job-name word-mode) - (if (or dumb-mode (not (ediff-window-display-p))) + (if (or dumb-mode (not (display-mouse-p))) (setq wind-A (ediff-get-next-window wind-A nil) wind-B (ediff-get-next-window wind-B wind-A)) (setq wind-A (ediff-get-window-by-clicking wind-A nil 1) diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 8b10d71dcb3..7dda04eda21 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -1104,7 +1104,7 @@ If nothing was called, return non-nil." (unless (widget-apply button :mouse-down-action event) (let ((track-mouse t)) (while (not (widget-button-release-event-p event)) - (setq event (read-event)) + (setq event (read--potential-mouse-event)) (when (and mouse-1 (mouse-movement-p event)) (push event unread-command-events) (setq event oevent) @@ -1169,7 +1169,7 @@ If nothing was called, return non-nil." (when up ;; Don't execute up events twice. (while (not (widget-button-release-event-p event)) - (setq event (read-event)))) + (setq event (read--potential-mouse-event)))) (when command (call-interactively command))))) (message "You clicked somewhere weird."))) @@ -3486,14 +3486,16 @@ It reads a directory name from an editable text field." :help-echo "C-q: insert KEY, EVENT, or CODE; RET: enter value" :tag "Key sequence") +;; FIXME: Consider combining this with help--read-key-sequence which +;; can also read double and triple mouse events. (defun widget-key-sequence-read-event (ev) (interactive (list (let ((inhibit-quit t) quit-flag) - (read-event "Insert KEY, EVENT, or CODE: ")))) + (read-key "Insert KEY, EVENT, or CODE: " t)))) (let ((ev2 (and (memq 'down (event-modifiers ev)) - (read-event))) - (tr (and (keymapp function-key-map) - (lookup-key function-key-map (vector ev))))) + (read-key nil t))) + (tr (and (keymapp local-function-key-map) + (lookup-key local-function-key-map (vector ev))))) (when (and (integerp ev) (or (and (<= ?0 ev) (< ev (+ ?0 (min 10 read-quoted-char-radix)))) (and (<= ?a (downcase ev)) diff --git a/lisp/window.el b/lisp/window.el index a6cdd4dec2f..0a37d16273f 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -1736,9 +1736,11 @@ interpret DELTA as pixels." (setq window (window-normalize-window window)) (cond ((< delta 0) - (max (- (window-min-size window horizontal ignore pixelwise) - (window-size window horizontal pixelwise)) - delta)) + (let ((min-size (window-min-size window horizontal ignore pixelwise)) + (size (window-size window horizontal pixelwise))) + (if (<= size min-size) + 0 + (max (- min-size size) delta)))) ((> delta 0) (if (window-size-fixed-p window horizontal ignore) 0 diff --git a/src/data.c b/src/data.c index d420bf5fc58..35a6890b9bd 100644 --- a/src/data.c +++ b/src/data.c @@ -3760,6 +3760,7 @@ syms_of_data (void) DEFSYM (Qbuffer_read_only, "buffer-read-only"); DEFSYM (Qtext_read_only, "text-read-only"); DEFSYM (Qmark_inactive, "mark-inactive"); + DEFSYM (Qinhibited_interaction, "inhibited-interaction"); DEFSYM (Qlistp, "listp"); DEFSYM (Qconsp, "consp"); @@ -3844,6 +3845,8 @@ syms_of_data (void) PUT_ERROR (Qbuffer_read_only, error_tail, "Buffer is read-only"); PUT_ERROR (Qtext_read_only, pure_cons (Qbuffer_read_only, error_tail), "Text is read-only"); + PUT_ERROR (Qinhibited_interaction, error_tail, + "User interaction while inhibited"); DEFSYM (Qrange_error, "range-error"); DEFSYM (Qdomain_error, "domain-error"); diff --git a/src/dispnew.c b/src/dispnew.c index 36a6dd8a091..e603c671363 100644 --- a/src/dispnew.c +++ b/src/dispnew.c @@ -6049,7 +6049,14 @@ additional wait period, in milliseconds; this is for backwards compatibility. READING is true if reading input. If DISPLAY_OPTION is >0 display process output while waiting. If DISPLAY_OPTION is >1 perform an initial redisplay before waiting. -*/ + + Returns a boolean Qt if we waited the full time and returns Qnil if the + wait was interrupted by incoming process output or keyboard events. + + FIXME: When `wait_reading_process_output` returns early because of + process output, instead of returning nil we should loop and wait some + more (i.e. until either there's pending input events or the timeout + expired). */ Lisp_Object sit_for (Lisp_Object timeout, bool reading, int display_option) @@ -6110,8 +6117,9 @@ sit_for (Lisp_Object timeout, bool reading, int display_option) gobble_input (); #endif - wait_reading_process_output (sec, nsec, reading ? -1 : 1, do_display, - Qnil, NULL, 0); + int nbytes + = wait_reading_process_output (sec, nsec, reading ? -1 : 1, do_display, + Qnil, NULL, 0); if (reading && curbuf_eq_winbuf) /* Timers and process filters/sentinels may have changed the selected @@ -6120,7 +6128,7 @@ sit_for (Lisp_Object timeout, bool reading, int display_option) buffer to start with). */ set_buffer_internal (XBUFFER (XWINDOW (selected_window)->contents)); - return detect_input_pending () ? Qnil : Qt; + return (nbytes > 0 || detect_input_pending ()) ? Qnil : Qt; } diff --git a/src/fns.c b/src/fns.c index 5fcc54f0d1f..7ab2e8f1a03 100644 --- a/src/fns.c +++ b/src/fns.c @@ -5548,6 +5548,90 @@ It should not be used for anything security-related. See return make_digest_string (digest, SHA1_DIGEST_SIZE); } +DEFUN ("buffer-line-statistics", Fbuffer_line_statistics, + Sbuffer_line_statistics, 0, 1, 0, + doc: /* Return data about lines in BUFFER. +The data is returned as a list, and the first element is the number of +lines in the buffer, the second is the length of the longest line, and +the third is the mean line length. The lengths returned are in bytes, not +characters. */ ) + (Lisp_Object buffer_or_name) +{ + Lisp_Object buffer; + ptrdiff_t lines = 0, longest = 0; + double mean = 0; + struct buffer *b; + + if (NILP (buffer_or_name)) + buffer = Fcurrent_buffer (); + else + buffer = Fget_buffer (buffer_or_name); + if (NILP (buffer)) + nsberror (buffer_or_name); + + b = XBUFFER (buffer); + + unsigned char *start = BUF_BEG_ADDR (b); + ptrdiff_t area = BUF_GPT_BYTE (b) - BUF_BEG_BYTE (b), pre_gap = 0; + + /* Process the first part of the buffer. */ + while (area > 0) + { + unsigned char *n = memchr (start, '\n', area); + + if (n) + { + ptrdiff_t this_line = n - start; + if (this_line > longest) + longest = this_line; + lines++; + /* Blame Knuth. */ + mean = mean + (this_line - mean) / lines; + area = area - this_line - 1; + start += this_line + 1; + } + else + { + /* Didn't have a newline here, so save the rest for the + post-gap calculation. */ + pre_gap = area; + area = 0; + } + } + + /* If the gap is before the end of the buffer, process the last half + of the buffer. */ + if (BUF_GPT_BYTE (b) < BUF_Z_BYTE (b)) + { + start = BUF_GAP_END_ADDR (b); + area = BUF_Z_ADDR (b) - BUF_GAP_END_ADDR (b); + + while (area > 0) + { + unsigned char *n = memchr (start, '\n', area); + ptrdiff_t this_line = n? n - start + pre_gap: area + pre_gap; + + if (this_line > longest) + longest = this_line; + lines++; + /* Blame Knuth again. */ + mean = mean + (this_line - mean) / lines; + area = area - this_line - 1; + start += this_line + 1; + pre_gap = 0; + } + } + else if (pre_gap > 0) + { + if (pre_gap > longest) + longest = pre_gap; + lines++; + mean = mean + (pre_gap - mean) / lines; + } + + return list3 (make_int (lines), make_int (longest), make_float (mean)); +} + static bool string_ascii_p (Lisp_Object string) { @@ -5871,4 +5955,5 @@ this variable. */); defsubr (&Ssecure_hash); defsubr (&Sbuffer_hash); defsubr (&Slocale_info); + defsubr (&Sbuffer_line_statistics); } diff --git a/src/frame.c b/src/frame.c index 45ee96e9620..599c4075f88 100644 --- a/src/frame.c +++ b/src/frame.c @@ -2572,23 +2572,30 @@ before calling this function on it, like this. int yval = check_integer_range (y, INT_MIN, INT_MAX); /* I think this should be done with a hook. */ -#ifdef HAVE_WINDOW_SYSTEM if (FRAME_WINDOW_P (XFRAME (frame))) - /* Warping the mouse will cause enternotify and focus events. */ - frame_set_mouse_position (XFRAME (frame), xval, yval); -#elif defined MSDOS - if (FRAME_MSDOS_P (XFRAME (frame))) + { +#ifdef HAVE_WINDOW_SYSTEM + /* Warping the mouse will cause enternotify and focus events. */ + frame_set_mouse_position (XFRAME (frame), xval, yval); +#endif /* HAVE_WINDOW_SYSTEM */ + } +#ifdef MSDOS + else if (FRAME_MSDOS_P (XFRAME (frame))) { Fselect_frame (frame, Qnil); mouse_moveto (xval, yval); } -#elif defined HAVE_GPM - Fselect_frame (frame, Qnil); - term_mouse_moveto (xval, yval); +#endif /* MSDOS */ + else + { + Fselect_frame (frame, Qnil); +#ifdef HAVE_GPM + term_mouse_moveto (xval, yval); #else - (void) xval; - (void) yval; -#endif + (void) xval; + (void) yval; +#endif /* HAVE_GPM */ + } return Qnil; } @@ -2610,23 +2617,31 @@ before calling this function on it, like this. int yval = check_integer_range (y, INT_MIN, INT_MAX); /* I think this should be done with a hook. */ -#ifdef HAVE_WINDOW_SYSTEM if (FRAME_WINDOW_P (XFRAME (frame))) - /* Warping the mouse will cause enternotify and focus events. */ - frame_set_mouse_pixel_position (XFRAME (frame), xval, yval); -#elif defined MSDOS - if (FRAME_MSDOS_P (XFRAME (frame))) + { + /* Warping the mouse will cause enternotify and focus events. */ +#ifdef HAVE_WINDOW_SYSTEM + frame_set_mouse_pixel_position (XFRAME (frame), xval, yval); +#endif /* HAVE_WINDOW_SYSTEM */ + } +#ifdef MSDOS + else if (FRAME_MSDOS_P (XFRAME (frame))) { Fselect_frame (frame, Qnil); mouse_moveto (xval, yval); } -#elif defined HAVE_GPM - Fselect_frame (frame, Qnil); - term_mouse_moveto (xval, yval); +#endif /* MSDOS */ + else + { + Fselect_frame (frame, Qnil); +#ifdef HAVE_GPM + term_mouse_moveto (xval, yval); #else - (void) xval; - (void) yval; -#endif + (void) xval; + (void) yval; +#endif /* HAVE_GPM */ + + } return Qnil; } diff --git a/src/keymap.c b/src/keymap.c index 1197f6fd4a5..de9b2b58c5e 100644 --- a/src/keymap.c +++ b/src/keymap.c @@ -1646,39 +1646,6 @@ specified buffer position instead of point are used. /* GC is possible in this function if it autoloads a keymap. */ -DEFUN ("local-key-binding", Flocal_key_binding, Slocal_key_binding, 1, 2, 0, - doc: /* Return the binding for command KEYS in current local keymap only. -KEYS is a string or vector, a sequence of keystrokes. -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 `lookup-key' for more details about this. */) - (Lisp_Object keys, Lisp_Object accept_default) -{ - register Lisp_Object map = BVAR (current_buffer, keymap); - if (NILP (map)) - return Qnil; - return Flookup_key (map, keys, accept_default); -} - -/* GC is possible in this function if it autoloads a keymap. */ - -DEFUN ("global-key-binding", Fglobal_key_binding, Sglobal_key_binding, 1, 2, 0, - doc: /* Return the binding for command KEYS in current global keymap only. -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' -\(which see). - -If optional argument ACCEPT-DEFAULT is non-nil, recognize default -bindings; see the description of `lookup-key' for more details about this. */) - (Lisp_Object keys, Lisp_Object accept_default) -{ - return Flookup_key (current_global_map, keys, accept_default); -} - -/* GC is possible in this function if it autoloads a keymap. */ - DEFUN ("minor-mode-key-binding", Fminor_mode_key_binding, Sminor_mode_key_binding, 1, 2, 0, doc: /* Find the visible minor mode bindings of KEY. Return an alist of pairs (MODENAME . BINDING), where MODENAME is @@ -3253,8 +3220,6 @@ be preferred. */); defsubr (&Scopy_keymap); defsubr (&Scommand_remapping); defsubr (&Skey_binding); - defsubr (&Slocal_key_binding); - defsubr (&Sglobal_key_binding); defsubr (&Sminor_mode_key_binding); defsubr (&Sdefine_key); defsubr (&Slookup_key); diff --git a/src/lisp.h b/src/lisp.h index 9d8dbbd629f..f6588685443 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4351,6 +4351,7 @@ extern EMACS_INT minibuf_level; extern Lisp_Object get_minibuffer (EMACS_INT); extern void init_minibuf_once (void); extern void syms_of_minibuf (void); +extern void barf_if_interaction_inhibited (void); /* Defined in callint.c. */ diff --git a/src/lread.c b/src/lread.c index 1ff0828e85e..72b68df6631 100644 --- a/src/lread.c +++ b/src/lread.c @@ -767,11 +767,16 @@ is used for reading a character. If the optional argument SECONDS is non-nil, it should be a number specifying the maximum number of seconds to wait for input. If no input arrives in that time, return nil. SECONDS may be a -floating-point value. */) +floating-point value. + +If `inhibit-interaction' is non-nil, this function will signal an +`inhibited-interaction' error. */) (Lisp_Object prompt, Lisp_Object inherit_input_method, Lisp_Object seconds) { Lisp_Object val; + barf_if_interaction_inhibited (); + if (! NILP (prompt)) message_with_string ("%s", prompt, 0); val = read_filtered_event (1, 1, 1, ! NILP (inherit_input_method), seconds); @@ -782,6 +787,12 @@ floating-point value. */) DEFUN ("read-event", Fread_event, Sread_event, 0, 3, 0, doc: /* Read an event object from the input stream. + +If you want to read non-character events, consider calling `read-key' +instead. `read-key' will decode events via `input-decode-map' that +`read-event' will not. On a terminal this includes function keys such +as and , or mouse events generated by `xterm-mouse-mode'. + If the optional argument PROMPT is non-nil, display that as a prompt. If PROMPT is nil or the string \"\", the key sequence/events that led to the current command is used as the prompt. @@ -793,9 +804,14 @@ is used for reading a character. If the optional argument SECONDS is non-nil, it should be a number specifying the maximum number of seconds to wait for input. If no input arrives in that time, return nil. SECONDS may be a -floating-point value. */) +floating-point value. + +If `inhibit-interaction' is non-nil, this function will signal an +`inhibited-interaction' error. */) (Lisp_Object prompt, Lisp_Object inherit_input_method, Lisp_Object seconds) { + barf_if_interaction_inhibited (); + if (! NILP (prompt)) message_with_string ("%s", prompt, 0); return read_filtered_event (0, 0, 0, ! NILP (inherit_input_method), seconds); @@ -822,11 +838,16 @@ is used for reading a character. If the optional argument SECONDS is non-nil, it should be a number specifying the maximum number of seconds to wait for input. If no input arrives in that time, return nil. SECONDS may be a -floating-point value. */) - (Lisp_Object prompt, Lisp_Object inherit_input_method, Lisp_Object seconds) +floating-point value. + +If `inhibit-interaction' is non-nil, this function will signal an +`inhibited-interaction' error. */) +(Lisp_Object prompt, Lisp_Object inherit_input_method, Lisp_Object seconds) { Lisp_Object val; + barf_if_interaction_inhibited (); + if (! NILP (prompt)) message_with_string ("%s", prompt, 0); diff --git a/src/minibuf.c b/src/minibuf.c index 868e481f843..5df10453739 100644 --- a/src/minibuf.c +++ b/src/minibuf.c @@ -1075,6 +1075,13 @@ read_minibuf_unwind (void) } +void +barf_if_interaction_inhibited (void) +{ + if (inhibit_interaction) + xsignal0 (Qinhibited_interaction); +} + DEFUN ("read-from-minibuffer", Fread_from_minibuffer, Sread_from_minibuffer, 1, 7, 0, doc: /* Read a string from the minibuffer, prompting with string PROMPT. @@ -1119,6 +1126,9 @@ If the variable `minibuffer-allow-text-properties' is non-nil, then the string which is returned includes whatever text properties were present in the minibuffer. Otherwise the value has no text properties. +If `inhibit-interaction' is non-nil, this function will signal an + `inhibited-interaction' error. + The remainder of this documentation string describes the INITIAL-CONTENTS argument in more detail. It is only relevant when studying existing code, or when HIST is a cons. If non-nil, @@ -1134,6 +1144,8 @@ and some related functions, which use zero-indexing for POSITION. */) { Lisp_Object histvar, histpos, val; + barf_if_interaction_inhibited (); + CHECK_STRING (prompt); if (NILP (keymap)) keymap = Vminibuffer_local_map; @@ -1207,11 +1219,17 @@ point positioned at the end, so that SPACE will accept the input. \(Actually, INITIAL can also be a cons of a string and an integer. Such values are treated as in `read-from-minibuffer', but are normally not useful in this function.) + Third arg INHERIT-INPUT-METHOD, if non-nil, means the minibuffer inherits -the current input method and the setting of`enable-multibyte-characters'. */) +the current input method and the setting of`enable-multibyte-characters'. + +If `inhibit-interaction' is non-nil, this function will signal an +`inhibited-interaction' error. */) (Lisp_Object prompt, Lisp_Object initial, Lisp_Object inherit_input_method) { CHECK_STRING (prompt); + barf_if_interaction_inhibited (); + return read_minibuf (Vminibuffer_local_ns_map, initial, prompt, 0, Qminibuffer_history, make_fixnum (0), Qnil, 0, !NILP (inherit_input_method)); @@ -2321,6 +2339,15 @@ This variable also overrides the default character that `read-passwd' uses to hide passwords. */); Vread_hide_char = Qnil; + DEFVAR_BOOL ("inhibit-interaction", + inhibit_interaction, + doc: /* Non-nil means any user interaction will signal an error. +This variable can be bound when user interaction can't be performed, +for instance when running a headless Emacs server. Functions like +`read-from-minibuffer' (and the like) will signal `inhibited-interaction' +instead. */); + inhibit_interaction = 0; + defsubr (&Sactive_minibuffer_window); defsubr (&Sset_minibuffer_window); defsubr (&Sread_from_minibuffer); diff --git a/src/process.c b/src/process.c index dac7d0440fa..aca87f8ed35 100644 --- a/src/process.c +++ b/src/process.c @@ -283,6 +283,16 @@ static int max_desc; the file descriptor of a socket that is already bound. */ static int external_sock_fd; +/* File descriptor that becomes readable when we receive SIGCHLD. */ +static int child_signal_read_fd = -1; +/* The write end thereof. The SIGCHLD handler writes to this file + descriptor to notify `wait_reading_process_output' of process + status changes. */ +static int child_signal_write_fd = -1; +static void child_signal_init (void); +static void child_signal_read (int, void *); +static void child_signal_notify (void); + /* Indexed by descriptor, gives the process (if any) for that descriptor. */ static Lisp_Object chan_process[FD_SETSIZE]; static void wait_for_socket_fds (Lisp_Object, char const *); @@ -2060,6 +2070,10 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir) Lisp_Object lisp_pty_name = Qnil; sigset_t oldset; + /* Ensure that the SIGCHLD handler can notify + `wait_reading_process_output'. */ + child_signal_init (); + inchannel = outchannel = -1; if (p->pty_flag) @@ -5395,6 +5409,14 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, check_write = true; } + /* We have to be informed when we receive a SIGCHLD signal for + an asynchronous process. Otherwise this might deadlock if we + receive a SIGCHLD during `pselect'. */ + int child_fd = child_signal_read_fd; + eassert (child_fd < FD_SETSIZE); + if (0 <= child_fd) + FD_SET (child_fd, &Available); + /* If frame size has changed or the window is newly mapped, redisplay now, before we start to wait. There is a race condition here; if a SIGIO arrives between now and the select @@ -7114,7 +7136,70 @@ process has been transmitted to the serial port. */) subprocesses which the main thread should not reap. For example, if the main thread attempted to reap an already-reaped child, it might inadvertently reap a GTK-created process that happened to - have the same process ID. */ + have the same process ID. + + To avoid a deadlock when receiving SIGCHLD while + `wait_reading_process_output' is in `pselect', the SIGCHLD handler + will notify the `pselect' using a pipe. */ + +/* Set up `child_signal_read_fd' and `child_signal_write_fd'. */ + +static void +child_signal_init (void) +{ + /* Either both are initialized, or both are uninitialized. */ + eassert ((child_signal_read_fd < 0) == (child_signal_write_fd < 0)); + + if (0 <= child_signal_read_fd) + return; /* already done */ + + int fds[2]; + if (emacs_pipe (fds) < 0) + report_file_error ("Creating pipe for child signal", Qnil); + if (FD_SETSIZE <= fds[0]) + { + /* Since we need to `pselect' on the read end, it has to fit + into an `fd_set'. */ + emacs_close (fds[0]); + emacs_close (fds[1]); + report_file_errno ("Creating pipe for child signal", Qnil, + EMFILE); + } + + /* We leave the file descriptors open until the Emacs process + exits. */ + eassert (0 <= fds[0]); + eassert (0 <= fds[1]); + add_read_fd (fds[0], child_signal_read, NULL); + fd_callback_info[fds[0]].flags &= ~KEYBOARD_FD; + child_signal_read_fd = fds[0]; + child_signal_write_fd = fds[1]; +} + +/* Consume a process status change. */ + +static void +child_signal_read (int fd, void *data) +{ + eassert (0 <= fd); + eassert (fd == child_signal_read_fd); + char dummy; + if (emacs_read (fd, &dummy, 1) < 0) + emacs_perror ("reading from child signal FD"); +} + +/* Notify `wait_reading_process_output' of a process status + change. */ + +static void +child_signal_notify (void) +{ + int fd = child_signal_write_fd; + eassert (0 <= fd); + char dummy = 0; + if (emacs_write (fd, &dummy, 1) != 1) + emacs_perror ("writing to child signal FD"); +} /* LIB_CHILD_HANDLER is a SIGCHLD handler that Emacs calls while doing its own SIGCHLD handling. On POSIXish systems, glib needs this to @@ -7152,6 +7237,7 @@ static void handle_child_signal (int sig) { Lisp_Object tail, proc; + bool changed = false; /* Find the process that signaled us, and record its status. */ @@ -7174,6 +7260,7 @@ handle_child_signal (int sig) eassert (ok); if (child_status_changed (deleted_pid, 0, 0)) { + changed = true; if (STRINGP (XCDR (head))) unlink (SSDATA (XCDR (head))); XSETCAR (tail, Qnil); @@ -7191,6 +7278,7 @@ handle_child_signal (int sig) && child_status_changed (p->pid, &status, WUNTRACED | WCONTINUED)) { /* Change the status of the process that was found. */ + changed = true; p->tick = ++process_tick; p->raw_status = status; p->raw_status_new = 1; @@ -7210,6 +7298,10 @@ handle_child_signal (int sig) } } + if (changed) + /* Wake up `wait_reading_process_output'. */ + child_signal_notify (); + lib_child_handler (sig); #ifdef NS_IMPL_GNUSTEP /* NSTask in GNUstep sets its child handler each time it is called. diff --git a/src/term.c b/src/term.c index a87f9c745ce..2e2ab2bf438 100644 --- a/src/term.c +++ b/src/term.c @@ -2382,7 +2382,6 @@ frame's terminal). */) #ifdef HAVE_GPM -#ifndef HAVE_WINDOW_SYSTEM void term_mouse_moveto (int x, int y) { @@ -2396,7 +2395,6 @@ term_mouse_moveto (int x, int y) last_mouse_x = x; last_mouse_y = y; */ } -#endif /* HAVE_WINDOW_SYSTEM */ /* Implementation of draw_row_with_mouse_face for TTY/GPM. */ void @@ -4246,8 +4244,8 @@ use the Bourne shell command 'TERM=...; export TERM' (C-shell:\n\ #ifdef HAVE_GPM terminal->mouse_position_hook = term_mouse_position; - tty->mouse_highlight.mouse_face_window = Qnil; #endif + tty->mouse_highlight.mouse_face_window = Qnil; terminal->kboard = allocate_kboard (Qnil); terminal->kboard->reference_count++; diff --git a/src/termhooks.h b/src/termhooks.h index 85a47c071b6..3800679e803 100644 --- a/src/termhooks.h +++ b/src/termhooks.h @@ -366,9 +366,7 @@ enum { #ifdef HAVE_GPM #include extern int handle_one_term_event (struct tty_display_info *, Gpm_Event *); -#ifndef HAVE_WINDOW_SYSTEM extern void term_mouse_moveto (int, int); -#endif /* The device for which we have enabled gpm support. */ extern struct tty_display_info *gpm_tty; diff --git a/src/xdisp.c b/src/xdisp.c index 6a4304d194b..32e9773b54e 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -9285,8 +9285,8 @@ move_it_in_display_line_to (struct it *it, if (may_wrap && char_can_wrap_before (it)) { /* We have reached a glyph that follows one or more - whitespace characters or a character that allows - wrapping after it. If this character allows + whitespace characters or characters that allow + wrapping after them. If this character allows wrapping before it, save this position as a wrapping point. */ if (atpos_it.sp >= 0) @@ -9303,7 +9303,6 @@ move_it_in_display_line_to (struct it *it, } /* Otherwise, we can wrap here. */ SAVE_IT (wrap_it, *it, wrap_data); - next_may_wrap = false; } /* Update may_wrap for the next iteration. */ may_wrap = next_may_wrap; @@ -10650,9 +10649,10 @@ include the height of both, if present, in the return value. */) bpos = BEGV_BYTE; while (bpos < ZV_BYTE) { - c = fetch_char_advance (&start, &bpos); + c = FETCH_BYTE (bpos); if (!(c == ' ' || c == '\t' || c == '\n' || c == '\r')) break; + inc_both (&start, &bpos); } while (bpos > BEGV_BYTE) { @@ -10681,7 +10681,10 @@ include the height of both, if present, in the return value. */) dec_both (&end, &bpos); c = FETCH_BYTE (bpos); if (!(c == ' ' || c == '\t' || c == '\n' || c == '\r')) - break; + { + inc_both (&end, &bpos); + break; + } } while (bpos < ZV_BYTE) { @@ -20819,9 +20822,8 @@ try_window_id (struct window *w) + window_wants_header_line (w) + window_internal_height (w)); -#if defined (HAVE_GPM) || defined (MSDOS) gui_clear_window_mouse_face (w); -#endif + /* Perform the operation on the screen. */ if (dvpos > 0) { diff --git a/test/Makefile.in b/test/Makefile.in index fc40dad5e2e..2d595d9bf16 100644 --- a/test/Makefile.in +++ b/test/Makefile.in @@ -246,6 +246,12 @@ endef $(foreach test,${TESTS},$(eval $(call test_template,${test}))) +# Get the tests for only a specific directory +NET_TESTS := $(patsubst %.el,%,$(wildcard lisp/net/*.el)) +LISP_TESTS := $(patsubst %.el,%,$(wildcard lisp/*.el)) +check-net: ${NET_TESTS} +check-lisp: ${LISP_TESTS} + ifeq (@HAVE_MODULES@, yes) # -fPIC is a no-op on Windows, but causes a compiler warning ifeq ($(SO),.dll) diff --git a/test/README b/test/README index ec566cb58dc..38f4a109701 100644 --- a/test/README +++ b/test/README @@ -39,6 +39,12 @@ The Makefile in this directory supports the following targets: * make check-all Like "make check", but run all tests. +* make check-lisp + Like "make check", but run only the tests in test/lisp/*.el + +* make check-net + Like "make check", but run only the tests in test/lisp/net/*.el + * make -or- make .log Run all tests declared in .el. This includes expensive tests. In the former case the output is shown on the terminal, in diff --git a/test/file-organization.org b/test/file-organization.org index 64c0755b3bc..efc354529c5 100644 --- a/test/file-organization.org +++ b/test/file-organization.org @@ -57,3 +57,8 @@ directory called ~test/lisp/progmodes/flymake-resources~. No guidance is given for the organization of resource files inside the ~-resources~ directory; files can be organized at the author's discretion. + +** Testing Infrastructure Files + +Files used to support testing infrastructure such as EMBA should be +placed in ~infra~. diff --git a/test/infra/Dockerfile.emba b/test/infra/Dockerfile.emba new file mode 100644 index 00000000000..421264db9c9 --- /dev/null +++ b/test/infra/Dockerfile.emba @@ -0,0 +1,71 @@ +# 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 . + +# GNU Emacs support for the GitLab-specific build of Docker images. + +# The presence of this file does not imply any FSF/GNU endorsement of +# Docker or any other particular tool. Also, it is intended for +# evaluation purposes, thus possibly temporary. + +# Maintainer: Ted Zlatanov +# URL: https://emba.gnu.org/emacs/emacs + +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 git \ + && rm -rf /var/lib/apt/lists/* + +FROM emacs-base as emacs-inotify + +RUN apt-get update && \ + apt-get install -y --no-install-recommends -o=Dpkg::Use-Pty=0 inotify-tools \ + && rm -rf /var/lib/apt/lists/* + +COPY . /checkout +WORKDIR /checkout +RUN ./autogen.sh autoconf +RUN ./configure --without-makeinfo +RUN make -j4 bootstrap +RUN make -j4 + +FROM emacs-base as emacs-filenotify-gio + +RUN apt-get update && \ + apt-get install -y --no-install-recommends -o=Dpkg::Use-Pty=0 libglib2.0-dev libglib2.0-bin libglib2.0-0 \ + && rm -rf /var/lib/apt/lists/* + +COPY . /checkout +WORKDIR /checkout +RUN ./autogen.sh autoconf +RUN ./configure --without-makeinfo --with-file-notification=gfile +RUN make bootstrap +RUN make -j4 + +FROM emacs-base as emacs-gnustep + +RUN apt-get update && \ + apt-get install -y --no-install-recommends -o=Dpkg::Use-Pty=0 gnustep-devel \ + && rm -rf /var/lib/apt/lists/* + +COPY . /checkout +WORKDIR /checkout +RUN ./autogen.sh autoconf +RUN ./configure --without-makeinfo --with-ns +RUN make bootstrap +RUN make -j4 diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml new file mode 100644 index 00000000000..f9c0e0c11ab --- /dev/null +++ b/test/infra/gitlab-ci.yml @@ -0,0 +1,217 @@ +# Copyright (C) 2017-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 . + +# 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 +# evaluation purposes, thus possibly temporary. + +# Maintainer: Ted Zlatanov +# URL: https://emba.gnu.org/emacs/emacs + +# Never run merge request pipelines, they usually duplicate push pipelines +# see https://docs.gitlab.com/ee/ci/yaml/README.html#common-if-clauses-for-rules + +# Rules: always run tags and branches named master*, emacs*, feature*, fix* +# Test that it triggers by pushing a tag: `git tag mytag; git push origin mytag` +# Test that it triggers by pushing to: feature/emba, feature1, master, master-2, fix/emba, emacs-299, fix-2 +# Test that it doesn't trigger by pushing to: scratch-2, scratch/emba, oldbranch, dev +workflow: + rules: + - if: '$CI_PIPELINE_SOURCE == "merge_request_event"' + when: never + - if: '$CI_COMMIT_TAG' + when: always + - if: '$CI_COMMIT_BRANCH !~ /^(master|emacs|feature|fix)/' + when: never + - when: always + +variables: + GIT_STRATEGY: fetch + EMACS_EMBA_CI: 1 + # # 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 avoid conflicts + DOCKER_CONFIG: "/.docker-config-${CI_COMMIT_SHA}" + +default: + image: docker:19.03.12 + timeout: 3 hours + before_script: + - docker info + - echo "docker registry is ${CI_REGISTRY}" + - docker login -u ${CI_REGISTRY_USER} -p ${CI_REGISTRY_PASSWORD} ${CI_REGISTRY} + +.job-template: + # these will be cached across builds + cache: + key: ${CI_COMMIT_SHA} + paths: [] + policy: pull-push + # these will be saved for followup builds + artifacts: + expire_in: 24 hrs + paths: [] + # - "test/**/*.log" + # - "**/*.log" + +.build-template: + script: + - docker build --pull --target ${target} -t ${CI_REGISTRY_IMAGE}:${target}-${CI_COMMIT_SHA} -f test/infra/Dockerfile.emba . + - docker push ${CI_REGISTRY_IMAGE}:${target}-${CI_COMMIT_SHA} + +.gnustep-template: + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + changes: + - "**/Makefile.in" + - .gitlab-ci.yml + - configure.ac + - src/ns*.{h,m} + - src/macfont.{h,m} + - lisp/term/ns-win.el + - nextstep/**/* + - test/infra/* + +.filenotify-gio-template: + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + changes: + - "**/Makefile.in" + - .gitlab-ci.yml + - lisp/autorevert.el + - lisp/filenotify.el + - lisp/net/tramp-sh.el + - src/gfilenotify.c + - test/infra/* + - test/lisp/autorevert-tests.el + - test/lisp/filenotify-tests.el + +.test-template: + rules: + - changes: + - "**/Makefile.in" + - .gitlab-ci.yml + - aclocal.m4 + - autogen.sh + - configure.ac + - lib/*.{h,c} + - lisp/**/*.el + - src/*.{h,c} + - test/infra/* + - 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 + + # using the variables for each job + script: + - docker pull ${CI_REGISTRY_IMAGE}:${target}-${CI_COMMIT_SHA} + # TODO: with make -j4 several of the tests were failing, for example shadowfile-tests, but passed without it + - docker run -i --rm -e EMACS_EMBA_CI=${EMACS_EMBA_CI} ${CI_REGISTRY_IMAGE}:${target}-${CI_COMMIT_SHA} make ${make_params} + +stages: + - prep-images + - build-images + - fast + - normal + - platform-images + - platforms + - slow + +prep-image-base: + stage: prep-images + extends: [.job-template, .build-template] + variables: + target: emacs-base + +build-image-inotify: + stage: build-images + extends: [.job-template, .build-template] + variables: + target: emacs-inotify + +test-fast-inotify: + stage: fast + extends: [.job-template, .test-template] + variables: + target: emacs-inotify + make_params: "-C test check" + +build-image-filenotify-gio: + stage: platform-images + extends: [.job-template, .build-template, .filenotify-gio-template] + variables: + target: emacs-filenotify-gio + +build-image-gnustep: + stage: platform-images + extends: [.job-template, .build-template, .gnustep-template] + variables: + target: emacs-gnustep + +test-lisp-inotify: + stage: normal + extends: [.job-template, .test-template] + variables: + target: emacs-inotify + make_params: "-C test check-lisp" + +test-net-inotify: + stage: normal + extends: [.job-template, .test-template] + variables: + target: emacs-inotify + make_params: "-C test check-net" + +test-filenotify-gio: + # This tests file monitor libraries gfilemonitor and gio. + stage: platforms + extends: [.job-template, .test-template, .filenotify-gio-template] + variables: + target: emacs-filenotify-gio + make_params: "-k -C test autorevert-tests filenotify-tests" + +test-gnustep: + # This tests the GNUstep build process + stage: platforms + extends: [.job-template, .test-template, .gnustep-template] + variables: + target: emacs-gnustep + make_params: install + +test-all-inotify: + # This tests also file monitor libraries inotify and inotifywatch. + stage: slow + extends: [.job-template, .test-template] + rules: + # note there's no "changes" section, so this always runs on a schedule + - if: '$CI_PIPELINE_SOURCE == "schedule"' + variables: + target: emacs-inotify + make_params: check-expensive diff --git a/test/lisp/calendar/lunar-tests.el b/test/lisp/calendar/lunar-tests.el index 5f1f6782f1a..268dcfdb550 100644 --- a/test/lisp/calendar/lunar-tests.el +++ b/test/lisp/calendar/lunar-tests.el @@ -27,39 +27,37 @@ (defmacro with-lunar-test (&rest body) `(let ((calendar-latitude 40.1) (calendar-longitude -88.2) - (calendar-location-name "Urbana, IL") - (calendar-time-zone -360) - (calendar-standard-time-zone-name "CST") - (calendar-time-display-form '(12-hours ":" minutes am-pm))) + (calendar-location-name "Paris") + (calendar-time-zone 0) + (calendar-standard-time-zone-name "UTC") + ;; Make sure daylight saving is disabled to avoid interference + ;; from the system settings (see bug#45818). + (calendar-daylight-savings-starts nil) + (calendar-time-display-form '(24-hours ":" minutes))) ,@body)) (ert-deftest lunar-test-phase () (with-lunar-test (should (equal (lunar-phase 1) - '((1 7 1900) "11:40pm" 1 ""))))) + '((1 8 1900) "05:40" 1 ""))))) (ert-deftest lunar-test-eclipse-check () (with-lunar-test (should (equal (eclipse-check 1 1) "** Eclipse **")))) -;; This fails in certain time zones. -;; Eg TZ=America/Phoenix make lisp/calendar/lunar-tests -;; Similarly with TZ=UTC. -;; Daylight saving related? (ert-deftest lunar-test-phase-list () - :tags '(:unstable) (with-lunar-test (should (equal (lunar-phase-list 3 1871) - '(((3 20 1871) "11:03pm" 0 "") - ((3 29 1871) "1:46am" 1 "** Eclipse **") - ((4 5 1871) "9:20am" 2 "") - ((4 12 1871) "12:57am" 3 "** Eclipse possible **") - ((4 19 1871) "2:06pm" 0 "") - ((4 27 1871) "6:49pm" 1 "") - ((5 4 1871) "5:57pm" 2 "") - ((5 11 1871) "9:29am" 3 "") - ((5 19 1871) "5:46am" 0 "") - ((5 27 1871) "8:02am" 1 "")))))) + '(((3 21 1871) "04:03" 0 "") + ((3 29 1871) "06:46" 1 "** Eclipse **") + ((4 5 1871) "14:20" 2 "") + ((4 12 1871) "05:57" 3 "** Eclipse possible **") + ((4 19 1871) "19:06" 0 "") + ((4 27 1871) "23:49" 1 "") + ((5 4 1871) "22:57" 2 "") + ((5 11 1871) "14:29" 3 "") + ((5 19 1871) "10:46" 0 "") + ((5 27 1871) "13:02" 1 "")))))) (ert-deftest lunar-test-new-moon-time () (with-lunar-test diff --git a/test/lisp/calendar/solar-tests.el b/test/lisp/calendar/solar-tests.el index 7a37f8db558..337deb8ce9a 100644 --- a/test/lisp/calendar/solar-tests.el +++ b/test/lisp/calendar/solar-tests.el @@ -26,7 +26,9 @@ (calendar-longitude 75.8) (calendar-time-zone +330) (calendar-standard-time-zone-name "IST") - (calendar-daylight-time-zone-name "IST") + ;; Make sure our clockwork isn't confused by daylight saving rules + ;; in effect for any other time zone (bug#45818). + (calendar-daylight-savings-starts nil) (epsilon (/ 60.0))) ; Minute accuracy is good enough. (let* ((sunrise-sunset (solar-sunrise-sunset '(12 30 2020))) (sunrise (car (nth 0 sunrise-sunset))) diff --git a/test/lisp/cedet/semantic-utest.el b/test/lisp/cedet/semantic-utest.el index c0099386f1c..67de4a5b02d 100644 --- a/test/lisp/cedet/semantic-utest.el +++ b/test/lisp/cedet/semantic-utest.el @@ -577,10 +577,8 @@ INSERTME is the text to be inserted after the deletion." (ert-deftest semantic-utest-Javascript() - (if (fboundp 'javascript-mode) - (semantic-utest-generic (semantic-utest-fname "javascripttest.js") semantic-utest-Javascript-buffer-contents semantic-utest-Javascript-name-contents '("fun2") "//1" "//deleted line") - (message "Skipping JavaScript test: NO major mode.")) - ) + (skip-unless (fboundp 'javascript-mode)) + (semantic-utest-generic (semantic-utest-fname "javascripttest.js") semantic-utest-Javascript-buffer-contents semantic-utest-Javascript-name-contents '("fun2") "//1" "//deleted line")) (ert-deftest semantic-utest-Java() ;; If JDE is installed, it might mess things up depending on the version diff --git a/test/lisp/cedet/srecode-utest-getset.el b/test/lisp/cedet/srecode-utest-getset.el index 0497dea505d..1c6578038c0 100644 --- a/test/lisp/cedet/srecode-utest-getset.el +++ b/test/lisp/cedet/srecode-utest-getset.el @@ -128,7 +128,6 @@ private: (srecode-utest-getset-jumptotag "miscFunction")) (let ((pos (point))) - (skip-chars-backward " \t\n") ; xemacs forward-comment is different. (forward-comment -1) (re-search-forward "miscFunction" pos)) diff --git a/test/lisp/cedet/srecode-utest-template.el b/test/lisp/cedet/srecode-utest-template.el index 57d8a648050..f97ff18320e 100644 --- a/test/lisp/cedet/srecode-utest-template.el +++ b/test/lisp/cedet/srecode-utest-template.el @@ -307,13 +307,9 @@ INSIDE SECTION: ARG HANDLER ONE") (should (srecode-table major-mode)) ;; Loop over the output testpoints. - (dolist (p srecode-utest-output-entries) - (set-buffer testbuff) ;; XEmacs causes a buffer switch. I don't know why - (should-not (srecode-utest-test p)) - ) + (should-not (srecode-utest-test p))))) - )) (when (file-exists-p srecode-utest-testfile) (delete-file srecode-utest-testfile))) diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index a07af188fac..263736af4ed 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -617,13 +617,13 @@ Subtests signal errors if something goes wrong." (make-obsolete-variable 'bytecomp--tests-obsolete-var nil "99.99") (bytecomp--define-warning-file-test "warn-obsolete-hook.el" - "bytecomp--tests-obs.*obsolete.*99.99") + "bytecomp--tests-obs.*obsolete[^z-a]*99.99") (bytecomp--define-warning-file-test "warn-obsolete-variable-same-file.el" "foo-obs.*obsolete.*99.99" t) (bytecomp--define-warning-file-test "warn-obsolete-variable.el" - "bytecomp--tests-obs.*obsolete.*99.99") + "bytecomp--tests-obs.*obsolete[^z-a]*99.99") (bytecomp--define-warning-file-test "warn-obsolete-variable-bound.el" "bytecomp--tests-obs.*obsolete.*99.99" t) diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el index 1b06c6e7543..e6f4c097504 100644 --- a/test/lisp/emacs-lisp/pcase-tests.el +++ b/test/lisp/emacs-lisp/pcase-tests.el @@ -32,6 +32,10 @@ (should (equal (pcase '(2 . 3) ;bug#18554 (`(,hd . ,(and (pred atom) tl)) (list hd tl)) ((pred consp) nil)) + '(2 3))) + (should (equal (pcase '(2 . 3) + (`(,hd . ,(and (pred (not consp)) tl)) (list hd tl)) + ((pred consp) nil)) '(2 3)))) (pcase-defmacro pcase-tests-plus (pat n) diff --git a/test/lisp/emacs-lisp/timer-tests.el b/test/lisp/emacs-lisp/timer-tests.el index 74da33eff69..7856c217f9e 100644 --- a/test/lisp/emacs-lisp/timer-tests.el +++ b/test/lisp/emacs-lisp/timer-tests.el @@ -36,8 +36,8 @@ (ert-deftest timer-tests-debug-timer-check () ;; This function exists only if --enable-checking. - (if (fboundp 'debug-timer-check) - (should (debug-timer-check)) t)) + (skip-unless (fboundp 'debug-timer-check)) + (should (debug-timer-check))) (ert-deftest timer-test-multiple-of-time () (should (time-equal-p diff --git a/test/lisp/help-tests.el b/test/lisp/help-tests.el index 835d9fe7949..8034764741c 100644 --- a/test/lisp/help-tests.el +++ b/test/lisp/help-tests.el @@ -95,7 +95,7 @@ key binding --- ------- -C-g abort-recursive-edit +C-g abort-minibuffers TAB minibuffer-complete C-j minibuffer-complete-and-exit RET minibuffer-complete-and-exit @@ -122,7 +122,7 @@ M-s next-matching-history-element (ert-deftest help-tests-substitute-command-keys/keymap-change () (with-substitute-command-keys-test - (test "\\\\[abort-recursive-edit]" "C-g") + (test "\\\\[abort-recursive-edit]" "C-]") (test "\\\\[eval-defun]" "C-M-x"))) (defvar help-tests-remap-map diff --git a/test/lisp/net/nsm-tests.el b/test/lisp/net/nsm-tests.el index 88c30c20395..ff453319b37 100644 --- a/test/lisp/net/nsm-tests.el +++ b/test/lisp/net/nsm-tests.el @@ -49,15 +49,17 @@ (should (eq nil (nsm-should-check "127.0.0.1"))) (should (eq nil (nsm-should-check "localhost")))))) -(defun nsm-ipv6-is-available () +;; This will need updating when IANA assign more IPv6 global ranges. +(defun ipv6-is-available () (and (featurep 'make-network-process '(:family ipv6)) (cl-rassoc-if (lambda (elt) - (eq 9 (length elt))) + (and (eq 9 (length elt)) + (= (logand (aref elt 0) #xe000) #x2000))) (network-interface-list)))) (ert-deftest nsm-check-local-subnet-ipv6 () - (skip-unless (nsm-ipv6-is-available)) + (skip-unless (ipv6-is-available)) (let ((local-ip '[123 456 789 11 172 26 128 160 0]) (mask '[255 255 255 255 255 255 255 0 0]) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 3995006898a..ef0968a3385 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -78,6 +78,8 @@ ;; Needed for Emacs 27. (defvar process-file-return-signal-string) (defvar shell-command-dont-erase-buffer) +;; Needed for Emacs 28. +(defvar dired-copy-dereference) ;; Beautify batch mode. (when noninteractive @@ -98,7 +100,6 @@ '("mock" (tramp-login-program "sh") (tramp-login-args (("-i"))) - (tramp-direct-async-args (("-c"))) (tramp-remote-shell "/bin/sh") (tramp-remote-shell-args ("-c")) (tramp-connection-timeout 10))) @@ -2438,7 +2439,7 @@ This checks also `file-name-as-directory', `file-name-directory', ;; We must check the last line. There could be ;; other messages from the progress reporter. (should - (string-match + (string-match-p (if (and (null noninteractive) (or (eq visit t) (null visit) (stringp visit))) (format "^Wrote %s\n\\'" (regexp-quote tmp-name)) @@ -2833,6 +2834,7 @@ 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)))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let* ((tmp-name1 (tramp--test-make-temp-name nil quoted)) @@ -3612,8 +3614,8 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." `(condition-case err (progn ,@body) (file-error - (unless (string-match "^error with add-name-to-file" - (error-message-string err)) + (unless (string-match-p "^error with add-name-to-file" + (error-message-string err)) (signal (car err) (cdr err)))))) (ert-deftest tramp-test21-file-links () @@ -4388,7 +4390,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; there's an indication for a signal describing string. (let ((process-file-return-signal-string t)) (should - (string-match + (string-match-p "Interrupt\\|Signal 2" (process-file (if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh") @@ -4456,7 +4458,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (with-timeout (10 (tramp--test-timeout-handler)) (while (< (- (point-max) (point-min)) (length "foo")) (while (accept-process-output proc 0 nil t)))) - (should (string-match "foo" (buffer-string)))) + (should (string-match-p "foo" (buffer-string)))) ;; Cleanup. (ignore-errors (delete-process proc))) @@ -4475,7 +4477,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (with-timeout (10 (tramp--test-timeout-handler)) (while (< (- (point-max) (point-min)) (length "foo")) (while (accept-process-output proc 0 nil t)))) - (should (string-match "foo" (buffer-string)))) + (should (string-match-p "foo" (buffer-string)))) ;; Cleanup. (ignore-errors @@ -4497,7 +4499,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (with-timeout (10 (tramp--test-timeout-handler)) (while (< (- (point-max) (point-min)) (length "foo")) (while (accept-process-output proc 0 nil t)))) - (should (string-match "foo" (buffer-string)))) + (should (string-match-p "foo" (buffer-string)))) ;; Cleanup. (ignore-errors (delete-process proc))) @@ -4539,8 +4541,6 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (cons '(nil "direct-async-process" t) tramp-connection-properties))) (skip-unless (tramp-direct-async-process-p)) - ;; For whatever reason, it doesn't cooperate with the "mock" method. - (skip-unless (not (tramp--test-mock-p))) ;; We do expect an established connection already, ;; `file-truename' does it by side-effect. Suppress ;; `tramp--test-enabled', in order to keep the connection. @@ -4586,7 +4586,7 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (with-timeout (10 (tramp--test-timeout-handler)) (while (< (- (point-max) (point-min)) (length "foo")) (while (accept-process-output proc 0 nil t)))) - (should (string-match "foo" (buffer-string)))) + (should (string-match-p "foo" (buffer-string)))) ;; Cleanup. (ignore-errors (delete-process proc))) @@ -4607,7 +4607,7 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (with-timeout (10 (tramp--test-timeout-handler)) (while (< (- (point-max) (point-min)) (length "foo")) (while (accept-process-output proc 0 nil t)))) - (should (string-match "foo" (buffer-string)))) + (should (string-match-p "foo" (buffer-string)))) ;; Cleanup. (ignore-errors @@ -4631,9 +4631,9 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (process-send-eof proc) ;; Read output. (with-timeout (10 (tramp--test-timeout-handler)) - (while (not (string-match "foo" (buffer-string))) + (while (not (string-match-p "foo" (buffer-string))) (while (accept-process-output proc 0 nil t)))) - (should (string-match "foo" (buffer-string)))) + (should (string-match-p "foo" (buffer-string)))) ;; Cleanup. (ignore-errors (delete-process proc))) @@ -4658,7 +4658,7 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (with-timeout (10 (tramp--test-timeout-handler)) (while (accept-process-output proc 0 nil t))) ;; On some MS Windows systems, it returns "unknown signal". - (should (string-match "unknown signal\\|killed" (buffer-string)))) + (should (string-match-p "unknown signal\\|killed" (buffer-string)))) ;; Cleanup. (ignore-errors (delete-process proc))) @@ -4682,7 +4682,7 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (delete-process proc) (with-current-buffer stderr (should - (string-match + (string-match-p "cat:.* No such file or directory" (buffer-string))))) ;; Cleanup. @@ -4709,7 +4709,7 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (with-temp-buffer (insert-file-contents tmpfile) (should - (string-match + (string-match-p "cat:.* No such file or directory" (buffer-string))))) ;; Cleanup. @@ -4852,7 +4852,7 @@ INPUT, if non-nil, is a string sent to the process." (should (string-equal ;; tramp-adb.el echoes, so we must add the string. - (if (tramp--test-adb-p) + (if (and (tramp--test-adb-p) (not (tramp-direct-async-process-p))) (format "%s\n%s\n" (file-name-nondirectory tmp-name) @@ -5043,7 +5043,7 @@ INPUT, if non-nil, is a string sent to the process." (cons (concat envvar "=foo") process-environment))) ;; Default value. (should - (string-match + (string-match-p "foo" (funcall this-shell-command-to-string @@ -5054,13 +5054,13 @@ INPUT, if non-nil, is a string sent to the process." (cons (concat envvar "=") process-environment))) ;; Value is null. (should - (string-match + (string-match-p "bla" (funcall this-shell-command-to-string (format "echo \"${%s:-bla}\"" envvar)))) ;; Variable is set. (should - (string-match + (string-match-p (regexp-quote envvar) (funcall this-shell-command-to-string "set")))) @@ -5072,7 +5072,7 @@ INPUT, if non-nil, is a string sent to the process." (cons (concat envvar "=foo") tramp-remote-process-environment))) ;; Set the initial value, we want to unset below. (should - (string-match + (string-match-p "foo" (funcall this-shell-command-to-string @@ -5080,14 +5080,14 @@ INPUT, if non-nil, is a string sent to the process." (let ((process-environment (cons envvar process-environment))) ;; Variable is unset. (should - (string-match + (string-match-p "bla" (funcall this-shell-command-to-string (format "echo \"${%s:-bla}\"" envvar)))) ;; Variable is unset. (should-not - (string-match + (string-match-p (regexp-quote envvar) ;; We must remove PS1, the output is truncated otherwise. (funcall @@ -5125,7 +5125,7 @@ Use direct async.") (format "%s=%d" envvar port) tramp-remote-process-environment))) (should - (string-match + (string-match-p (number-to-string port) (shell-command-to-string (format "echo $%s" envvar)))))) @@ -5253,7 +5253,7 @@ Use direct async.") (with-timeout (10) (while (accept-process-output (get-buffer-process (current-buffer)) nil nil t))) - (should (string-match "^foo$" (buffer-string))))) + (should (string-match-p "^foo$" (buffer-string))))) ;; Cleanup. (put 'explicit-shell-file-name 'permanent-local nil) @@ -5388,25 +5388,27 @@ Use direct async.") (tramp-remote-process-environment tramp-remote-process-environment) (inhibit-message t) (vc-handled-backends - (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil - (cond - ((tramp-find-executable - v vc-git-program (tramp-get-remote-path v)) - '(Git)) - ((tramp-find-executable - v vc-hg-program (tramp-get-remote-path v)) - '(Hg)) - ((tramp-find-executable - v vc-bzr-program (tramp-get-remote-path v)) - (setq tramp-remote-process-environment - (cons (format "BZR_HOME=%s" - (file-remote-p tmp-name1 'localname)) - tramp-remote-process-environment)) - ;; We must force a reconnect, in order to activate $BZR_HOME. - (tramp-cleanup-connection - tramp-test-vec 'keep-debug 'keep-password) - '(Bzr)) - (t nil)))) + (cond + ((tramp-find-executable + tramp-test-vec vc-git-program + (tramp-get-remote-path tramp-test-vec)) + '(Git)) + ((tramp-find-executable + tramp-test-vec vc-hg-program + (tramp-get-remote-path tramp-test-vec)) + '(Hg)) + ((tramp-find-executable + tramp-test-vec vc-bzr-program + (tramp-get-remote-path tramp-test-vec)) + (setq tramp-remote-process-environment + (cons (format "BZR_HOME=%s" + (file-remote-p tmp-name1 'localname)) + tramp-remote-process-environment)) + ;; We must force a reconnect, in order to activate $BZR_HOME. + (tramp-cleanup-connection + tramp-test-vec 'keep-debug 'keep-password) + '(Bzr)) + (t nil))) ;; Suppress nasty messages. (inhibit-message t)) (skip-unless vc-handled-backends) @@ -5732,7 +5734,7 @@ This does not support some special file names." "Check, whether an FTP-like method is used. This does not support globbing characters in file names (yet)." ;; Globbing characters are ??, ?* and ?\[. - (string-match + (string-match-p "ftp$" (file-remote-p tramp-test-temporary-file-directory 'method))) (defun tramp--test-gvfs-p (&optional method) @@ -5746,18 +5748,18 @@ If optional METHOD is given, it is checked first." "Check, whether the remote host runs HP-UX. Several special characters do not work properly there." ;; We must refill the cache. `file-truename' does it. - (with-parsed-tramp-file-name - (file-truename tramp-test-temporary-file-directory) nil - (string-match "^HP-UX" (tramp-get-connection-property v "uname" "")))) + (file-truename tramp-test-temporary-file-directory) nil + (string-match-p + "^HP-UX" (tramp-get-connection-property tramp-test-vec "uname" ""))) (defun tramp--test-ksh-p () "Check, whether the remote shell is ksh. ksh93 makes some strange conversions of non-latin characters into a $'' syntax." ;; We must refill the cache. `file-truename' does it. - (with-parsed-tramp-file-name - (file-truename tramp-test-temporary-file-directory) nil - (string-match "ksh$" (tramp-get-connection-property v "remote-shell" "")))) + (file-truename tramp-test-temporary-file-directory) nil + (string-match-p + "ksh$" (tramp-get-connection-property tramp-test-vec "remote-shell" ""))) (defun tramp--test-mock-p () "Check, whether the mock method is used. @@ -5809,7 +5811,7 @@ This does not support special characters." "Check, whether the locale host runs MS Windows, and ps{cp,ftp} is used. This does not support utf8 based file transfer." (and (eq system-type 'windows-nt) - (string-match + (string-match-p (regexp-opt '("pscp" "psftp")) (file-remote-p tramp-test-temporary-file-directory 'method)))) @@ -6072,6 +6074,7 @@ This requires restrictions of file name syntax." (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-rsync-p))) (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) + (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) (tramp--test-special-characters)) @@ -6083,6 +6086,8 @@ Use the `stat' command." (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-rsync-p))) (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) + (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) + ;; We cannot use `tramp-test-vec', because this fails during compilation. (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil (skip-unless (tramp-get-remote-stat v))) @@ -6101,6 +6106,8 @@ Use the `perl' command." (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-rsync-p))) (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) + (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) + ;; We cannot use `tramp-test-vec', because this fails during compilation. (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil (skip-unless (tramp-get-remote-perl v))) @@ -6123,6 +6130,7 @@ Use the `ls' command." (skip-unless (not (tramp--test-rsync-p))) (skip-unless (not (tramp--test-windows-nt-and-batch-p))) (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) + (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) (let ((tramp-connection-properties (append @@ -6191,6 +6199,7 @@ Use the `ls' command." (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) (skip-unless (not (tramp--test-ksh-p))) (skip-unless (not (tramp--test-crypt-p))) + (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) (tramp--test-utf8)) @@ -6206,6 +6215,8 @@ Use the `stat' command." (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) (skip-unless (not (tramp--test-ksh-p))) (skip-unless (not (tramp--test-crypt-p))) + (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) + ;; We cannot use `tramp-test-vec', because this fails during compilation. (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil (skip-unless (tramp-get-remote-stat v))) @@ -6228,6 +6239,8 @@ Use the `perl' command." (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) (skip-unless (not (tramp--test-ksh-p))) (skip-unless (not (tramp--test-crypt-p))) + (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) + ;; We cannot use `tramp-test-vec', because this fails during compilation. (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil (skip-unless (tramp-get-remote-perl v))) @@ -6253,6 +6266,7 @@ Use the `ls' command." (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) (skip-unless (not (tramp--test-ksh-p))) (skip-unless (not (tramp--test-crypt-p))) + (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) (let ((tramp-connection-properties (append @@ -6541,7 +6555,7 @@ process sentinels. They shall not disturb each other." (message \"Tramp loaded: %%s\" (and (file-remote-p %S) t)))" tramp-test-temporary-file-directory))) (should - (string-match + (string-match-p "Tramp loaded: t[\n\r]+" (shell-command-to-string (format @@ -6572,7 +6586,7 @@ process sentinels. They shall not disturb each other." ;; Tramp doesn't load when `tramp-mode' is nil. (dolist (tm '(t nil)) (should - (string-match + (string-match-p (format "Tramp loaded: nil[\n\r]+Tramp loaded: nil[\n\r]+Tramp loaded: %s[\n\r]+" tm) @@ -6598,7 +6612,7 @@ process sentinels. They shall not disturb each other." tramp-test-temporary-file-directory temporary-file-directory))) (should-not - (string-match + (string-match-p "Recursive load" (shell-command-to-string (format @@ -6623,7 +6637,7 @@ process sentinels. They shall not disturb each other." (load-path (cons \"/foo:bar:\" load-path))) \ (tramp-cleanup-all-connections))")) (should - (string-match + (string-match-p (format "Loading %s" (regexp-quote @@ -6670,11 +6684,11 @@ Since it unloads Tramp, it shall be the last test to run." (lambda (x) (and (or (and (boundp x) (null (local-variable-if-set-p x))) (and (functionp x) (null (autoloadp (symbol-function x))))) - (string-match "^tramp" (symbol-name x)) + (string-match-p "^tramp" (symbol-name x)) ;; `tramp-completion-mode' is autoloaded in Emacs < 28.1. (not (eq 'tramp-completion-mode x)) - (not (string-match "^tramp\\(-archive\\)?--?test" (symbol-name x))) - (not (string-match "unload-hook$" (symbol-name x))) + (not (string-match-p "^tramp\\(-archive\\)?--?test" (symbol-name x))) + (not (string-match-p "unload-hook$" (symbol-name x))) (ert-fail (format "`%s' still bound" x))))) ;; The defstruct `tramp-file-name' and all its internal functions ;; shall be purged. @@ -6682,15 +6696,15 @@ Since it unloads Tramp, it shall be the last test to run." (mapatoms (lambda (x) (and (functionp x) - (string-match "tramp-file-name" (symbol-name x)) + (string-match-p "tramp-file-name" (symbol-name x)) (ert-fail (format "Structure function `%s' still exists" x))))) ;; There shouldn't be left a hook function containing a Tramp ;; function. We do not regard the Tramp unload hooks. (mapatoms (lambda (x) (and (boundp x) - (string-match "-\\(hook\\|function\\)s?$" (symbol-name x)) - (not (string-match "unload-hook$" (symbol-name x))) + (string-match-p "-\\(hook\\|function\\)s?$" (symbol-name x)) + (not (string-match-p "unload-hook$" (symbol-name x))) (consp (symbol-value x)) (ignore-errors (all-completions "tramp" (symbol-value x))) (ert-fail (format "Hook `%s' still contains Tramp function" x)))))) diff --git a/test/lisp/progmodes/elisp-mode-tests.el b/test/lisp/progmodes/elisp-mode-tests.el index a10d5dab906..fd43707f277 100644 --- a/test/lisp/progmodes/elisp-mode-tests.el +++ b/test/lisp/progmodes/elisp-mode-tests.el @@ -314,7 +314,19 @@ (let* ((xref (pop xrefs)) (expected (pop expected-xrefs)) (expected-xref (or (when (consp expected) (car expected)) expected)) - (expected-source (when (consp expected) (cdr expected)))) + (expected-source (when (consp expected) (cdr expected))) + (xref-file (xref-elisp-location-file (oref xref location))) + (expected-file (xref-elisp-location-file + (oref expected-xref location)))) + + ;; Make sure file names compare as strings. + (when (file-name-absolute-p xref-file) + (setf (xref-elisp-location-file (oref xref location)) + (file-truename (xref-elisp-location-file (oref xref location))))) + (when (file-name-absolute-p expected-file) + (setf (xref-elisp-location-file (oref expected-xref location)) + (file-truename (xref-elisp-location-file + (oref expected-xref location))))) ;; Downcase the filenames for case-insensitive file systems. (when xref--case-insensitive diff --git a/test/lisp/progmodes/tcl-tests.el b/test/lisp/progmodes/tcl-tests.el index 8ff85470ece..cf1ed2896e4 100644 --- a/test/lisp/progmodes/tcl-tests.el +++ b/test/lisp/progmodes/tcl-tests.el @@ -50,14 +50,14 @@ (insert "proc notinthis {} {\n # nothing\n}\n\n") (should-not (add-log-current-defun)))) -(ert-deftest tcl-mode-function-name () +(ert-deftest tcl-mode-function-name-2 () (with-temp-buffer (tcl-mode) (insert "proc simple {} {\n # nothing\n}") (backward-char 3) (should (equal "simple" (add-log-current-defun))))) -(ert-deftest tcl-mode-function-name () +(ert-deftest tcl-mode-function-name-3 () (with-temp-buffer (tcl-mode) (insert "proc inthis {} {\n # nothing\n") @@ -72,6 +72,16 @@ (indent-region (point-min) (point-max)) (should (equal (buffer-string) text))))) +;; From bug#44834 +(ert-deftest tcl-mode-namespace-indent-2 () + :expected-result :failed + (with-temp-buffer + (tcl-mode) + (let ((text "namespace eval Foo {\n proc foo {} {}\n\n proc bar {}{}}\n")) + (insert text) + (indent-region (point-min) (point-max)) + (should (equal (buffer-string) text))))) + (provide 'tcl-tests) ;;; tcl-tests.el ends here diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index e0826208b60..fc5a1eba6d8 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -87,6 +87,17 @@ ;; Returns the symbol. (should (eq (define-prefix-command 'foo-bar) 'foo-bar))) +(ert-deftest subr-test-local-key-binding () + (with-temp-buffer + (emacs-lisp-mode) + (should (keymapp (local-key-binding [menu-bar]))) + (should-not (local-key-binding [f12])))) + +(ert-deftest subr-test-global-key-binding () + (should (eq (global-key-binding [f1]) 'help-command)) + (should (eq (global-key-binding "x") 'self-insert-command)) + (should-not (global-key-binding [f12]))) + ;;;; Mode hooks. diff --git a/test/src/decompress-tests.el b/test/src/decompress-tests.el index 67a7fefb05e..520445cca5a 100644 --- a/test/src/decompress-tests.el +++ b/test/src/decompress-tests.el @@ -29,16 +29,16 @@ (ert-deftest zlib--decompress () "Test decompressing a gzipped file." - (when (and (fboundp 'zlib-available-p) - (zlib-available-p)) - (should (string= - (with-temp-buffer - (set-buffer-multibyte nil) - (insert-file-contents-literally - (expand-file-name "foo.gz" zlib-tests-data-directory)) - (zlib-decompress-region (point-min) (point-max)) - (buffer-string)) - "foo\n")))) + (skip-unless (and (fboundp 'zlib-available-p) + (zlib-available-p))) + (should (string= + (with-temp-buffer + (set-buffer-multibyte nil) + (insert-file-contents-literally + (expand-file-name "foo.gz" zlib-tests-data-directory)) + (zlib-decompress-region (point-min) (point-max)) + (buffer-string)) + "foo\n"))) (provide 'decompress-tests) diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el index a9daf878b81..e0aed2a71b6 100644 --- a/test/src/fns-tests.el +++ b/test/src/fns-tests.el @@ -1040,3 +1040,61 @@ (let ((list (list 1))) (setcdr list list) (length< list #x1fffe)))) + +(defun approx-equal (list1 list2) + (and (equal (length list1) (length list2)) + (cl-loop for v1 in list1 + for v2 in list2 + when (not (or (= v1 v2) + (< (abs (- v1 v2)) 0.1))) + return nil + finally return t))) + +(ert-deftest test-buffer-line-stats-nogap () + (with-temp-buffer + (insert "") + (should (approx-equal (buffer-line-statistics) '(0 0 0)))) + (with-temp-buffer + (insert "123\n") + (should (approx-equal (buffer-line-statistics) '(1 3 3)))) + (with-temp-buffer + (insert "123\n12345\n123\n") + (should (approx-equal (buffer-line-statistics) '(3 5 3.66)))) + (with-temp-buffer + (insert "123\n12345\n123") + (should (approx-equal (buffer-line-statistics) '(3 5 3.66)))) + (with-temp-buffer + (insert "123\n12345") + (should (approx-equal (buffer-line-statistics) '(2 5 4)))) + + (with-temp-buffer + (insert "123\n12é45\n123\n") + (should (approx-equal (buffer-line-statistics) '(3 6 4)))) + + (with-temp-buffer + (insert "\n\n\n") + (should (approx-equal (buffer-line-statistics) '(3 0 0))))) + +(ert-deftest test-buffer-line-stats-gap () + (with-temp-buffer + (dotimes (_ 1000) + (insert "12345678901234567890123456789012345678901234567890\n")) + (goto-char (point-min)) + ;; This should make a gap appear. + (insert "123\n") + (delete-region (point-min) (point)) + (should (approx-equal (buffer-line-statistics) '(1000 50 50.0)))) + (with-temp-buffer + (dotimes (_ 1000) + (insert "12345678901234567890123456789012345678901234567890\n")) + (goto-char (point-min)) + (insert "123\n") + (should (approx-equal (buffer-line-statistics) '(1001 50 49.9)))) + (with-temp-buffer + (dotimes (_ 1000) + (insert "12345678901234567890123456789012345678901234567890\n")) + (goto-char (point-min)) + (insert "123\n") + (goto-char (point-max)) + (insert "fóo") + (should (approx-equal (buffer-line-statistics) '(1002 50 49.9))))) diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el index edf88214f97..f2a60bcf327 100644 --- a/test/src/lread-tests.el +++ b/test/src/lread-tests.el @@ -190,4 +190,10 @@ literals (Bug#20852)." (ert-deftest lread-circular-hash () (should-error (read "#s(hash-table data #0=(#0# . #0#))"))) +(ert-deftest test-inhibit-interaction () + (let ((inhibit-interaction t)) + (should-error (read-char "foo: ")) + (should-error (read-event "foo: ")) + (should-error (read-char-exclusive "foo: ")))) + ;;; lread-tests.el ends here diff --git a/test/src/minibuf-tests.el b/test/src/minibuf-tests.el index b9cd255462d..28119fc999e 100644 --- a/test/src/minibuf-tests.el +++ b/test/src/minibuf-tests.el @@ -410,5 +410,20 @@ (should (equal (try-completion "baz" '("bAz" "baz")) (try-completion "baz" '("baz" "bAz")))))) +(ert-deftest test-inhibit-interaction () + (let ((inhibit-interaction t)) + (should-error (read-from-minibuffer "foo: ")) + + (should-error (y-or-n-p "foo: ")) + (should-error (yes-or-no-p "foo: ")) + (should-error (read-blanks-no-input "foo: ")) + + ;; See that we get the expected error. + (should (eq (condition-case nil + (read-from-minibuffer "foo: ") + (inhibited-interaction 'inhibit) + (error nil)) + 'inhibit)))) + ;;; minibuf-tests.el ends here diff --git a/test/src/process-tests.el b/test/src/process-tests.el index 921bcd5f85b..dad36426a09 100644 --- a/test/src/process-tests.el +++ b/test/src/process-tests.el @@ -28,6 +28,7 @@ (require 'puny) (require 'rx) (require 'subr-x) +(require 'dns) ;; Timeout in seconds; the test fails if the timeout is reached. (defvar process-test-sentinel-wait-timeout 2.0) @@ -350,14 +351,23 @@ See Bug#30460." ;; All the following tests require working DNS, which appears not to ;; be the case for hydra.nixos.org, so disable them there for now. +;; This will need updating when IANA assign more IPv6 global ranges. +(defun ipv6-is-available () + (and (featurep 'make-network-process '(:family ipv6)) + (cl-rassoc-if + (lambda (elt) + (and (eq 9 (length elt)) + (= (logand (aref elt 0) #xe000) #x2000))) + (network-interface-list)))) + (ert-deftest lookup-family-specification () "`network-lookup-address-info' should only accept valid family symbols." (skip-unless (not (getenv "EMACS_HYDRA_CI"))) (with-timeout (60 (ert-fail "Test timed out")) - (should-error (network-lookup-address-info "google.com" 'both)) - (should (network-lookup-address-info "google.com" 'ipv4)) - (when (featurep 'make-network-process '(:family ipv6)) - (should (network-lookup-address-info "google.com" 'ipv6))))) + (should-error (network-lookup-address-info "localhost" 'both)) + (should (network-lookup-address-info "localhost" 'ipv4)) + (when (ipv6-is-available) + (should (network-lookup-address-info "localhost" 'ipv6))))) (ert-deftest lookup-unicode-domains () "Unicode domains should fail." @@ -380,7 +390,8 @@ See Bug#30460." (addresses-v4 (network-lookup-address-info "google.com" 'ipv4))) (should addresses-both) (should addresses-v4)) - (when (featurep 'make-network-process '(:family ipv6)) + (when (and (ipv6-is-available) + (dns-query "google.com" 'AAAA)) (should (network-lookup-address-info "google.com" 'ipv6))))) (ert-deftest non-existent-lookup-failure () @@ -565,11 +576,6 @@ FD_SETSIZE file descriptors (Bug#24325)." (should (memq (process-status process) '(run exit))) (when (process-live-p process) (process-send-eof process)) - ;; FIXME: This `sleep-for' shouldn't be needed. It - ;; indicates a bug in Emacs; perhaps SIGCHLD is - ;; received in parallel with `accept-process-output', - ;; causing the latter to hang. - (sleep-for 0.1) (while (accept-process-output process)) (should (eq (process-status process) 'exit)) ;; If there's an error between fork and exec, Emacs diff --git a/test/src/xdisp-tests.el b/test/src/xdisp-tests.el index d13ce77a997..ec96d777ffb 100644 --- a/test/src/xdisp-tests.el +++ b/test/src/xdisp-tests.el @@ -72,4 +72,34 @@ (should (equal (nth 0 posns) (nth 1 posns))) (should (equal (nth 1 posns) (nth 2 posns))))) +(ert-deftest xdisp-tests--window-text-pixel-size () ;; bug#45748 + (with-temp-buffer + (insert "xxx") + (let* ((window + (display-buffer (current-buffer) '(display-buffer-in-child-frame . nil))) + (char-width (frame-char-width)) + (size (window-text-pixel-size nil t t))) + (delete-frame (window-frame window)) + (should (equal (/ (car size) char-width) 3))))) + +(ert-deftest xdisp-tests--window-text-pixel-size-leading-space () ;; bug#45748 + (with-temp-buffer + (insert " xx") + (let* ((window + (display-buffer (current-buffer) '(display-buffer-in-child-frame . nil))) + (char-width (frame-char-width)) + (size (window-text-pixel-size nil t t))) + (delete-frame (window-frame window)) + (should (equal (/ (car size) char-width) 3))))) + +(ert-deftest xdisp-tests--window-text-pixel-size-trailing-space () ;; bug#45748 + (with-temp-buffer + (insert "xx ") + (let* ((window + (display-buffer (current-buffer) '(display-buffer-in-child-frame . nil))) + (char-width (frame-char-width)) + (size (window-text-pixel-size nil t t))) + (delete-frame (window-frame window)) + (should (equal (/ (car size) char-width) 3))))) + ;;; xdisp-tests.el ends here diff --git a/test/src/xml-tests.el b/test/src/xml-tests.el index 632cf965fa2..a35b4d2ccc8 100644 --- a/test/src/xml-tests.el +++ b/test/src/xml-tests.el @@ -44,12 +44,12 @@ (ert-deftest libxml-tests () "Test libxml." - (when (fboundp 'libxml-parse-xml-region) - (with-temp-buffer - (dolist (test libxml-tests--data-comments-preserved) - (erase-buffer) - (insert (car test)) - (should (equal (cdr test) - (libxml-parse-xml-region (point-min) (point-max)))))))) + (skip-unless (fboundp 'libxml-parse-xml-region)) + (with-temp-buffer + (dolist (test libxml-tests--data-comments-preserved) + (erase-buffer) + (insert (car test)) + (should (equal (cdr test) + (libxml-parse-xml-region (point-min) (point-max))))))) ;;; libxml-tests.el ends here