pestctrl/emacs
1
0
Fork 0
forked from Github/emacs
Code Issues Pull requests Projects Releases Packages Wiki Activity

Merge branch 'master' into scratch/etags-regen

Browse source
This commit is contained in:
Dmitry Gutov 2021-01-16 21:43:33 +02:00
commit 8d00e2f20b
99 changed files with 1818 additions and 1014 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
.gitignore vendored
View file

@ -298,3 +298,4 @@ nt/emacs.rc
nt/emacsclient.rc
src/gdb.ini
/var/
src/fingerprint.c

90
.gitlab-ci.yml
View file

@ -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 <tzz@lifelogs.com>
# 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'

32
admin/notes/elpa
View file

@ -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 <pkgname> into the packages
directory with:
make packages/<pkgname>
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.

38
admin/nt/dist-build/README-scripts
View file

@ -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.

49
admin/nt/dist-build/README-windows-binaries
View file

@ -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

202
admin/nt/dist-build/build-dep-zips.py
View file

@ -17,7 +17,6 @@
## You should have received a copy of the GNU General Public License
## along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
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 ):

90
admin/nt/dist-build/build-zips.sh
View file

@ -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

31
admin/nt/dist-build/emacs.nsi
View file

@ -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

21
configure.ac
View file

@ -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}

14
doc/lispref/commands.texi
View file

@ -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

5
doc/lispref/control.texi
View file

@ -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)

1
doc/lispref/elisp.texi
View file

@ -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

5
doc/lispref/errors.texi
View file

@ -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.

33
doc/lispref/minibuf.texi
View file

@ -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

2
doc/lispref/modes.texi
View file

@ -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")

28
doc/misc/tramp.texi
View file

@ -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.

2
doc/misc/trampver.texi
View file

@ -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

2
etc/HELLO
View file

@ -30,6 +30,8 @@ Bengali (বাংলা) নমস্কার
Braille ⠓⠑⠇⠇⠕
Burmese (မြန်မာ) မင်္ဂလာပါ
C printf ("Hello, world!\n");
Cham (ꨌꩌ) ꨦꨤꩌ ꨦꨰꨁ
Cherokee (ᏣᎳᎩ ᎦᏬᏂᎯᏍᏗ) ᎣᏏᏲ / ᏏᏲ
Comanche /kəˈmæntʃiː/ Haa marʉ́awe

24
etc/NEWS
View file

@ -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.

5
etc/PROBLEMS
View file

@ -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

10
lisp/calc/calc.el
View file

@ -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"))

24
lisp/cedet/ede/auto.el
View file

@ -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.

26
lisp/comint.el
View file

@ -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)

1
lisp/cus-face.el
View file

@ -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)

11
lisp/custom.el
View file

@ -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

2
lisp/dired-x.el
View file

@ -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.

319
lisp/emacs-lisp/byte-opt.el
View file

@ -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 <x>) --> <x>.
(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 <x>) --> <x>.
(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."

135
lisp/emacs-lisp/eieio-base.el
View file

@ -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)

4
lisp/emacs-lisp/ert.el
View file

@ -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)

46
lisp/emacs-lisp/pcase.el
View file

@ -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."

7
lisp/emacs-lisp/radix-tree.el
View file

@ -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.

56
lisp/erc/erc-services.el
View file

@ -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:

2
lisp/foldout.el
View file

@ -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)

8
lisp/frame.el
View file

@ -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

11
lisp/gnus/gnus-search.el
View file

@ -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

3
lisp/gnus/nnmaildir.el
View file

@ -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)

2
lisp/info.el
View file

@ -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)))

61
lisp/isearch.el
View file

@ -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

7
lisp/language/cham.el
View file

@ -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)

6
lisp/mail/rmailsum.el
View file

@ -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.")

4
lisp/mouse-drag.el
View file

@ -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)))

2
lisp/mouse.el
View file

@ -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))))

2
lisp/net/nsm.el
View file

@ -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)

6
lisp/net/tramp-adb.el
View file

@ -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

17
lisp/net/tramp-sh.el
View file

@ -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

24
lisp/net/tramp.el
View file

@ -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

6
lisp/net/trampver.el
View file

@ -7,7 +7,7 @@
;; Maintainer: Michael Albinus <michael.albinus@gmx.de>
;; 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)))

12
lisp/pixel-scroll.el
View file

@ -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

19
lisp/progmodes/project.el
View file

@ -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))

4
lisp/ruler-mode.el
View file

@ -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)

1
lisp/shell.el
View file

@ -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)

34
lisp/simple.el
View file

@ -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)))))

37
lisp/startup.el
View file

@ -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)

23
lisp/strokes.el
View file

@ -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

78
lisp/subr.el
View file

@ -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!

6
lisp/textmodes/artist.el
View file

@ -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

7
lisp/textmodes/reftex-vars.el
View file

@ -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.

5
lisp/vc/ediff-wind.el
View file

@ -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))))

2
lisp/vc/ediff.el
View file

@ -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)

14
lisp/wid-edit.el
View file

@ -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))

8
lisp/window.el
View file

@ -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

3
src/data.c
View file

@ -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");

16
src/dispnew.c
View file

@ -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;
}

85
src/fns.c
View file

@ -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);
}

59
src/frame.c
View file

@ -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;
}

35
src/keymap.c
View file

@ -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);

1
src/lisp.h
View file

@ -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. */

29
src/lread.c
View file

@ -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 <F7> and <RIGHT>, 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);

29
src/minibuf.c
View file

@ -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);

94
src/process.c
View file

@ -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.

4
src/term.c
View file

@ -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++;

2
src/termhooks.h
View file

@ -366,9 +366,7 @@ enum {
#ifdef HAVE_GPM
#include <gpm.h>
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;

16
src/xdisp.c
View file

@ -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)
{

6
test/Makefile.in
View file

@ -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)

6
test/README
View file

@ -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 <filename> -or- make <filename>.log
Run all tests declared in <filename>.el. This includes expensive
tests. In the former case the output is shown on the terminal, in

5
test/file-organization.org
View file

@ -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~.

71
test/infra/Dockerfile.emba Normal file
View file

@ -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 <https://www.gnu.org/licenses/>.
# 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 <tzz@lifelogs.com>
# 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

217
test/infra/gitlab-ci.yml Normal file
View file

@ -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 <https://www.gnu.org/licenses/>.
# 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 <tzz@lifelogs.com>
# 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

38
test/lisp/calendar/lunar-tests.el
View file

@ -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

4
test/lisp/calendar/solar-tests.el
View file

@ -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)))

6
test/lisp/cedet/semantic-utest.el
View file

@ -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

1
test/lisp/cedet/srecode-utest-getset.el
View file

@ -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))

6
test/lisp/cedet/srecode-utest-template.el
View file

@ -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)))

4
test/lisp/emacs-lisp/bytecomp-tests.el
View file

@ -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)

4
test/lisp/emacs-lisp/pcase-tests.el
View file

@ -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)

4
test/lisp/emacs-lisp/timer-tests.el
View file

@ -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

4
test/lisp/help-tests.el
View file

@ -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 "\\<minibuffer-local-must-match-map>\\[abort-recursive-edit]" "C-g")
(test "\\<minibuffer-local-must-match-map>\\[abort-recursive-edit]" "C-]")
(test "\\<emacs-lisp-mode-map>\\[eval-defun]" "C-M-x")))
(defvar help-tests-remap-map

8
test/lisp/net/nsm-tests.el
View file

@ -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])

140
test/lisp/net/tramp-tests.el
View file

@ -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))))))

14
test/lisp/progmodes/elisp-mode-tests.el
View file

@ -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

14
test/lisp/progmodes/tcl-tests.el
View file

@ -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

11
test/lisp/subr-tests.el
View file

@ -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.

20
test/src/decompress-tests.el
View file

@ -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)

58
test/src/fns-tests.el
View file

@ -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)))))

6
test/src/lread-tests.el
View file

@ -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

15
test/src/minibuf-tests.el
View file

@ -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

26
test/src/process-tests.el
View file

@ -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

30
test/src/xdisp-tests.el
View file

@ -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

14
test/src/xml-tests.el
View file

@ -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