[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
feature/pgtk bebc657: Merge branch 'master' of git.sv.gnu.org:/srv/git/e
|
From: |
Yuuki Harano |
|
Subject: |
feature/pgtk bebc657: Merge branch 'master' of git.sv.gnu.org:/srv/git/emacs into feature/pgtk |
|
Date: |
Wed, 20 Jan 2021 07:49:08 -0500 (EST) |
branch: feature/pgtk
commit bebc657aad7c9b448a8e0cafd9d09d7774097975
Merge: 7326982 8b33b76
Author: Yuuki Harano <masm+github@masm11.me>
Commit: Yuuki Harano <masm+github@masm11.me>
Merge branch 'master' of git.sv.gnu.org:/srv/git/emacs into feature/pgtk
---
.gitlab-ci.yml | 90 +----
admin/notes/elpa | 32 +-
admin/nt/dist-build/README-scripts | 38 +-
admin/nt/dist-build/README-windows-binaries | 49 +--
admin/nt/dist-build/build-dep-zips.py | 188 +++++-----
admin/nt/dist-build/build-zips.sh | 90 ++---
admin/nt/dist-build/emacs.nsi | 31 +-
configure.ac | 21 +-
doc/emacs/mini.texi | 10 +-
doc/emacs/trouble.texi | 7 +
doc/lispref/commands.texi | 14 +-
doc/lispref/control.texi | 5 +-
doc/lispref/display.texi | 17 +-
doc/lispref/elisp.texi | 1 +
doc/lispref/errors.texi | 5 +
doc/lispref/keymaps.texi | 5 +-
doc/lispref/markers.texi | 4 +-
doc/lispref/minibuf.texi | 57 ++-
doc/lispref/modes.texi | 2 +-
doc/lispref/processes.texi | 27 +-
doc/misc/auth.texi | 12 +
doc/misc/gnus.texi | 2 +-
doc/misc/tramp.texi | 36 +-
doc/misc/trampver.texi | 2 +-
etc/HELLO | 10 +-
etc/NEWS | 72 +++-
etc/NEWS.19 | 2 +
etc/PROBLEMS | 5 +
etc/w32-feature.el | 35 +-
lisp/calc/calc-embed.el | 2 +
lisp/calc/calc-lang.el | 2 +-
lisp/calc/calc.el | 12 +-
lisp/calc/calccomp.el | 247 ++++++++-----
lisp/cedet/ede/auto.el | 24 +-
lisp/cedet/ede/base.el | 5 +-
lisp/cedet/ede/proj.el | 2 +-
lisp/comint.el | 32 +-
lisp/cus-face.el | 1 +
lisp/cus-start.el | 8 +-
lisp/custom.el | 23 +-
lisp/emacs-lisp/byte-opt.el | 351 ++++++++++---------
lisp/emacs-lisp/eieio-base.el | 135 ++++----
lisp/emacs-lisp/ert.el | 4 +-
lisp/emacs-lisp/lisp-mode.el | 6 +-
lisp/emacs-lisp/pcase.el | 46 ++-
lisp/emacs-lisp/radix-tree.el | 7 +-
lisp/emacs-lisp/shortdoc.el | 13 +-
lisp/epa.el | 4 +-
lisp/erc/erc-services.el | 56 ++-
lisp/facemenu.el | 11 +-
lisp/foldout.el | 2 +-
lisp/frame.el | 24 +-
lisp/gnus/gnus-agent.el | 383 +++++++--------------
lisp/gnus/gnus-async.el | 9 +-
lisp/gnus/gnus-cache.el | 126 ++-----
lisp/gnus/gnus-cloud.el | 16 +-
lisp/gnus/gnus-search.el | 11 +-
lisp/gnus/gnus-sum.el | 65 +++-
lisp/gnus/gnus.el | 9 +-
lisp/gnus/message.el | 45 +--
lisp/gnus/mm-decode.el | 19 +-
lisp/gnus/nnmaildir.el | 3 +-
lisp/gnus/nntp.el | 2 +-
lisp/gnus/nnvirtual.el | 172 +++------
lisp/help-fns.el | 7 +-
lisp/help-mode.el | 3 +-
lisp/ibuf-ext.el | 16 +-
lisp/ibuffer.el | 9 +-
lisp/info.el | 2 +-
lisp/international/fontset.el | 1 +
lisp/isearch.el | 91 ++---
lisp/language/cham.el | 8 +-
lisp/leim/quail/cham.el | 116 +++++++
lisp/mail/rmailedit.el | 9 +-
lisp/mail/rmailsum.el | 6 +-
lisp/minibuffer.el | 8 +-
lisp/mouse-drag.el | 4 +-
lisp/mouse.el | 2 +-
lisp/net/nsm.el | 2 +-
lisp/net/tramp-adb.el | 6 +-
lisp/net/tramp-sh.el | 170 ++++-----
lisp/net/tramp.el | 24 +-
lisp/net/trampver.el | 6 +-
lisp/nxml/nxml-mode.el | 30 +-
lisp/obsolete/nnir.el | 1 -
lisp/pixel-scroll.el | 12 +-
lisp/progmodes/perl-mode.el | 11 +-
lisp/progmodes/project.el | 22 +-
lisp/progmodes/prolog.el | 6 +-
lisp/progmodes/python.el | 6 +-
lisp/progmodes/sh-script.el | 2 +-
lisp/progmodes/xref.el | 18 +-
lisp/replace.el | 41 +--
lisp/ruler-mode.el | 4 +-
lisp/shell.el | 1 +
lisp/simple.el | 34 +-
lisp/startup.el | 44 +--
lisp/strokes.el | 23 +-
lisp/subr.el | 82 ++++-
lisp/textmodes/artist.el | 6 +-
lisp/textmodes/fill.el | 11 +-
lisp/textmodes/reftex-vars.el | 7 +-
lisp/vc/ediff-wind.el | 5 +-
lisp/vc/ediff.el | 2 +-
lisp/vc/vc.el | 42 ++-
lisp/version.el | 6 +-
lisp/wid-edit.el | 33 +-
lisp/window.el | 13 +-
src/buffer.c | 2 +-
src/callproc.c | 2 +-
src/data.c | 3 +
src/dispnew.c | 16 +-
src/emacs.c | 4 +-
src/eval.c | 26 ++
src/fns.c | 85 +++++
src/frame.c | 59 ++--
src/keymap.c | 35 --
src/lisp.h | 4 +
src/lread.c | 29 +-
src/minibuf.c | 211 ++++++++++--
src/nsselect.m | 15 +-
src/nsterm.h | 9 +
src/nsterm.m | 21 +-
src/pdumper.c | 2 +-
src/process.c | 105 +++++-
src/sysdep.c | 217 ++++++++++++
src/term.c | 4 +-
src/termhooks.h | 2 -
src/w32term.c | 3 +-
src/window.c | 5 +-
src/window.h | 4 -
src/xdisp.c | 16 +-
src/xfaces.c | 8 +-
test/Makefile.in | 16 +-
test/README | 9 +-
test/file-organization.org | 21 +-
test/infra/Dockerfile.emba | 71 ++++
test/infra/gitlab-ci.yml | 243 +++++++++++++
test/lisp/calendar/lunar-tests.el | 38 +-
test/lisp/calendar/solar-tests.el | 4 +-
test/lisp/cedet/semantic-utest.el | 6 +-
test/lisp/cedet/srecode-utest-getset.el | 1 -
test/lisp/cedet/srecode-utest-template.el | 6 +-
test/lisp/emacs-lisp/bytecomp-tests.el | 4 +-
test/lisp/emacs-lisp/pcase-tests.el | 4 +
test/lisp/emacs-lisp/timer-tests.el | 4 +-
.../gnus/mm-decode-resources/win1252-multipart.bin | 44 +++
test/lisp/gnus/mm-decode-tests.el | 35 +-
test/lisp/help-mode-tests.el | 21 +-
test/lisp/help-tests.el | 4 +-
test/lisp/net/nsm-tests.el | 8 +-
test/lisp/net/socks-tests.el | 103 ++++++
test/lisp/net/tramp-tests.el | 219 +++++++-----
test/lisp/progmodes/elisp-mode-tests.el | 14 +-
test/lisp/progmodes/tcl-tests.el | 14 +-
test/lisp/replace-tests.el | 13 +
test/lisp/subr-tests.el | 11 +
test/lisp/textmodes/fill-tests.el | 31 ++
test/lisp/time-stamp-tests.el | 127 ++++---
test/lisp/wid-edit-tests.el | 11 +
test/src/decompress-tests.el | 20 +-
test/src/fns-tests.el | 58 ++++
test/src/lread-tests.el | 6 +
test/src/minibuf-tests.el | 15 +
test/src/process-tests.el | 141 +++++++-
test/src/xdisp-tests.el | 27 ++
test/src/xml-tests.el | 14 +-
167 files changed, 3889 insertions(+), 2059 deletions(-)
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml
index bc18137..3138f41 100644
--- a/.gitlab-ci.yml
+++ b/.gitlab-ci.yml
@@ -1,4 +1,4 @@
-# Copyright (C) 2017-2021 Free Software Foundation, Inc.
+# Copyright (C) 2021 Free Software Foundation, Inc.
#
# This file is part of GNU Emacs.
#
@@ -24,89 +24,5 @@
# Maintainer: Ted Zlatanov <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'
diff --git a/admin/notes/elpa b/admin/notes/elpa
index ea6c132..1e9e7a9 100644
--- a/admin/notes/elpa
+++ b/admin/notes/elpa
@@ -5,17 +5,31 @@ repository named "elpa", hosted on Savannah. To check it out:
git clone git://git.sv.gnu.org/emacs/elpa
cd elpa
- git remote set-url --push origin git+ssh://git.sv.gnu.org/srv/git/emacs/elpa
- [create task branch for edits, etc.]
+ make setup
-Changes to this branch propagate to elpa.gnu.org via a "deployment" script run
-daily. This script (which is kept in elpa/admin/update-archive.sh) generates
-the content visible at https://elpa.gnu.org/packages.
+That leaves the elpa/packages directory empty; you must check out the
+ones you want.
-A new package is released as soon as the "version number" of that package is
-changed. So you can use 'elpa' to work on a package without fear of releasing
-those changes prematurely. And once the code is ready, just bump the
-version number to make a new release of the package.
+If you wish to check out all the packages into the packages directory,
+you can run the command:
+
+ make worktrees
+
+You can check out a specific package <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.
diff --git a/admin/nt/dist-build/README-scripts
b/admin/nt/dist-build/README-scripts
index 4c3554e..f27bcd3 100644
--- a/admin/nt/dist-build/README-scripts
+++ b/admin/nt/dist-build/README-scripts
@@ -33,26 +33,21 @@ build-zips.sh file will create this for you.
A location for the dependencies. This needs to contain two zip files
with the dependencies. build-dep-zips.py will create these files for you.
-~/emacs-build/deps/libXpm/i686
-~/emacs-build/deps/libXpm/x86_64
+~/emacs-build/deps/libXpm
Contain libXpm-noX4.dll. This file is used to load images for the
splash screen, menu items and so on. Emacs runs without it, but looks
-horrible. The x86_64 comes from msys2, while the i686 comes from
-ezwinports because it itself has no dependencies. These have to be
-placed manually (but probably never need updating).
+horrible. The files came original from msys2, and contains no
+dependencies. It has to be placed manually (but probably never
+need updating).
-
-~/emacs-build/build/$version/i686
-~/emacs-build/build/$version/x86_64
+~/emacs-build/build/$version
We build Emacs out-of-source here. This directory is created by
build-zips.sh. This directory can be freely deleted after zips have
been created
-
-~/emacs-build/install/$version/i686
-~/emacs-build/install/$version/x86_64
+~/emacs-build/install/$version
We install Emacs here. This directory is created by build-zips.sh.
This directory can and *should* be deleted after zips have been
@@ -79,9 +74,9 @@ To do this:
Update msys to the latest version with `pacman -Syu`.
-Then run build-dep-zips.py, in the ~/emacs-build/deps directory. Three
-zips will be created, containing the 64bit and 32bit dependencies, as
-well as the source for these.
+Then run build-dep-zips.py, in the ~/emacs-build/deps directory. Two
+zips will be created, containing the dependencies, as well as the
+source for these.
For emacs release or pre-test version:
@@ -105,12 +100,12 @@ To do this:
Update msys to the latest version with `pacman -Syu`.
-Then run build-dep-zips.py, in ~/emacs-build/deps directory. Three
-zips will be created, containing the 64bit and 32bit dependencies, as
-well as the source for these. These deps files contain the date of
-creation in their name. The deps file can be reused as desired, or a
-new version created. Where multiple deps files exist, the most
-recent will be used.
+Then run build-dep-zips.py, in ~/emacs-build/deps directory. Two zips
+will be created, containing the dependencies, as well as the source
+for these. These deps files contain the date of creation in their
+name. The deps file can be reused as desired, or a new version
+created. Where multiple deps files exist, the most recent will be
+used.
Now, run `build-zips.sh -s` to build a snapshot release.
@@ -134,4 +129,5 @@ For snapshots from another branch
Snapshots can be build from any other branch. There is rarely a need
to do this, except where some significant, wide-ranging feature is
being added on a feature branch. In this case, the branch can be
-given using `build-zips.sh -b pdumper -s` for example.
+given using `build-zips.sh -b pdumper -s` for example. Any "/"
+characters in the branch title are replaced.
diff --git a/admin/nt/dist-build/README-windows-binaries
b/admin/nt/dist-build/README-windows-binaries
index 001bdd7..b6f6e55 100644
--- a/admin/nt/dist-build/README-windows-binaries
+++ b/admin/nt/dist-build/README-windows-binaries
@@ -4,7 +4,7 @@ See the end of the file for license conditions.
Precompiled Distributions of
Emacs for Windows
- Jan 1, 2020
+ Jan 14, 2021
This directory contains precompiled distributions for GNU Emacs on
Windows
@@ -25,51 +25,33 @@ old binaries.
Windows Binaries
================
-Currently, we provide six different binary packages for Emacs, which
+Currently, we provide three different binary packages for Emacs, which
are:
-emacs-$VERSION-x86_64-installer.exe
+emacs-$VERSION-installer.exe
-Contains a 64-bit build of Emacs with dependencies as an installer
+Contains Emacs with dependencies as an installer
package. Mostly, this is the best one to install.
-emacs-$VERSION-x86_64.zip
+emacs-$VERSION.zip
-Contains a 64-bit build of Emacs with dependencies. This contains the
-same files as the installer but as a zip file which some users may
-prefer.
+Contains Emacs with dependencies. This contains the same files as the
+installer but as a zip file which some users may prefer.
-emacs-$VERSION-x86_64-no-deps.zip
+emacs-$VERSION-no-deps.zip
-Contains a 64-bit build of Emacs without any dependencies. This may be
-useful if you wish to install where the dependencies are already
-available, or if you want the small possible Emacs.
-
-emacs-$VERSION-i686-installer.exe
-
-Contains a 32-bit build of Emacs with dependencies as an installer
-package. This is useful for running on a 32-bit machine.
-
-emacs-$VERSION-i686.zip
-
-Contains a 32-bit build of Emacs with dependencies.
-
-emacs-$VERSION-i686-no-deps.zip
-
-Contains a 32-bit build of Emacs without dependencies
+Contains Emacs without any dependencies. This may be useful if you
+wish to install where the dependencies are already available, or if
+you want the small possible Emacs.
In addition, we provide the following files which will not be useful
for most end-users.
-emacs-$VERSION-x86_64-deps.zip
+emacs-$VERSION-deps.zip
The dependencies. Unzipping this file on top of
-emacs-$VERSION-x86_64-no-deps.zip should result in the same install as
-emacs-$VERSION-x86_64.zip.
-
-emacs-$VERSION-i686-deps.zip
-
-The 32-bit version of the dependencies.
+emacs-$VERSION-no-deps.zip should result in the same install as
+emacs-$VERSION.zip.
emacs-$VERSION-deps-mingw-w64-src.zip
@@ -85,7 +67,8 @@ Snapshots
We also distribute "snapshots" of Emacs built at points throughout the
development cycle, for those interested in following this cycle. They
-are not recommended for normal users.
+are not recommended for normal users; however, they are useful for
+people who want to report bugs against the current master.
The files follow the same naming convention, but also include a date
(and sometimes information about their branch). The Emacs source at
diff --git a/admin/nt/dist-build/build-dep-zips.py
b/admin/nt/dist-build/build-dep-zips.py
index 47185db..19168e7 100755
--- a/admin/nt/dist-build/build-dep-zips.py
+++ b/admin/nt/dist-build/build-dep-zips.py
@@ -17,7 +17,6 @@
## You should have received a copy of the GNU General Public License
## along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
import argparse
-import multiprocessing as mp
import os
import shutil
import re
@@ -40,21 +39,84 @@ mingw-w64-x86_64-libtiff
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
+
+def check_output_maybe(*args,**kwargs):
+ if(DRY_RUN):
+ print("Calling: {}{}".format(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-x86_64-glib2"]
+SKIP_DEP_PKGS=["mingw-w64-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!
@@ -62,12 +124,6 @@ ARCH_PKGS=[]
SRC_REPO="https://sourceforge.net/projects/msys2/files/REPOS/MINGW/Sources";
-def check_output_maybe(*args,**kwargs):
- if(DRY_RUN):
- print("Calling: {}{}".format(args,kwargs))
- else:
- return check_output(*args,**kwargs)
-
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))
-def gather_source(deps):
+ print("Copying {} from local".format(tarball))
+ shutil.copyfile("../emacs-src-cache/{}".format(tarball),
+ "{}".format(tarball))
- ## Source for gcc-libs is part of gcc
- ## Source for libwinpthread is in libwinpthreads
- ## mpc, termcap, xpm -- has x86_64, and i686 versions
+## Fetch all the source code
+def gather_source(deps):
+
+ if not os.path.exists("emacs-src-cache"):
+ os.mkdir("emacs-src-cache")
- ## 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]
-
- for d in downloads:
- ## Switch names if necessary
- d = MUNGE_SRC_PKGS.get(d,d)
+ ## Switch names if necessary
+ pkg_name = MUNGE_SRC_PKGS.get(pkg_name,pkg_name)
- tarball = "{}-{}.src.tar.gz".format(d,pkg_version)
+ tarball = "{}-{}.src.tar.gz".format(pkg_name,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 @@ parser = argparse.ArgumentParser()
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 @@ parser.add_argument("-l", help="list dependencies only",
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 @@ if args.s:
else:
DATE=""
-if( do_all or args.t ):
- gather_deps(deps,"i686","mingw32")
-
-if( do_all or args.f ):
- gather_deps(deps,"x86_64","mingw64")
+if( do_all):
+ gather_deps()
if( do_all or args.r ):
+ deps=extract_deps()
gather_source(deps)
if( args.c ):
diff --git a/admin/nt/dist-build/build-zips.sh
b/admin/nt/dist-build/build-zips.sh
index 4a9a7b5..7bc6ea6 100755
--- a/admin/nt/dist-build/build-zips.sh
+++ b/admin/nt/dist-build/build-zips.sh
@@ -29,72 +29,62 @@ function git_up {
}
function build_zip {
-
- ARCH=$1
- PKG=$2
- HOST=$3
-
- echo [build] Building Emacs-$VERSION for $ARCH
- if [ $ARCH == "i686" ]
- then
- PATH=/mingw32/bin:$PATH
- MSYSTEM=MINGW32
- fi
+ echo [build] Building Emacs-$VERSION
## Clean the install location because we use it twice
- rm -rf $HOME/emacs-build/install/emacs-$VERSION/$ARCH
- mkdir --parents $HOME/emacs-build/build/emacs-$VERSION/$ARCH
- cd $HOME/emacs-build/build/emacs-$VERSION/$ARCH
+ rm -rf $HOME/emacs-build/install/emacs-$VERSION
+ mkdir --parents $HOME/emacs-build/build/emacs-$VERSION
+ cd $HOME/emacs-build/build/emacs-$VERSION
+
+ ## Do we need this or is it the default?
+ export PKG_CONFIG_PATH=/mingw64/lib/pkgconfig
- export PKG_CONFIG_PATH=$PKG
## Running configure forces a rebuild of the C core which takes
## time that is not always needed, so do not do it unless we have
## to.
if [ ! -f Makefile ] || (($CONFIG))
then
- echo [build] Configuring Emacs $ARCH
+ echo [build] Configuring Emacs
$REPO_DIR/$BRANCH/configure \
--without-dbus \
- --host=$HOST --without-compress-install \
+ --without-compress-install \
$CACHE \
CFLAGS="$CFLAGS"
fi
make -j 4 $INSTALL_TARGET \
- prefix=$HOME/emacs-build/install/emacs-$VERSION/$ARCH
- cd $HOME/emacs-build/install/emacs-$VERSION/$ARCH
- cp $HOME/emacs-build/deps/libXpm/$ARCH/libXpm-noX4.dll bin
- zip -r -9 emacs-$OF_VERSION-$ARCH-no-deps.zip *
- mv emacs-$OF_VERSION-$ARCH-no-deps.zip $HOME/emacs-upload
- rm bin/libXpm-noX4.dll
+ prefix=$HOME/emacs-build/install/emacs-$VERSION
+ cd $HOME/emacs-build/install/emacs-$VERSION
+ zip -r -9 emacs-$OF_VERSION-no-deps.zip *
+ mv emacs-$OF_VERSION-no-deps.zip $HOME/emacs-upload
if [ -z $SNAPSHOT ];
then
- DEPS_FILE=$HOME/emacs-build/deps/emacs-$MAJOR_VERSION-$ARCH-deps.zip
+ DEPS_FILE=$HOME/emacs-build/deps/emacs-$MAJOR_VERSION-deps.zip
else
## Pick the most recent snapshot whatever that is
- DEPS_FILE=`ls
$HOME/emacs-build/deps/emacs-$MAJOR_VERSION-*-$ARCH-deps.zip | tail -n 1`
+ DEPS_FILE=`ls $HOME/emacs-build/deps/emacs-$MAJOR_VERSION-*-deps.zip |
tail -n 1`
fi
echo [build] Using $DEPS_FILE
- unzip $DEPS_FILE
+ unzip -d bin $DEPS_FILE
- zip -r -9 emacs-$OF_VERSION-$ARCH.zip *
- mv emacs-$OF_VERSION-$ARCH.zip ~/emacs-upload
+ zip -r -9 emacs-$OF_VERSION.zip *
+ mv emacs-$OF_VERSION.zip ~/emacs-upload
}
function build_installer {
- ARCH=$1
- cd $HOME/emacs-build/install/emacs-$VERSION
+ cd $HOME/emacs-build/install/
echo [build] Calling makensis in `pwd`
cp $REPO_DIR/$BRANCH/admin/nt/dist-build/emacs.nsi .
makensis -v4 \
- -DARCH=$ARCH -DEMACS_VERSION=$ACTUAL_VERSION \
+ -DEMACS_VERSION=$ACTUAL_VERSION \
+ -DVERSION_BRANCH=$VERSION \
-DOUT_VERSION=$OF_VERSION emacs.nsi
rm emacs.nsi
- mv emacs-$OF_VERSION-$ARCH-installer.exe ~/emacs-upload
+ mv emacs-$OF_VERSION-installer.exe ~/emacs-upload
}
set -o errexit
@@ -103,7 +93,6 @@ SNAPSHOT=
CACHE=
BUILD=1
-BUILD_32=1
BUILD_64=1
GIT_UP=0
CONFIG=1
@@ -114,19 +103,8 @@ INSTALL_TARGET="install-strip"
REPO_DIR=$HOME/emacs-build/git/
-while getopts "36gb:hnsiV:" opt; do
+while getopts "gb:hnsiV:" opt; do
case $opt in
- 3)
- BUILD_32=1
- BUILD_64=0
- GIT_UP=0
- ;;
- 6)
- BUILD_32=0
- BUILD_64=1
- GIT_UP=0
- ;;
-
g)
BUILD_32=0
BUILD_64=0
@@ -152,10 +130,11 @@ while getopts "36gb:hnsiV:" opt; do
;;
h)
echo "build-zips.sh"
- echo " -3 32 bit build only"
- echo " -6 64 bit build only"
+ echo " -b args -- build args branch"
echo " -g git update and worktree only"
echo " -i build installer only"
+ echo " -n do not configure"
+ echo " -s snaphot build"
exit 0
;;
\?)
@@ -208,7 +187,7 @@ then
else
BRANCH=$REQUIRED_BRANCH
echo [build] Building from Branch $BRANCH
- VERSION=$VERSION-$BRANCH
+ VERSION=$VERSION-${BRANCH/\//_}
OF_VERSION="$VERSION-`date +%Y-%m-%d`"
## Use snapshot dependencies
SNAPSHOT=1
@@ -225,18 +204,7 @@ if (($BUILD_64))
then
if (($BUILD))
then
- build_zip x86_64 /mingw64/lib/pkgconfig x86_64-w64-mingw32
- 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
+ build_zip
fi
- build_installer i686
+ build_installer
fi
diff --git a/admin/nt/dist-build/emacs.nsi b/admin/nt/dist-build/emacs.nsi
index dce8f3d..557bb10 100644
--- a/admin/nt/dist-build/emacs.nsi
+++ b/admin/nt/dist-build/emacs.nsi
@@ -2,7 +2,7 @@
!include LogicLib.nsh
!include x64.nsh
-Outfile "emacs-${OUT_VERSION}-${ARCH}-installer.exe"
+Outfile "emacs-${OUT_VERSION}-installer.exe"
SetCompressor /solid lzma
@@ -14,15 +14,15 @@ Var StartMenuFolder
!define MUI_WELCOMEPAGE_TITLE_3LINES
!define MUI_WELCOMEPAGE_TEXT "Welcome to Emacs -- the editor of a lifetime."
-!define MUI_WELCOMEFINISHPAGE_BITMAP
"${ARCH}\share\emacs\${EMACS_VERSION}\etc\images\splash.bmp"
-!define MUI_ICON
"${ARCH}\share\emacs\${EMACS_VERSION}\etc\images\icons\hicolor\scalable\apps\emacs.ico"
-!define MUI_UNICON
"${ARCH}\share\emacs\${EMACS_VERSION}\etc\images\icons\hicolor\scalable\apps\emacs.ico"
+!define MUI_WELCOMEFINISHPAGE_BITMAP
"emacs-${VERSION_BRANCH}\share\emacs\${EMACS_VERSION}\etc\images\splash.bmp"
+!define MUI_ICON
"emacs-${VERSION_BRANCH}\share\emacs\${EMACS_VERSION}\etc\images\icons\hicolor\scalable\apps\emacs.ico"
+!define MUI_UNICON
"emacs-${VERSION_BRANCH}\share\emacs\${EMACS_VERSION}\etc\images\icons\hicolor\scalable\apps\emacs.ico"
!insertmacro MUI_PAGE_WELCOME
!define MUI_LICENSEPAGE_TEXT_TOP "The GNU General Public License"
-!insertmacro MUI_PAGE_LICENSE
"${ARCH}\share\emacs\${EMACS_VERSION}\lisp\COPYING"
+!insertmacro MUI_PAGE_LICENSE
"emacs-${VERSION_BRANCH}\share\emacs\${EMACS_VERSION}\lisp\COPYING"
!insertmacro MUI_PAGE_DIRECTORY
!insertmacro MUI_PAGE_INSTFILES
@@ -36,19 +36,7 @@ Var StartMenuFolder
Name Emacs-${EMACS_VERSION}
function .onInit
- ${If} ${RunningX64}
- ${If} ${ARCH} == "x86_64"
- StrCpy $INSTDIR "$PROGRAMFILES64\Emacs"
- ${Else}
- StrCpy $INSTDIR "$PROGRAMFILES32\Emacs"
- ${Endif}
- ${Else}
- ${If} ${ARCH} == "x86_64"
- Quit
- ${Else}
- StrCpy $INSTDIR "$PROGRAMFILES\Emacs"
- ${Endif}
- ${EndIf}
+ StrCpy $INSTDIR "$PROGRAMFILES64\Emacs"
functionend
@@ -56,7 +44,8 @@ Section
SetOutPath $INSTDIR
- File /r ${ARCH}
+ File /r emacs-${VERSION_BRANCH}
+
# define uninstaller name
WriteUninstaller $INSTDIR\Uninstall.exe
@@ -66,7 +55,7 @@ Section
CreateShortcut "$SMPROGRAMS\$StartMenuFolder\Uninstall.lnk"
"$INSTDIR\Uninstall.exe"
!insertmacro MUI_STARTMENU_WRITE_END
- CreateShortCut "$SMPROGRAMS\$StartMenuFolder\Emacs.lnk"
"$INSTDIR\${ARCH}\bin\runemacs.exe"
+ CreateShortCut "$SMPROGRAMS\$StartMenuFolder\Emacs.lnk"
"$INSTDIR\emacs-${VERSION_BRANCH}\bin\runemacs.exe"
SectionEnd
@@ -78,7 +67,7 @@ Section "Uninstall"
Delete "$INSTDIR\Uninstall.exe"
# now delete installed directory
- RMDir /r "$INSTDIR\${ARCH}"
+ RMDir /r "$INSTDIR"
RMDir "$INSTDIR"
!insertmacro MUI_STARTMENU_GETFOLDER Application $StartMenuFolder
diff --git a/configure.ac b/configure.ac
index 815d3c9..369d4f4 100644
--- a/configure.ac
+++ b/configure.ac
@@ -5736,6 +5736,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}'.
@@ -5750,12 +5756,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 PGTK 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 PGTK 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} ;;
@@ -5792,11 +5800,6 @@ done
AC_DEFINE_UNQUOTED(EMACS_CONFIG_FEATURES, "${emacs_config_features}",
[Summary of some of the main features enabled by configure.])
-if test -z "$GMP_H"; then
- HAVE_GMP=yes
-else
- HAVE_GMP=no
-fi
AS_ECHO([" Does Emacs use -lXaw3d?
${HAVE_XAW3D}
Does Emacs use -lXpm? ${HAVE_XPM}
Does Emacs use -ljpeg? ${HAVE_JPEG}
diff --git a/doc/emacs/mini.texi b/doc/emacs/mini.texi
index c7c8fb3..f81e64b 100644
--- a/doc/emacs/mini.texi
+++ b/doc/emacs/mini.texi
@@ -76,9 +76,13 @@ default, the active minibuffer moves to this new frame. If
you set
the user option @code{minibuffer-follows-selected-frame} to
@code{nil}, then the minibuffer stays in the frame where you opened
it, and you must switch back to that frame in order to complete (or
-abort) the current command. Note that the effect of the command, when
-you finally finish using the minibuffer, always takes place in the
-frame where you first opened it.
+abort) the current command. If you set that option to a value which
+is neither @code{nil} nor @code{t}, the minibuffer moves frame only
+after a recursive minibuffer has been opened in the current command
+(@pxref{Recursive Mini,,, elisp}). This option is mainly to retain
+(approximately) the behavior prior to Emacs 28.1. Note that the
+effect of the command, when you finally finish using the minibuffer,
+always takes place in the frame where you first opened it.
@node Minibuffer File
@section Minibuffers for File Names
diff --git a/doc/emacs/trouble.texi b/doc/emacs/trouble.texi
index 4da3d4a..9a63881 100644
--- a/doc/emacs/trouble.texi
+++ b/doc/emacs/trouble.texi
@@ -57,6 +57,13 @@ incremental search, @kbd{C-g} behaves specially; it may take
two
successive @kbd{C-g} characters to get out of a search.
@xref{Incremental Search}, for details.
+ If you type @kbd{C-g} in a minibuffer, this quits the command that
+opened that minibuffer, closing it. If that minibuffer is not the
+most recently opened one (which can happen when
+@code{minibuffer-follows-selected-frame} is @code{nil} (@pxref{Basic
+Minibuffer})), @kbd{C-g} also closes the more recently opened ones,
+quitting their associated commands, after asking you for confirmation.
+
On MS-DOS, the character @kbd{C-@key{Break}} serves as a quit character
like @kbd{C-g}. The reason is that it is not feasible, on MS-DOS, to
recognize @kbd{C-g} while a command is running, between interactions
diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi
index 6c68f70..3a2c7d0 100644
--- a/doc/lispref/commands.texi
+++ b/doc/lispref/commands.texi
@@ -2696,9 +2696,11 @@ from the terminal---not counting those generated by
keyboard macros.
@code{read-event}, @code{read-char}, and @code{read-char-exclusive} do
not perform the translations described in @ref{Translation Keymaps}.
If you wish to read a single key taking these translations into
-account, use the function @code{read-key}:
+account (for example, to read @ref{Function Keys} in a terminal or
+@ref{Mouse Events} from @code{xterm-mouse-mode}), use the function
+@code{read-key}:
-@defun read-key &optional prompt
+@defun read-key &optional prompt disable-fallbacks
This function reads a single key. It is intermediate between
@code{read-key-sequence} and @code{read-event}. Unlike the former, it
reads a single key, not a key sequence. Unlike the latter, it does
@@ -2708,6 +2710,14 @@ and @code{key-translation-map} (@pxref{Translation
Keymaps}).
The argument @var{prompt} is either a string to be displayed in the
echo area as a prompt, or @code{nil}, meaning not to display a prompt.
+
+If argument @var{disable-fallbacks} is non-@code{nil} then the usual
+fallback logic for unbound keys in @code{read-key-sequence} is not
+applied. This means that mouse button-down and multi-click events
+will not be discarded and @code{local-function-key-map} and
+@code{key-translation-map} will not get applied. If @code{nil} or
+unspecified, the only fallback disabled is downcasing of the last
+event.
@end defun
@defun read-char-choice prompt chars &optional inhibit-quit
diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi
index 55bcddb..80e9eb7 100644
--- a/doc/lispref/control.texi
+++ b/doc/lispref/control.texi
@@ -557,8 +557,9 @@ Likewise, it makes no sense to bind keyword symbols
@item (pred @var{function})
Matches if the predicate @var{function} returns non-@code{nil}
-when called on @var{expval}.
-the predicate @var{function} can have one of the following forms:
+when called on @var{expval}. The test can be negated with the syntax
+@code{(pred (not @var{function}))}.
+The predicate @var{function} can have one of the following forms:
@table @asis
@item function name (a symbol)
diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi
index b149a66..93e935c 100644
--- a/doc/lispref/display.texi
+++ b/doc/lispref/display.texi
@@ -2485,15 +2485,16 @@ avoiding any increase in the character height or width.
For simplification
the width could be specified with only a single number @var{n} instead
of a list, such case is equivalent to @code{((abs @var{n}) . @var{n})}.
-The value @var{color} specifies the color to draw with. The default is
-the foreground color of the face for simple boxes, and the background
-color of the face for 3D boxes.
-
The value @var{style} specifies whether to draw a 3D box. If it is
-@code{released-button}, the box looks like a 3D button that is not being
-pressed. If it is @code{pressed-button}, the box looks like a 3D button
-that is being pressed. If it is @code{nil} or omitted, a plain 2D box
-is used.
+@code{released-button}, the box looks like a 3D button that is not
+being pressed. If it is @code{pressed-button}, the box looks like a
+3D button that is being pressed. If it is @code{nil},
+@code{flat-button} or omitted, a plain 2D box is used.
+
+The value @var{color} specifies the color to draw with. The default
+is the background color of the face for 3D boxes and
+@code{flat-button}, and the foreground color of the face for other
+boxes.
@end table
@item :inverse-video
diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi
index fa548b5..12255d1 100644
--- a/doc/lispref/elisp.texi
+++ b/doc/lispref/elisp.texi
@@ -739,6 +739,7 @@ Minibuffers
* Minibuffer Windows:: Operating on the special minibuffer windows.
* Minibuffer Contents:: How such commands access the minibuffer text.
* Recursive Mini:: Whether recursive entry to minibuffer is allowed.
+* Inhibiting Interaction:: Running Emacs when no interaction is possible.
* Minibuffer Misc:: Various customization hooks and variables.
Completion
diff --git a/doc/lispref/errors.texi b/doc/lispref/errors.texi
index 9ec1271..fb393b9 100644
--- a/doc/lispref/errors.texi
+++ b/doc/lispref/errors.texi
@@ -230,6 +230,11 @@ The message is @samp{Wrong type argument}. @xref{Type
Predicates}.
@item unknown-image-type
The message is @samp{Cannot determine image type}. @xref{Images}.
+
+@item inhibited-interaction
+The message is @samp{User interaction while inhibited}. This error is
+signalled when @code{inhibit-interaction} is non-@code{nil} and a user
+interaction function (like @code{read-from-minibuffer}) is called.
@end table
@ignore The following seem to be unused now.
diff --git a/doc/lispref/keymaps.texi b/doc/lispref/keymaps.texi
index 37bab7e..55d179b 100644
--- a/doc/lispref/keymaps.texi
+++ b/doc/lispref/keymaps.texi
@@ -2852,9 +2852,8 @@ Here is how to insert an item called @samp{Work} in the
@samp{Signals}
menu of Shell mode, after the item @code{break}:
@example
-(define-key-after
- (lookup-key shell-mode-map [menu-bar signals])
- [work] '("Work" . work-command) 'break)
+(define-key-after shell-mode-map [menu-bar signals work]
+ '("Work" . work-command) 'break)
@end example
@end defun
diff --git a/doc/lispref/markers.texi b/doc/lispref/markers.texi
index cdd0938..b39373f 100644
--- a/doc/lispref/markers.texi
+++ b/doc/lispref/markers.texi
@@ -560,7 +560,9 @@ deactivate the mark. If the value is @w{@code{(only .
@var{oldval})}},
then @code{transient-mark-mode} is set to the value @var{oldval} after
any subsequent command that moves point and is not shift-translated
(@pxref{Key Sequence Input, shift-translation}), or after any other
-action that would normally deactivate the mark.
+action that would normally deactivate the mark. (Marking a region
+with the mouse will temporarily enable @code{transient-mark-mode} in
+this way.)
@end defopt
@defopt mark-even-if-inactive
diff --git a/doc/lispref/minibuf.texi b/doc/lispref/minibuf.texi
index f0036f0..0ce17ed 100644
--- a/doc/lispref/minibuf.texi
+++ b/doc/lispref/minibuf.texi
@@ -32,6 +32,7 @@ argument.
* Minibuffer Windows:: Operating on the special minibuffer windows.
* Minibuffer Contents:: How such commands access the minibuffer text.
* Recursive Mini:: Whether recursive entry to minibuffer is allowed.
+* Inhibiting Interaction:: Running Emacs when no interaction is possible.
* Minibuffer Misc:: Various customization hooks and variables.
@end menu
@@ -82,10 +83,12 @@ there is an active minibuffer; such a minibuffer is called a
incrementing the number at the end of the name. (The names begin with
a space so that they won't show up in normal buffer lists.) Of
several recursive minibuffers, the innermost (or most recently
-entered) is the active minibuffer. We usually call this @emph{the}
-minibuffer. You can permit or forbid recursive minibuffers by setting
-the variable @code{enable-recursive-minibuffers}, or by putting
-properties of that name on command symbols (@xref{Recursive Mini}.)
+entered) is the @dfn{active minibuffer}--it is the one you can
+terminate by typing @key{RET} (@code{exit-minibuffer}) in. We usually
+call this @emph{the} minibuffer. You can permit or forbid recursive
+minibuffers by setting the variable
+@code{enable-recursive-minibuffers}, or by putting properties of that
+name on command symbols (@xref{Recursive Mini}.)
Like other buffers, a minibuffer uses a local keymap
(@pxref{Keymaps}) to specify special key bindings. The function that
@@ -2380,7 +2383,8 @@ minibuffer.
@deffn Command exit-minibuffer
This command exits the active minibuffer. It is normally bound to
-keys in minibuffer local keymaps.
+keys in minibuffer local keymaps. The command throws an error if the
+current buffer is not the active minibuffer.
@end deffn
@deffn Command self-insert-and-exit
@@ -2594,8 +2598,11 @@ returns zero.
If this variable is non-@code{nil}, you can invoke commands (such as
@code{find-file}) that use minibuffers even while the minibuffer is
active. Such invocation produces a recursive editing level for a new
-minibuffer. The outer-level minibuffer is invisible while you are
-editing the inner one.
+minibuffer. By default, the outer-level minibuffer is invisible while
+you are editing the inner one. If you have
+@code{minibuffer-follows-selected-frame} set to @code{nil}, you can
+have minibuffers visible on several frames at the same time.
+@xref{Basic Minibuffer,,, emacs}.
If this variable is @code{nil}, you cannot invoke minibuffer commands
when the minibuffer is active, not even if you switch to another window
@@ -2611,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
@@ -2623,7 +2662,7 @@ active minibuffer.
@end defun
@defvar minibuffer-setup-hook
-This is a normal hook that is run whenever the minibuffer is entered.
+This is a normal hook that is run whenever a minibuffer is entered.
@xref{Hooks}.
@end defvar
@@ -2641,7 +2680,7 @@ called once, for the outermost use of the minibuffer.
@end defmac
@defvar minibuffer-exit-hook
-This is a normal hook that is run whenever the minibuffer is exited.
+This is a normal hook that is run whenever a minibuffer is exited.
@xref{Hooks}.
@end defvar
diff --git a/doc/lispref/modes.texi b/doc/lispref/modes.texi
index 9d38fe6..abc1254 100644
--- a/doc/lispref/modes.texi
+++ b/doc/lispref/modes.texi
@@ -4241,7 +4241,7 @@ Here is an example of an indentation function:
(`(:elem . basic) sample-indent-basic)
(`(,_ . ",") (smie-rule-separator kind))
(`(:after . ":=") sample-indent-basic)
- (`(:before . ,(or `"begin" `"(" `"@{")))
+ (`(:before . ,(or `"begin" `"(" `"@{"))
(if (smie-rule-hanging-p) (smie-rule-parent)))
(`(:before . "if")
(and (not (smie-rule-bolp)) (smie-rule-prev-p "else")
diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi
index 535cebe..6dedaa3 100644
--- a/doc/lispref/processes.texi
+++ b/doc/lispref/processes.texi
@@ -729,7 +729,9 @@ coding systems (@pxref{Default Coding Systems}). On the
other hand,
it will use @var{query-flag} as its query-on-exit flag (@pxref{Query
Before Exit}). It will be associated with the @var{stderr} buffer
(@pxref{Process Buffers}) and send its output (which is the standard
-error of the main process) there.
+error of the main process) there. To get the process object for the
+standard error process, pass the @var{stderr} buffer to
+@code{get-buffer-process}.
If @var{stderr} is a pipe process, Emacs will use it as standard error
process for the new process.
@@ -1942,6 +1944,29 @@ code:
(while (accept-process-output stderr-process))
@end example
+If you passed a buffer to the @var{stderr} argument of
+@code{make-process}, you still have to wait for the standard error
+process, like so:
+
+@example
+(let* ((stdout (generate-new-buffer "stdout"))
+ (stderr (generate-new-buffer "stderr"))
+ (process (make-process :name "test"
+ :command '("my-program")
+ :buffer stdout
+ :stderr stderr))
+ (stderr-process (get-buffer-process stderr)))
+ (unless (and process stderr-process)
+ (error "Process unexpectedly nil"))
+ (while (accept-process-output process))
+ (while (accept-process-output stderr-process)))
+@end example
+
+@noindent
+Only when both @code{accept-process-output} forms return @code{nil},
+you can be sure that the process has exited and Emacs has read all its
+output.
+
Reading pending standard error from a process running on a remote host
is not possible this way.
diff --git a/doc/misc/auth.texi b/doc/misc/auth.texi
index d810f15..034004d 100644
--- a/doc/misc/auth.texi
+++ b/doc/misc/auth.texi
@@ -107,6 +107,18 @@ The @code{user} is the user name. It's known as
@var{:user} in
@code{auth-source-search} queries. You can also use @code{login} and
@code{account}.
+Matching entries are usually used in the order they appear, so placing
+the most specific entries first in the file is a good idea. For
+instance:
+
+@example
+machine example.com login foobar password geheimnis port smtp
+machine example.com login foobar password hemmelig
+@end example
+
+Here we're using one password for the @code{smtp} service, and a
+different one for all the other services.
+
You can also use this file to specify client certificates to use when
setting up TLS connections. The format is:
diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi
index 797315d..5a79cbc 100644
--- a/doc/misc/gnus.texi
+++ b/doc/misc/gnus.texi
@@ -20195,7 +20195,7 @@ Phu.
For example, to do hierarchical scoring but use a non-server-specific
overall score file, you could use the value
@example
-(list (lambda (group) ("all.SCORE"))
+(list (lambda (group) (list "all.SCORE"))
'gnus-score-find-hierarchical)
@end example
diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi
index 358f6fc..e9ffd6a 100644
--- a/doc/misc/tramp.texi
+++ b/doc/misc/tramp.texi
@@ -443,7 +443,7 @@ are optional, in case of a missing part a default value is
assumed.
The default value for an empty local file name part is the remote
user's home directory. The shortest remote file name is
@file{@trampfn{-,,}}, therefore. The @samp{-} notation for the
-default host is used for syntactical reasons, @ref{Default Host}.
+default method is used for syntactical reasons, @ref{Default Method}.
The @code{method} part describes the connection method used to reach
the remote host, see below.
@@ -1622,6 +1622,7 @@ support this command.
@subsection Tunneling with ssh
+@vindex ProxyCommand@r{, ssh option}
With @command{ssh}, you could use the @option{ProxyCommand} entry in
@file{~/.ssh/config}:
@@ -2056,9 +2057,11 @@ default value is @t{"/data/local/tmp"} for the
@option{adb} method,
@item @t{"direct-async-process"}
When this property is non-@code{nil}, an alternative, more performant
-implementation of @code{make-process} and
-@code{start-file-process} is applied. @ref{Improving performance of
-asynchronous remote processes} for a discussion of constraints.
+implementation of @code{make-process} and @code{start-file-process} is
+applied. The connection method must also be marked with a
+non-@code{nil} @code{tramp-direct-async} parameter in
+@code{tramp-methods}. @ref{Improving performance of asynchronous
+remote processes} for a discussion of constraints.
@item @t{"posix"}
@@ -2214,6 +2217,11 @@ overwrite this, you might apply
This uses also the settings in @code{tramp-sh-extra-args}.
+@vindex RemoteCommand@r{, ssh option}
+@strong{Note}: If you use an @option{ssh}-based method for connection,
+do @emph{not} set the @option{RemoteCommand} option in your
+@command{ssh} configuration, for example to @command{screen}.
+
@subsection Other remote shell setup hints
@cindex remote shell setup
@@ -2361,8 +2369,7 @@ that can identify such questions using
@lisp
@group
(defconst my-tramp-prompt-regexp
- (concat (regexp-opt '("Enter the birth date of your mother:") t)
- "\\s-*")
+ "Enter the birth date of your mother:\\s-*"
"Regular expression matching my login prompt question.")
@end group
@@ -2381,6 +2388,11 @@ that can identify such questions using
@end group
@end lisp
+The regular expressions used in @code{tramp-actions-before-shell} must
+match the end of the connection buffer. Due to performance reasons,
+this search starts at the end of the buffer, and it is limited to 256
+characters backwards.
+
@item Conflicting names for users and variables in @file{.profile}
@@ -3304,6 +3316,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 +3580,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 +4284,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 +4301,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 +4324,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 +4336,8 @@ this @code{nil} setting:
(customize-set-variable 'tramp-use-ssh-controlmaster-options nil)
@end lisp
+@vindex ProxyCommand@r{, ssh option}
+@vindex ProxyJump@r{, ssh option}
This shall also be set to @code{nil} if you use the
@option{ProxyCommand} or @option{ProxyJump} options in your
@command{ssh} configuration.
diff --git a/doc/misc/trampver.texi b/doc/misc/trampver.texi
index 6970c46..827c477 100644
--- a/doc/misc/trampver.texi
+++ b/doc/misc/trampver.texi
@@ -8,7 +8,7 @@
@c In the Tramp GIT, the version numbers are auto-frobbed from
@c tramp.el, and the bug report address is auto-frobbed from
@c configure.ac.
-@set trampver 2.5.0
+@set trampver 2.5.1-pre
@set trampurl https://www.gnu.org/software/tramp/
@set tramp-bug-report-address tramp-devel@@gnu.org
@set emacsver 25.1
diff --git a/etc/HELLO b/etc/HELLO
index dec3a77..0cebb2b 100644
--- a/etc/HELLO
+++ b/etc/HELLO
@@ -30,20 +30,16 @@ Bengali (বাংলা) নমস্কার
Braille ⠓⠑⠇⠇⠕
Burmese (မြန်မာ) မင်္ဂလာပါ
C printf ("Hello, world!\n");
+Cham (ꨌꩌ) ꨦꨤꩌ ꨦꨁꨰ
Cherokee (ᏣᎳᎩ ᎦᏬᏂᎯᏍᏗ) ᎣᏏᏲ / ᏏᏲ
Comanche /kəˈmæntʃiː/ Haa marʉ́awe
-
Cree (ᓀᐦᐃᔭᐍᐏᐣ) ᑕᓂᓯ / ᐙᒋᔮ
-
Czech (čeština) Dobrý den
Danish (dansk) Hej / Goddag / Halløj
Dutch (Nederlands) Hallo / Dag
Efik /ˈɛfɪk/ Mɔkɔm
-
Egyptian Hieroglyphs (𓂋𓏤𓈖𓆎𓅓𓏏𓊖) 𓅓𓊵𓏏𓊪, 𓇍𓇋𓂻𓍘𓇋
-
Emacs emacs --no-splash -f view-hello-file
-
Emoji 👋
English /ˈɪŋɡlɪʃ/ Hello
Esperanto Saluton (Eĥoŝanĝo ĉiuĵaŭde)
@@ -59,7 +55,6 @@ Hebrew (עִבְרִית) שָׁלוֹם
Hungarian (magyar) Szép jó napot!
Hindi (हिंदी) नमस्ते / नमस्कार ।
Inuktitut (ᐃᓄᒃᑎᑐᑦ) ᐊᐃ
-
Italian (italiano) Ciao / Buon giorno
Javanese (ꦧꦱꦗꦮꦶ) console.log("ꦲꦭꦺꦴ");
Kannada (ಕನ್ನಡ) ನಮಸ್ಕಾರ
@@ -67,7 +62,6 @@ Khmer (ភាសាខ្មែរ) ជំរាបសួរ
Lao (ພາສາລາວ) ສະບາຍດີ / ຂໍໃຫ້ໂຊກດີ
Malayalam (മലയാളം) നമസ്കാരം
Maldivian (ދިވެހި) އައްސަލާމު ޢަލައިކުމް / ކިހިނެހް؟
-
Maltese (il-Malti) Bonġu / Saħħa
Mathematics ∀ p ∈ world • hello p □
Mongolian (монгол хэл) Сайн байна уу?
@@ -83,7 +77,6 @@ Swedish (svenska) Hej / Goddag / Hallå
Tamil (தமிழ்) வணக்கம்
Telugu (తెలుగు) నమస్కారం
TaiViet (ꪁꪫꪱꪣ ꪼꪕ) ꪅꪰꪙꫂ ꪨꪮꫂ ꪁꪫꪱ / ꪅꪽ ꪨꪷ ꪁꪫꪱ
-
Thai (ภาษาไทย) สวัสดีครับ / สวัสดีค่ะ
Tibetan (བོད་སྐད་) བཀྲ་ཤིས་བདེ་ལེགས༎
Tigrigna (ትግርኛ) ሰላማት
@@ -97,7 +90,6 @@ Vietnamese (tiếng Việt) Chào bạn
</x-charset><x-charset><param>chinese-gb2312</param>Chinese (中文,普通话,汉语)
你好
</x-charset><x-charset><param>chinese-big5-1</param>Cantonese (粵語,廣東話) 早晨, 你好
</x-charset><x-charset><param>korean-ksc5601</param>Korean (한글) 안녕하세요 /
안녕하십니까
-
</x-charset>
diff --git a/etc/NEWS b/etc/NEWS
index eaaf9bf..7a012b4 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -102,12 +102,13 @@ effect should be negligible in the vast majority of cases
anyway.
By default, when you switch to another frame, an active minibuffer now
moves to the newly selected frame. Nevertheless, the effect of what
you type in the minibuffer happens in the frame where the minibuffer
-was first activated, even if it moved to another frame. An
-alternative behavior is available by customizing
-'minibuffer-follows-selected-frame' to nil. Here, the minibuffer
-stays in the frame where you first opened it, and you must switch back
-to this frame to continue or abort its command. The old, somewhat
-unsystematic behavior, which mixed these two is no longer available.
+was first activated. An alternative behavior is available by
+customizing 'minibuffer-follows-selected-frame' to nil. Here, the
+minibuffer stays in the frame where you first opened it, and you must
+switch back to this frame to continue or abort its command. The old
+behavior, which mixed these two, can be approximated by customizing
+'minibuffer-follows-selected-frame' to a value which is neither nil
+nor t.
+++
** New system for displaying documentation for groups of functions.
@@ -325,6 +326,16 @@ the buffer cycles the whole buffer between "only top-level
headings",
* Changes in Specialized Modes and Packages in Emacs 28.1
+** 'blink-cursor-mode' is now enabled by default regardless of the UI.
+It used to be enabled when Emacs is started in GUI mode but not when started
+in text mode. The cursor still only actually blinks in GUI frames.
+
+** 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
@@ -345,8 +356,16 @@ When emacsclient connects, Emacs will (by default) output
a message
about how to exit the client frame. If 'server-client-instructions'
is set to nil, this message is inhibited.
+** Perl mode
+
+---
+*** New face 'perl-non-scalar-variable'.
+This is used to fontify non-scalar variables.
+
** Python mode
+*** 'python-shell-interpreter' now defaults to python3 on systems with python3.
+
*** 'C-c C-r' can now be used on arbitrary regions.
The command previously extended the start of the region to the start
of the line, but will now actually send the marked region, as
@@ -699,6 +718,13 @@ not.
** Message
+---
+*** Respect 'message-forward-ignored-headers' more.
+Previously, this variable would not be consulted if
+'message-forward-show-mml' was nil. It's now always used, except if
+'message-forward-show-mml' is 'best', and we're forwarding an
+encrypted/signed message.
+
+++
*** Message now supports the OpenPGP header.
To generate these headers, add the new function
@@ -811,6 +837,10 @@ so e.g. like 'C-x 8 [' inserts a left single quotation
mark,
Added a new Mozhi scheme. The inapplicable ITRANS scheme is now
deprecated. Errors in the Inscript method were corrected.
+---
+*** New input method 'cham'.
+There's also a Cham greeting in 'etc/HELLO'.
+
** Ispell
+++
@@ -1333,6 +1363,11 @@ have been renamed to have "proper" public names and
documented
('xref-show-definitions-buffer' and
'xref-show-definitions-buffer-at-bottom').
+*** New command 'xref-quit-and-pop-marker-stack' and a binding for it
+in Xref buffers ('M-,'). This combination is easy to press
+semi-accidentally if the user wants to go back in the middle of
+choosing the exact definition to go to, and this should do TRT.
+
---
*** New value 'project-relative' for 'xref-file-name-display'
If chosen, file names in *xref* buffers will be displayed relative
@@ -1357,6 +1392,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".
@@ -1513,8 +1557,22 @@ 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.
+
+++
-*** 'add-to-ordered-list' can now take a test predicate.
+*** New button face 'flat-button'.
+This is a plain 2D button, but uses the background color instead of
+the foreground color.
+++
*** New predicate functions 'length<', 'length>' and 'length='.
diff --git a/etc/NEWS.19 b/etc/NEWS.19
index 43235e0..f2cef62 100644
--- a/etc/NEWS.19
+++ b/etc/NEWS.19
@@ -2824,6 +2824,8 @@ the text of the region according to the new value.
the fill-column has been exceeded; the function can determine on its
own whether filling (or justification) is necessary.
+**** New helper function 'indent-line-to'
+
** Processes
*** process-tty-name is a new function that returns the name of the
diff --git a/etc/PROBLEMS b/etc/PROBLEMS
index 25e129b..15e34ea 100644
--- a/etc/PROBLEMS
+++ b/etc/PROBLEMS
@@ -746,6 +746,11 @@ versions of gnutls-cli, or use Emacs's built-in gnutls
support.
** Characters are displayed as empty boxes or with wrong font under X.
+*** This may be due to your local fontconfig customization.
+Try removing or moving aside "$XDG_CONFIG_HOME/fontconfig/conf.d" and
+"$XDG_CONFIG_HOME/fontconfig/fonts.conf"
+($XDG_CONFIG_HOME is treated as "~/.config" if not set)
+
*** This can occur when two different versions of FontConfig are used.
For example, XFree86 4.3.0 has one version and Gnome usually comes
with a newer version. Emacs compiled with Gtk+ will then use the
diff --git a/etc/w32-feature.el b/etc/w32-feature.el
index c5f2cd5..364e934 100644
--- a/etc/w32-feature.el
+++ b/etc/w32-feature.el
@@ -25,9 +25,21 @@
;; designed to check whether bundled binary distributions of Emacs on
;; windows are fully functional.
+;; By default is checks whether the features that we are expect to be
+;; available on Emacs for Windows are reported to be available. It
+;; should be possible to run these tests from a distributed version of
+;; Emacs.
+
+;; In addition, it provides a single command
+;; `w32-feature-load-tests'. If the full source repository of Emacs is
+;; available, this will load selected files from the repository which
+;; test these features.
+
;;; Code:
(require 'ert)
+(defvar w32-feature-core-tests nil)
+
(ert-deftest feature-optimization ()
(should
(string-match-p "CFLAGS=-O2" system-configuration-options)))
@@ -41,16 +53,24 @@
(ert-deftest feature-gnutls ()
(should (gnutls-available-p)))
+(add-to-list 'w32-feature-core-tests "lisp/net/gnutls-tests.el")
+
(ert-deftest feature-zlib ()
(should (zlib-available-p)))
+(add-to-list 'w32-feature-core-tests "src/decompress-tests.el")
+
(ert-deftest feature-thread ()
(should (fboundp 'make-thread)))
+(add-to-list 'w32-feature-core-tests "lisp/thread-tests.el")
+
(ert-deftest feature-json ()
(should
(fboundp 'json-serialize)))
+(add-to-list 'w32-feature-core-tests "src/json-tests.el")
+
(ert-deftest feature-gmp ()
(should
(string-match-p "GMP" system-configuration-features)))
@@ -61,9 +81,13 @@
(ert-deftest feature-libxml ()
(should (libxml-available-p)))
+(add-to-list 'w32-feature-core-tests "src/xml-tests.el")
+
(ert-deftest feature-lcms2 ()
(should (lcms2-available-p)))
+(add-to-list 'w32-feature-core-tests "src/lcms-tests.el")
+
(ert-deftest feature-xpm ()
(should (image-type-available-p 'xpm)))
@@ -73,8 +97,7 @@
(ert-deftest feature-png ()
(should (image-type-available-p 'png)))
-(ert-deftest feature-xpm ()
- (should (image-type-available-p 'xpm)))
+(add-to-list 'w32-feature-core-tests "lisp/image-file-tests.el")
(ert-deftest feature-jpeg ()
(should (image-type-available-p 'jpeg)))
@@ -84,4 +107,12 @@
(ert-deftest feature-svg ()
(should (image-type-available-p 'svg)))
+
+(defun w32-feature-load-tests (dir)
+ (interactive "D")
+ (mapc
+ (lambda(f)
+ (load-file (concat dir "test/" f)))
+ w32-feature-core-tests))
+
;;; feature.el ends here
diff --git a/lisp/calc/calc-embed.el b/lisp/calc/calc-embed.el
index ea79bfa..fda0b4b 100644
--- a/lisp/calc/calc-embed.el
+++ b/lisp/calc/calc-embed.el
@@ -651,6 +651,8 @@ The command \\[yank] can retrieve it from there."
(defvar calc-embed-prev-modes)
(defun calc-embedded-set-modes (gmodes modes local-modes &optional temp)
+ (defvar the-language)
+ (defvar the-display-just)
(let ((the-language (calc-embedded-language))
(the-display-just (calc-embedded-justify))
(v gmodes)
diff --git a/lisp/calc/calc-lang.el b/lisp/calc/calc-lang.el
index b4b2d4c..0117f44 100644
--- a/lisp/calc/calc-lang.el
+++ b/lisp/calc/calc-lang.el
@@ -2181,7 +2181,7 @@ order to Calc's."
v math-read-big-baseline))
;; Small radical sign.
- ((and (= other-char ?V)
+ ((and (memq other-char '(?V ?√))
(= (math-read-big-char (1+ math-rb-h1) (1- v)) ?\_))
(setq h (1+ math-rb-h1))
(math-read-big-emptyp math-rb-h1 math-rb-v1 h (1- v) nil t)
diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el
index 68ae468..ec09abb 100644
--- a/lisp/calc/calc.el
+++ b/lisp/calc/calc.el
@@ -1095,15 +1095,7 @@ Used by `calc-user-invocation'.")
(ignore-errors
(define-key calc-digit-map x 'calcDigit-delchar)
(define-key calc-mode-map x 'calc-pop)
- (define-key calc-mode-map
- (if (and (vectorp x) (featurep 'xemacs))
- (if (= (length x) 1)
- (vector (if (consp (aref x 0))
- (cons 'meta (aref x 0))
- (list 'meta (aref x 0))))
- "\e\C-d")
- (vconcat "\e" x))
- 'calc-pop-above)))
+ (define-key calc-mode-map (vconcat "\e" x) 'calc-pop-above)))
(if calc-scan-for-dels
(append (where-is-internal 'delete-forward-char global-map)
'("\C-d"))
@@ -2152,7 +2144,7 @@ the United States."
(let ((w (split-window nil (/ (* (window-width) 2) 3) t)))
(set-window-buffer w calc-trail-buffer)
(and calc-make-windows-dedicated
- (set-window-dedicated-p nil t))))
+ (set-window-dedicated-p w t))))
(calc-wrapper
(setq overlay-arrow-string calc-trail-overlay
overlay-arrow-position calc-trail-pointer)
diff --git a/lisp/calc/calccomp.el b/lisp/calc/calccomp.el
index 07e70ca..5f38ee7 100644
--- a/lisp/calc/calccomp.el
+++ b/lisp/calc/calccomp.el
@@ -138,19 +138,19 @@
(math-format-number (nth 2 aa))))))
(if (= calc-number-radix 10)
c
- (list 'horiz "(" c
- (list 'subscr ")"
- (int-to-string calc-number-radix)))))
+ (list 'subscr (math--comp-round-bracket c)
+ (int-to-string calc-number-radix))))
(math-format-number a)))
(if (not (eq calc-language 'big))
(math-format-number a prec)
(if (memq (car-safe a) '(cplx polar))
(if (math-zerop (nth 2 a))
(math-compose-expr (nth 1 a) prec)
- (list 'horiz "("
- (math-compose-expr (nth 1 a) 0)
- (if (eq (car a) 'cplx) ", " "; ")
- (math-compose-expr (nth 2 a) 0) ")"))
+ (math--comp-round-bracket
+ (list 'horiz
+ (math-compose-expr (nth 1 a) 0)
+ (if (eq (car a) 'cplx) ", " "; ")
+ (math-compose-expr (nth 2 a) 0))))
(if (or (= calc-number-radix 10)
(not (Math-realp a))
(and calc-group-digits
@@ -340,12 +340,13 @@
(funcall spfn a prec)
(math-compose-var a)))))
((eq (car a) 'intv)
- (list 'horiz
- (if (memq (nth 1 a) '(0 1)) "(" "[")
- (math-compose-expr (nth 2 a) 0)
- " .. "
- (math-compose-expr (nth 3 a) 0)
- (if (memq (nth 1 a) '(0 2)) ")" "]")))
+ (math--comp-bracket
+ (if (memq (nth 1 a) '(0 1)) ?\( ?\[)
+ (if (memq (nth 1 a) '(0 2)) ?\) ?\])
+ (list 'horiz
+ (math-compose-expr (nth 2 a) 0)
+ " .. "
+ (math-compose-expr (nth 3 a) 0))))
((eq (car a) 'date)
(if (eq (car calc-date-format) 'X)
(math-format-date a)
@@ -377,7 +378,7 @@
(and (eq (car-safe (nth 1 a)) 'cplx)
(math-negp (nth 1 (nth 1 a)))
(eq (nth 2 (nth 1 a)) 0)))
- (list 'horiz "(" (math-compose-expr (nth 1 a) 0) ")")
+ (math--comp-round-bracket (math-compose-expr (nth 1 a) 0))
(math-compose-expr (nth 1 a) 201))
(let ((calc-language 'flat)
(calc-number-radix 10)
@@ -444,7 +445,7 @@
(if (> prec (nth 2 a))
(if (setq spfn (get calc-language 'math-big-parens))
(list 'horiz (car spfn) c (cdr spfn))
- (list 'horiz "(" c ")"))
+ (math--comp-round-bracket c))
c)))
((and (eq (car a) 'calcFunc-choriz)
(not (eq calc-language 'unform))
@@ -612,7 +613,7 @@
(list 'horiz "{left ( "
(math-compose-expr a -1)
" right )}")))
- (list 'horiz "(" (math-compose-expr a 0) ")"))))
+ (math--comp-round-bracket (math-compose-expr a 0)))))
((and (memq calc-language '(tex latex))
(memq (car a) '(/ calcFunc-choose calcFunc-evalto))
(>= prec 0))
@@ -638,7 +639,7 @@
(rhs (math-compose-expr (nth 2 a) (nth 3 op) (eq (nth 1
op) '/))))
(and (equal (car op) "^")
(eq (math-comp-first-char lhs) ?-)
- (setq lhs (list 'horiz "(" lhs ")")))
+ (setq lhs (math--comp-round-bracket lhs)))
(and (memq calc-language '(tex latex))
(or (equal (car op) "^") (equal (car op) "_"))
(not (and (stringp rhs) (= (length rhs) 1)))
@@ -721,7 +722,7 @@
(list 'horiz "{left ( "
(math-compose-expr a -1)
" right )}")))
- (list 'horiz "(" (math-compose-expr a 0) ")"))))
+ (math--comp-round-bracket (math-compose-expr a 0)))))
(t
(let ((lhs (math-compose-expr (nth 1 a) (nth 2 op))))
(list 'horiz
@@ -759,7 +760,7 @@
(list 'horiz "{left ( "
(math-compose-expr a -1)
" right )}")))
- (list 'horiz "(" (math-compose-expr a 0) ")"))))
+ (math--comp-round-bracket (math-compose-expr a 0)))))
(t
(let ((rhs (math-compose-expr (nth 1 a) (nth 3 op))))
(list 'horiz
@@ -966,6 +967,69 @@
(and (memq (car a) '(^ calcFunc-subscr))
(math-tex-expr-is-flat (nth 1 a)))))
+;; FIXME: maybe try box drawing chars if big bracket chars are unavailable,
+;; like ┌ ┐n
+;; │a + b│ ┌ a + b ┐n
+;; │-----│ or │ ----- │ ?
+;; │ c │ └ c ┘
+;; └ ┘
+;; They are more common than the chars below, but look a bit square.
+;; Rounded corners exist but are less commonly available.
+
+(defconst math--big-bracket-alist
+ '((?\( . (?⎛ ?⎝ ?⎜))
+ (?\) . (?⎞ ?⎠ ?⎟))
+ (?\[ . (?⎡ ?⎣ ?⎢))
+ (?\] . (?⎤ ?⎦ ?⎥))
+ (?\{ . (?⎧ ?⎩ ?⎪ ?⎨))
+ (?\} . (?⎫ ?⎭ ?⎪ ?⎬)))
+ "Alist mapping bracket chars to (UPPER LOWER EXTENSION MIDPIECE).
+Not all brackets have midpieces.")
+
+(defun math--big-bracket (bracket-char height baseline)
+ "Composition for BRACKET-CHAR of HEIGHT with BASELINE."
+ (if (<= height 1)
+ (char-to-string bracket-char)
+ (let ((pieces (cdr (assq bracket-char math--big-bracket-alist))))
+ (if (memq nil (mapcar #'char-displayable-p pieces))
+ (char-to-string bracket-char)
+ (let* ((upper (nth 0 pieces))
+ (lower (nth 1 pieces))
+ (extension (nth 2 pieces))
+ (midpiece (nth 3 pieces)))
+ (cons 'vleft ; alignment doesn't matter; width is 1 char
+ (cons baseline
+ (mapcar
+ #'char-to-string
+ (append
+ (list upper)
+ (if midpiece
+ (let ((lower-ext (/ (- height 3) 2)))
+ (append
+ (make-list (- height 3 lower-ext) extension)
+ (list midpiece)
+ (make-list lower-ext extension)))
+ (make-list (- height 2) extension))
+ (list lower))))))))))
+
+(defun math--comp-bracket (left-bracket right-bracket comp)
+ "Put the composition COMP inside LEFT-BRACKET and RIGHT-BRACKET."
+ (if (eq calc-language 'big)
+ (let ((height (math-comp-height comp))
+ (baseline (1- (math-comp-ascent comp))))
+ (list 'horiz
+ (math--big-bracket left-bracket height baseline)
+ comp
+ (math--big-bracket right-bracket height baseline)))
+ (list 'horiz
+ (char-to-string left-bracket)
+ comp
+ (char-to-string right-bracket))))
+
+(defun math--comp-round-bracket (comp)
+ "Put the composition COMP inside plain brackets."
+ (math--comp-bracket ?\( ?\) comp))
+
(put 'calcFunc-log 'math-compose-big #'math-compose-log)
(defun math-compose-log (a _prec)
(and (= (length a) 3)
@@ -973,18 +1037,14 @@
(list 'subscr "log"
(let ((calc-language 'flat))
(math-compose-expr (nth 2 a) 1000)))
- "("
- (math-compose-expr (nth 1 a) 1000)
- ")")))
+ (math--comp-round-bracket (math-compose-expr (nth 1 a) 1000)))))
(put 'calcFunc-log10 'math-compose-big #'math-compose-log10)
(defun math-compose-log10 (a _prec)
(and (= (length a) 2)
(list 'horiz
- (list 'subscr "log" "10")
- "("
- (math-compose-expr (nth 1 a) 1000)
- ")")))
+ (list 'subscr "log" "10")
+ (math--comp-round-bracket (math-compose-expr (nth 1 a) 1000)))))
(put 'calcFunc-deriv 'math-compose-big #'math-compose-deriv)
(put 'calcFunc-tderiv 'math-compose-big #'math-compose-deriv)
@@ -1027,12 +1087,9 @@
(defun math-compose-choose (a _prec)
(let ((a1 (math-compose-expr (nth 1 a) 0))
(a2 (math-compose-expr (nth 2 a) 0)))
- (list 'horiz
- "("
- (list 'vcent
- (math-comp-height a1)
- a1 " " a2)
- ")")))
+ (math--comp-round-bracket (list 'vcent
+ (+ (math-comp-height a1))
+ a1 " " a2))))
(put 'calcFunc-integ 'math-compose-big #'math-compose-integ)
(defun math-compose-integ (a prec)
@@ -1052,9 +1109,12 @@
"d%s"
(nth 1 (nth 2 a)))))
(nth 1 a)) 185))
- (calc-language 'flat)
- (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
- (high (and (nth 4 a) (math-compose-expr (nth 4 a) 0)))
+ (low (and (nth 3 a)
+ (let ((calc-language 'flat))
+ (math-compose-expr (nth 3 a) 0))))
+ (high (and (nth 4 a)
+ (let ((calc-language 'flat))
+ (math-compose-expr (nth 4 a) 0))))
;; Check if we have Unicode integral top/bottom parts.
(fancy (and (char-displayable-p ?⌠)
(char-displayable-p ?⌡)))
@@ -1066,40 +1126,47 @@
((char-displayable-p ?│) "│ ")
;; U+007C VERTICAL LINE
(t "| "))))
- (list 'horiz
- (if parens "(" "")
- (append (list 'vcent (if fancy
- (if high 2 1)
- (if high 3 2)))
- (and high (list (if fancy
- (list 'horiz high " ")
- (list 'horiz " " high))))
- (if fancy
- (list "⌠ " fancy-stem "⌡ ")
- '(" /"
- " | "
- " | "
- " | "
- "/ "))
- (and low (list (if fancy
- (list 'horiz low " ")
- (list 'horiz low " ")))))
- expr
- (if over
- ""
- (list 'horiz " d" var))
- (if parens ")" "")))))
+ (let ((comp
+ (list 'horiz
+ (append (list 'vcent (if fancy
+ (if high 2 1)
+ (if high 3 2)))
+ (and high (list (if fancy
+ (list 'horiz high " ")
+ (list 'horiz " " high))))
+ (if fancy
+ (list "⌠ " fancy-stem "⌡ ")
+ '(" /"
+ " | "
+ " | "
+ " | "
+ "/ "))
+ (and low (list (if fancy
+ (list 'horiz low " ")
+ (list 'horiz low " ")))))
+ expr
+ (if over
+ ""
+ (list 'horiz " d" var)))))
+ (if parens
+ (math--comp-round-bracket comp)
+ comp)))))
(put 'calcFunc-sum 'math-compose-big #'math-compose-sum)
(defun math-compose-sum (a prec)
(and (memq (length a) '(3 5 6))
(let* ((expr (math-compose-expr (nth 1 a) 185))
- (calc-language 'flat)
- (var (math-compose-expr (nth 2 a) 0))
- (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
- (high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0))))
- (list 'horiz
- (if (memq prec '(180 201)) "(" "")
+ (var
+ (let ((calc-language 'flat))
+ (math-compose-expr (nth 2 a) 0)))
+ (low (and (nth 3 a)
+ (let ((calc-language 'flat))
+ (math-compose-expr (nth 3 a) 0))))
+ (high (and (nth 4 a)
+ (let ((calc-language 'flat))
+ (math-compose-vector (nthcdr 4 a) ", " 0))))
+ (comp
+ (list 'horiz
(append (list 'vcent (if high 3 2))
(and high (list high))
'("---- "
@@ -1112,32 +1179,42 @@
(list var)))
(if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod))
" " "")
- expr
- (if (memq prec '(180 201)) ")" "")))))
+ expr)))
+ (if (memq prec '(180 201))
+ (math--comp-round-bracket comp)
+ comp))))
(put 'calcFunc-prod 'math-compose-big #'math-compose-prod)
(defun math-compose-prod (a prec)
(and (memq (length a) '(3 5 6))
(let* ((expr (math-compose-expr (nth 1 a) 198))
- (calc-language 'flat)
- (var (math-compose-expr (nth 2 a) 0))
- (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
- (high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0))))
- (list 'horiz
- (if (memq prec '(196 201)) "(" "")
- (append (list 'vcent (if high 3 2))
- (and high (list high))
- '("----- "
- " | | "
- " | | "
- " | | ")
- (if low
- (list (list 'horiz var " = " low))
- (list var)))
- (if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod))
- " " "")
- expr
- (if (memq prec '(196 201)) ")" "")))))
+ (var
+ (let ((calc-language 'flat))
+ (math-compose-expr (nth 2 a) 0)))
+ (low (and (nth 3 a)
+ (let ((calc-language 'flat))
+ (math-compose-expr (nth 3 a) 0))))
+ (high (and (nth 4 a)
+ (let ((calc-language 'flat))
+ (math-compose-vector (nthcdr 4 a) ", " 0))))
+ (comp
+ (list 'horiz
+ (append (list 'vcent (if high 3 2))
+ (and high (list high))
+ '("----- "
+ " | | "
+ " | | "
+ " | | ")
+ (if low
+ (list (list 'horiz var " = " low))
+ (list var)))
+ (if (memq (car-safe (nth 1 a))
+ '(calcFunc-sum calcFunc-prod))
+ " " "")
+ expr)))
+ (if (memq prec '(196 201))
+ (math--comp-round-bracket comp)
+ comp))))
;; The variables math-svo-c, math-svo-wid and math-svo-off are local
;; to math-stack-value-offset in calc.el, but are used by
diff --git a/lisp/cedet/ede/auto.el b/lisp/cedet/ede/auto.el
index ee75e29..e1417d7 100644
--- a/lisp/cedet/ede/auto.el
+++ b/lisp/cedet/ede/auto.el
@@ -64,24 +64,22 @@ location is varied dependent on other complex criteria,
this class
can be used to define that match without loading the specific project
into memory.")
+(cl-defmethod ede-calc-fromconfig ((dirmatch ede-project-autoload-dirmatch))
+ "Calculate the value of :fromconfig from DIRMATCH."
+ (let* ((fc (oref dirmatch fromconfig))
+ (found (cond ((stringp fc) fc)
+ ((functionp fc) (funcall fc))
+ (t (error "Unknown dirmatch object match style.")))))
+ (expand-file-name found)
+ ))
+
(cl-defmethod ede-dirmatch-installed ((dirmatch ede-project-autoload-dirmatch))
"Return non-nil if the tool DIRMATCH might match is installed on the system."
- (let ((fc (oref dirmatch fromconfig)))
-
- (cond
- ;; If the thing to match is stored in a config file.
- ((stringp fc)
- (file-exists-p fc))
-
- ;; Add new types of dirmatches here.
-
- ;; Error for weird stuff
- (t (error "Unknown dirmatch type.")))))
-
+ (file-exists-p (ede-calc-fromconfig dirmatch)))
(cl-defmethod ede-do-dirmatch ((dirmatch ede-project-autoload-dirmatch) file)
"Does DIRMATCH match the filename FILE."
- (let ((fc (oref dirmatch fromconfig)))
+ (let ((fc (ede-calc-fromconfig dirmatch)))
(cond
;; If the thing to match is stored in a config file.
diff --git a/lisp/cedet/ede/base.el b/lisp/cedet/ede/base.el
index 7799746..810d6ef 100644
--- a/lisp/cedet/ede/base.el
+++ b/lisp/cedet/ede/base.el
@@ -160,16 +160,13 @@ and querying them will cause the actual project to get
loaded.")
;; Projects can also affect how EDE works, by changing what appears in
;; the EDE menu, or how some keys are bound.
;;
-(unless (fboundp 'ede-target-list-p)
- (cl-deftype ede-target-list () '(list-of ede-target)))
-
(defclass ede-project (ede-project-placeholder)
((subproj :initform nil
:type list
:documentation "Sub projects controlled by this project.
For Automake based projects, each directory is treated as a project.")
(targets :initarg :targets
- :type ede-target-list
+ :type (list-of ede-target)
:custom (repeat (object :objectcreatefcn ede-new-target-custom))
:label "Local Targets"
:group (targets)
diff --git a/lisp/cedet/ede/proj.el b/lisp/cedet/ede/proj.el
index 59628eb..4af8b41 100644
--- a/lisp/cedet/ede/proj.el
+++ b/lisp/cedet/ede/proj.el
@@ -184,7 +184,7 @@ Target variables are always renamed such as foo_CFLAGS,
then included into
commands where the variable would usually appear.")
(rules :initarg :rules
:initform nil
- :type list
+ :type (list-of ede-makefile-rule)
:custom (repeat (object :objecttype ede-makefile-rule))
:label "Additional Rules"
:group (make)
diff --git a/lisp/comint.el b/lisp/comint.el
index 2e683a7..e52d67d 100644
--- a/lisp/comint.el
+++ b/lisp/comint.el
@@ -979,6 +979,7 @@ See also `comint-input-ignoredups' and
`comint-write-input-ring'."
(ring (make-ring ring-size))
;; Use possibly buffer-local values of these variables.
(ring-separator comint-input-ring-separator)
+ (ring-file-prefix comint-input-ring-file-prefix)
(history-ignore comint-input-history-ignore)
(ignoredups comint-input-ignoredups))
(with-temp-buffer
@@ -990,24 +991,15 @@ See also `comint-input-ignoredups' and
`comint-write-input-ring'."
(while (and (< count comint-input-ring-size)
(re-search-backward ring-separator nil t)
(setq end (match-beginning 0)))
- (setq start
- (if (re-search-backward ring-separator nil t)
- (progn
- (when (and comint-input-ring-file-prefix
- (looking-at
- comint-input-ring-file-prefix))
- ;; Skip zsh extended_history stamps
- (goto-char (match-end 0)))
- (match-end 0))
- (progn
- (goto-char (point-min))
- (when (and comint-input-ring-file-prefix
- (looking-at
- comint-input-ring-file-prefix))
- (goto-char (match-end 0)))
- (point))))
+ (goto-char (if (re-search-backward ring-separator nil t)
+ (match-end 0)
+ (point-min)))
+ (when (and ring-file-prefix
+ (looking-at ring-file-prefix))
+ ;; Skip zsh extended_history stamps
+ (goto-char (match-end 0)))
+ (setq start (point))
(setq history (buffer-substring start end))
- (goto-char start)
(when (and (not (string-match history-ignore history))
(or (null ignoredups)
(ring-empty-p ring)
@@ -3871,7 +3863,11 @@ REGEXP-GROUP is the regular expression group in REGEXP
to use."
(push (buffer-substring-no-properties
(match-beginning regexp-group)
(match-end regexp-group))
- results))
+ results)
+ (when (zerop (length (match-string 0)))
+ ;; If the regexp can be empty (for instance, "^.*$"), we
+ ;; don't advance, so ensure forward progress.
+ (forward-line 1)))
(nreverse results))))
;; Converting process modes to use comint mode
diff --git a/lisp/cus-face.el b/lisp/cus-face.el
index 5dcb284..21fe89c 100644
--- a/lisp/cus-face.el
+++ b/lisp/cus-face.el
@@ -175,6 +175,7 @@
(choice :tag "Style"
(const :tag "Raised" released-button)
(const :tag "Sunken" pressed-button)
+ (const :tag "Flat" flat-button)
(const :tag "None" nil))))
;; filter to make value suitable for customize
(lambda (real-value)
diff --git a/lisp/cus-start.el b/lisp/cus-start.el
index 85dd14f..27fdb72 100644
--- a/lisp/cus-start.el
+++ b/lisp/cus-start.el
@@ -394,7 +394,11 @@ Leaving \"Default\" unchecked is equivalent with
specifying a default of
;; (directory :format "%v"))))
(load-prefer-newer lisp boolean "24.4")
;; minibuf.c
- (minibuffer-follows-selected-frame minibuffer boolean "28.1")
+ (minibuffer-follows-selected-frame
+ minibuffer (choice (const :tag "Always" t)
+ (const :tag "When used" hybrid)
+ (const :tag "Never" nil))
+ "28.1")
(enable-recursive-minibuffers minibuffer boolean)
(history-length minibuffer
(choice (const :tag "Infinite" t) integer)
@@ -876,7 +880,7 @@ since it could result in memory overflow and make Emacs
crash."
;; Don't re-add to custom-delayed-init-variables post-startup.
(unless after-init-time
;; Note this is the _only_ initialize property we handle.
- (if (eq (cadr (memq :initialize rest)) 'custom-initialize-delay)
+ (if (eq (cadr (memq :initialize rest)) #'custom-initialize-delay)
;; These vars are defined early and should hence be initialized
;; early, even if this file happens to be loaded late. so add them
;; to the end of custom-delayed-init-variables. Otherwise,
diff --git a/lisp/custom.el b/lisp/custom.el
index d9d0898..5e354c4 100644
--- a/lisp/custom.el
+++ b/lisp/custom.el
@@ -125,16 +125,9 @@ This is used in files that are preloaded (or for autoloaded
variables), so that the initialization is done in the run-time
context rather than the build-time context. This also has the
side-effect that the (delayed) initialization is performed with
-the :set function.
-
-For variables in preloaded files, you can simply use this
-function for the :initialize property. For autoloaded variables,
-you will also need to add an autoload stanza calling this
-function, and another one setting the standard-value property.
-Or you can wrap the defcustom in a progn, to force the autoloader
-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."
+the :set function."
+ ;; 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
@@ -237,6 +230,8 @@ The following keywords are meaningful:
:type VALUE should be a widget type for editing the symbol's value.
Every `defcustom' should specify a value for this keyword.
+ See Info node `(elisp) Customization Types' for a list of
+ base types and useful composite types.
:options VALUE should be a list of valid members of the widget type.
:initialize
VALUE should be a function used to initialize the
@@ -778,8 +773,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".
@@ -787,11 +781,10 @@ E.g. dumped variables whose default depends on run-time
information."
;; custom-initialize-delay but needs the :set function custom-set-minor-mode
;; to also run during initialization. So, long story short, we
;; always do the funcall step, even if symbol was not bound before.
- (or (default-boundp symbol)
- (eval `(defvar ,symbol nil))) ; reset below, so any value is fine
(funcall (or (get symbol 'custom-set) #'set-default)
symbol
- (eval (car (or (get symbol 'saved-value) (get symbol
'standard-value))))))
+ (eval (car (or (get symbol 'saved-value)
+ (get symbol 'standard-value))))))
;;; Custom Themes
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index cf89456..f29f85b 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -374,185 +374,184 @@
;; the important aspect is that they are subrs that don't evaluate all of
;; their args.)
;;
- (let ((fn (car-safe form))
- tmp)
- (cond ((not (consp form))
- (if (not (and for-effect
- (or byte-compile-delete-errors
- (not (symbolp form))
- (eq form t))))
- form))
- ((eq fn 'quote)
- (if (cdr (cdr form))
- (byte-compile-warn "malformed quote form: `%s'"
- (prin1-to-string form)))
- ;; map (quote nil) to nil to simplify optimizer logic.
- ;; map quoted constants to nil if for-effect (just because).
- (and (nth 1 form)
- (not for-effect)
- form))
- ((memq fn '(let let*))
- ;; recursively enter the optimizer for the bindings and body
- ;; of a let or let*. This for depth-firstness: forms that
- ;; are more deeply nested are optimized first.
- (cons fn
+ ;; FIXME: There are a bunch of `byte-compile-warn' here which arguably
+ ;; have no place in an optimizer: the corresponding tests should be
+ ;; performed in `macroexpand-all', or in `cconv', or in `bytecomp'.
+ (let ((fn (car-safe form)))
+ (pcase form
+ ((pred (not consp))
+ (if (not (and for-effect
+ (or byte-compile-delete-errors
+ (not (symbolp form))
+ (eq form t))))
+ form))
+ (`(quote . ,v)
+ (if (cdr v)
+ (byte-compile-warn "malformed quote form: `%s'"
+ (prin1-to-string form)))
+ ;; Map (quote nil) to nil to simplify optimizer logic.
+ ;; Map quoted constants to nil if for-effect (just because).
+ (and (car v)
+ (not for-effect)
+ form))
+ (`(,(or 'let 'let*) . ,(or `(,bindings . ,exps) pcase--dontcare))
+ ;; Recursively enter the optimizer for the bindings and body
+ ;; of a let or let*. This for depth-firstness: forms that
+ ;; are more deeply nested are optimized first.
+ (cons fn
(cons
(mapcar (lambda (binding)
- (if (symbolp binding)
- binding
- (if (cdr (cdr binding))
- (byte-compile-warn "malformed let binding: `%s'"
- (prin1-to-string binding)))
- (list (car binding)
- (byte-optimize-form (nth 1 binding) nil))))
- (nth 1 form))
- (byte-optimize-body (cdr (cdr form)) for-effect))))
- ((eq fn 'cond)
- (cons fn
- (mapcar (lambda (clause)
- (if (consp clause)
- (cons
- (byte-optimize-form (car clause) nil)
- (byte-optimize-body (cdr clause) for-effect))
- (byte-compile-warn "malformed cond form: `%s'"
- (prin1-to-string clause))
- clause))
- (cdr form))))
- ((eq fn 'progn)
- ;; As an extra added bonus, this simplifies (progn <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)))
-
- ((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)))
-
- ((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)))))
-
- ((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)))))
-
- ((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))))
-
- ((eq fn '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)
-
- ((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))))
-
- ((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)))))
-
- ((eq fn 'catch)
- (cons fn
- (cons (byte-optimize-form (nth 1 form) nil)
- (byte-optimize-body (cdr form) 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))))
-
- ;; Needed as long as we run byte-optimize-form after cconv.
- ((eq fn '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))))
-
- ((eq (car-safe fn) 'closure) form)
-
- ((byte-code-function-p fn)
- (cons fn (mapcar #'byte-optimize-form (cdr form))))
-
- ((not (symbolp fn))
- (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))
+ (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)))
+
+ (`(,(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)))
+
+ (`(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'"))
+
+ (`(,(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))))
+
+ (`(while ,exp . ,exps)
+ `(while ,(byte-optimize-form exp nil)
+ . ,(byte-optimize-body exps t)))
+ (`(while . ,_)
+ (byte-compile-warn "too few arguments for `while'"))
+
+ (`(interactive . ,_)
+ (byte-compile-warn "misplaced interactive spec: `%s'"
+ (prin1-to-string form))
+ nil)
+
+ (`(function . ,_)
+ ;; This forms is compiled as constant or by breaking out
+ ;; all the subexpressions and compiling them separately.
+ form)
- (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))))))
+ (`(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)))
+
+ (`(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))
+
+ (`(catch . ,(or `(,tag . ,exps) pcase--dontcare))
+ `(catch ,(byte-optimize-form tag nil)
+ . ,(byte-optimize-body exps for-effect)))
+
+ (`(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.
+ (`(internal-make-closure . ,_) form)
+
+ (`((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))))
+
+ ;; FIXME: Strictly speaking, I think this is a bug: (closure...)
+ ;; is a *value* and shouldn't appear in the car.
+ (`((closure . ,_) . ,_) form)
+
+ (`(,(pred byte-code-function-p) . ,exps)
+ (cons fn (mapcar #'byte-optimize-form exps)))
+
+ (`(,(pred (not symbolp)) . ,_)
+ (byte-compile-warn "`%s' is a malformed function"
+ (prin1-to-string fn))
+ form)
+
+ ((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))
+
+ (_
+ ;; Otherwise, no args can be considered to be for-effect,
+ ;; even if the called function is for-effect, because we
+ ;; don't know anything about that function.
+ (let ((form (cons fn (mapcar #'byte-optimize-form (cdr form)))))
+ (if (get fn 'pure)
+ (byte-optimize-constant-args form)
+ form))))))
(defun byte-optimize-form (form &optional for-effect)
"The source-level pass of the optimizer."
diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el
index 4ba72ae..ec1077d 100644
--- a/lisp/emacs-lisp/eieio-base.el
+++ b/lisp/emacs-lisp/eieio-base.el
@@ -162,6 +162,59 @@ only one object ever exists."
old)))
+;;; Named object
+
+(defclass eieio-named ()
+ ((object-name :initarg :object-name :initform nil))
+ "Object with a name."
+ :abstract t)
+
+(cl-defmethod eieio-object-name-string ((obj eieio-named))
+ "Return a string which is OBJ's name."
+ (or (slot-value obj 'object-name)
+ (cl-call-next-method)))
+
+(cl-defgeneric eieio-object-set-name-string (obj name)
+ "Set the string which is OBJ's NAME."
+ (declare (obsolete "inherit from `eieio-named' and use (setf (slot-value OBJ
\\='object-name) NAME) instead" "25.1"))
+ (cl-check-type name string)
+ (setf (gethash obj eieio--object-names) name))
+(define-obsolete-function-alias
+ 'object-set-name-string 'eieio-object-set-name-string "24.4")
+
+(with-suppressed-warnings ((obsolete eieio-object-set-name-string))
+ (cl-defmethod eieio-object-set-name-string ((obj eieio-named) name)
+ "Set the string which is OBJ's NAME."
+ (cl-check-type name string)
+ (eieio-oset obj 'object-name name)))
+
+(cl-defmethod clone ((obj eieio-named) &rest params)
+ "Clone OBJ, initializing `:parent' to OBJ.
+All slots are unbound, except those initialized with PARAMS."
+ (let* ((newname (and (stringp (car params)) (pop params)))
+ (nobj (apply #'cl-call-next-method obj params))
+ (nm (slot-value nobj 'object-name)))
+ (eieio-oset nobj 'object-name
+ (or newname
+ (if (equal nm (slot-value obj 'object-name))
+ (save-match-data
+ (if (and nm (string-match "-\\([0-9]+\\)" nm))
+ (let ((num (1+ (string-to-number
+ (match-string 1 nm)))))
+ (concat (substring nm 0 (match-beginning 0))
+ "-" (int-to-string num)))
+ (concat nm "-1")))
+ nm)))
+ nobj))
+
+(cl-defmethod make-instance ((class (subclass eieio-named)) &rest args)
+ (if (not (stringp (car args)))
+ (cl-call-next-method)
+ (funcall (if eieio-backward-compatibility #'ignore #'message)
+ "Obsolete: name passed without :object-name to %S constructor"
+ class)
+ (apply #'cl-call-next-method class :object-name args)))
+
;;; eieio-persistent
;;
;; For objects which must save themselves to disk. Provides an
@@ -264,12 +317,17 @@ objects found there."
(:method
((objclass (subclass eieio-default-superclass)) inputlist)
- (let ((slots (if (stringp (car inputlist))
- ;; Earlier versions of `object-write' added a
- ;; string name for the object, now obsolete.
- (cdr inputlist)
- inputlist))
- (createslots nil))
+ (let* ((name nil)
+ (slots (if (stringp (car inputlist))
+ (progn
+ ;; Earlier versions of `object-write' added a
+ ;; string name for the object, now obsolete.
+ ;; Save as 'name' in case this object is subclass
+ ;; of eieio-named with no :object-name slot specified.
+ (setq name (car inputlist))
+ (cdr inputlist))
+ inputlist))
+ (createslots nil))
;; If OBJCLASS is an eieio autoload object, then we need to
;; load it (we don't need the return value).
(eieio--full-class-object objclass)
@@ -286,7 +344,17 @@ objects found there."
(setq slots (cdr (cdr slots))))
- (apply #'make-instance objclass (nreverse createslots)))))
+ (let ((newobj (apply #'make-instance objclass (nreverse createslots))))
+
+ ;; Check for special case of subclass of `eieio-named', and do
+ ;; name assignment.
+ (when (and eieio-backward-compatibility
+ (object-of-class-p newobj 'eieio-named)
+ (not (oref newobj object-name))
+ name)
+ (oset newobj object-name name))
+
+ newobj))))
(defun eieio-persistent-fix-value (proposed-value)
"Fix PROPOSED-VALUE.
@@ -408,59 +476,6 @@ instance."
;; It should also set up some hooks to help it keep itself up to date.
-;;; Named object
-
-(defclass eieio-named ()
- ((object-name :initarg :object-name :initform nil))
- "Object with a name."
- :abstract t)
-
-(cl-defmethod eieio-object-name-string ((obj eieio-named))
- "Return a string which is OBJ's name."
- (or (slot-value obj 'object-name)
- (cl-call-next-method)))
-
-(cl-defgeneric eieio-object-set-name-string (obj name)
- "Set the string which is OBJ's NAME."
- (declare (obsolete "inherit from `eieio-named' and use (setf (slot-value OBJ
\\='object-name) NAME) instead" "25.1"))
- (cl-check-type name string)
- (setf (gethash obj eieio--object-names) name))
-(define-obsolete-function-alias
- 'object-set-name-string 'eieio-object-set-name-string "24.4")
-
-(with-suppressed-warnings ((obsolete eieio-object-set-name-string))
- (cl-defmethod eieio-object-set-name-string ((obj eieio-named) name)
- "Set the string which is OBJ's NAME."
- (cl-check-type name string)
- (eieio-oset obj 'object-name name)))
-
-(cl-defmethod clone ((obj eieio-named) &rest params)
- "Clone OBJ, initializing `:parent' to OBJ.
-All slots are unbound, except those initialized with PARAMS."
- (let* ((newname (and (stringp (car params)) (pop params)))
- (nobj (apply #'cl-call-next-method obj params))
- (nm (slot-value nobj 'object-name)))
- (eieio-oset nobj 'object-name
- (or newname
- (if (equal nm (slot-value obj 'object-name))
- (save-match-data
- (if (and nm (string-match "-\\([0-9]+\\)" nm))
- (let ((num (1+ (string-to-number
- (match-string 1 nm)))))
- (concat (substring nm 0 (match-beginning 0))
- "-" (int-to-string num)))
- (concat nm "-1")))
- nm)))
- nobj))
-
-(cl-defmethod make-instance ((class (subclass eieio-named)) &rest args)
- (if (not (stringp (car args)))
- (cl-call-next-method)
- (funcall (if eieio-backward-compatibility #'ignore #'message)
- "Obsolete: name passed without :object-name to %S constructor"
- class)
- (apply #'cl-call-next-method class :object-name args)))
-
(provide 'eieio-base)
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index 5851754..fdbf953 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -487,7 +487,7 @@ Errors during evaluation are caught and handled like nil."
Returns nil if they are."
(if (not (eq (type-of a) (type-of b)))
`(different-types ,a ,b)
- (pcase-exhaustive a
+ (pcase a
((pred consp)
(let ((a-length (proper-list-p a))
(b-length (proper-list-p b)))
@@ -538,7 +538,7 @@ Returns nil if they are."
for xi = (ert--explain-equal-rec ai bi)
do (when xi (cl-return `(array-elt ,i ,xi)))
finally (cl-assert (equal a b) t))))
- ((pred atom)
+ (_
(if (not (equal a b))
(if (and (symbolp a) (symbolp b) (string= a b))
`(different-symbols-with-the-same-name ,a ,b)
diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el
index 1ae216c..8780c5d 100644
--- a/lisp/emacs-lisp/lisp-mode.el
+++ b/lisp/emacs-lisp/lisp-mode.el
@@ -456,8 +456,7 @@ This will generate compile-time constants from BINDINGS."
("\\(\\\\\\)\\([^\"\\]\\)"
(1 (elisp--font-lock-backslash) prepend))
;; Words inside ‘’ and `' tend to be symbol names.
- (,(concat "[`‘]\\(\\(?:\\sw\\|\\s_\\|\\\\.\\)"
- lisp-mode-symbol-regexp "\\)['’]")
+ (,(concat "[`‘]\\(" lisp-mode-symbol-regexp "\\)['’]")
(1 font-lock-constant-face prepend))
;; Constant values.
(,(concat "\\_<:" lisp-mode-symbol-regexp "\\_>")
@@ -507,8 +506,7 @@ This will generate compile-time constants from BINDINGS."
(,(concat "(" cl-errs-re "\\_>")
(1 font-lock-warning-face))
;; Words inside ‘’ and `' tend to be symbol names.
- (,(concat "[`‘]\\(\\(?:\\sw\\|\\s_\\|\\\\.\\)"
- lisp-mode-symbol-regexp "\\)['’]")
+ (,(concat "[`‘]\\(" lisp-mode-symbol-regexp "\\)['’]")
(1 font-lock-constant-face prepend))
;; Uninterned symbols, e.g., (defpackage #:my-package ...)
;; must come before keywords below to have effect
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 72ea1ba..bfd577c 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -39,10 +39,10 @@
;; - along these lines, provide patterns to match CL structs.
;; - provide something like (setq VAR) so a var can be set rather than
;; let-bound.
-;; - provide a way to fallthrough to subsequent cases (not sure what I meant by
-;; this :-()
+;; - provide a way to fallthrough to subsequent cases
+;; (e.g. Like Racket's (=> ID).
;; - try and be more clever to reduce the size of the decision tree, and
-;; to reduce the number of leaves that need to be turned into function:
+;; to reduce the number of leaves that need to be turned into functions:
;; - first, do the tests shared by all remaining branches (it will have
;; to be performed anyway, so better do it first so it's shared).
;; - then choose the test that discriminates more (?).
@@ -97,11 +97,15 @@
(declare-function get-edebug-spec "edebug" (symbol))
(declare-function edebug-match "edebug" (cursor specs))
+(defun pcase--get-macroexpander (s)
+ "Return the macroexpander for pcase pattern head S, or nil"
+ (get s 'pcase-macroexpander))
+
(defun pcase--edebug-match-macro (cursor)
(let (specs)
(mapatoms
(lambda (s)
- (let ((m (get s 'pcase-macroexpander)))
+ (let ((m (pcase--get-macroexpander s)))
(when (and m (get-edebug-spec m))
(push (cons (symbol-name s) (get-edebug-spec m))
specs)))))
@@ -128,6 +132,7 @@ PATTERN matches. PATTERN can take one of the forms:
If a SYMBOL is used twice in the same pattern
the second occurrence becomes an `eq'uality test.
(pred FUN) matches if FUN called on EXPVAL returns non-nil.
+ (pred (not FUN)) matches if FUN called on EXPVAL returns nil.
(app FUN PAT) matches if FUN called on EXPVAL matches PAT.
(guard BOOLEXP) matches if BOOLEXP evaluates to non-nil.
(let PAT EXPR) matches if EXPR matches PAT.
@@ -193,7 +198,7 @@ Emacs Lisp manual for more information and examples."
(let (more)
;; Collect all the extensions.
(mapatoms (lambda (symbol)
- (let ((me (get symbol 'pcase-macroexpander)))
+ (let ((me (pcase--get-macroexpander symbol)))
(when me
(push (cons symbol me)
more)))))
@@ -424,7 +429,7 @@ of the elements of LIST is performed as if by `pcase-let'.
((eq head 'let) `(let ,(pcase--macroexpand (cadr pat)) ,@(cddr pat)))
((eq head 'app) `(app ,(nth 1 pat) ,(pcase--macroexpand (nth 2 pat))))
(t
- (let* ((expander (get head 'pcase-macroexpander))
+ (let* ((expander (pcase--get-macroexpander head))
(npat (if expander (apply expander (cdr pat)))))
(if (null npat)
(error (if expander
@@ -658,6 +663,14 @@ MATCH is the pattern that needs to be matched, of the form:
'(:pcase--succeed . nil))))
(defun pcase--split-pred (vars upat pat)
+ "Indicate the overlap or mutual-exclusion between UPAT and PAT.
+More specifically retuns a pair (A . B) where A indicates whether PAT
+can match when UPAT has matched, and B does the same for the case
+where UPAT failed to match.
+A and B can be one of:
+- nil if we don't know
+- `:pcase--fail' if UPAT match's result implies that PAT can't match
+- `:pcase--succeed' if UPAT match's result implies that PAT matches"
(let (test)
(cond
((and (equal upat pat)
@@ -670,6 +683,19 @@ MATCH is the pattern that needs to be matched, of the form:
;; and catch at least the easy cases such as (bug#14773).
(not (macroexp--fgrep (mapcar #'car vars) (cadr upat)))))
'(:pcase--succeed . :pcase--fail))
+ ;; In case UPAT is of the form (pred (not PRED))
+ ((and (eq 'pred (car upat)) (eq 'not (car-safe (cadr upat))))
+ (let* ((test (cadr (cadr upat)))
+ (res (pcase--split-pred vars `(pred ,test) pat)))
+ (cons (cdr res) (car res))))
+ ;; In case PAT is of the form (pred (not PRED))
+ ((and (eq 'pred (car-safe pat)) (eq 'not (car-safe (cadr pat))))
+ (let* ((test (cadr (cadr pat)))
+ (res (pcase--split-pred vars upat `(pred ,test)))
+ (reverse (lambda (x) (cond ((eq x :pcase--succeed) :pcase--fail)
+ ((eq x :pcase--fail) :pcase--succeed)))))
+ (cons (funcall reverse (car res))
+ (funcall reverse (cdr res)))))
((and (eq 'pred (car upat))
(let ((otherpred
(cond ((eq 'pred (car-safe pat)) (cadr pat))
@@ -728,8 +754,10 @@ MATCH is the pattern that needs to be matched, of the form:
(defun pcase--funcall (fun arg vars)
"Build a function call to FUN with arg ARG."
- (if (symbolp fun)
- `(,fun ,arg)
+ (cond
+ ((symbolp fun) `(,fun ,arg))
+ ((eq 'not (car-safe fun)) `(not ,(pcase--funcall (cadr fun) arg vars)))
+ (t
(let* (;; `env' is an upper bound on the bindings we need.
(env (mapcar (lambda (x) (list (car x) (cdr x)))
(macroexp--fgrep vars fun)))
@@ -747,7 +775,7 @@ MATCH is the pattern that needs to be matched, of the form:
;; Let's not replace `vars' in `fun' since it's
;; too difficult to do it right, instead just
;; let-bind `vars' around `fun'.
- `(let* ,env ,call)))))
+ `(let* ,env ,call))))))
(defun pcase--eval (exp vars)
"Build an expression that will evaluate EXP."
diff --git a/lisp/emacs-lisp/radix-tree.el b/lisp/emacs-lisp/radix-tree.el
index 6a483a6..0905ac6 100644
--- a/lisp/emacs-lisp/radix-tree.el
+++ b/lisp/emacs-lisp/radix-tree.el
@@ -198,9 +198,10 @@ If not found, return nil."
(pcase-defmacro radix-tree-leaf (vpat)
"Pattern which matches a radix-tree leaf.
The pattern VPAT is matched against the leaf's carried value."
- ;; FIXME: We'd like to use a negative pattern (not consp), but pcase
- ;; doesn't support it. Using `atom' works but generates sub-optimal code.
- `(or `(t . ,,vpat) (and (pred atom) ,vpat))))
+ ;; We used to use `(pred atom)', but `pcase' doesn't understand that
+ ;; `atom' is equivalent to the negation of `consp' and hence generates
+ ;; suboptimal code.
+ `(or `(t . ,,vpat) (and (pred (not consp)) ,vpat))))
(defun radix-tree-iter-subtrees (tree fun)
"Apply FUN to every immediate subtree of radix TREE.
diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el
index 698467e..39e69f5 100644
--- a/lisp/emacs-lisp/shortdoc.el
+++ b/lisp/emacs-lisp/shortdoc.el
@@ -1126,12 +1126,21 @@ There can be any number of :example/:result elements."
(insert (propertize "("
'shortdoc-function t))
(if (plist-get data :no-manual)
- (insert (symbol-name function))
+ (insert-text-button
+ (symbol-name function)
+ 'face 'button
+ 'action (lambda (_)
+ (describe-function function))
+ 'follow-link t
+ 'help-echo (purecopy "mouse-1, RET: describe function"))
(insert-text-button
(symbol-name function)
'face 'button
'action (lambda (_)
- (info-lookup-symbol function 'emacs-lisp-mode))))
+ (info-lookup-symbol function 'emacs-lisp-mode))
+ 'follow-link t
+ 'help-echo (purecopy "mouse-1, RET: show \
+function's documentation in the Info manual")))
(setq arglist-start (point))
(insert ")\n")
;; Doc string.
diff --git a/lisp/epa.el b/lisp/epa.el
index db2b127..197cd92 100644
--- a/lisp/epa.el
+++ b/lisp/epa.el
@@ -359,8 +359,8 @@ DOC is documentation text to insert at the start."
;; Find the end of the documentation text at the start.
;; Set POINT to where it ends, or nil if ends at eob.
- (unless (get-text-property point 'epa-list-keys)
- (setq point (next-single-property-change point 'epa-list-keys)))
+ (unless (get-text-property point 'epa-key)
+ (setq point (next-single-property-change point 'epa-key)))
;; If caller specified documentation text for that, replace the old
;; documentation text (if any) with what was specified.
diff --git a/lisp/erc/erc-services.el b/lisp/erc/erc-services.el
index 4f9b0b1..9ef8b7f 100644
--- a/lisp/erc/erc-services.el
+++ b/lisp/erc/erc-services.el
@@ -168,8 +168,19 @@ You can also use \\[erc-nickserv-identify-mode] to change
modes."
:group 'erc-services
:type 'boolean)
+(defcustom erc-use-auth-source-for-nickserv-password nil
+ "Query auth-source for a password when identifiying to NickServ.
+This option has an no effect if `erc-prompt-for-nickserv-password'
+is non-nil, and passwords from `erc-nickserv-passwords' take
+precedence."
+ :version "28.1"
+ :group 'erc-services
+ :type 'boolean)
+
(defcustom erc-nickserv-passwords nil
"Passwords used when identifying to NickServ automatically.
+`erc-prompt-for-nickserv-password' must be nil for these
+passwords to be used.
Example of use:
(setq erc-nickserv-passwords
@@ -375,7 +386,8 @@ Make sure it is the real NickServ for this network.
If `erc-prompt-for-nickserv-password' is non-nil, prompt the user for the
password for this nickname, otherwise try to send it automatically."
(unless (and (null erc-nickserv-passwords)
- (null erc-prompt-for-nickserv-password))
+ (null erc-prompt-for-nickserv-password)
+ (null erc-use-auth-source-for-nickserv-password))
(let* ((network (erc-network))
(sender (erc-nickserv-alist-sender network))
(identify-regex (erc-nickserv-alist-regexp network))
@@ -394,30 +406,49 @@ password for this nickname, otherwise try to send it
automatically."
(defun erc-nickserv-identify-on-connect (_server nick)
"Identify to Nickserv after the connection to the server is established."
(unless (or (and (null erc-nickserv-passwords)
- (null erc-prompt-for-nickserv-password))
- (and (eq erc-nickserv-identify-mode 'both)
- (erc-nickserv-alist-regexp (erc-network))))
+ (null erc-prompt-for-nickserv-password)
+ (null erc-use-auth-source-for-nickserv-password))
+ (and (eq erc-nickserv-identify-mode 'both)
+ (erc-nickserv-alist-regexp (erc-network))))
(erc-nickserv-call-identify-function nick)))
(defun erc-nickserv-identify-on-nick-change (nick _old-nick)
"Identify to Nickserv whenever your nick changes."
(unless (or (and (null erc-nickserv-passwords)
- (null erc-prompt-for-nickserv-password))
- (and (eq erc-nickserv-identify-mode 'both)
- (erc-nickserv-alist-regexp (erc-network))))
+ (null erc-prompt-for-nickserv-password)
+ (null erc-use-auth-source-for-nickserv-password))
+ (and (eq erc-nickserv-identify-mode 'both)
+ (erc-nickserv-alist-regexp (erc-network))))
(erc-nickserv-call-identify-function nick)))
+(defun erc-nickserv-get-password (nickname)
+ "Return the password for NICKNAME from configured sources.
+
+It uses `erc-nickserv-passwords' and additionally auth-source
+when `erc-use-auth-source-for-nickserv-password' is not nil."
+ (or
+ (when erc-nickserv-passwords
+ (cdr (assoc nickname
+ (nth 1 (assoc (erc-network)
+ erc-nickserv-passwords)))))
+ (when erc-use-auth-source-for-nickserv-password
+ (let* ((secret (nth 0 (auth-source-search
+ :max 1 :require '(:secret)
+ :host (erc-with-server-buffer erc-session-server)
+ :port (format ; ensure we have a string
+ "%s" (erc-with-server-buffer
erc-session-port))
+ :user nickname))))
+ (when secret
+ (let ((passwd (plist-get secret :secret)))
+ (if (functionp passwd) (funcall passwd) passwd)))))))
+
(defun erc-nickserv-call-identify-function (nickname)
"Call `erc-nickserv-identify'.
Either call it interactively or run it with NICKNAME's password,
depending on the value of `erc-prompt-for-nickserv-password'."
(if erc-prompt-for-nickserv-password
(call-interactively 'erc-nickserv-identify)
- (when erc-nickserv-passwords
- (erc-nickserv-identify
- (cdr (assoc nickname
- (nth 1 (assoc (erc-network)
- erc-nickserv-passwords))))))))
+ (erc-nickserv-identify (erc-nickserv-get-password nickname))))
(defvar erc-auto-discard-away)
@@ -451,6 +482,7 @@ When called interactively, read the password using
`read-passwd'."
(provide 'erc-services)
+
;;; erc-services.el ends here
;;
;; Local Variables:
diff --git a/lisp/facemenu.el b/lisp/facemenu.el
index 2609397..dc5f8f4 100644
--- a/lisp/facemenu.el
+++ b/lisp/facemenu.el
@@ -606,9 +606,14 @@ color. The function should accept a single argument, the
color name."
(defun list-colors-print (list &optional callback)
(let ((callback-fn
- (if callback
- `(lambda (button)
- (funcall ,callback (button-get button 'color-name))))))
+ ;; Expect CALLBACK to be a function, but allow it to be a form that
+ ;; evaluates to a function, for backward-compatibility. (Bug#45831)
+ (cond ((functionp callback)
+ (lambda (button)
+ (funcall callback (button-get button 'color-name))))
+ (callback
+ `(lambda (button)
+ (funcall ,callback (button-get button 'color-name)))))))
(dolist (color list)
(if (consp color)
(if (cdr color)
diff --git a/lisp/foldout.el b/lisp/foldout.el
index 771b81e..4c479d6 100644
--- a/lisp/foldout.el
+++ b/lisp/foldout.el
@@ -487,7 +487,7 @@ What happens depends on the number of mouse clicks:-
Signal an error if the final event isn't the same type as the first one."
(let ((initial-event-type (event-basic-type event)))
(while (null (sit-for (/ double-click-time 1000.0) 'nodisplay))
- (setq event (read-event)))
+ (setq event (read--potential-mouse-event)))
(or (eq initial-event-type (event-basic-type event))
(error "")))
event)
diff --git a/lisp/frame.el b/lisp/frame.el
index b378917..010bab4 100644
--- a/lisp/frame.el
+++ b/lisp/frame.el
@@ -2574,13 +2574,15 @@ Use 0 or negative value to blink forever."
This starts the timer `blink-cursor-timer', which makes the cursor blink
if appropriate. It also arranges to cancel that timer when the next
command starts, by installing a pre-command hook."
- (when (null blink-cursor-timer)
+ (cond
+ ((null blink-cursor-mode) (blink-cursor-mode -1))
+ ((null blink-cursor-timer)
;; Set up the timer first, so that if this signals an error,
;; 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)
- (internal-show-cursor nil nil)))
+ (add-hook 'pre-command-hook #'blink-cursor-end)
+ (internal-show-cursor nil nil))))
(defun blink-cursor-timer-function ()
"Timer function of timer `blink-cursor-timer'."
@@ -2594,14 +2596,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)
@@ -2637,7 +2639,7 @@ stopped by `blink-cursor-suspend'. Internally calls
`blink-cursor--should-blink' and returns its result."
(let ((should-blink (blink-cursor--should-blink)))
(when (and should-blink (not blink-cursor-idle-timer))
- (remove-hook 'post-command-hook 'blink-cursor-check)
+ (remove-hook 'post-command-hook #'blink-cursor-check)
(blink-cursor--start-idle-timer))
should-blink))
@@ -2659,18 +2661,18 @@ This command is effective only on graphical frames. On
text-only
terminals, cursor blinking is controlled by the terminal."
:init-value (not (or noninteractive
no-blinking-cursor
- (eq system-type 'ms-dos)
- (not (display-blink-cursor-p))))
- :initialize 'custom-initialize-delay
+ (eq system-type 'ms-dos)))
+ :initialize #'custom-initialize-delay
:group 'cursor
:global t
(blink-cursor-suspend)
(remove-hook 'after-delete-frame-functions #'blink-cursor--rescan-frames)
(remove-function after-focus-change-function #'blink-cursor--rescan-frames)
(when blink-cursor-mode
- (add-function :after after-focus-change-function
#'blink-cursor--rescan-frames)
+ (add-function :after after-focus-change-function
+ #'blink-cursor--rescan-frames)
(add-hook 'after-delete-frame-functions #'blink-cursor--rescan-frames)
- (blink-cursor--start-idle-timer)))
+ (blink-cursor-check)))
;; Frame maximization/fullscreen
diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el
index 56640ea..6866230 100644
--- a/lisp/gnus/gnus-agent.el
+++ b/lisp/gnus/gnus-agent.el
@@ -1789,6 +1789,7 @@ variables. Returns the first non-nil value found."
. gnus-agent-enable-expiration)
(agent-predicate . gnus-agent-predicate)))))))
+;; FIXME: This looks an awful lot like `gnus-agent-retrieve-headers'.
(defun gnus-agent-fetch-headers (group)
"Fetch interesting headers into the agent. The group's overview
file will be updated to include the headers while a list of available
@@ -1810,10 +1811,9 @@ article numbers will be returned."
(cdr active))))
(gnus-uncompress-range (gnus-active group)))
(gnus-list-of-unread-articles group)))
- (gnus-decode-encoded-word-function 'identity)
- (gnus-decode-encoded-address-function 'identity)
(file (gnus-agent-article-name ".overview" group))
- (file-name-coding-system nnmail-pathname-coding-system))
+ (file-name-coding-system nnmail-pathname-coding-system)
+ headers fetched-headers)
(unless fetch-all
;; Add articles with marks to the list of article headers we want to
@@ -1824,7 +1824,7 @@ article numbers will be returned."
(dolist (arts (gnus-info-marks (gnus-get-info group)))
(unless (memq (car arts) '(seen recent killed cache))
(setq articles (gnus-range-add articles (cdr arts)))))
- (setq articles (sort (gnus-uncompress-sequence articles) '<)))
+ (setq articles (sort (gnus-uncompress-range articles) '<)))
;; At this point, I have the list of articles to consider for
;; fetching. This is the list that I'll return to my caller. Some
@@ -1867,38 +1867,52 @@ article numbers will be returned."
10 "gnus-agent-fetch-headers: undownloaded articles are `%s'"
(gnus-compress-sequence articles t)))
- (with-current-buffer nntp-server-buffer
- (if articles
- (progn
- (gnus-message 8 "Fetching headers for %s..." group)
-
- ;; Fetch them.
- (gnus-make-directory (nnheader-translate-file-chars
- (file-name-directory file) t))
-
- (unless (eq 'nov (gnus-retrieve-headers articles group))
- (nnvirtual-convert-headers))
- (gnus-agent-check-overview-buffer)
- ;; Move these headers to the overview buffer so that
- ;; gnus-agent-braid-nov can merge them with the contents
- ;; of FILE.
- (copy-to-buffer
- gnus-agent-overview-buffer (point-min) (point-max))
- ;; NOTE: Call g-a-brand-nov even when the file does not
- ;; exist. As a minimum, it will validate the article
- ;; numbers already in the buffer.
- (gnus-agent-braid-nov articles file)
- (let ((coding-system-for-write
- gnus-agent-file-coding-system))
- (gnus-agent-check-overview-buffer)
- (write-region (point-min) (point-max) file nil 'silent))
- (gnus-agent-update-view-total-fetched-for group t)
- (gnus-agent-save-alist group articles nil)
- articles)
- (ignore-errors
- (erase-buffer)
- (nnheader-insert-file-contents file)))))
- articles))
+ ;; Parse known headers from FILE.
+ (if (file-exists-p file)
+ (with-current-buffer gnus-agent-overview-buffer
+ (erase-buffer)
+ (let ((nnheader-file-coding-system
+ gnus-agent-file-coding-system))
+ (nnheader-insert-nov-file file (car articles))
+ (with-current-buffer nntp-server-buffer
+ (erase-buffer)
+ (insert-buffer-substring gnus-agent-overview-buffer)
+ (setq headers
+ (gnus-get-newsgroup-headers-xover
+ articles nil (buffer-local-value
+ 'gnus-newsgroup-dependencies
+ gnus-summary-buffer)
+ gnus-newsgroup-name)))))
+ (gnus-make-directory (nnheader-translate-file-chars
+ (file-name-directory file) t)))
+
+ ;; Fetch our new headers.
+ (gnus-message 8 "Fetching headers for %s..." group)
+ (if articles
+ (setq fetched-headers (gnus-fetch-headers articles)))
+
+ ;; Merge two sets of headers.
+ (setq headers
+ (if (and headers fetched-headers)
+ (delete-dups
+ (sort (append headers (copy-sequence fetched-headers))
+ (lambda (l r)
+ (< (mail-header-number l)
+ (mail-header-number r)))))
+ (or headers fetched-headers)))
+
+ ;; Save the new set of headers to FILE.
+ (let ((coding-system-for-write
+ gnus-agent-file-coding-system))
+ (with-current-buffer gnus-agent-overview-buffer
+ (goto-char (point-max))
+ (mapc #'nnheader-insert-nov fetched-headers)
+ (sort-numeric-fields 1 (point-min) (point-max))
+ (gnus-agent-check-overview-buffer)
+ (write-region (point-min) (point-max) file nil 'silent))
+ (gnus-agent-update-view-total-fetched-for group t)
+ (gnus-agent-save-alist group articles nil)))
+ headers))
(defsubst gnus-agent-read-article-number ()
"Read the article number at point.
@@ -1924,96 +1938,6 @@ Return nil when a valid article number can not be read."
(set-buffer nntp-server-buffer)
(insert-buffer-substring gnus-agent-overview-buffer b e))))
-(defun gnus-agent-braid-nov (articles file)
- "Merge agent overview data with given file.
-Takes unvalidated headers for ARTICLES from
-`gnus-agent-overview-buffer' and validated headers from the given
-FILE and places the combined valid headers into
-`nntp-server-buffer'. This function can be used, when file
-doesn't exist, to valid the overview buffer."
- (let (start last)
- (set-buffer gnus-agent-overview-buffer)
- (goto-char (point-min))
- (set-buffer nntp-server-buffer)
- (erase-buffer)
- (when (file-exists-p file)
- (nnheader-insert-file-contents file))
- (goto-char (point-max))
- (forward-line -1)
-
- (unless (or (= (point-min) (point-max))
- (< (setq last (read (current-buffer))) (car articles)))
- ;; Old and new overlap -- We do it the hard way.
- (when (nnheader-find-nov-line (car articles))
- ;; Replacing existing NOV entry
- (delete-region (point) (progn (forward-line 1) (point))))
- (gnus-agent-copy-nov-line (pop articles))
-
- (ignore-errors
- (while articles
- (while (let ((art (read (current-buffer))))
- (cond ((< art (car articles))
- (forward-line 1)
- t)
- ((= art (car articles))
- (beginning-of-line)
- (delete-region
- (point) (progn (forward-line 1) (point)))
- nil)
- (t
- (beginning-of-line)
- nil))))
-
- (gnus-agent-copy-nov-line (pop articles)))))
-
- (goto-char (point-max))
-
- ;; Append the remaining lines
- (when articles
- (when last
- (set-buffer gnus-agent-overview-buffer)
- (setq start (point))
- (set-buffer nntp-server-buffer))
-
- (let ((p (point)))
- (insert-buffer-substring gnus-agent-overview-buffer start)
- (goto-char p))
-
- (setq last (or last -134217728))
- (while (catch 'problems
- (let (sort art)
- (while (not (eobp))
- (setq art (gnus-agent-read-article-number))
- (cond ((not art)
- ;; Bad art num - delete this line
- (beginning-of-line)
- (delete-region (point) (progn (forward-line 1)
(point))))
- ((< art last)
- ;; Art num out of order - enable sort
- (setq sort t)
- (forward-line 1))
- ((= art last)
- ;; Bad repeat of art number - delete this line
- (beginning-of-line)
- (delete-region (point) (progn (forward-line 1)
(point))))
- (t
- ;; Good art num
- (setq last art)
- (forward-line 1))))
- (when sort
- ;; something is seriously wrong as we simply shouldn't see
out-of-order data.
- ;; First, we'll fix the sort.
- (sort-numeric-fields 1 (point-min) (point-max))
-
- ;; but now we have to consider that we may have duplicate
rows...
- ;; so reset to beginning of file
- (goto-char (point-min))
- (setq last -134217728)
-
- ;; and throw a code that restarts this scan
- (throw 'problems t))
- nil))))))
-
;; Keeps the compiler from warning about the free variable in
;; gnus-agent-read-agentview.
(defvar gnus-agent-read-agentview)
@@ -2386,10 +2310,9 @@ modified) original contents, they are first saved to
their own file."
(gnus-orphan-score gnus-orphan-score)
;; Maybe some other gnus-summary local variables should also
;; be put here.
-
+ fetched-headers
gnus-headers
gnus-score
- articles
predicate info marks
)
(unless (gnus-check-group group)
@@ -2410,38 +2333,35 @@ modified) original contents, they are first saved to
their own file."
(setq info (gnus-get-info group)))))))
(when arts
(setq marked-articles (nconc (gnus-uncompress-range arts)
- marked-articles))
- ))))
+ marked-articles))))))
(setq marked-articles (sort marked-articles '<))
- ;; Fetch any new articles from the server
- (setq articles (gnus-agent-fetch-headers group))
+ (setq gnus-newsgroup-dependencies
+ (or gnus-newsgroup-dependencies
+ (gnus-make-hashtable)))
- ;; Merge new articles with marked
- (setq articles (sort (append marked-articles articles) '<))
+ ;; Fetch headers for any new articles from the server.
+ (setq fetched-headers (gnus-agent-fetch-headers group))
- (when articles
- ;; Parse them and see which articles we want to fetch.
- (setq gnus-newsgroup-dependencies
- (or gnus-newsgroup-dependencies
- (gnus-make-hashtable (length articles))))
+ (when fetched-headers
(setq gnus-newsgroup-headers
- (or gnus-newsgroup-headers
- (gnus-get-newsgroup-headers-xover articles nil nil
- group)))
- ;; `gnus-agent-overview-buffer' may be killed for
- ;; timeout reason. If so, recreate it.
+ (or gnus-newsgroup-headers
+ fetched-headers)))
+ (when marked-articles
+ ;; `gnus-agent-overview-buffer' may be killed for timeout
+ ;; reason. If so, recreate it.
(gnus-agent-create-buffer)
(setq predicate
- (gnus-get-predicate
- (gnus-agent-find-parameter group 'agent-predicate)))
+ (gnus-get-predicate
+ (gnus-agent-find-parameter group 'agent-predicate)))
+
+ ;; If the selection predicate requires scoring, score each header.
- ;; If the selection predicate requires scoring, score each header
(unless (memq predicate '(gnus-agent-true gnus-agent-false))
(let ((score-param
(gnus-agent-find-parameter group 'agent-score-file)))
- ;; Translate score-param into real one
+ ;; Translate score-param into real one.
(cond
((not score-param))
((eq score-param 'file)
@@ -3661,11 +3581,9 @@ has been fetched."
(defun gnus-agent-retrieve-headers (articles group &optional fetch-old)
(save-excursion
(gnus-agent-create-buffer)
- (let ((gnus-decode-encoded-word-function 'identity)
- (gnus-decode-encoded-address-function 'identity)
- (file (gnus-agent-article-name ".overview" group))
- uncached-articles
- (file-name-coding-system nnmail-pathname-coding-system))
+ (let ((file (gnus-agent-article-name ".overview" group))
+ (file-name-coding-system nnmail-pathname-coding-system)
+ uncached-articles headers fetched-headers)
(gnus-make-directory (nnheader-translate-file-chars
(file-name-directory file) t))
@@ -3676,122 +3594,63 @@ has been fetched."
1)
(car (last articles))))))
- ;; Populate temp buffer with known headers
+ ;; See if we've got cached headers for ARTICLES and put them in
+ ;; HEADERS. Articles with no cached headers go in
+ ;; UNCACHED-ARTICLES to be fetched from the server.
(when (file-exists-p file)
(with-current-buffer gnus-agent-overview-buffer
(erase-buffer)
(let ((nnheader-file-coding-system
gnus-agent-file-coding-system))
- (nnheader-insert-nov-file file (car articles)))))
-
- (if (setq uncached-articles (gnus-agent-uncached-articles articles group
- t))
- (progn
- ;; Populate nntp-server-buffer with uncached headers
- (set-buffer nntp-server-buffer)
- (erase-buffer)
- (cond ((not (eq 'nov (let (gnus-agent) ; Turn off agent
- (gnus-retrieve-headers
- uncached-articles group))))
- (nnvirtual-convert-headers))
- ((eq 'nntp (car gnus-current-select-method))
- ;; The author of gnus-get-newsgroup-headers-xover
- ;; reports that the XOVER command is commonly
- ;; unreliable. The problem is that recently
- ;; posted articles may not be entered into the
- ;; NOV database in time to respond to my XOVER
- ;; query.
- ;;
- ;; I'm going to use his assumption that the NOV
- ;; database is updated in order of ascending
- ;; article ID. Therefore, a response containing
- ;; article ID N implies that all articles from 1
- ;; to N-1 are up-to-date. Therefore, missing
- ;; articles in that range have expired.
-
- (set-buffer nntp-server-buffer)
- (let* ((fetched-articles (list nil))
- (tail-fetched-articles fetched-articles)
- (min (car articles))
- (max (car (last articles))))
-
- ;; Get the list of articles that were fetched
- (goto-char (point-min))
- (let ((pm (point-max))
- art)
- (while (< (point) pm)
- (when (setq art (gnus-agent-read-article-number))
- (gnus-agent-append-to-list tail-fetched-articles
art))
- (forward-line 1)))
-
- ;; Clip this list to the headers that will
- ;; actually be returned
- (setq fetched-articles (gnus-list-range-intersection
- (cdr fetched-articles)
- (cons min max)))
-
- ;; Clip the uncached articles list to exclude
- ;; IDs after the last FETCHED header. The
- ;; excluded IDs may be fetchable using HEAD.
- (if (car tail-fetched-articles)
- (setq uncached-articles
- (gnus-list-range-intersection
- uncached-articles
- (cons (car uncached-articles)
- (car tail-fetched-articles)))))
-
- ;; Create the list of articles that were
- ;; "successfully" fetched. Success, in this
- ;; case, means that the ID should not be
- ;; fetched again. In the case of an expired
- ;; article, the header will not be fetched.
- (setq uncached-articles
- (gnus-sorted-nunion fetched-articles
- uncached-articles))
- )))
-
- ;; Erase the temp buffer
- (set-buffer gnus-agent-overview-buffer)
- (erase-buffer)
-
- ;; Copy the nntp-server-buffer to the temp buffer
- (set-buffer nntp-server-buffer)
- (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max))
-
- ;; Merge the temp buffer with the known headers (found on
- ;; disk in FILE) into the nntp-server-buffer
- (when uncached-articles
- (gnus-agent-braid-nov uncached-articles file))
-
- ;; Save the new set of known headers to FILE
- (set-buffer nntp-server-buffer)
+ (nnheader-insert-nov-file file (car articles))
+ (with-current-buffer nntp-server-buffer
+ (erase-buffer)
+ (insert-buffer-substring gnus-agent-overview-buffer)
+ (setq headers
+ (gnus-get-newsgroup-headers-xover
+ articles nil (buffer-local-value
+ 'gnus-newsgroup-dependencies
+ gnus-summary-buffer)
+ gnus-newsgroup-name))))))
+
+ (setq uncached-articles
+ (gnus-agent-uncached-articles articles group t))
+
+ (when uncached-articles
+ (let ((gnus-newsgroup-name group)
+ gnus-agent) ; Prevent loop.
+ ;; Fetch additional headers for the uncached articles.
+ (setq fetched-headers (gnus-fetch-headers uncached-articles))
+ ;; Merge headers we got from the overview file with our
+ ;; newly-fetched headers.
+ (when fetched-headers
+ (setq headers
+ (delete-dups
+ (sort (append headers (copy-sequence fetched-headers))
+ (lambda (l r)
+ (< (mail-header-number l)
+ (mail-header-number r))))))
+
+ ;; Add the new set of known headers to the overview file.
(let ((coding-system-for-write
gnus-agent-file-coding-system))
- (gnus-agent-check-overview-buffer)
- (write-region (point-min) (point-max) file nil 'silent))
-
- (gnus-agent-update-view-total-fetched-for group t)
-
- ;; Update the group's article alist to include the newly
- ;; fetched articles.
- (gnus-agent-load-alist group)
- (gnus-agent-save-alist group uncached-articles nil)
- )
-
- ;; Copy the temp buffer to the nntp-server-buffer
- (set-buffer nntp-server-buffer)
- (erase-buffer)
- (insert-buffer-substring gnus-agent-overview-buffer)))
-
- (if (and fetch-old
- (not (numberp fetch-old)))
- t ; Don't remove anything.
- (nnheader-nov-delete-outside-range
- (car articles)
- (car (last articles)))
- t)
-
- 'nov))
+ (with-current-buffer gnus-agent-overview-buffer
+ ;; We stick the new headers in at the end, then
+ ;; re-sort the whole buffer with
+ ;; `sort-numeric-fields'. If this turns out to be
+ ;; slow, we could consider a loop to add the headers
+ ;; in sorted order to begin with.
+ (goto-char (point-max))
+ (mapc #'nnheader-insert-nov fetched-headers)
+ (sort-numeric-fields 1 (point-min) (point-max))
+ (gnus-agent-check-overview-buffer)
+ (write-region (point-min) (point-max) file nil 'silent)
+ (gnus-agent-update-view-total-fetched-for group t)
+ ;; Update the group's article alist to include the
+ ;; newly fetched articles.
+ (gnus-agent-load-alist group)
+ (gnus-agent-save-alist group uncached-articles nil))))))
+ headers)))
(defun gnus-agent-request-article (article group)
"Retrieve ARTICLE in GROUP from the agent cache."
diff --git a/lisp/gnus/gnus-async.el b/lisp/gnus/gnus-async.el
index fefd02c..ed948a2 100644
--- a/lisp/gnus/gnus-async.el
+++ b/lisp/gnus/gnus-async.el
@@ -357,8 +357,13 @@ that was fetched."
(let ((nntp-server-buffer (current-buffer))
(nnheader-callback-function
(lambda (_arg)
- (setq gnus-async-header-prefetched
- (cons group unread)))))
+ (setq gnus-async-header-prefetched
+ (cons group unread)))))
+ ;; FIXME: If header prefetch is ever put into use, we'll
+ ;; have to handle the possibility that
+ ;; `gnus-retrieve-headers' might return a list of header
+ ;; vectors directly, rather than writing them into the
+ ;; current buffer.
(gnus-retrieve-headers unread group gnus-fetch-old-headers))))))
(defun gnus-async-retrieve-fetched-headers (articles group)
diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el
index 36657e4..9423d9f 100644
--- a/lisp/gnus/gnus-cache.el
+++ b/lisp/gnus/gnus-cache.el
@@ -294,49 +294,47 @@ it's not cached."
(defun gnus-cache-retrieve-headers (articles group &optional fetch-old)
"Retrieve the headers for ARTICLES in GROUP."
(let ((cached
- (setq gnus-newsgroup-cached (gnus-cache-articles-in-group group))))
+ (setq gnus-newsgroup-cached (gnus-cache-articles-in-group group)))
+ (gnus-newsgroup-name group)
+ (gnus-fetch-old-headers fetch-old))
(if (not cached)
;; No cached articles here, so we just retrieve them
;; the normal way.
(let ((gnus-use-cache nil))
- (gnus-retrieve-headers articles group fetch-old))
+ (gnus-retrieve-headers articles group))
(let ((uncached-articles (gnus-sorted-difference articles cached))
(cache-file (gnus-cache-file-name group ".overview"))
- type
- (file-name-coding-system nnmail-pathname-coding-system))
+ (file-name-coding-system nnmail-pathname-coding-system)
+ headers)
;; We first retrieve all the headers that we don't have in
;; the cache.
(let ((gnus-use-cache nil))
(when uncached-articles
- (setq type (and articles
- (gnus-retrieve-headers
- uncached-articles group fetch-old)))))
+ (setq headers (and articles
+ (gnus-fetch-headers uncached-articles)))))
(gnus-cache-save-buffers)
- ;; Then we insert the cached headers.
- (save-excursion
- (cond
- ((not (file-exists-p cache-file))
- ;; There are no cached headers.
- type)
- ((null type)
- ;; There were no uncached headers (or retrieval was
- ;; unsuccessful), so we use the cached headers exclusively.
- (set-buffer nntp-server-buffer)
- (erase-buffer)
- (let ((coding-system-for-read
- gnus-cache-overview-coding-system))
- (insert-file-contents cache-file))
- 'nov)
- ((eq type 'nov)
- ;; We have both cached and uncached NOV headers, so we
- ;; braid them.
- (gnus-cache-braid-nov group cached)
- type)
- (t
- ;; We braid HEADs.
- (gnus-cache-braid-heads group (gnus-sorted-intersection
- cached articles))
- type)))))))
+ ;; Then we include the cached headers.
+ (when (file-exists-p cache-file)
+ (setq headers
+ (delete-dups
+ (sort
+ (append headers
+ (let ((coding-system-for-read
+ gnus-cache-overview-coding-system))
+ (with-current-buffer nntp-server-buffer
+ (erase-buffer)
+ (insert-file-contents cache-file)
+ (gnus-get-newsgroup-headers-xover
+ (gnus-sorted-difference
+ cached uncached-articles)
+ nil (buffer-local-value
+ 'gnus-newsgroup-dependencies
+ gnus-summary-buffer)
+ group))))
+ (lambda (l r)
+ (< (mail-header-number l)
+ (mail-header-number r)))))))
+ headers))))
(defun gnus-cache-enter-article (&optional n)
"Enter the next N articles into the cache.
@@ -529,70 +527,6 @@ Returns the list of articles removed."
(setq gnus-cache-active-altered t)))
articles)))
-(defun gnus-cache-braid-nov (group cached &optional file)
- (let ((cache-buf (gnus-get-buffer-create " *gnus-cache*"))
- beg end)
- (gnus-cache-save-buffers)
- (with-current-buffer cache-buf
- (erase-buffer)
- (let ((coding-system-for-read gnus-cache-overview-coding-system)
- (file-name-coding-system nnmail-pathname-coding-system))
- (insert-file-contents
- (or file (gnus-cache-file-name group ".overview"))))
- (goto-char (point-min))
- (insert "\n")
- (goto-char (point-min)))
- (set-buffer nntp-server-buffer)
- (goto-char (point-min))
- (while cached
- (while (and (not (eobp))
- (< (read (current-buffer)) (car cached)))
- (forward-line 1))
- (beginning-of-line)
- (set-buffer cache-buf)
- (if (search-forward (concat "\n" (int-to-string (car cached)) "\t")
- nil t)
- (setq beg (point-at-bol)
- end (progn (end-of-line) (point)))
- (setq beg nil))
- (set-buffer nntp-server-buffer)
- (when beg
- (insert-buffer-substring cache-buf beg end)
- (insert "\n"))
- (setq cached (cdr cached)))
- (kill-buffer cache-buf)))
-
-(defun gnus-cache-braid-heads (group cached)
- (let ((cache-buf (gnus-get-buffer-create " *gnus-cache*")))
- (with-current-buffer cache-buf
- (erase-buffer))
- (set-buffer nntp-server-buffer)
- (goto-char (point-min))
- (dolist (entry cached)
- (while (and (not (eobp))
- (looking-at "2.. +\\([0-9]+\\) ")
- (< (progn (goto-char (match-beginning 1))
- (read (current-buffer)))
- entry))
- (search-forward "\n.\n" nil 'move))
- (beginning-of-line)
- (set-buffer cache-buf)
- (erase-buffer)
- (let ((coding-system-for-read gnus-cache-coding-system)
- (file-name-coding-system nnmail-pathname-coding-system))
- (insert-file-contents (gnus-cache-file-name group entry)))
- (goto-char (point-min))
- (insert "220 ")
- (princ (pop cached) (current-buffer))
- (insert " Article retrieved.\n")
- (search-forward "\n\n" nil 'move)
- (delete-region (point) (point-max))
- (forward-char -1)
- (insert ".")
- (set-buffer nntp-server-buffer)
- (insert-buffer-substring cache-buf))
- (kill-buffer cache-buf)))
-
;;;###autoload
(defun gnus-jog-cache ()
"Go through all groups and put the articles into the cache.
diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el
index f7c71f4..00b85f5 100644
--- a/lisp/gnus/gnus-cloud.el
+++ b/lisp/gnus/gnus-cloud.el
@@ -30,6 +30,8 @@
(require 'parse-time)
(require 'nnimap)
+(declare-function gnus-fetch-headers "gnus-sum")
+(defvar gnus-alter-header-function)
(eval-when-compile (require 'epg)) ;; setf-method for `epg-context-armor'
(autoload 'epg-make-context "epg")
@@ -391,8 +393,6 @@ When FULL is t, upload everything, not just a difference
from the last full."
(gnus-group-refresh-group group))
(gnus-error 2 "Failed to upload Gnus Cloud data to %s" group)))))
-(defvar gnus-alter-header-function)
-
(defun gnus-cloud-add-timestamps (elems)
(dolist (elem elems)
(let* ((file-name (plist-get elem :file-name))
@@ -407,14 +407,10 @@ When FULL is t, upload everything, not just a difference
from the last full."
(gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method)
(let* ((group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method))
(active (gnus-active group))
- headers head)
- (when (gnus-retrieve-headers (gnus-uncompress-range active) group)
- (with-current-buffer nntp-server-buffer
- (goto-char (point-min))
- (while (setq head (nnheader-parse-head))
- (when gnus-alter-header-function
- (funcall gnus-alter-header-function head))
- (push head headers))))
+ (gnus-newsgroup-name group)
+ (headers (gnus-fetch-headers (gnus-uncompress-range active))))
+ (when gnus-alter-header-function
+ (mapc gnus-alter-header-function headers))
(sort (nreverse headers)
(lambda (h1 h2)
(> (gnus-cloud-chunk-sequence (mail-header-subject h1))
diff --git a/lisp/gnus/gnus-search.el b/lisp/gnus/gnus-search.el
index 44f43b0..5c6a5b9 100644
--- a/lisp/gnus/gnus-search.el
+++ b/lisp/gnus/gnus-search.el
@@ -1036,7 +1036,7 @@ Responsible for handling and, or, and parenthetical
expressions.")
'(body cc bcc from header keyword larger smaller subject text to uid x-gm-raw
answered before deleted draft flagged on since recent seen sentbefore
senton sentsince unanswered undeleted undraft unflagged unkeyword
- unseen all)
+ unseen all old new or not)
"Known IMAP search keys.")
;; imap interface
@@ -1072,10 +1072,11 @@ Responsible for handling and, or, and parenthetical
expressions.")
;; A bit of backward-compatibility slash convenience: if the
;; query string doesn't start with any known IMAP search
;; keyword, assume it is a "TEXT" search.
- (unless (and (string-match "\\`[^[:blank:]]+" q-string)
- (memql (intern-soft (downcase
- (match-string 0 q-string)))
- gnus-search-imap-search-keys))
+ (unless (or (looking-at "(")
+ (and (string-match "\\`[^[:blank:]]+" q-string)
+ (memql (intern-soft (downcase
+ (match-string 0 q-string)))
+ gnus-search-imap-search-keys)))
(setq q-string (concat "TEXT " q-string)))
;; If it's a thread query, make sure that all message-id
diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el
index b0f9ed4..5bd58b6 100644
--- a/lisp/gnus/gnus-sum.el
+++ b/lisp/gnus/gnus-sum.el
@@ -5658,10 +5658,21 @@ or a straight list of headers."
(setf (mail-header-subject header) subject))))))
(defun gnus-fetch-headers (articles &optional limit force-new dependencies)
- "Fetch headers of ARTICLES."
+ "Fetch headers of ARTICLES.
+This calls the `gnus-retrieve-headers' function of the current
+group's backend server. The server can do one of two things:
+
+1. Write the headers for ARTICLES into the
+ `nntp-server-buffer' (the current buffer) in a parseable format, or
+2. Return the headers directly as a list of vectors.
+
+In the first case, `gnus-retrieve-headers' returns a symbol
+value, either `nov' or `headers'. This value determines which
+parsing function is used to read the headers. It is also stored
+into the variable `gnus-headers-retrieved-by', which is consulted
+later when possibly building full threads."
(gnus-message 7 "Fetching headers for %s..." gnus-newsgroup-name)
- (prog1
- (pcase (setq gnus-headers-retrieved-by
+ (let ((res (setq gnus-headers-retrieved-by
(gnus-retrieve-headers
articles gnus-newsgroup-name
(or limit
@@ -5671,22 +5682,34 @@ or a straight list of headers."
(not (eq gnus-fetch-old-headers 'some))
(not (numberp gnus-fetch-old-headers)))
(> (length articles) 1))
- gnus-fetch-old-headers))))
- ('nov
- (gnus-get-newsgroup-headers-xover
- articles force-new dependencies gnus-newsgroup-name t))
- ('headers
- (gnus-get-newsgroup-headers dependencies force-new))
- ((pred listp)
- (let ((dependencies
- (or dependencies
- (with-current-buffer gnus-summary-buffer
- gnus-newsgroup-dependencies))))
- (delq nil (mapcar #'(lambda (header)
- (gnus-dependencies-add-header
- header dependencies force-new))
- gnus-headers-retrieved-by)))))
- (gnus-message 7 "Fetching headers for %s...done" gnus-newsgroup-name)))
+ gnus-fetch-old-headers))))))
+ (prog1
+ (pcase res
+ ('nov
+ (gnus-get-newsgroup-headers-xover
+ articles force-new dependencies gnus-newsgroup-name t))
+ ;; For now, assume that any backend returning its own
+ ;; headers takes some effort to do so, so return `headers'.
+ ((pred listp)
+ (setq gnus-headers-retrieved-by 'headers)
+ (let ((dependencies
+ (or dependencies
+ (buffer-local-value
+ 'gnus-newsgroup-dependencies gnus-summary-buffer))))
+ (when (functionp gnus-alter-header-function)
+ (mapc gnus-alter-header-function res))
+ (mapc (lambda (header)
+ ;; The agent or the cache may have already
+ ;; registered this header in the dependency
+ ;; table.
+ (unless (gethash (mail-header-id header) dependencies)
+ (gnus-dependencies-add-header
+ header dependencies force-new)))
+ res)
+ res))
+ (_ (gnus-get-newsgroup-headers dependencies force-new)))
+ (gnus-message 7 "Fetching headers for %s...done"
+ gnus-newsgroup-name))))
(defun gnus-select-newsgroup (group &optional read-all select-articles)
"Select newsgroup GROUP.
@@ -6443,6 +6466,10 @@ The resulting hash table is returned, or nil if no Xrefs
were found."
(unless (gnus-ephemeral-group-p group)
(gnus-group-update-group group t))))))
+;; FIXME: Refactor this with `gnus-get-newsgroup-headers-xover' and
+;; extract the necessary bits for the direct-header-return case. Also
+;; look at this and see how similar it is to
+;; `nnheader-parse-naked-head'.
(defun gnus-get-newsgroup-headers (&optional dependencies force-new)
(let ((dependencies
(or dependencies
diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el
index 3b172db..2e9ee71 100644
--- a/lisp/gnus/gnus.el
+++ b/lisp/gnus/gnus.el
@@ -2388,7 +2388,14 @@ Typical marks are those that make no sense in a
standalone back end,
such as a mark that says whether an article is stored in the cache
\(which doesn't make sense in a standalone back end).")
-(defvar gnus-headers-retrieved-by nil)
+(defvar gnus-headers-retrieved-by nil
+ "Holds the return value of `gnus-retrieve-headers'.
+This is either the symbol `nov' or the symbol `headers'. This
+value is checked during the summary creation process, when
+building threads. A value of `nov' indicates that header
+retrieval is relatively cheap and threading is encouraged to
+include more old articles. A value of `headers' indicates that
+retrieval is expensive and should be minimized.")
(defvar gnus-article-reply nil)
(defvar gnus-override-method nil)
(defvar gnus-opened-servers nil)
diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el
index 3ff3d29..b22b454 100644
--- a/lisp/gnus/message.el
+++ b/lisp/gnus/message.el
@@ -620,8 +620,8 @@ Done before generating the new subject of a forward."
(defcustom message-forward-ignored-headers
"^Content-Transfer-Encoding:\\|^X-Gnus"
"All headers that match this regexp will be deleted when forwarding a
message.
-This variable is only consulted when forwarding \"normally\", not
-when forwarding as MIME or the like.
+This variable is not consulted when forwarding encrypted messages
+and `message-forward-show-mml' is `best'.
This may also be a list of regexps."
:version "21.1"
@@ -3057,22 +3057,23 @@ See also `message-forbidden-properties'."
(defun message--syntax-propertize (beg end)
"Syntax-propertize certain message text specially."
- (let ((citation-regexp (concat "^" message-cite-prefix-regexp ".*$"))
- (smiley-regexp (regexp-opt message-smileys)))
- (goto-char beg)
- (while (search-forward-regexp citation-regexp
- end 'noerror)
- (let ((start (match-beginning 0))
- (end (match-end 0)))
- (add-text-properties start (1+ start)
- `(syntax-table ,(string-to-syntax "<")))
- (add-text-properties end (min (1+ end) (point-max))
- `(syntax-table ,(string-to-syntax ">")))))
- (goto-char beg)
- (while (search-forward-regexp smiley-regexp
- end 'noerror)
- (add-text-properties (match-beginning 0) (match-end 0)
- `(syntax-table ,(string-to-syntax "."))))))
+ (with-syntax-table message-mode-syntax-table
+ (let ((citation-regexp (concat "^" message-cite-prefix-regexp ".*$"))
+ (smiley-regexp (regexp-opt message-smileys)))
+ (goto-char beg)
+ (while (search-forward-regexp citation-regexp
+ end 'noerror)
+ (let ((start (match-beginning 0))
+ (end (match-end 0)))
+ (add-text-properties start (1+ start)
+ `(syntax-table ,(string-to-syntax "<")))
+ (add-text-properties end (min (1+ end) (point-max))
+ `(syntax-table ,(string-to-syntax ">")))))
+ (goto-char beg)
+ (while (search-forward-regexp smiley-regexp
+ end 'noerror)
+ (add-text-properties (match-beginning 0) (match-end 0)
+ `(syntax-table ,(string-to-syntax ".")))))))
;;;###autoload
(define-derived-mode message-mode text-mode "Message"
@@ -7638,7 +7639,8 @@ Optional DIGEST will use digest to forward."
message-forward-included-headers)
t nil t)))))
-(defun message-forward-make-body-mime (forward-buffer &optional beg end)
+(defun message-forward-make-body-mime (forward-buffer &optional beg end
+ remove-headers)
(let ((b (point)))
(insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n")
(save-restriction
@@ -7648,6 +7650,8 @@ Optional DIGEST will use digest to forward."
(goto-char (point-min))
(when (looking-at "From ")
(replace-match "X-From-Line: "))
+ (when remove-headers
+ (message-remove-ignored-headers (point-min) (point-max)))
(goto-char (point-max)))
(insert "<#/part>\n")
;; Consider there is no illegible text.
@@ -7786,7 +7790,8 @@ is for the internal use."
(message-signed-or-encrypted-p)
(error t))))))
(message-forward-make-body-mml forward-buffer)
- (message-forward-make-body-mime forward-buffer))
+ (message-forward-make-body-mime
+ forward-buffer nil nil (not (eq message-forward-show-mml 'best))))
(message-forward-make-body-plain forward-buffer)))
(message-position-point))
diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el
index 2b0b61b..61946aa 100644
--- a/lisp/gnus/mm-decode.el
+++ b/lisp/gnus/mm-decode.el
@@ -1264,20 +1264,11 @@ in HANDLE."
(when (and (mm-handle-buffer handle)
(buffer-name (mm-handle-buffer handle)))
(with-temp-buffer
- (if (and (eq (mm-handle-encoding handle) '8bit)
- (with-current-buffer (mm-handle-buffer handle)
- enable-multibyte-characters))
- ;; Due to unfortunate historical reasons, we may have a
- ;; multibyte buffer here, but if it's using an 8bit
- ;; Content-Transfer-Encoding, then work around that by
- ;; just ignoring the situation.
- (insert-buffer-substring (mm-handle-buffer handle))
- ;; Do the decoding.
- (mm-disable-multibyte)
- (insert-buffer-substring (mm-handle-buffer handle))
- (mm-decode-content-transfer-encoding
- (mm-handle-encoding handle)
- (mm-handle-media-type handle)))
+ (mm-disable-multibyte)
+ (insert-buffer-substring (mm-handle-buffer handle))
+ (mm-decode-content-transfer-encoding
+ (mm-handle-encoding handle)
+ (mm-handle-media-type handle))
,@forms))))
(put 'mm-with-part 'lisp-indent-function 1)
(put 'mm-with-part 'edebug-form-spec '(body))
diff --git a/lisp/gnus/nnmaildir.el b/lisp/gnus/nnmaildir.el
index e4fd976..2a4c74d 100644
--- a/lisp/gnus/nnmaildir.el
+++ b/lisp/gnus/nnmaildir.el
@@ -1351,7 +1351,8 @@ This variable is set by `nnmaildir-request-article'.")
(throw 'return nil))
(with-current-buffer (or to-buffer nntp-server-buffer)
(erase-buffer)
- (nnheader-insert-file-contents nnmaildir-article-file-name))
+ (let ((coding-system-for-read mm-text-coding-system))
+ (mm-insert-file-contents nnmaildir-article-file-name)))
(cons gname num-msgid))))
(defun nnmaildir-request-post (&optional _server)
diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el
index 7e10e15..c2bb960 100644
--- a/lisp/gnus/nntp.el
+++ b/lisp/gnus/nntp.el
@@ -1209,7 +1209,7 @@ If SEND-IF-FORCE, only send authinfo to the server if the
(read-passwd (format "NNTP (%s@%s) password: "
user nntp-address)))))))
(if (not result)
- (signal 'nntp-authinfo-rejected "Password rejected")
+ (error "Password rejected")
result))))))
;;; Internal functions.
diff --git a/lisp/gnus/nnvirtual.el b/lisp/gnus/nnvirtual.el
index 1e2feda..ba29343 100644
--- a/lisp/gnus/nnvirtual.el
+++ b/lisp/gnus/nnvirtual.el
@@ -101,15 +101,10 @@ It is computed from the marks of individual component
groups.")
(erase-buffer)
(if (stringp (car articles))
'headers
- (let ((vbuf (nnheader-set-temp-buffer
- (gnus-get-buffer-create " *virtual headers*")))
- (carticles (nnvirtual-partition-sequence articles))
+ (let ((carticles (nnvirtual-partition-sequence articles))
(sysname (system-name))
- cgroup carticle article result prefix)
- (while carticles
- (setq cgroup (caar carticles))
- (setq articles (cdar carticles))
- (pop carticles)
+ cgroup headers all-headers article prefix)
+ (pcase-dolist (`(,cgroup . ,articles) carticles)
(when (and articles
(gnus-check-server
(gnus-find-method-for-group cgroup) t)
@@ -119,69 +114,37 @@ It is computed from the marks of individual component
groups.")
;; This is probably evil if people have set
;; gnus-use-cache to nil themselves, but I
;; have no way of finding the true value of it.
- (let ((gnus-use-cache t))
- (setq result (gnus-retrieve-headers
- articles cgroup nil))))
- (set-buffer nntp-server-buffer)
- ;; If we got HEAD headers, we convert them into NOV
- ;; headers. This is slow, inefficient and, come to think
- ;; of it, downright evil. So sue me. I couldn't be
- ;; bothered to write a header parse routine that could
- ;; parse a mixed HEAD/NOV buffer.
- (when (eq result 'headers)
- (nnvirtual-convert-headers))
- (goto-char (point-min))
- (while (not (eobp))
- (delete-region (point)
- (progn
- (setq carticle (read nntp-server-buffer))
- (point)))
-
- ;; We remove this article from the articles list, if
- ;; anything is left in the articles list after going through
- ;; the entire buffer, then those articles have been
- ;; expired or canceled, so we appropriately update the
- ;; component group below. They should be coming up
- ;; generally in order, so this shouldn't be slow.
- (setq articles (delq carticle articles))
-
- (setq article (nnvirtual-reverse-map-article cgroup carticle))
- (if (null article)
- ;; This line has no reverse mapping, that means it
- ;; was an extra article reference returned by nntp.
- (progn
- (beginning-of-line)
- (delete-region (point) (progn (forward-line 1) (point))))
- ;; Otherwise insert the virtual article number,
- ;; and clean up the xrefs.
- (princ article nntp-server-buffer)
- (nnvirtual-update-xref-header cgroup carticle
- prefix sysname)
- (forward-line 1))
- )
-
- (set-buffer vbuf)
- (goto-char (point-max))
- (insert-buffer-substring nntp-server-buffer))
- ;; Anything left in articles is expired or canceled.
- ;; Could be smart and not tell it about articles already known?
- (when articles
- (gnus-group-make-articles-read cgroup articles))
- )
-
- ;; The headers are ready for reading, so they are inserted into
- ;; the nntp-server-buffer, which is where Gnus expects to find
- ;; them.
- (prog1
- (with-current-buffer nntp-server-buffer
- (erase-buffer)
- (insert-buffer-substring vbuf)
- ;; FIX FIX FIX, we should be able to sort faster than
- ;; this if needed, since each cgroup is sorted, we just
- ;; need to merge
- (sort-numeric-fields 1 (point-min) (point-max))
- 'nov)
- (kill-buffer vbuf)))))))
+ (let ((gnus-use-cache t)
+ (gnus-newsgroup-name cgroup)
+ (gnus-fetch-old-headers nil))
+ (setq headers (gnus-fetch-headers articles))))
+ (erase-buffer)
+ ;; Remove all header article numbers from `articles'.
+ ;; If there's anything left, those are expired or
+ ;; canceled articles, so we update the component group
+ ;; below.
+ (dolist (h headers)
+ (setq articles (delq (mail-header-number h) articles)
+ article (nnvirtual-reverse-map-article
+ cgroup (mail-header-number h)))
+ ;; Update all the header numbers according to their
+ ;; reverse mapping, and drop any with no such mapping.
+ (when article
+ ;; Do this first, before we re-set the header's
+ ;; article number.
+ (nnvirtual-update-xref-header
+ h cgroup prefix sysname)
+ (setf (mail-header-number h) article)
+ (push h all-headers)))
+ ;; Anything left in articles is expired or canceled.
+ ;; Could be smart and not tell it about articles already
+ ;; known?
+ (when articles
+ (gnus-group-make-articles-read cgroup articles))))
+
+ (sort all-headers (lambda (h1 h2)
+ (< (mail-header-number h1)
+ (mail-header-number h2)))))))))
(defvoo nnvirtual-last-accessed-component-group nil)
@@ -372,61 +335,18 @@ It is computed from the marks of individual component
groups.")
;;; Internal functions.
-(defun nnvirtual-convert-headers ()
- "Convert HEAD headers into NOV headers."
- (with-current-buffer nntp-server-buffer
- (let* ((dependencies (make-hash-table :test #'equal))
- (headers (gnus-get-newsgroup-headers dependencies)))
- (erase-buffer)
- (mapc 'nnheader-insert-nov headers))))
-
-
-(defun nnvirtual-update-xref-header (group article prefix sysname)
- "Edit current NOV header in current buffer to have an xref to the component
group, and also server prefix any existing xref lines."
- ;; Move to beginning of Xref field, creating a slot if needed.
- (beginning-of-line)
- (looking-at
- "[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t")
- (goto-char (match-end 0))
- (unless (search-forward "\t" (point-at-eol) 'move)
- (insert "\t"))
-
- ;; Remove any spaces at the beginning of the Xref field.
- (while (eq (char-after (1- (point))) ? )
- (forward-char -1)
- (delete-char 1))
-
- (insert "Xref: " sysname " " group ":")
- (princ article (current-buffer))
- (insert " ")
-
- ;; If there were existing xref lines, clean them up to have the correct
- ;; component server prefix.
- (save-restriction
- (narrow-to-region (point)
- (or (search-forward "\t" (point-at-eol) t)
- (point-at-eol)))
- (goto-char (point-min))
- (when (re-search-forward "Xref: *[^\n:0-9 ]+ *" nil t)
- (replace-match "" t t))
- (goto-char (point-min))
- (when (re-search-forward
- (concat (regexp-quote (gnus-group-real-name group)) ":[0-9]+")
- nil t)
- (replace-match "" t t))
- (unless (eobp)
- (insert " ")
- (when (not (string= "" prefix))
- (while (re-search-forward "[^ ]+:[0-9]+" nil t)
- (save-excursion
- (goto-char (match-beginning 0))
- (insert prefix))))))
-
- ;; Ensure a trailing \t.
- (end-of-line)
- (or (eq (char-after (1- (point))) ?\t)
- (insert ?\t)))
-
+(defun nnvirtual-update-xref-header (header group prefix sysname)
+ "Add xref to component GROUP to HEADER.
+Also add a server PREFIX any existing xref lines."
+ (let ((bits (split-string (mail-header-xref header)
+ nil t "[[:blank:]]"))
+ (art-no (mail-header-number header)))
+ (setf (mail-header-xref header)
+ (concat
+ (format "%s %s:%d " sysname group art-no)
+ (mapconcat (lambda (bit)
+ (concat prefix bit))
+ bits " ")))))
(defun nnvirtual-possibly-change-server (server)
(or (not server)
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index afbb5e3..da90519 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -713,7 +713,9 @@ FILE is the file where FUNCTION was probably defined."
(insert-text-button
(symbol-name group)
'action (lambda (_)
- (shortdoc-display-group group))))
+ (shortdoc-display-group group))
+ 'follow-link t
+ 'help-echo (purecopy "mouse-1, RET: show documentation group")))
groups)
(insert (if (= (length groups) 1)
" group.\n"
@@ -1651,6 +1653,9 @@ in `describe-keymap'. See also `Searching the Active
Keymaps'."
(get-char-property (point) 'local-map)
(current-local-map)))))
+(defvar keymap-name-history nil
+ "History for input to `describe-keymap'.")
+
;;;###autoload
(defun describe-keymap (keymap)
"Describe key bindings in KEYMAP.
diff --git a/lisp/help-mode.el b/lisp/help-mode.el
index cd08b2b..7043f12 100644
--- a/lisp/help-mode.el
+++ b/lisp/help-mode.el
@@ -357,8 +357,7 @@ Commands:
"\\(symbol\\|program\\|property\\)\\|" ; Don't link
"\\(source \\(?:code \\)?\\(?:of\\|for\\)\\)\\)"
"[ \t\n]+\\)?"
- ;; Note starting with word-syntax character:
- "['`‘]\\(\\sw\\(\\sw\\|\\s_\\)+\\|`\\)['’]"))
+ "['`‘]\\(\\(?:\\sw\\|\\s_\\)+\\|`\\)['’]"))
"Regexp matching doc string references to symbols.
The words preceding the quoted symbol can be used in doc strings to
diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el
index 7be1b3d..ed5c9c0 100644
--- a/lisp/ibuf-ext.el
+++ b/lisp/ibuf-ext.el
@@ -1823,18 +1823,12 @@ When BUF nil, default to the buffer at current line."
;;;###autoload
(defun ibuffer-mark-by-file-name-regexp (regexp)
"Mark all buffers whose file name matches REGEXP."
- (interactive "sMark by file name (regexp): ")
+ (interactive (list (read-regexp "Mark by file name (regexp)")))
(ibuffer-mark-on-buffer
- #'(lambda (buf)
- (let ((name (or (buffer-file-name buf)
- (with-current-buffer buf
- (and
- (boundp 'dired-directory)
- (stringp dired-directory)
- dired-directory)))))
- (when name
- ;; Match on the displayed file name (which is abbreviated).
- (string-match regexp (abbreviate-file-name name)))))))
+ (lambda (buf)
+ (when-let ((name (with-current-buffer buf (ibuffer-buffer-file-name))))
+ ;; Match on the displayed file name (which is abbreviated).
+ (string-match-p regexp (ibuffer--abbreviate-file-name name))))))
;;;###autoload
(defun ibuffer-mark-by-content-regexp (regexp &optional all-buffers)
diff --git a/lisp/ibuffer.el b/lisp/ibuffer.el
index 4800e02..84c53b1 100644
--- a/lisp/ibuffer.el
+++ b/lisp/ibuffer.el
@@ -1308,6 +1308,11 @@ a new window in the current frame, splitting vertically."
(car dired-directory)))))
(and dirname (expand-file-name dirname))))))
+(defun ibuffer--abbreviate-file-name (filename)
+ "Abbreviate FILENAME using `ibuffer-directory-abbrev-alist'."
+ (let ((directory-abbrev-alist ibuffer-directory-abbrev-alist))
+ (abbreviate-file-name filename)))
+
(define-ibuffer-op ibuffer-do-save ()
"Save marked buffers as with `save-buffer'."
(:complex t
@@ -1885,9 +1890,7 @@ If point is on a group name, this function operates on
that group."
(cond ((zerop total) "No files")
((= 1 total) "1 file")
(t (format "%d files" total))))))
- (let ((directory-abbrev-alist ibuffer-directory-abbrev-alist))
- (abbreviate-file-name
- (or (ibuffer-buffer-file-name) ""))))
+ (ibuffer--abbreviate-file-name (or (ibuffer-buffer-file-name) "")))
(define-ibuffer-column filename-and-process
(:name "Filename/Process"
diff --git a/lisp/info.el b/lisp/info.el
index 62d7b58..dec9392 100644
--- a/lisp/info.el
+++ b/lisp/info.el
@@ -1973,7 +1973,6 @@ If DIRECTION is `backward', search in the reverse
direction."
"Regexp search%s" (car Info-search-history)
(if case-fold-search "" " case-sensitively"))
nil 'Info-search-history)))
- (deactivate-mark)
(when (equal regexp "")
(setq regexp (car Info-search-history)))
(when regexp
@@ -2066,6 +2065,7 @@ If DIRECTION is `backward', search in the reverse
direction."
(< found opoint-max))
;; Search landed in the same node
(goto-char found)
+ (deactivate-mark)
(widen)
(goto-char found)
(save-match-data (Info-select-node)))
diff --git a/lisp/international/fontset.el b/lisp/international/fontset.el
index 14e7b89..8f0f263 100644
--- a/lisp/international/fontset.el
+++ b/lisp/international/fontset.el
@@ -719,6 +719,7 @@
georgian
cherokee
canadian-aboriginal
+ cham
ogham
runic
symbol
diff --git a/lisp/isearch.el b/lisp/isearch.el
index 67cc7be..a866785 100644
--- a/lisp/isearch.el
+++ b/lisp/isearch.el
@@ -838,10 +838,6 @@ This is like `describe-bindings', but displays only
Isearch keys."
:image '(isearch-tool-bar-image "left-arrow")))
map))
-;; Note: Before adding more key bindings to this map, please keep in
-;; mind that any unbound key exits Isearch and runs the command bound
-;; to it in the local or global map. So in effect every key unbound
-;; in this map is implicitly bound.
(defvar minibuffer-local-isearch-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map minibuffer-local-map)
@@ -2498,6 +2494,21 @@ If search string is empty, just beep."
(unless isearch-mode (isearch-mode t))
(isearch-yank-string (current-kill 0)))
+(defun isearch-yank-from-kill-ring ()
+ "Read a string from the `kill-ring' and append it to the search string."
+ (interactive)
+ (with-isearch-suspended
+ (let ((string (read-from-kill-ring)))
+ (if (and isearch-case-fold-search
+ (eq 'not-yanks search-upper-case))
+ (setq string (downcase string)))
+ (if isearch-regexp (setq string (regexp-quote string)))
+ (setq isearch-yank-flag t)
+ (setq isearch-new-string (concat isearch-string string)
+ isearch-new-message (concat isearch-message
+ (mapconcat
'isearch-text-char-description
+ string ""))))))
+
(defun isearch-yank-pop ()
"Replace just-yanked search string with previously killed string.
Unlike `isearch-yank-pop-only', when this command is called not immediately
@@ -2506,37 +2517,31 @@ minibuffer to read a string from the `kill-ring' as
`yank-pop' does."
(interactive)
(if (not (memq last-command '(isearch-yank-kill
isearch-yank-pop isearch-yank-pop-only)))
- ;; Yank string from kill-ring-browser.
- (with-isearch-suspended
- (let ((string (read-from-kill-ring)))
- (if (and isearch-case-fold-search
- (eq 'not-yanks search-upper-case))
- (setq string (downcase string)))
- (if isearch-regexp (setq string (regexp-quote string)))
- (setq isearch-yank-flag t)
- (setq isearch-new-string (concat isearch-string string)
- isearch-new-message (concat isearch-message
- (mapconcat
'isearch-text-char-description
- string "")))))
+ (isearch-yank-from-kill-ring)
(isearch-pop-state)
(isearch-yank-string (current-kill 1))))
-(defun isearch-yank-pop-only ()
+(defun isearch-yank-pop-only (&optional arg)
"Replace just-yanked search string with previously killed string.
Unlike `isearch-yank-pop', when this command is called not immediately
after a `isearch-yank-kill' or a `isearch-yank-pop-only', it only pops
the last killed string instead of activating the minibuffer to read
-a string from the `kill-ring' as `yank-pop' does."
- (interactive)
- (if (not (memq last-command '(isearch-yank-kill
- isearch-yank-pop isearch-yank-pop-only)))
- ;; Fall back on `isearch-yank-kill' for the benefits of people
- ;; who are used to the old behavior of `M-y' in isearch mode.
- ;; In future, `M-y' could be changed from `isearch-yank-pop-only'
- ;; to `isearch-yank-pop' that uses the kill-ring-browser.
- (isearch-yank-kill)
+a string from the `kill-ring' as `yank-pop' does. The prefix arg C-u
+always reads a string from the `kill-ring' using the minibuffer."
+ (interactive "P")
+ (cond
+ ((equal arg '(4))
+ (isearch-yank-from-kill-ring))
+ ((not (memq last-command '(isearch-yank-kill
+ isearch-yank-pop isearch-yank-pop-only)))
+ ;; Fall back on `isearch-yank-kill' for the benefits of people
+ ;; who are used to the old behavior of `M-y' in isearch mode.
+ ;; In future, `M-y' could be changed from `isearch-yank-pop-only'
+ ;; to `isearch-yank-pop' that uses the kill-ring-browser.
+ (isearch-yank-kill))
+ (t
(isearch-pop-state)
- (isearch-yank-string (current-kill 1))))
+ (isearch-yank-string (current-kill 1)))))
(defun isearch-yank-x-selection ()
"Pull current X selection into search string."
@@ -2997,7 +3002,7 @@ See more for options in `search-exit-option'."
((and (eq (car-safe main-event) 'down-mouse-1)
(window-minibuffer-p (posn-window (event-start main-event))))
;; Swallow the up-event.
- (read-event)
+ (read--potential-mouse-event)
(setq this-command 'isearch-edit-string))
;; Don't terminate the search for motion commands.
((and isearch-yank-on-move
@@ -3752,23 +3757,27 @@ since they have special meaning in a regexp."
(overlay-put isearch-overlay 'priority 1001)
(overlay-put isearch-overlay 'face isearch-face)))
- (when (and search-highlight-submatches
- isearch-regexp)
+ (when (and search-highlight-submatches isearch-regexp)
(mapc 'delete-overlay isearch-submatches-overlays)
(setq isearch-submatches-overlays nil)
- (let ((submatch-data (cddr (butlast match-data)))
+ ;; 'cddr' removes whole expression match from match-data
+ (let ((submatch-data (cddr match-data))
(group 0)
- ov face)
+ b e ov face)
(while submatch-data
- (setq group (1+ group))
- (setq ov (make-overlay (pop submatch-data) (pop submatch-data))
- face (intern-soft (format "isearch-group-%d" group)))
- ;; Recycle faces from beginning.
- (unless (facep face)
- (setq group 1 face 'isearch-group-1))
- (overlay-put ov 'face face)
- (overlay-put ov 'priority 1002)
- (push ov isearch-submatches-overlays)))))
+ (setq b (pop submatch-data)
+ e (pop submatch-data))
+ (when (and (integer-or-marker-p b)
+ (integer-or-marker-p e))
+ (setq ov (make-overlay b e)
+ group (1+ group)
+ face (intern-soft (format "isearch-group-%d" group)))
+ ;; Recycle faces from beginning
+ (unless (facep face)
+ (setq group 1 face 'isearch-group-1))
+ (overlay-put ov 'face face)
+ (overlay-put ov 'priority 1002)
+ (push ov isearch-submatches-overlays))))))
(defun isearch-dehighlight ()
(when isearch-overlay
diff --git a/lisp/language/cham.el b/lisp/language/cham.el
index eef6d6f..089988d 100644
--- a/lisp/language/cham.el
+++ b/lisp/language/cham.el
@@ -34,6 +34,12 @@
(set-language-info-alist
"Cham" '((charset unicode)
(coding-system utf-8)
- (coding-priority utf-8)))
+ (coding-priority utf-8)
+ (input-method . "cham")
+ (sample-text . "Cham (ꨌꩌ)\tꨦꨤꩌ ꨦꨁꨰ")
+ (documentation . "\
+The Cham script is a Brahmic script used to write Cham,
+an Austronesian language spoken by some 245,000 Chams
+in Vietnam and Cambodia.")))
(provide 'cham)
diff --git a/lisp/leim/quail/cham.el b/lisp/leim/quail/cham.el
new file mode 100644
index 0000000..d12ae6c
--- /dev/null
+++ b/lisp/leim/quail/cham.el
@@ -0,0 +1,116 @@
+;;; cham.el --- Quail package for inputting Cham characters -*- coding:
utf-8; lexical-binding:t -*-
+
+;; Copyright (C) 2021 Free Software Foundation, Inc.
+
+;; Author: Eli Zaretskii <eliz@gnu.org>
+;; Keywords: i18n
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file defines the following Cham keyboards:
+;;
+;; - QWERTY-based Cham.
+
+;;; Code:
+
+(require 'quail)
+
+(quail-define-package
+ "cham" "Cham" "ꨌꩌ" t
+ "A QWERTY-based Cham input method."
+ nil t nil nil t nil nil nil nil nil t)
+
+(quail-define-rules
+ ("a" ?ꨀ)
+ ("A" ?ꨄ)
+ ("i" ?ꨁ)
+ ("u" ?ꨂ)
+ ("e" ?ꨃ)
+ ("o" ?ꨅ)
+ ("k" ?ꨆ)
+ ("K" ?ꨇ)
+ ("g" ?ꨈ)
+ ("G" ?ꨉ)
+ ("q" ?ꨊ)
+ ("Q" ?ꨋ)
+ ("c" ?ꨌ)
+ ("C" ?ꨍ)
+ ("j" ?ꨎ)
+ ("J" ?ꨏ)
+ ("z" ?ꨐ)
+ ("Z" ?ꨑ)
+ ("zz" ?ꨒ)
+ ("t" ?ꨓ)
+ ("T" ?ꨔ)
+ ("d" ?ꨕ)
+ ("D" ?ꨖ)
+ ("n" ?ꨗ)
+ ("N" ?ꨘ)
+ ("p" ?ꨚ)
+ ("P" ?ꨛ)
+ ("f" ?ꨜ)
+ ("b" ?ꨝ)
+ ("B" ?ꨞ)
+ ("m" ?ꨟ)
+ ("M" ?ꨠ)
+ ("mm" ?ꨡ)
+ ("y" ?ꨢ)
+ ("r" ?ꨣ)
+ ("l" ?ꨤ)
+ ("w" ?ꨥ)
+ ("v" ?ꨥ)
+ ("x" ?ꨦ)
+ ("s" ?ꨧ)
+ ("h" ?ꨨ)
+ ("kk" ?ꩀ)
+ ("ww" ?ꩁ)
+ ("vv" ?ꩁ)
+ ("qq" ?ꩂ)
+ ("cc" ?ꩄ)
+ ("tt" ?ꩅ)
+ ("nn" ?ꩆ)
+ ("pp" ?ꩇ)
+ ("yy" ?ꩈ)
+ ("rr" ?ꩉ)
+ ("ll" ?ꩊ)
+ ("gg" ?ꩊ)
+ ("xx" ?ꩋ)
+ ("." ?ꩌ)
+ ("H" ?ꩍ)
+ ("0" ?꩐)
+ ("1" ?꩑)
+ ("2" ?꩒)
+ ("3" ?꩓)
+ ("4" ?꩔)
+ ("5" ?꩕)
+ ("6" ?꩖)
+ ("7" ?꩗)
+ ("8" ?꩘)
+ ("9" ?꩙)
+ ("!" ?ꨩ)
+ ("#" ?ꨪ)
+ ("$" ?ꨫ)
+ ("^" ?ꨬ)
+ ("&" ?ꨮ)
+ ("`" ?꩜)
+ ("=" ?ꨱ)
+ ("-" ?ꩃ)
+ ("~" ?꩟)
+ )
+
+;;; cham.el ends here
diff --git a/lisp/mail/rmailedit.el b/lisp/mail/rmailedit.el
index 2680ed7..c3b351d 100644
--- a/lisp/mail/rmailedit.el
+++ b/lisp/mail/rmailedit.el
@@ -145,8 +145,9 @@ This function runs the hooks `text-mode-hook' and
`rmail-edit-mode-hook'.
(declare-function rmail-summary-enable "rmailsum" ())
(declare-function rmail-summary-update-line "rmailsum" (n))
-(defun rmail-cease-edit ()
- "Finish editing message; switch back to Rmail proper."
+(defun rmail-cease-edit (&optional abort)
+ "Finish editing message; switch back to Rmail proper.
+If ABORT, this is the result of aborting an edit."
(interactive)
(if (rmail-summary-exists)
(with-current-buffer rmail-summary-buffer
@@ -271,6 +272,8 @@ This function runs the hooks `text-mode-hook' and
`rmail-edit-mode-hook'.
;; No match for rmail-mime-charset-pattern, but there was some
;; other Content-Type. We should not insert another. (Bug#4624)
(content-type)
+ ;; Don't insert anything if aborting.
+ (abort)
((null old-coding)
;; If there was no charset= spec, insert one.
(backward-char 1)
@@ -352,7 +355,7 @@ This function runs the hooks `text-mode-hook' and
`rmail-edit-mode-hook'.
(widen)
(delete-region (point-min) (point-max))
(insert rmail-old-text)
- (rmail-cease-edit)
+ (rmail-cease-edit t)
(rmail-highlight-headers))
(defun rmail-edit-headers-alist (&optional widen markers)
diff --git a/lisp/mail/rmailsum.el b/lisp/mail/rmailsum.el
index 60b67ed..d29115a 100644
--- a/lisp/mail/rmailsum.el
+++ b/lisp/mail/rmailsum.el
@@ -51,10 +51,10 @@ Setting this option to nil might speed up the generation of
summaries."
:group 'rmail-summary)
(defvar rmail-summary-font-lock-keywords
- '(("^.....D.*" . font-lock-string-face) ; Deleted.
- ("^.....-.*" . font-lock-type-face) ;
Unread.
+ '(("^ *[0-9]+D.*" . font-lock-string-face) ; Deleted.
+ ("^ *[0-9]+-.*" . font-lock-type-face) ; Unread.
;; Neither of the below will be highlighted if either of the above are:
- ("^.....[^D-] \\(......\\)" 1 font-lock-keyword-face) ; Date.
+ ("^ *[0-9]+[^D-] \\(......\\)" 1 font-lock-keyword-face) ; Date.
("{ \\([^\n}]+\\) }" 1 font-lock-comment-face)) ; Labels.
"Additional expressions to highlight in Rmail Summary mode.")
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index 556f5d3..315f2d3 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -2125,8 +2125,10 @@ variables.")
;; A better solution would be to make deactivate-mark buffer-local
;; (or to turn it into a list of buffers, ...), but in the mean time,
;; this should do the trick in most cases.
- (setq deactivate-mark nil)
- (throw 'exit nil))
+ (when (innermost-minibuffer-p)
+ (setq deactivate-mark nil)
+ (throw 'exit nil))
+ (error "%s" "Not in most nested minibuffer"))
(defun self-insert-and-exit ()
"Terminate minibuffer input."
@@ -2394,7 +2396,7 @@ The completion method is determined by
`completion-at-point-functions'."
;;; Key bindings.
(let ((map minibuffer-local-map))
- (define-key map "\C-g" 'abort-recursive-edit)
+ (define-key map "\C-g" 'abort-minibuffers)
(define-key map "\M-<" 'minibuffer-beginning-of-buffer)
(define-key map "\r" 'exit-minibuffer)
diff --git a/lisp/mouse-drag.el b/lisp/mouse-drag.el
index f661260..907ef06 100644
--- a/lisp/mouse-drag.el
+++ b/lisp/mouse-drag.el
@@ -225,7 +225,7 @@ To test this function, evaluate:
;; Don't change the mouse pointer shape while we drag.
(setq track-mouse 'dragging)
(while (progn
- (setq event (read-event)
+ (setq event (read--potential-mouse-event)
end (event-end event)
row (cdr (posn-col-row end))
col (car (posn-col-row end)))
@@ -286,7 +286,7 @@ To test this function, evaluate:
window-last-col (- (window-width) 2))
(track-mouse
(while (progn
- (setq event (read-event)
+ (setq event (read--potential-mouse-event)
end (event-end event)
row (cdr (posn-col-row end))
col (car (posn-col-row end)))
diff --git a/lisp/mouse.el b/lisp/mouse.el
index 0da8288..8732fb8 100644
--- a/lisp/mouse.el
+++ b/lisp/mouse.el
@@ -1792,7 +1792,7 @@ The function returns a non-nil value if it creates a
secondary selection."
(let (event end end-point)
(track-mouse
(while (progn
- (setq event (read-event))
+ (setq event (read--potential-mouse-event))
(or (mouse-movement-p event)
(memq (car-safe event) '(switch-frame select-window))))
diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el
index 3f3e713..0ce65a3 100644
--- a/lisp/net/nsm.el
+++ b/lisp/net/nsm.el
@@ -239,7 +239,7 @@ otherwise."
(mapc
(lambda (info)
(let ((local-ip (nth 1 info))
- (mask (nth 2 info)))
+ (mask (nth 3 info)))
(when
(nsm-network-same-subnet (substring local-ip 0 -1)
(substring mask 0 -1)
diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el
index c0c215d..2c4ef2a 100644
--- a/lisp/net/tramp-adb.el
+++ b/lisp/net/tramp-adb.el
@@ -98,6 +98,7 @@ It is used for TCP/IP devices."
`(,tramp-adb-method
(tramp-login-program ,tramp-adb-program)
(tramp-login-args (("shell")))
+ (tramp-direct-async t)
(tramp-tmpdir "/data/local/tmp")
(tramp-default-port 5555)))
@@ -895,8 +896,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are
completely ignored."
;; terminated.
(defun tramp-adb-handle-make-process (&rest args)
"Like `make-process' for Tramp files.
-If connection property \"direct-async-process\" is non-nil, an
-alternative implementation will be used."
+If method parameter `tramp-direct-async' and connection property
+\"direct-async-process\" are non-nil, an alternative
+implementation will be used."
(if (tramp-direct-async-process-p args)
(apply #'tramp-handle-make-process args)
(when args
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index b43b448..618a9fb 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -168,6 +168,7 @@ The string is used in `tramp-methods'.")
(tramp-login-args (("-l" "%u") ("-p" "%p") ("%c")
("-e" "none") ("%h")))
(tramp-async-args (("-q")))
+ (tramp-direct-async t)
(tramp-remote-shell ,tramp-default-remote-shell)
(tramp-remote-shell-login ("-l"))
(tramp-remote-shell-args ("-c"))
@@ -183,6 +184,7 @@ The string is used in `tramp-methods'.")
("-e" "none") ("-t" "-t") ("%h")
("%l")))
(tramp-async-args (("-q")))
+ (tramp-direct-async t)
(tramp-remote-shell ,tramp-default-remote-shell)
(tramp-remote-shell-login ("-l"))
(tramp-remote-shell-args ("-c"))
@@ -197,6 +199,7 @@ The string is used in `tramp-methods'.")
(tramp-login-args (("-l" "%u") ("-p" "%p") ("%c")
("-e" "none") ("%h")))
(tramp-async-args (("-q")))
+ (tramp-direct-async t)
(tramp-remote-shell ,tramp-default-remote-shell)
(tramp-remote-shell-login ("-l"))
(tramp-remote-shell-args ("-c"))
@@ -227,6 +230,7 @@ The string is used in `tramp-methods'.")
(tramp-login-args (("-l" "%u") ("-p" "%p") ("%c")
("-e" "none") ("%h")))
(tramp-async-args (("-q")))
+ (tramp-direct-async t)
(tramp-remote-shell ,tramp-default-remote-shell)
(tramp-remote-shell-login ("-l"))
(tramp-remote-shell-args ("-c"))))
@@ -237,6 +241,7 @@ The string is used in `tramp-methods'.")
("-e" "none") ("-t" "-t") ("%h")
("%l")))
(tramp-async-args (("-q")))
+ (tramp-direct-async t)
(tramp-remote-shell ,tramp-default-remote-shell)
(tramp-remote-shell-login ("-l"))
(tramp-remote-shell-args ("-c"))))
@@ -2601,14 +2606,13 @@ The method used must be an out-of-band method."
(t nil)))))))))
(defun tramp-sh-handle-insert-directory
- (filename switches &optional wildcard full-directory-p)
+ (filename switches &optional wildcard full-directory-p)
"Like `insert-directory' for Tramp files."
- (setq filename (expand-file-name filename))
(unless switches (setq switches ""))
;; Check, whether directory is accessible.
(unless wildcard
(access-file filename "Reading directory"))
- (with-parsed-tramp-file-name filename nil
+ (with-parsed-tramp-file-name (expand-file-name filename) nil
(if (and (featurep 'ls-lisp)
(not (symbol-value 'ls-lisp-use-insert-directory-program)))
(tramp-handle-insert-directory
@@ -2636,66 +2640,63 @@ The method used must be an out-of-band method."
v 4 "Inserting directory `ls %s %s', wildcard %s, fulldir %s"
switches filename (if wildcard "yes" "no")
(if full-directory-p "yes" "no"))
- ;; If `full-directory-p', we just say `ls -l FILENAME'.
- ;; Else we chdir to the parent directory, then say `ls -ld BASENAME'.
+ ;; If `full-directory-p', we just say `ls -l FILENAME'. Else we
+ ;; chdir to the parent directory, then say `ls -ld BASENAME'.
(if full-directory-p
(tramp-send-command
- v
- (format "%s %s %s 2>%s"
- (tramp-get-ls-command v)
- switches
- (if wildcard
- localname
- (tramp-shell-quote-argument (concat localname ".")))
- (tramp-get-remote-null-device v)))
+ v (format "%s %s %s 2>%s"
+ (tramp-get-ls-command v)
+ switches
+ (if wildcard
+ localname
+ (tramp-shell-quote-argument (concat localname ".")))
+ (tramp-get-remote-null-device v)))
(tramp-barf-unless-okay
- v
- (format "cd %s" (tramp-shell-quote-argument
- (tramp-run-real-handler
- #'file-name-directory (list localname))))
+ v (format "cd %s" (tramp-shell-quote-argument
+ (tramp-run-real-handler
+ #'file-name-directory (list localname))))
"Couldn't `cd %s'"
(tramp-shell-quote-argument
(tramp-run-real-handler #'file-name-directory (list localname))))
(tramp-send-command
- v
- (format "%s %s %s 2>%s"
- (tramp-get-ls-command v)
- switches
- (if (or wildcard
- (zerop (length
- (tramp-run-real-handler
- #'file-name-nondirectory (list localname)))))
- ""
- (tramp-shell-quote-argument
- (tramp-run-real-handler
- #'file-name-nondirectory (list localname))))
- (tramp-get-remote-null-device v))))
-
- (save-restriction
- (let ((beg (point))
- (emc enable-multibyte-characters))
- (narrow-to-region (point) (point))
- ;; We cannot use `insert-buffer-substring' because the Tramp
- ;; buffer changes its contents before insertion due to calling
- ;; `expand-file-name' and alike.
- (insert
- (with-current-buffer (tramp-get-buffer v)
- (buffer-string)))
-
- ;; Check for "--dired" output. We must enable unibyte
- ;; strings, because the "--dired" output counts in bytes.
- (set-buffer-multibyte nil)
+ v (format "%s %s %s 2>%s"
+ (tramp-get-ls-command v)
+ switches
+ (if (or wildcard
+ (zerop (length
+ (tramp-run-real-handler
+ #'file-name-nondirectory (list
localname)))))
+ ""
+ (tramp-shell-quote-argument
+ (tramp-run-real-handler
+ #'file-name-nondirectory (list localname))))
+ (tramp-get-remote-null-device v))))
+
+ (let ((beg-marker (copy-marker (point) nil))
+ (end-marker (copy-marker (point) t))
+ (emc enable-multibyte-characters))
+ ;; We cannot use `insert-buffer-substring' because the Tramp
+ ;; buffer changes its contents before insertion due to calling
+ ;; `expand-file-name' and alike.
+ (insert (with-current-buffer (tramp-get-buffer v) (buffer-string)))
+
+ ;; We must enable unibyte strings, because the "--dired"
+ ;; output counts in bytes.
+ (set-buffer-multibyte nil)
+ (save-restriction
+ (narrow-to-region beg-marker end-marker)
+ ;; Check for "--dired" output.
(forward-line -2)
(when (looking-at-p "//SUBDIRED//")
(forward-line -1))
(when (looking-at "//DIRED//\\s-+")
- (let ((databeg (match-end 0))
+ (let ((beg (match-end 0))
(end (point-at-eol)))
;; Now read the numeric positions of file names.
- (goto-char databeg)
+ (goto-char beg)
(while (< (point) end)
- (let ((start (+ beg (read (current-buffer))))
- (end (+ beg (read (current-buffer)))))
+ (let ((start (+ (point-min) (read (current-buffer))))
+ (end (+ (point-min) (read (current-buffer)))))
(if (memq (char-after end) '(?\n ?\ ))
;; End is followed by \n or by " -> ".
(put-text-property start end 'dired-filename t))))))
@@ -2703,18 +2704,18 @@ The method used must be an out-of-band method."
(goto-char (point-at-bol))
(while (looking-at "//")
(forward-line 1)
- (delete-region (match-beginning 0) (point)))
- ;; Reset multibyte if needed.
- (set-buffer-multibyte emc)
+ (delete-region (match-beginning 0) (point))))
+ ;; Reset multibyte if needed.
+ (set-buffer-multibyte emc)
+ (save-restriction
+ (narrow-to-region beg-marker end-marker)
;; Some busyboxes are reluctant to discard colors.
(unless
(string-match-p "color" (tramp-get-connection-property v "ls" ""))
- (save-excursion
- (goto-char beg)
- (while
- (re-search-forward tramp-display-escape-sequence-regexp nil t)
- (replace-match ""))))
+ (goto-char (point-min))
+ (while (re-search-forward tramp-display-escape-sequence-regexp nil
t)
+ (replace-match "")))
;; Now decode what read if necessary. Stolen from
`insert-directory'.
(let ((coding (or coding-system-for-read
@@ -2729,36 +2730,32 @@ The method used must be an out-of-band method."
;; If no coding system is specified or detection is
;; requested, detect the coding.
(if (eq (coding-system-base coding) 'undecided)
- (setq coding (detect-coding-region beg (point) t)))
- (if (not (eq (coding-system-base coding) 'undecided))
- (save-restriction
- (setq coding-no-eol
- (coding-system-change-eol-conversion coding 'unix))
- (narrow-to-region beg (point))
- (goto-char (point-min))
- (while (not (eobp))
- (setq pos (point)
- val (get-text-property (point) 'dired-filename))
- (goto-char (next-single-property-change
- (point) 'dired-filename nil (point-max)))
- ;; Force no eol conversion on a file name, so
- ;; that CR is preserved.
- (decode-coding-region pos (point)
- (if val coding-no-eol coding))
- (if val
- (put-text-property pos (point)
- 'dired-filename t)))))))
+ (setq coding (detect-coding-region (point-min) (point) t)))
+ (unless (eq (coding-system-base coding) 'undecided)
+ (setq coding-no-eol
+ (coding-system-change-eol-conversion coding 'unix))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (setq pos (point)
+ val (get-text-property (point) 'dired-filename))
+ (goto-char (next-single-property-change
+ (point) 'dired-filename nil (point-max)))
+ ;; Force no eol conversion on a file name, so that
+ ;; CR is preserved.
+ (decode-coding-region
+ pos (point) (if val coding-no-eol coding))
+ (if val (put-text-property pos (point) 'dired-filename t))))))
;; The inserted file could be from somewhere else.
(when (and (not wildcard) (not full-directory-p))
(goto-char (point-max))
(when (file-symlink-p filename)
- (goto-char (search-backward "->" beg 'noerror)))
+ (goto-char (search-backward "->" (point-min) 'noerror)))
(search-backward
(if (directory-name-p filename)
"."
(file-name-nondirectory filename))
- beg 'noerror)
+ (point-min) 'noerror)
(replace-match (file-relative-name filename) t))
;; Try to insert the amount of free space.
@@ -2769,9 +2766,11 @@ The method used must be an out-of-band method."
;; Replace "total" with "total used", to avoid confusion.
(replace-match "\\1 used in directory")
(end-of-line)
- (insert " available " available)))
+ (insert " available " available))))
- (goto-char (point-max)))))))
+ (prog1 (goto-char end-marker)
+ (set-marker beg-marker nil)
+ (set-marker end-marker nil))))))
;; Canonicalization of file names.
@@ -2840,9 +2839,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
@@ -4306,11 +4305,14 @@ file exists and nonzero exit status otherwise."
;; ensure they have the correct values when the shell starts, not
;; just processes run within the shell. (Which processes include
;; our initial probes to ensure the remote shell is usable.)
+ ;; For the time being, we assume that all shells interpret -i as
+ ;; interactive shell. Must be the last argument, because (for
+ ;; example) bash expects long options first.
(tramp-send-command
vec (format
(concat
"exec env TERM='%s' INSIDE_EMACS='%s,tramp:%s' "
- "ENV=%s %s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s")
+ "ENV=%s %s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s -i")
tramp-terminal-type
(or (getenv "INSIDE_EMACS") emacs-version) tramp-version
(or (getenv-internal "ENV" tramp-remote-process-environment) "")
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index cc8dda8..2816c58 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -259,9 +259,9 @@ pair of the form (KEY VALUE). The following KEYs are
defined:
parameters to suppress diagnostic messages, in order not to
tamper the process output.
- * `tramp-direct-async-args'
- An additional argument when a direct asynchronous process is
- started. Used so far only in the \"mock\" method of tramp-tests.el.
+ * `tramp-direct-async'
+ Whether the method supports direct asynchronous processes.
+ Until now, just \"ssh\"-based and \"adb\"-based methods do.
* `tramp-copy-program'
This specifies the name of the program to use for remotely copying
@@ -1755,7 +1755,8 @@ The outline level is equal to the verbosity of the Tramp
message."
Message is formatted with FMT-STRING as control string and the remaining
ARGUMENTS to actually emit the message (if applicable)."
(let ((inhibit-message t)
- file-name-handler-alist message-log-max signal-hook-function)
+ create-lockfiles file-name-handler-alist message-log-max
+ signal-hook-function)
(with-current-buffer (tramp-get-debug-buffer vec)
(goto-char (point-max))
(let ((point (point)))
@@ -1982,6 +1983,13 @@ the resulting error message."
(put #'tramp-with-demoted-errors 'tramp-suppress-trace t)
+(defun tramp-test-message (fmt-string &rest arguments)
+ "Emit a Tramp message according `default-directory'."
+ (if (tramp-tramp-file-p default-directory)
+ (apply #'tramp-message
+ (tramp-dissect-file-name default-directory) 0 fmt-string arguments)
+ (apply #'message fmt-string arguments)))
+
;; This function provides traces in case of errors not triggered by
;; Tramp functions.
(defun tramp-signal-hook-function (error-symbol data)
@@ -3741,7 +3749,9 @@ User is always nil."
(let ((v (tramp-dissect-file-name default-directory))
(buffer (plist-get args :buffer))
(stderr (plist-get args :stderr)))
- (and ;; It has been indicated.
+ (and ;; The method supports it.
+ (tramp-get-method-parameter v 'tramp-direct-async)
+ ;; It has been indicated.
(tramp-get-connection-property v "direct-async-process" nil)
;; There's no multi-hop.
(or (not (tramp-multi-hop-p v))
@@ -3821,8 +3831,6 @@ It does not support `:stderr'."
(tramp-get-method-parameter v 'tramp-login-args))
(async-args
(tramp-get-method-parameter v 'tramp-async-args))
- (direct-async-args
- (tramp-get-method-parameter v 'tramp-direct-async-args))
;; We don't create the temporary file. In fact, it
;; is just a prefix for the ControlPath option of
;; ssh; the real temporary file has another name, and
@@ -3850,7 +3858,7 @@ It does not support `:stderr'."
?h (or host "") ?u (or user "") ?p (or port "")
?c options ?l "")
;; Add arguments for asynchronous processes.
- login-args (append async-args direct-async-args login-args)
+ login-args (append async-args login-args)
;; Expand format spec.
login-args
(tramp-compat-flatten-tree
diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el
index 714b3f9..ced3e93 100644
--- a/lisp/net/trampver.el
+++ b/lisp/net/trampver.el
@@ -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)))
diff --git a/lisp/nxml/nxml-mode.el b/lisp/nxml/nxml-mode.el
index 5bc3049..0602943 100644
--- a/lisp/nxml/nxml-mode.el
+++ b/lisp/nxml/nxml-mode.el
@@ -54,26 +54,30 @@
"Non-nil means display glyph following character reference.
The glyph is displayed in face `nxml-glyph'."
:group 'nxml
- :type 'boolean)
+ :type 'boolean
+ :safe #'booleanp)
(defcustom nxml-sexp-element-flag t
"Non-nil means sexp commands treat an element as a single expression."
:version "27.1" ; nil -> t
:group 'nxml
- :type 'boolean)
+ :type 'boolean
+ :safe #'booleanp)
(defcustom nxml-slash-auto-complete-flag nil
"Non-nil means typing a slash automatically completes the end-tag.
This is used by `nxml-electric-slash'."
:group 'nxml
- :type 'boolean)
+ :type 'boolean
+ :safe #'booleanp)
(defcustom nxml-child-indent 2
"Indentation for the children of an element relative to the start-tag.
This only applies when the line or lines containing the start-tag contains
nothing else other than that start-tag."
:group 'nxml
- :type 'integer)
+ :type 'integer
+ :safe #'integerp)
(defcustom nxml-attribute-indent 4
"Indentation for the attributes of an element relative to the start-tag.
@@ -81,12 +85,14 @@ This only applies when the first attribute of a tag starts
a line.
In other cases, the first attribute on one line is indented the same
as the first attribute on the previous line."
:group 'nxml
- :type 'integer)
+ :type 'integer
+ :safe #'integerp)
(defcustom nxml-bind-meta-tab-to-complete-flag t
"Non-nil means to use nXML completion in \\[completion-at-point]."
:group 'nxml
- :type 'boolean)
+ :type 'boolean
+ :safe #'booleanp)
(defcustom nxml-prefer-utf-16-to-utf-8-flag nil
"Non-nil means prefer UTF-16 to UTF-8 when saving a buffer.
@@ -94,7 +100,8 @@ This is used only when a buffer does not contain an encoding
declaration
and when its current `buffer-file-coding-system' specifies neither UTF-16
nor UTF-8."
:group 'nxml
- :type 'boolean)
+ :type 'boolean
+ :safe #'booleanp)
(defcustom nxml-prefer-utf-16-little-to-big-endian-flag (eq system-type
'windows-nt)
@@ -103,7 +110,8 @@ This is used only for saving a buffer; when reading the
byte-order is
auto-detected. It may be relevant both when there is no encoding declaration
and when the encoding declaration specifies `UTF-16'."
:group 'nxml
- :type 'boolean)
+ :type 'boolean
+ :safe #'booleanp)
(defcustom nxml-default-buffer-file-coding-system nil
"Default value for `buffer-file-coding-system' for a buffer for a new file.
@@ -112,13 +120,15 @@ A value of nil means use the default value of
A buffer's `buffer-file-coding-system' affects what
\\[nxml-insert-xml-declaration] inserts."
:group 'nxml
- :type 'coding-system)
+ :type 'coding-system
+ :safe #'coding-system-p)
(defcustom nxml-auto-insert-xml-declaration-flag nil
"Non-nil means automatically insert an XML declaration in a new file.
The XML declaration is inserted using `nxml-insert-xml-declaration'."
:group 'nxml
- :type 'boolean)
+ :type 'boolean
+ :safe #'booleanp)
(defface nxml-delimited-data
'((t (:inherit font-lock-doc-face)))
diff --git a/lisp/obsolete/nnir.el b/lisp/obsolete/nnir.el
index 147efed..0b7d1e4 100644
--- a/lisp/obsolete/nnir.el
+++ b/lisp/obsolete/nnir.el
@@ -504,7 +504,6 @@ Add an entry here when adding a new search engine.")
,@(mapcar (lambda (elem) (list 'const (car elem)))
nnir-engines)))))
-
(defmacro nnir-add-result (dirnam artno score prefix server artlist)
"Construct a result vector and add it to ARTLIST.
DIRNAM, ARTNO, SCORE, PREFIX and SERVER are passed to
diff --git a/lisp/pixel-scroll.el b/lisp/pixel-scroll.el
index cc0e159..68dc0fb 100644
--- a/lisp/pixel-scroll.el
+++ b/lisp/pixel-scroll.el
@@ -132,8 +132,10 @@ This is an alternative of `scroll-up'. Scope moves
downward."
(pixel-line-height))))
(if (pixel-eob-at-top-p) ; when end-of-the-buffer is close
(scroll-up 1) ; relay on robust method
- (while (pixel-point-at-top-p amt) ; prevent too late (multi tries)
- (vertical-motion 1)) ; move point downward
+ (catch 'no-movement
+ (while (pixel-point-at-top-p amt) ; prevent too late (multi tries)
+ (unless (>= (vertical-motion 1) 1) ; move point downward
+ (throw 'no-movement nil)))) ; exit loop when point did not move
(pixel-scroll-pixel-up amt)))))) ; move scope downward
(defun pixel-scroll-down (&optional arg)
@@ -149,8 +151,10 @@ This is and alternative of `scroll-down'. Scope moves
upward."
pixel-resolution-fine-flag
(frame-char-height))
(pixel-line-height -1))))
- (while (pixel-point-at-bottom-p amt) ; prevent too late (multi tries)
- (vertical-motion -1)) ; move point upward
+ (catch 'no-movement
+ (while (pixel-point-at-bottom-p amt) ; prevent too late (multi tries)
+ (unless (<= (vertical-motion -1) -1) ; move point upward
+ (throw 'no-movement nil)))) ; exit loop when point did not move
(if (or (pixel-bob-at-top-p amt) ; when beginning-of-the-buffer is seen
(pixel-eob-at-top-p)) ; for file with a long line
(scroll-down 1) ; relay on robust method
diff --git a/lisp/progmodes/perl-mode.el b/lisp/progmodes/perl-mode.el
index 2a2a497..d047dd5 100644
--- a/lisp/progmodes/perl-mode.el
+++ b/lisp/progmodes/perl-mode.el
@@ -95,6 +95,12 @@
:prefix "perl-"
:group 'languages)
+(defface perl-non-scalar-variable
+ '((t :inherit font-lock-variable-name-face :underline t))
+ "Face used for non-scalar variables."
+ :version "28.1"
+ :group 'perl)
+
(defvar perl-mode-abbrev-table nil
"Abbrev table in use in perl-mode buffers.")
(define-abbrev-table 'perl-mode-abbrev-table ())
@@ -187,11 +193,12 @@
;;
;; Fontify function, variable and file name references.
("&\\(\\sw+\\(::\\sw+\\)*\\)" 1 font-lock-function-name-face)
- ;; Additionally underline non-scalar variables. Maybe this is a bad idea.
+ ;; Additionally fontify non-scalar variables. `perl-non-scalar-variable'
+ ;; will underline them by default.
;;'("[$@%*][#{]?\\(\\sw+\\)" 1 font-lock-variable-name-face)
("[$*]{?\\(\\sw+\\(::\\sw+\\)*\\)" 1 font-lock-variable-name-face)
("\\([@%]\\|\\$#\\)\\(\\sw+\\(::\\sw+\\)*\\)"
- (2 (cons font-lock-variable-name-face '(underline))))
+ (2 'perl-non-scalar-variable))
("<\\(\\sw+\\)>" 1 font-lock-constant-face)
;;
;; Fontify keywords with/and labels as we do in `c++-font-lock-keywords'.
diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el
index 62c3cf4..1812422 100644
--- a/lisp/progmodes/project.el
+++ b/lisp/progmodes/project.el
@@ -929,6 +929,7 @@ if one already exists."
(defun project-async-shell-command ()
"Run `async-shell-command' in the current project's root directory."
(interactive)
+ (declare (interactive-only async-shell-command))
(let ((default-directory (project-root (project-current t))))
(call-interactively #'async-shell-command)))
@@ -936,6 +937,7 @@ if one already exists."
(defun project-shell-command ()
"Run `shell-command' in the current project's root directory."
(interactive)
+ (declare (interactive-only shell-command))
(let ((default-directory (project-root (project-current t))))
(call-interactively #'shell-command)))
@@ -970,20 +972,12 @@ 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)
+ (declare (interactive-only compile))
+ (let ((default-directory (project-root (project-current t))))
+ (call-interactively #'compile)))
(defun project--read-project-buffer ()
(let* ((pr (project-current t))
diff --git a/lisp/progmodes/prolog.el b/lisp/progmodes/prolog.el
index c8f6c12..9f5f9ed 100644
--- a/lisp/progmodes/prolog.el
+++ b/lisp/progmodes/prolog.el
@@ -1201,7 +1201,9 @@ Commands:
(define-derived-mode mercury-mode prolog-mode "Prolog[Mercury]"
"Major mode for editing Mercury programs.
Actually this is just customized `prolog-mode'."
- (setq-local prolog-system 'mercury))
+ (setq-local prolog-system 'mercury)
+ ;; Run once more to set up based on `prolog-system'
+ (prolog-mode-variables))
;;-------------------------------------------------------------------
@@ -2082,7 +2084,7 @@ Argument BOUND is a buffer position limiting searching."
(delq
nil
(cond
- ((eq major-mode 'prolog-mode)
+ ((derived-mode-p 'prolog-mode)
(list
head-predicates
head-predicates-1
diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el
index 0965fec..d6c0a4d 100644
--- a/lisp/progmodes/python.el
+++ b/lisp/progmodes/python.el
@@ -2027,8 +2027,12 @@ position, else returns nil."
:group 'python
:safe 'stringp)
-(defcustom python-shell-interpreter "python"
+(defcustom python-shell-interpreter
+ (cond ((executable-find "python3") "python3")
+ ((executable-find "python") "python")
+ (t "python3"))
"Default Python interpreter for shell."
+ :version "28.1"
:type 'string
:group 'python)
diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el
index a417de3..d3692d4 100644
--- a/lisp/progmodes/sh-script.el
+++ b/lisp/progmodes/sh-script.el
@@ -1556,7 +1556,7 @@ with your script for an edit-interpret-debug cycle."
(sh-set-shell
(cond ((save-excursion
(goto-char (point-min))
- (looking-at "#![ \t]?\\([^ \t\n]*/bin/env[ \t]\\)?\\([^
\t\n]+\\)"))
+ (looking-at auto-mode-interpreter-regexp))
(match-string 2))
((not buffer-file-name) sh-shell-file)
;; Checks that use `buffer-file-name' follow.
diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el
index d3b6ae7..aecb30a 100644
--- a/lisp/progmodes/xref.el
+++ b/lisp/progmodes/xref.el
@@ -663,6 +663,12 @@ means to first quit the *xref* buffer."
(interactive)
(xref-goto-xref t))
+(defun xref-quit-and-pop-marker-stack ()
+ "Quit *xref* buffer, then pop the xref marker stack."
+ (interactive)
+ (quit-window)
+ (xref-pop-marker-stack))
+
(defun xref-query-replace-in-results (from to)
"Perform interactive replacement of FROM with TO in all displayed xrefs.
@@ -793,6 +799,7 @@ references displayed in the current *xref* buffer."
(define-key map (kbd ".") #'xref-next-line)
(define-key map (kbd ",") #'xref-prev-line)
(define-key map (kbd "g") #'xref-revert-buffer)
+ (define-key map (kbd "M-,") #'xref-quit-and-pop-marker-stack)
map))
(define-derived-mode xref--xref-buffer-mode special-mode "XREF"
@@ -994,8 +1001,12 @@ When only one definition found, jump to it right away
instead."
When there is more than one definition, split the selected window
and show the list in a small window at the bottom. And use a
local keymap that binds `RET' to `xref-quit-and-goto-xref'."
- (let ((xrefs (funcall fetcher))
- (dd default-directory))
+ (let* ((xrefs (funcall fetcher))
+ (dd default-directory)
+ ;; XXX: Make percentage customizable maybe?
+ (max-height (/ (window-height) 2))
+ (size-fun (lambda (window)
+ (fit-window-to-buffer window max-height))))
(cond
((not (cdr xrefs))
(xref-pop-to-location (car xrefs)
@@ -1006,7 +1017,8 @@ local keymap that binds `RET' to
`xref-quit-and-goto-xref'."
(xref--transient-buffer-mode)
(xref--show-common-initialize (xref--analyze xrefs) fetcher alist)
(pop-to-buffer (current-buffer)
- '(display-buffer-in-direction . ((direction . below))))
+ `(display-buffer-in-direction . ((direction . below)
+ (window-height .
,size-fun))))
(current-buffer))))))
(define-obsolete-function-alias 'xref--show-defs-buffer-at-bottom
diff --git a/lisp/replace.el b/lisp/replace.el
index d41dc98..db5b340 100644
--- a/lisp/replace.el
+++ b/lisp/replace.el
@@ -866,13 +866,10 @@ If nil, uses `regexp-history'."
;; Do not automatically add default to the history for empty input.
(history-add-new-input nil)
(input (read-from-minibuffer
- (cond ((string-match-p ":[ \t]*\\'" prompt)
- prompt)
- ((and default (> (length default) 0))
- (format "%s (default %s): " prompt
- (query-replace-descr default)))
- (t
- (format "%s: " prompt)))
+ (if (string-match-p ":[ \t]*\\'" prompt)
+ prompt
+ (format-prompt prompt (and (length> default 0)
+ (query-replace-descr default))))
nil nil nil (or history 'regexp-history) suggestions t)))
(if (equal input "")
;; Return the default value when the user enters empty input.
@@ -2428,23 +2425,27 @@ It is called with three arguments, as if it were
(overlay-put replace-overlay 'priority 1001) ;higher than lazy overlays
(overlay-put replace-overlay 'face 'query-replace)))
- (when (and query-replace-highlight-submatches
- regexp-flag)
+ (when (and query-replace-highlight-submatches regexp-flag)
(mapc 'delete-overlay replace-submatches-overlays)
(setq replace-submatches-overlays nil)
- (let ((submatch-data (cddr (butlast (match-data t))))
+ ;; 'cddr' removes whole expression match from match-data
+ (let ((submatch-data (cddr (match-data t)))
(group 0)
- ov face)
+ b e ov face)
(while submatch-data
- (setq group (1+ group))
- (setq ov (make-overlay (pop submatch-data) (pop submatch-data))
- face (intern-soft (format "isearch-group-%d" group)))
- ;; Recycle faces from beginning.
- (unless (facep face)
- (setq group 1 face 'isearch-group-1))
- (overlay-put ov 'face face)
- (overlay-put ov 'priority 1002)
- (push ov replace-submatches-overlays))))
+ (setq b (pop submatch-data)
+ e (pop submatch-data))
+ (when (and (integer-or-marker-p b)
+ (integer-or-marker-p e))
+ (setq ov (make-overlay b e)
+ group (1+ group)
+ face (intern-soft (format "isearch-group-%d" group)))
+ ;; Recycle faces from beginning
+ (unless (facep face)
+ (setq group 1 face 'isearch-group-1))
+ (overlay-put ov 'face face)
+ (overlay-put ov 'priority 1002)
+ (push ov replace-submatches-overlays)))))
(if query-replace-lazy-highlight
(let ((isearch-string search-string)
diff --git a/lisp/ruler-mode.el b/lisp/ruler-mode.el
index 7cda6c9..1e81904 100644
--- a/lisp/ruler-mode.el
+++ b/lisp/ruler-mode.el
@@ -429,7 +429,7 @@ dragging. See also the variable
`ruler-mode-dragged-symbol'."
;; `ding' flushes the next messages about setting goal
;; column. So here I force fetch the event(mouse-2) and
;; throw away.
- (read-event)
+ (read--potential-mouse-event)
;; Ding BEFORE `message' is OK.
(when ruler-mode-set-goal-column-ding-flag
(ding))
@@ -460,7 +460,7 @@ the mouse has been clicked."
(track-mouse
;; Signal the display engine to freeze the mouse pointer shape.
(setq track-mouse 'dragging)
- (while (mouse-movement-p (setq event (read-event)))
+ (while (mouse-movement-p (setq event (read--potential-mouse-event)))
(setq drags (1+ drags))
(when (eq window (posn-window (event-end event)))
(ruler-mode-mouse-drag-any-column event)
diff --git a/lisp/shell.el b/lisp/shell.el
index c179dd2..0f86615 100644
--- a/lisp/shell.el
+++ b/lisp/shell.el
@@ -603,6 +603,7 @@ buffer."
(or hfile
(cond ((string-equal shell "bash") "~/.bash_history")
((string-equal shell "ksh") "~/.sh_history")
+ ((string-equal shell "zsh") "~/.zsh_history")
(t "~/.history")))))
(if (or (equal comint-input-ring-file-name "")
(equal (file-truename comint-input-ring-file-name)
diff --git a/lisp/simple.el b/lisp/simple.el
index 3ab1e39..113bffe 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -5606,7 +5606,9 @@ See also `zap-up-to-char'."
;; kill-line and its subroutines.
(defcustom kill-whole-line nil
- "If non-nil, `kill-line' with no arg at start of line kills the whole line."
+ "If non-nil, `kill-line' with no arg at start of line kills the whole line.
+This variable also affects `kill-visual-line' in the same way as
+it does `kill-line'."
:type 'boolean
:group 'killing)
@@ -7319,6 +7321,10 @@ If ARG is negative, kill visual lines backward.
If ARG is zero, kill the text before point on the current visual
line.
+If the variable `kill-whole-line' is non-nil, and this command is
+invoked at start of a line that ends in a newline, kill the newline
+as well.
+
If you want to append the killed line to the last killed text,
use \\[append-next-kill] before \\[kill-line].
@@ -7331,18 +7337,30 @@ even beep.)"
;; Like in `kill-line', it's better to move point to the other end
;; of the kill before killing.
(let ((opoint (point))
- (kill-whole-line (and kill-whole-line (bolp))))
+ (kill-whole-line (and kill-whole-line (bolp)))
+ (orig-y (cdr (nth 2 (posn-at-point))))
+ ;; FIXME: This tolerance should be zero! It isn't due to a
+ ;; bug in posn-at-point, see bug#45837.
+ (tol (/ (line-pixel-height) 2)))
(if arg
(vertical-motion (prefix-numeric-value arg))
(end-of-visual-line 1)
(if (= (point) opoint)
(vertical-motion 1)
- ;; Skip any trailing whitespace at the end of the visual line.
- ;; We used to do this only if `show-trailing-whitespace' is
- ;; nil, but that's wrong; the correct thing would be to check
- ;; whether the trailing whitespace is highlighted. But, it's
- ;; OK to just do this unconditionally.
- (skip-chars-forward " \t")))
+ ;; The first condition below verifies we are still on the same
+ ;; screen line, i.e. that the line isn't continued, and that
+ ;; end-of-visual-line didn't overshoot due to complications
+ ;; like display or overlay strings, intangible text, etc.:
+ ;; otherwise, we don't want to kill a character that's
+ ;; unrelated to the place where the visual line wrapped.
+ (and (< (abs (- (cdr (nth 2 (posn-at-point))) orig-y)) tol)
+ ;; Make sure we delete the character where the line wraps
+ ;; under visual-line-mode, be it whitespace or a
+ ;; character whose category set allows to wrap at it.
+ (or (looking-at-p "[ \t]")
+ (and word-wrap-by-category
+ (aref (char-category-set (following-char)) ?\|)))
+ (forward-char))))
(kill-region opoint (if (and kill-whole-line (= (following-char) ?\n))
(1+ (point))
(point)))))
diff --git a/lisp/startup.el b/lisp/startup.el
index 4b82f73..333cb13 100644
--- a/lisp/startup.el
+++ b/lisp/startup.el
@@ -921,7 +921,8 @@ the name of the init-file to load. If this file cannot be
loaded, and ALTERNATE-FILENAME-FUNCTION is non-nil, then it is
called with no arguments and should return the name of an
alternate init-file to load. If LOAD-DEFAULTS is non-nil, then
-load default.el after the init-file.
+load default.el after the init-file, unless `inhibit-default-init'
+is non-nil.
This function sets `user-init-file' to the name of the loaded
init-file, or to a default value if loading is not possible."
@@ -977,8 +978,8 @@ init-file, or to a default value if loading is not
possible."
(sit-for 1))
(setq user-init-file source))))
- (when load-defaults
-
+ (when (and load-defaults
+ (not inhibit-default-init))
;; Prevent default.el from changing the value of
;; `inhibit-startup-screen'.
(let ((inhibit-startup-screen nil))
@@ -1166,12 +1167,12 @@ 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)
+ (setq custom-delayed-init-variables nil)
;; Warn for invalid user name.
(when init-file-user
@@ -1288,8 +1289,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,26 +1298,10 @@ 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 pgtk))
- (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))
- ;; 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))
-
(normal-erase-is-backspace-setup-frame)
;; Register default TTY colors for the case the terminal hasn't a
@@ -1374,7 +1358,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)
@@ -1498,13 +1482,13 @@ to reading the init file), or afterwards when the user
first
opens a graphical frame.
This can set the values of `menu-bar-mode', `tool-bar-mode',
-`tab-bar-mode', and `no-blinking-cursor', as well as the `cursor' face.
+`tab-bar-mode', and `blink-cursor-mode', as well as the `cursor' face.
Changed settings will be marked as \"CHANGED outside of Customize\"."
(let ((no-vals '("no" "off" "false" "0"))
(settings '(("menuBar" "MenuBar" menu-bar-mode nil)
("toolBar" "ToolBar" tool-bar-mode nil)
("scrollBar" "ScrollBar" scroll-bar-mode nil)
- ("cursorBlink" "CursorBlink" no-blinking-cursor t))))
+ ("cursorBlink" "CursorBlink" blink-cursor-mode nil))))
(dolist (x settings)
(if (member (x-get-resource (nth 0 x) (nth 1 x)) no-vals)
(set (nth 2 x) (nth 3 x)))))
diff --git a/lisp/strokes.el b/lisp/strokes.el
index b0ab4f9..55f2ae8 100644
--- a/lisp/strokes.el
+++ b/lisp/strokes.el
@@ -756,12 +756,12 @@ Optional EVENT is acceptable as the starting event of the
stroke."
(strokes-fill-current-buffer-with-whitespace))
(when prompt
(message "%s" prompt)
- (setq event (read-event))
+ (setq event (read--potential-mouse-event))
(or (strokes-button-press-event-p event)
(error "You must draw with the mouse")))
(unwind-protect
(track-mouse
- (or event (setq event (read-event)
+ (or event (setq event (read--potential-mouse-event)
safe-to-draw-p t))
(while (not (strokes-button-release-event-p event))
(if (strokes-mouse-event-p event)
@@ -776,7 +776,7 @@ Optional EVENT is acceptable as the starting event of the
stroke."
(setq safe-to-draw-p t))
(push (cdr (mouse-pixel-position))
pix-locs)))
- (setq event (read-event)))))
+ (setq event (read--potential-mouse-event)))))
;; protected
;; clean up strokes buffer and then bury it.
(when (equal (buffer-name) strokes-buffer-name)
@@ -787,16 +787,16 @@ Optional EVENT is acceptable as the starting event of the
stroke."
;; Otherwise, don't use strokes buffer and read stroke silently
(when prompt
(message "%s" prompt)
- (setq event (read-event))
+ (setq event (read--potential-mouse-event))
(or (strokes-button-press-event-p event)
(error "You must draw with the mouse")))
(track-mouse
- (or event (setq event (read-event)))
+ (or event (setq event (read--potential-mouse-event)))
(while (not (strokes-button-release-event-p event))
(if (strokes-mouse-event-p event)
(push (cdr (mouse-pixel-position))
pix-locs))
- (setq event (read-event))))
+ (setq event (read--potential-mouse-event))))
(setq grid-locs (strokes-renormalize-to-grid (nreverse pix-locs)))
(strokes-fill-stroke
(strokes-eliminate-consecutive-redundancies grid-locs)))))
@@ -817,10 +817,10 @@ Optional EVENT is acceptable as the starting event of the
stroke."
(if prompt
(while (not (strokes-button-press-event-p event))
(message "%s" prompt)
- (setq event (read-event))))
+ (setq event (read--potential-mouse-event))))
(unwind-protect
(track-mouse
- (or event (setq event (read-event)))
+ (or event (setq event (read--potential-mouse-event)))
(while (not (and (strokes-button-press-event-p event)
(eq 'mouse-3
(car (get (car event)
@@ -834,14 +834,15 @@ Optional EVENT is acceptable as the starting event of the
stroke."
?\s strokes-character))
(push (cdr (mouse-pixel-position))
pix-locs)))
- (setq event (read-event)))
+ (setq event (read--potential-mouse-event)))
(push strokes-lift pix-locs)
(while (not (strokes-button-press-event-p event))
- (setq event (read-event))))
+ (setq event (read--potential-mouse-event))))
;; ### KLUDGE! ### sit and wait
;; for some useless event to
;; happen to fix the minibuffer bug.
- (while (not (strokes-button-release-event-p (read-event))))
+ (while (not (strokes-button-release-event-p
+ (read--potential-mouse-event))))
(setq pix-locs (nreverse (cdr pix-locs))
grid-locs (strokes-renormalize-to-grid pix-locs))
(strokes-fill-stroke
diff --git a/lisp/subr.el b/lisp/subr.el
index 2602029..f249ec3 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -1178,6 +1178,30 @@ KEY is a string or vector representing a sequence of
keystrokes."
(if (current-local-map)
(local-set-key key nil))
nil)
+
+(defun local-key-binding (keys &optional accept-default)
+ "Return the binding for command KEYS in current local keymap only.
+KEYS is a string or vector, a sequence of keystrokes.
+The binding is probably a symbol with a function definition.
+
+If optional argument ACCEPT-DEFAULT is non-nil, recognize default
+bindings; see the description of `lookup-key' for more details
+about this."
+ (let ((map (current-local-map)))
+ (when map (lookup-key map keys accept-default))))
+
+(defun global-key-binding (keys &optional accept-default)
+ "Return the binding for command KEYS in current global keymap only.
+KEYS is a string or vector, a sequence of keystrokes.
+The binding is probably a symbol with a function definition.
+This function's return values are the same as those of `lookup-key'
+\(which see).
+
+If optional argument ACCEPT-DEFAULT is non-nil, recognize default
+bindings; see the description of `lookup-key' for more details
+about this."
+ (lookup-key (current-global-map) keys accept-default))
+
;;;; substitute-key-definition and its subroutines.
@@ -1330,7 +1354,9 @@ The normal global definition of the character C-x
indirects to this keymap.")
map)
"Default global keymap mapping Emacs keyboard input into commands.
The value is a keymap that is usually (but not necessarily) Emacs's
-global map.")
+global map.
+
+See also `current-global-map'.")
(use-global-map global-map)
@@ -2543,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
@@ -2613,6 +2668,23 @@ some sort of escape sequence, the ambiguity is resolved
via `read-key-delay'."
(message nil)
(use-global-map old-global-map))))
+;; FIXME: Once there's a safe way to transition away from read-event,
+;; callers to this function should be updated to that way and this
+;; function should be deleted.
+(defun read--potential-mouse-event ()
+ "Read an event that might be a mouse event.
+
+This function exists for backward compatibility in code packaged
+with Emacs. Do not call it directly in your own packages."
+ ;; `xterm-mouse-mode' events must go through `read-key' as they
+ ;; are decoded via `input-decode-map'.
+ (if xterm-mouse-mode
+ (read-key nil
+ ;; Normally `read-key' discards all mouse button
+ ;; down events. However, we want them here.
+ t)
+ (read-event)))
+
(defvar read-passwd-map
;; BEWARE: `defconst' would purecopy it, breaking the sharing with
;; minibuffer-local-map along the way!
diff --git a/lisp/textmodes/artist.el b/lisp/textmodes/artist.el
index ce62082..50c00c9 100644
--- a/lisp/textmodes/artist.el
+++ b/lisp/textmodes/artist.el
@@ -5004,7 +5004,7 @@ The event, EV, is the mouse event."
(setq timer (run-at-time interval interval draw-fn x1 y1))))
;; Read next event
- (setq ev (read-event))))
+ (setq ev (read--potential-mouse-event))))
;; Cleanup: get rid of any active timer.
(if timer
(cancel-timer timer)))
@@ -5212,7 +5212,7 @@ The event, EV, is the mouse event."
;; Read next event (only if we should not stop)
(if (not done)
- (setq ev (read-event)))))
+ (setq ev (read--potential-mouse-event)))))
;; Reverse point-list (last points are cond'ed first)
(setq point-list (reverse point-list))
@@ -5339,7 +5339,7 @@ The event, EV, is the mouse event."
;; Read next event
- (setq ev (read-event))))
+ (setq ev (read--potential-mouse-event))))
;; If we are not rubber-banding (that is, we were moving around the `2')
;; draw the shape
diff --git a/lisp/textmodes/fill.el b/lisp/textmodes/fill.el
index 3346c55..6681b03 100644
--- a/lisp/textmodes/fill.el
+++ b/lisp/textmodes/fill.el
@@ -743,9 +743,16 @@ space does not end a sentence, so don't break a line
there."
;; This is the actual filling loop.
(goto-char from)
- (let (linebeg)
+ (let ((first t)
+ linebeg)
(while (< (point) to)
- (setq linebeg (point))
+ ;; On the first line, there may be text in the fill prefix
+ ;; zone. In that case, don't consider that area when
+ ;; trying to find a place to put a line break (bug#45720).
+ (if (not first)
+ (setq linebeg (point))
+ (setq first nil
+ linebeg (+ (point) (length fill-prefix))))
(move-to-column (current-fill-column))
(if (when (< (point) to)
;; Find the position where we'll break the line.
diff --git a/lisp/textmodes/reftex-vars.el b/lisp/textmodes/reftex-vars.el
index d4c1b87..1b29eaf 100644
--- a/lisp/textmodes/reftex-vars.el
+++ b/lisp/textmodes/reftex-vars.el
@@ -900,7 +900,7 @@ DOWNCASE t: Downcase words before using them."
,(concat
;; Make sure we search only for optional arguments of
;; environments/macros and don't match any other [. ctable
- ;; provides a macro called \ctable, listings/breqn have
+ ;; provides a macro called \ctable, beamer/breqn/listings have
;; environments. Start with a backslash and a group for names
"\\\\\\(?:"
;; begin, optional spaces and opening brace
@@ -936,8 +936,9 @@ The default value matches usual \\label{...} definitions and
keyval style [..., label = {...}, ...] label definitions. The
regexp for keyval style explicitly looks for environments
provided by the packages \"listings\" (\"lstlisting\"),
-\"breqn\" (\"dmath\", \"dseries\", \"dgroup\", \"darray\") and
-the macro \"\\ctable\" provided by the package of the same name.
+\"beamer\" (\"frame\"), \"breqn\" (\"dmath\", \"dseries\",
+\"dgroup\", \"darray\") and the macro \"\\ctable\" provided by
+the package of the same name.
It is assumed that the regexp group 1 matches the label text, so
you have to define it using \\(?1:...\\) when adding new regexps.
diff --git a/lisp/vc/ediff-wind.el b/lisp/vc/ediff-wind.el
index 72b3458..47ef37a 100644
--- a/lisp/vc/ediff-wind.el
+++ b/lisp/vc/ediff-wind.el
@@ -262,11 +262,12 @@ keyboard input to go into icons."
(let (event)
(message
"Select windows by clicking. Please click on Window %d " wind-number)
- (while (not (ediff-mouse-event-p (setq event (read-event))))
+ (while (not (ediff-mouse-event-p (setq event
+ (read--potential-mouse-event))))
(if (sit-for 1) ; if sequence of events, wait till the final word
(beep 1))
(message "Please click on Window %d " wind-number))
- (read-event) ; discard event
+ (read--potential-mouse-event) ; discard event
(posn-window (event-start event))))
diff --git a/lisp/vc/ediff.el b/lisp/vc/ediff.el
index e3612dd..ed375738 100644
--- a/lisp/vc/ediff.el
+++ b/lisp/vc/ediff.el
@@ -939,7 +939,7 @@ arguments after setting up the Ediff buffers."
;; If WIND-A is nil, use selected window.
;; If WIND-B is nil, use window next to WIND-A.
(defun ediff-windows (dumb-mode wind-A wind-B startup-hooks job-name word-mode)
- (if (or dumb-mode (not (ediff-window-display-p)))
+ (if (or dumb-mode (not (display-mouse-p)))
(setq wind-A (ediff-get-next-window wind-A nil)
wind-B (ediff-get-next-window wind-B wind-A))
(setq wind-A (ediff-get-window-by-clicking wind-A nil 1)
diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el
index 6c96d8c..bc9f112 100644
--- a/lisp/vc/vc.el
+++ b/lisp/vc/vc.el
@@ -2392,6 +2392,7 @@ If it contains `file', show short logs for files.
Not all VC backends support short logs!")
(defvar log-view-vc-fileset)
+(defvar log-view-message-re)
(defun vc-print-log-setup-buttons (working-revision is-start-revision limit
pl-return)
"Insert at the end of the current buffer buttons to show more log entries.
@@ -2401,21 +2402,32 @@ Does nothing if IS-START-REVISION is non-nil, or if
LIMIT is nil,
or if PL-RETURN is `limit-unsupported'."
(when (and limit (not (eq 'limit-unsupported pl-return))
(not is-start-revision))
- (goto-char (point-max))
- (insert "\n")
- (insert-text-button "Show 2X entries"
- 'action (lambda (&rest _ignore)
- (vc-print-log-internal
- log-view-vc-backend log-view-vc-fileset
- working-revision nil (* 2 limit)))
- 'help-echo "Show the log again, and double the number
of log entries shown")
- (insert " ")
- (insert-text-button "Show unlimited entries"
- 'action (lambda (&rest _ignore)
- (vc-print-log-internal
- log-view-vc-backend log-view-vc-fileset
- working-revision nil nil))
- 'help-echo "Show the log again, including all
entries")))
+ (let ((entries 0))
+ (goto-char (point-min))
+ (while (re-search-forward log-view-message-re nil t)
+ (cl-incf entries))
+ ;; If we got fewer entries than we asked for, then displaying
+ ;; the "more" buttons isn't useful.
+ (when (>= entries limit)
+ (goto-char (point-max))
+ (insert "\n")
+ (insert-text-button
+ "Show 2X entries"
+ 'action (lambda (&rest _ignore)
+ (vc-print-log-internal
+ log-view-vc-backend log-view-vc-fileset
+ working-revision nil (* 2 limit)))
+ 'help-echo
+ "Show the log again, and double the number of log entries shown")
+ (insert " ")
+ (insert-text-button
+ "Show unlimited entries"
+ 'action (lambda (&rest _ignore)
+ (vc-print-log-internal
+ log-view-vc-backend log-view-vc-fileset
+ working-revision nil nil))
+ 'help-echo "Show the log again, including all entries")
+ (insert "\n")))))
(defun vc-print-log-internal (backend files working-revision
&optional is-start-revision limit type)
diff --git a/lisp/version.el b/lisp/version.el
index fcfc2f8..3a3093f 100644
--- a/lisp/version.el
+++ b/lisp/version.el
@@ -29,14 +29,12 @@
(defconst emacs-major-version
(progn (string-match "^[0-9]+" emacs-version)
(string-to-number (match-string 0 emacs-version)))
- "Major version number of this version of Emacs.
-This variable first existed in version 19.23.")
+ "Major version number of this version of Emacs.")
(defconst emacs-minor-version
(progn (string-match "^[0-9]+\\.\\([0-9]+\\)" emacs-version)
(string-to-number (match-string 1 emacs-version)))
- "Minor version number of this version of Emacs.
-This variable first existed in version 19.23.")
+ "Minor version number of this version of Emacs.")
(defconst emacs-build-system (system-name)
"Name of the system on which Emacs was built, or nil if not available.")
diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el
index 8b10d71..68a0d3d 100644
--- a/lisp/wid-edit.el
+++ b/lisp/wid-edit.el
@@ -1104,7 +1104,7 @@ If nothing was called, return non-nil."
(unless (widget-apply button :mouse-down-action event)
(let ((track-mouse t))
(while (not (widget-button-release-event-p event))
- (setq event (read-event))
+ (setq event (read--potential-mouse-event))
(when (and mouse-1 (mouse-movement-p event))
(push event unread-command-events)
(setq event oevent)
@@ -1169,7 +1169,7 @@ If nothing was called, return non-nil."
(when up
;; Don't execute up events twice.
(while (not (widget-button-release-event-p event))
- (setq event (read-event))))
+ (setq event (read--potential-mouse-event))))
(when command
(call-interactively command)))))
(message "You clicked somewhere weird.")))
@@ -3486,14 +3486,16 @@ It reads a directory name from an editable text field."
:help-echo "C-q: insert KEY, EVENT, or CODE; RET: enter value"
:tag "Key sequence")
+;; FIXME: Consider combining this with help--read-key-sequence which
+;; can also read double and triple mouse events.
(defun widget-key-sequence-read-event (ev)
(interactive (list
(let ((inhibit-quit t) quit-flag)
- (read-event "Insert KEY, EVENT, or CODE: "))))
+ (read-key "Insert KEY, EVENT, or CODE: " t))))
(let ((ev2 (and (memq 'down (event-modifiers ev))
- (read-event)))
- (tr (and (keymapp function-key-map)
- (lookup-key function-key-map (vector ev)))))
+ (read-key nil t)))
+ (tr (and (keymapp local-function-key-map)
+ (lookup-key local-function-key-map (vector ev)))))
(when (and (integerp ev)
(or (and (<= ?0 ev) (< ev (+ ?0 (min 10
read-quoted-char-radix))))
(and (<= ?a (downcase ev))
@@ -4024,17 +4026,19 @@ is inline."
;;; The `color' Widget.
-;; Fixme: match
(define-widget 'color 'editable-field
"Choose a color name (with sample)."
:format "%{%t%}: %v (%{sample%})\n"
:value-create 'widget-color-value-create
- :size 10
+ :size (1+ (apply #'max 13 ; Longest RGB hex string.
+ (mapcar #'length (defined-colors))))
:tag "Color"
:value "black"
:completions (or facemenu-color-alist (defined-colors))
:sample-face-get 'widget-color-sample-face-get
:notify 'widget-color-notify
+ :match #'widget-color-match
+ :validate #'widget-color-validate
:action 'widget-color-action)
(defun widget-color-value-create (widget)
@@ -4083,6 +4087,19 @@ is inline."
(overlay-put (widget-get widget :sample-overlay)
'face (widget-apply widget :sample-face-get))
(widget-default-notify widget child event))
+
+(defun widget-color-match (_widget value)
+ "Non-nil if VALUE is a defined color or a RGB hex string."
+ (and (stringp value)
+ (or (color-defined-p value)
+ (string-match-p "^#\\(?:[[:xdigit:]]\\{3\\}\\)\\{1,4\\}$" value))))
+
+(defun widget-color-validate (widget)
+ "Check that WIDGET's value is a valid color."
+ (let ((value (widget-value widget)))
+ (unless (widget-color-match widget value)
+ (widget-put widget :error (format "Invalid color: %S" value))
+ widget)))
;;; The Help Echo
diff --git a/lisp/window.el b/lisp/window.el
index 38be778..0a37d16 100644
--- a/lisp/window.el
+++ b/lisp/window.el
@@ -1736,9 +1736,11 @@ interpret DELTA as pixels."
(setq window (window-normalize-window window))
(cond
((< delta 0)
- (max (- (window-min-size window horizontal ignore pixelwise)
- (window-size window horizontal pixelwise))
- delta))
+ (let ((min-size (window-min-size window horizontal ignore pixelwise))
+ (size (window-size window horizontal pixelwise)))
+ (if (<= size min-size)
+ 0
+ (max (- min-size size) delta))))
((> delta 0)
(if (window-size-fixed-p window horizontal ignore)
0
@@ -4116,7 +4118,10 @@ frame can be safely deleted."
frame))
(throw 'other t))))
(let ((minibuf (active-minibuffer-window)))
- (and minibuf (eq frame (window-frame minibuf)))))
+ (and minibuf (eq frame (window-frame minibuf))
+ (not (eq (default-toplevel-value
+ minibuffer-follows-selected-frame)
+ t)))))
'frame))
((window-minibuffer-p window)
;; If WINDOW is the minibuffer window of a non-minibuffer-only
diff --git a/src/buffer.c b/src/buffer.c
index 71ad5ed..80c799e 100644
--- a/src/buffer.c
+++ b/src/buffer.c
@@ -4785,7 +4785,7 @@ mmap_init (void)
if (mmap_fd <= 0)
{
/* No anonymous mmap -- we need the file descriptor. */
- mmap_fd = emacs_open ("/dev/zero", O_RDONLY, 0);
+ mmap_fd = emacs_open_noquit ("/dev/zero", O_RDONLY, 0);
if (mmap_fd == -1)
fatal ("Cannot open /dev/zero: %s", emacs_strerror (errno));
}
diff --git a/src/callproc.c b/src/callproc.c
index 1da315b..cb72b07 100644
--- a/src/callproc.c
+++ b/src/callproc.c
@@ -1336,7 +1336,7 @@ emacs_spawn (pid_t *newpid, int std_in, int std_out, int
std_err,
would work? */
if (std_in >= 0)
emacs_close (std_in);
- std_out = std_in = emacs_open (pty, O_RDWR, 0);
+ std_out = std_in = emacs_open_noquit (pty, O_RDWR, 0);
if (std_in < 0)
{
diff --git a/src/data.c b/src/data.c
index d420bf5..35a6890 100644
--- a/src/data.c
+++ b/src/data.c
@@ -3760,6 +3760,7 @@ syms_of_data (void)
DEFSYM (Qbuffer_read_only, "buffer-read-only");
DEFSYM (Qtext_read_only, "text-read-only");
DEFSYM (Qmark_inactive, "mark-inactive");
+ DEFSYM (Qinhibited_interaction, "inhibited-interaction");
DEFSYM (Qlistp, "listp");
DEFSYM (Qconsp, "consp");
@@ -3844,6 +3845,8 @@ syms_of_data (void)
PUT_ERROR (Qbuffer_read_only, error_tail, "Buffer is read-only");
PUT_ERROR (Qtext_read_only, pure_cons (Qbuffer_read_only, error_tail),
"Text is read-only");
+ PUT_ERROR (Qinhibited_interaction, error_tail,
+ "User interaction while inhibited");
DEFSYM (Qrange_error, "range-error");
DEFSYM (Qdomain_error, "domain-error");
diff --git a/src/dispnew.c b/src/dispnew.c
index 881bc52..55667fa 100644
--- a/src/dispnew.c
+++ b/src/dispnew.c
@@ -6049,7 +6049,14 @@ additional wait period, in milliseconds; this is for
backwards compatibility.
READING is true if reading input.
If DISPLAY_OPTION is >0 display process output while waiting.
If DISPLAY_OPTION is >1 perform an initial redisplay before waiting.
-*/
+
+ Returns a boolean Qt if we waited the full time and returns Qnil if the
+ wait was interrupted by incoming process output or keyboard events.
+
+ FIXME: When `wait_reading_process_output` returns early because of
+ process output, instead of returning nil we should loop and wait some
+ more (i.e. until either there's pending input events or the timeout
+ expired). */
Lisp_Object
sit_for (Lisp_Object timeout, bool reading, int display_option)
@@ -6110,8 +6117,9 @@ sit_for (Lisp_Object timeout, bool reading, int
display_option)
gobble_input ();
#endif
- wait_reading_process_output (sec, nsec, reading ? -1 : 1, do_display,
- Qnil, NULL, 0);
+ int nbytes
+ = wait_reading_process_output (sec, nsec, reading ? -1 : 1, do_display,
+ Qnil, NULL, 0);
if (reading && curbuf_eq_winbuf)
/* Timers and process filters/sentinels may have changed the selected
@@ -6120,7 +6128,7 @@ sit_for (Lisp_Object timeout, bool reading, int
display_option)
buffer to start with). */
set_buffer_internal (XBUFFER (XWINDOW (selected_window)->contents));
- return detect_input_pending () ? Qnil : Qt;
+ return (nbytes > 0 || detect_input_pending ()) ? Qnil : Qt;
}
diff --git a/src/emacs.c b/src/emacs.c
index 461d1b7..2299552 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -1275,7 +1275,7 @@ main (int argc, char **argv)
{
emacs_close (STDIN_FILENO);
emacs_close (STDOUT_FILENO);
- int result = emacs_open (term, O_RDWR, 0);
+ int result = emacs_open_noquit (term, O_RDWR, 0);
if (result != STDIN_FILENO
|| (fcntl (STDIN_FILENO, F_DUPFD_CLOEXEC, STDOUT_FILENO)
!= STDOUT_FILENO))
@@ -2862,7 +2862,7 @@ from the parent process and its tty file descriptors. */)
int nfd;
/* Get rid of stdin, stdout and stderr. */
- nfd = emacs_open ("/dev/null", O_RDWR, 0);
+ nfd = emacs_open_noquit ("/dev/null", O_RDWR, 0);
err |= nfd < 0;
err |= dup2 (nfd, STDIN_FILENO) < 0;
err |= dup2 (nfd, STDOUT_FILENO) < 0;
diff --git a/src/eval.c b/src/eval.c
index 706aafd..5bf3fae 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -1167,9 +1167,18 @@ Lisp_Object
internal_catch (Lisp_Object tag,
Lisp_Object (*func) (Lisp_Object), Lisp_Object arg)
{
+ /* MINIBUFFER_QUIT_LEVEL is to handle quitting from nested minibuffers by
+ throwing t to tag `exit'.
+ Value -1 means there is no (throw 'exit t) in progress;
+ 0 means the `throw' wasn't done from an active minibuffer;
+ N > 0 means the `throw' was done from the minibuffer at level N. */
+ static EMACS_INT minibuffer_quit_level = -1;
/* This structure is made part of the chain `catchlist'. */
struct handler *c = push_handler (tag, CATCHER);
+ if (EQ (tag, Qexit))
+ minibuffer_quit_level = -1;
+
/* Call FUNC. */
if (! sys_setjmp (c->jmp))
{
@@ -1183,6 +1192,23 @@ internal_catch (Lisp_Object tag,
Lisp_Object val = handlerlist->val;
clobbered_eassert (handlerlist == c);
handlerlist = handlerlist->next;
+ if (EQ (tag, Qexit) && EQ (val, Qt))
+ /* If we've thrown t to tag `exit' from within a minibuffer, we
+ exit all minibuffers more deeply nested than the current
+ one. */
+ {
+ EMACS_INT mini_depth = this_minibuffer_depth (Qnil);
+ if (mini_depth && mini_depth != minibuffer_quit_level)
+ {
+ if (minibuffer_quit_level == -1)
+ minibuffer_quit_level = mini_depth;
+ if (minibuffer_quit_level
+ && (minibuf_level > minibuffer_quit_level))
+ Fthrow (Qexit, Qt);
+ }
+ else
+ minibuffer_quit_level = -1;
+ }
return val;
}
}
diff --git a/src/fns.c b/src/fns.c
index 5fcc54f..7ab2e8f 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -5548,6 +5548,90 @@ It should not be used for anything security-related. See
return make_digest_string (digest, SHA1_DIGEST_SIZE);
}
+DEFUN ("buffer-line-statistics", Fbuffer_line_statistics,
+ Sbuffer_line_statistics, 0, 1, 0,
+ doc: /* Return data about lines in BUFFER.
+The data is returned as a list, and the first element is the number of
+lines in the buffer, the second is the length of the longest line, and
+the third is the mean line length. The lengths returned are in bytes, not
+characters. */ )
+ (Lisp_Object buffer_or_name)
+{
+ Lisp_Object buffer;
+ ptrdiff_t lines = 0, longest = 0;
+ double mean = 0;
+ struct buffer *b;
+
+ if (NILP (buffer_or_name))
+ buffer = Fcurrent_buffer ();
+ else
+ buffer = Fget_buffer (buffer_or_name);
+ if (NILP (buffer))
+ nsberror (buffer_or_name);
+
+ b = XBUFFER (buffer);
+
+ unsigned char *start = BUF_BEG_ADDR (b);
+ ptrdiff_t area = BUF_GPT_BYTE (b) - BUF_BEG_BYTE (b), pre_gap = 0;
+
+ /* Process the first part of the buffer. */
+ while (area > 0)
+ {
+ unsigned char *n = memchr (start, '\n', area);
+
+ if (n)
+ {
+ ptrdiff_t this_line = n - start;
+ if (this_line > longest)
+ longest = this_line;
+ lines++;
+ /* Blame Knuth. */
+ mean = mean + (this_line - mean) / lines;
+ area = area - this_line - 1;
+ start += this_line + 1;
+ }
+ else
+ {
+ /* Didn't have a newline here, so save the rest for the
+ post-gap calculation. */
+ pre_gap = area;
+ area = 0;
+ }
+ }
+
+ /* If the gap is before the end of the buffer, process the last half
+ of the buffer. */
+ if (BUF_GPT_BYTE (b) < BUF_Z_BYTE (b))
+ {
+ start = BUF_GAP_END_ADDR (b);
+ area = BUF_Z_ADDR (b) - BUF_GAP_END_ADDR (b);
+
+ while (area > 0)
+ {
+ unsigned char *n = memchr (start, '\n', area);
+ ptrdiff_t this_line = n? n - start + pre_gap: area + pre_gap;
+
+ if (this_line > longest)
+ longest = this_line;
+ lines++;
+ /* Blame Knuth again. */
+ mean = mean + (this_line - mean) / lines;
+ area = area - this_line - 1;
+ start += this_line + 1;
+ pre_gap = 0;
+ }
+ }
+ else if (pre_gap > 0)
+ {
+ if (pre_gap > longest)
+ longest = pre_gap;
+ lines++;
+ mean = mean + (pre_gap - mean) / lines;
+ }
+
+ return list3 (make_int (lines), make_int (longest), make_float (mean));
+}
+
static bool
string_ascii_p (Lisp_Object string)
{
@@ -5871,4 +5955,5 @@ this variable. */);
defsubr (&Ssecure_hash);
defsubr (&Sbuffer_hash);
defsubr (&Slocale_info);
+ defsubr (&Sbuffer_line_statistics);
}
diff --git a/src/frame.c b/src/frame.c
index 4ecb0e9..daaba2a 100644
--- a/src/frame.c
+++ b/src/frame.c
@@ -2575,23 +2575,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;
}
@@ -2613,23 +2620,31 @@ before calling this function on it, like this.
int yval = check_integer_range (y, INT_MIN, INT_MAX);
/* I think this should be done with a hook. */
-#ifdef HAVE_WINDOW_SYSTEM
if (FRAME_WINDOW_P (XFRAME (frame)))
- /* Warping the mouse will cause enternotify and focus events. */
- frame_set_mouse_pixel_position (XFRAME (frame), xval, yval);
-#elif defined MSDOS
- if (FRAME_MSDOS_P (XFRAME (frame)))
+ {
+ /* Warping the mouse will cause enternotify and focus events. */
+#ifdef HAVE_WINDOW_SYSTEM
+ frame_set_mouse_pixel_position (XFRAME (frame), xval, yval);
+#endif /* HAVE_WINDOW_SYSTEM */
+ }
+#ifdef MSDOS
+ else if (FRAME_MSDOS_P (XFRAME (frame)))
{
Fselect_frame (frame, Qnil);
mouse_moveto (xval, yval);
}
-#elif defined HAVE_GPM
- Fselect_frame (frame, Qnil);
- term_mouse_moveto (xval, yval);
+#endif /* MSDOS */
+ else
+ {
+ Fselect_frame (frame, Qnil);
+#ifdef HAVE_GPM
+ term_mouse_moveto (xval, yval);
#else
- (void) xval;
- (void) yval;
-#endif
+ (void) xval;
+ (void) yval;
+#endif /* HAVE_GPM */
+
+ }
return Qnil;
}
diff --git a/src/keymap.c b/src/keymap.c
index 1197f6f..de9b2b5 100644
--- a/src/keymap.c
+++ b/src/keymap.c
@@ -1646,39 +1646,6 @@ specified buffer position instead of point are used.
/* GC is possible in this function if it autoloads a keymap. */
-DEFUN ("local-key-binding", Flocal_key_binding, Slocal_key_binding, 1, 2, 0,
- doc: /* Return the binding for command KEYS in current local keymap
only.
-KEYS is a string or vector, a sequence of keystrokes.
-The binding is probably a symbol with a function definition.
-
-If optional argument ACCEPT-DEFAULT is non-nil, recognize default
-bindings; see the description of `lookup-key' for more details about this. */)
- (Lisp_Object keys, Lisp_Object accept_default)
-{
- register Lisp_Object map = BVAR (current_buffer, keymap);
- if (NILP (map))
- return Qnil;
- return Flookup_key (map, keys, accept_default);
-}
-
-/* GC is possible in this function if it autoloads a keymap. */
-
-DEFUN ("global-key-binding", Fglobal_key_binding, Sglobal_key_binding, 1, 2, 0,
- doc: /* Return the binding for command KEYS in current global keymap
only.
-KEYS is a string or vector, a sequence of keystrokes.
-The binding is probably a symbol with a function definition.
-This function's return values are the same as those of `lookup-key'
-\(which see).
-
-If optional argument ACCEPT-DEFAULT is non-nil, recognize default
-bindings; see the description of `lookup-key' for more details about this. */)
- (Lisp_Object keys, Lisp_Object accept_default)
-{
- return Flookup_key (current_global_map, keys, accept_default);
-}
-
-/* GC is possible in this function if it autoloads a keymap. */
-
DEFUN ("minor-mode-key-binding", Fminor_mode_key_binding,
Sminor_mode_key_binding, 1, 2, 0,
doc: /* Find the visible minor mode bindings of KEY.
Return an alist of pairs (MODENAME . BINDING), where MODENAME is
@@ -3253,8 +3220,6 @@ be preferred. */);
defsubr (&Scopy_keymap);
defsubr (&Scommand_remapping);
defsubr (&Skey_binding);
- defsubr (&Slocal_key_binding);
- defsubr (&Sglobal_key_binding);
defsubr (&Sminor_mode_key_binding);
defsubr (&Sdefine_key);
defsubr (&Slookup_key);
diff --git a/src/lisp.h b/src/lisp.h
index d139df9..f658868 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -4346,9 +4346,12 @@ extern Lisp_Object Vminibuffer_list;
extern Lisp_Object last_minibuf_string;
extern void move_minibuffer_onto_frame (void);
extern bool is_minibuffer (EMACS_INT, Lisp_Object);
+extern EMACS_INT this_minibuffer_depth (Lisp_Object);
+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. */
@@ -4575,6 +4578,7 @@ extern AVOID emacs_abort (void) NO_INLINE;
extern int emacs_fstatat (int, char const *, void *, int);
extern int emacs_openat (int, char const *, int, int);
extern int emacs_open (const char *, int, int);
+extern int emacs_open_noquit (const char *, int, int);
extern int emacs_pipe (int[2]);
extern int emacs_close (int);
extern ptrdiff_t emacs_read (int, void *, ptrdiff_t);
diff --git a/src/lread.c b/src/lread.c
index 1ff0828..72b68df 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -767,11 +767,16 @@ is used for reading a character.
If the optional argument SECONDS is non-nil, it should be a number
specifying the maximum number of seconds to wait for input. If no
input arrives in that time, return nil. SECONDS may be a
-floating-point value. */)
+floating-point value.
+
+If `inhibit-interaction' is non-nil, this function will signal an
+`inhibited-interaction' error. */)
(Lisp_Object prompt, Lisp_Object inherit_input_method, Lisp_Object seconds)
{
Lisp_Object val;
+ barf_if_interaction_inhibited ();
+
if (! NILP (prompt))
message_with_string ("%s", prompt, 0);
val = read_filtered_event (1, 1, 1, ! NILP (inherit_input_method), seconds);
@@ -782,6 +787,12 @@ floating-point value. */)
DEFUN ("read-event", Fread_event, Sread_event, 0, 3, 0,
doc: /* Read an event object from the input stream.
+
+If you want to read non-character events, consider calling `read-key'
+instead. `read-key' will decode events via `input-decode-map' that
+`read-event' will not. On a terminal this includes function keys such
+as <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);
diff --git a/src/minibuf.c b/src/minibuf.c
index 5ee440f..5df1045 100644
--- a/src/minibuf.c
+++ b/src/minibuf.c
@@ -63,10 +63,31 @@ static Lisp_Object minibuf_prompt;
static ptrdiff_t minibuf_prompt_width;
+static Lisp_Object nth_minibuffer (EMACS_INT depth);
+
+/* Return TRUE when a frame switch causes a minibuffer on the old
+ frame to move onto the new one. */
static bool
minibuf_follows_frame (void)
{
+ return EQ (Fdefault_toplevel_value (Qminibuffer_follows_selected_frame),
+ Qt);
+}
+
+/* Return TRUE when a minibuffer always remains on the frame where it
+ was first invoked. */
+static bool
+minibuf_stays_put (void)
+{
+ return NILP (Fdefault_toplevel_value (Qminibuffer_follows_selected_frame));
+}
+
+/* Return TRUE when opening a (recursive) minibuffer causes
+ minibuffers on other frames to move to the selected frame. */
+static bool
+minibuf_moves_frame_when_opened (void)
+{
return !NILP (Fdefault_toplevel_value (Qminibuffer_follows_selected_frame));
}
@@ -90,7 +111,7 @@ choose_minibuf_frame (void)
minibuf_window = sf->minibuffer_window;
/* If we've still got another minibuffer open, use its mini-window
instead. */
- if (minibuf_level && !minibuf_follows_frame ())
+ if (minibuf_level > 1 && minibuf_stays_put ())
{
Lisp_Object buffer = get_minibuffer (minibuf_level);
Lisp_Object tail, frame;
@@ -105,26 +126,40 @@ choose_minibuf_frame (void)
}
}
- if (minibuf_follows_frame ())
+ if (minibuf_moves_frame_when_opened ()
+ && FRAMEP (selected_frame)
+ && FRAME_LIVE_P (XFRAME (selected_frame)))
/* Make sure no other frame has a minibuffer as its selected window,
because the text would not be displayed in it, and that would be
confusing. Only allow the selected frame to do this,
and that only if the minibuffer is active. */
- {
- Lisp_Object tail, frame;
-
- FOR_EACH_FRAME (tail, frame)
- if (MINI_WINDOW_P (XWINDOW (FRAME_SELECTED_WINDOW (XFRAME (frame))))
- && !(EQ (frame, selected_frame)
- && minibuf_level > 0))
- Fset_frame_selected_window (frame, Fframe_first_window (frame),
- Qnil);
- }
+ {
+ Lisp_Object tail, frame;
+ struct frame *of;
+
+ FOR_EACH_FRAME (tail, frame)
+ if (!EQ (frame, selected_frame)
+ && minibuf_level > 1
+ /* The frame's minibuffer can be on a different frame. */
+ && ! EQ (XWINDOW ((of = XFRAME (frame))->minibuffer_window)->frame,
+ selected_frame))
+ {
+ if (MINI_WINDOW_P (XWINDOW (FRAME_SELECTED_WINDOW (of))))
+ Fset_frame_selected_window (frame, Fframe_first_window (frame),
+ Qnil);
+
+ if (!EQ (XWINDOW (of->minibuffer_window)->contents,
+ nth_minibuffer (0)))
+ set_window_buffer (of->minibuffer_window,
+ nth_minibuffer (0), 0, 0);
+ }
+ }
}
-/* If `minibuffer_follows_selected_frame' and we have a minibuffer, move it
- from its current frame to the selected frame. This function is
- intended to be called from `do_switch_frame' in frame.c. */
+/* If `minibuffer_follows_selected_frame' is t and we have a
+ minibuffer, move it from its current frame to the selected frame.
+ This function is intended to be called from `do_switch_frame' in
+ frame.c. */
void move_minibuffer_onto_frame (void)
{
if (!minibuf_level)
@@ -135,14 +170,18 @@ void move_minibuffer_onto_frame (void)
&& FRAME_LIVE_P (XFRAME (selected_frame))
&& !EQ (minibuf_window, XFRAME (selected_frame)->minibuffer_window))
{
+ EMACS_INT i;
struct frame *sf = XFRAME (selected_frame);
Lisp_Object old_frame = XWINDOW (minibuf_window)->frame;
struct frame *of = XFRAME (old_frame);
- Lisp_Object buffer = XWINDOW (minibuf_window)->contents;
- set_window_buffer (sf->minibuffer_window, buffer, 0, 0);
+ /* Stack up all the (recursively) open minibuffers on the selected
+ mini_window. */
+ for (i = 1; i <= minibuf_level; i++)
+ set_window_buffer (sf->minibuffer_window, nth_minibuffer (i), 0, 0);
minibuf_window = sf->minibuffer_window;
- set_window_buffer (of->minibuffer_window, get_minibuffer (0), 0, 0);
+ if (of != sf)
+ set_window_buffer (of->minibuffer_window, get_minibuffer (0), 0, 0);
}
}
@@ -336,6 +375,63 @@ return t only if BUFFER is an active minibuffer. */)
? Qt : Qnil;
}
+DEFUN ("innermost-minibuffer-p", Finnermost_minibuffer_p,
+ Sinnermost_minibuffer_p, 0, 1, 0,
+ doc: /* Return t if BUFFER is the most nested active minibuffer.
+No argument or nil as argument means use the current buffer as BUFFER. */)
+ (Lisp_Object buffer)
+{
+ if (NILP (buffer))
+ buffer = Fcurrent_buffer ();
+ return EQ (buffer, (Fcar (Fnthcdr (make_fixnum (minibuf_level),
+ Vminibuffer_list))))
+ ? Qt
+ : Qnil;
+}
+
+/* Return the nesting depth of the active minibuffer BUFFER, or 0 if
+ BUFFER isn't such a thing. If BUFFER is nil, this means use the current
+ buffer. */
+EMACS_INT
+this_minibuffer_depth (Lisp_Object buffer)
+{
+ EMACS_INT i;
+ Lisp_Object bufs;
+
+ if (NILP (buffer))
+ buffer = Fcurrent_buffer ();
+ for (i = 1, bufs = Fcdr (Vminibuffer_list);
+ i <= minibuf_level;
+ i++, bufs = Fcdr (bufs))
+ if (EQ (Fcar (bufs), buffer))
+ return i;
+ return 0;
+}
+
+DEFUN ("abort-minibuffers", Fabort_minibuffers, Sabort_minibuffers, 0, 0, "",
+ doc: /* Abort the current minibuffer.
+If we are not currently in the innermost minibuffer, prompt the user to
+confirm the aborting of the current minibuffer and all contained ones. */)
+ (void)
+{
+ EMACS_INT minibuf_depth = this_minibuffer_depth (Qnil);
+ Lisp_Object array[2];
+ AUTO_STRING (fmt, "Abort %s minibuffer levels? ");
+
+ if (!minibuf_depth)
+ error ("Not in a minibuffer");
+ if (minibuf_depth < minibuf_level)
+ {
+ array[0] = fmt;
+ array[1] = make_fixnum (minibuf_level - minibuf_depth + 1);
+ if (!NILP (Fyes_or_no_p (Fformat (2, array))))
+ Fthrow (Qexit, Qt);
+ }
+ else
+ Fthrow (Qexit, Qt);
+ return Qnil;
+}
+
DEFUN ("minibuffer-prompt-end", Fminibuffer_prompt_end,
Sminibuffer_prompt_end, 0, 0, 0,
doc: /* Return the buffer position of the end of the minibuffer prompt.
@@ -411,6 +507,7 @@ read_minibuf (Lisp_Object map, Lisp_Object initial,
Lisp_Object prompt,
Lisp_Object val;
ptrdiff_t count = SPECPDL_INDEX ();
Lisp_Object mini_frame, ambient_dir, minibuffer, input_method;
+ Lisp_Object calling_frame = selected_frame;
Lisp_Object enable_multibyte;
EMACS_INT pos = 0;
/* String to add to the history. */
@@ -648,6 +745,17 @@ read_minibuf (Lisp_Object map, Lisp_Object initial,
Lisp_Object prompt,
}
}
+ if (minibuf_moves_frame_when_opened ())
+ {
+ EMACS_INT i;
+
+ /* Stack up all the (recursively) open minibuffers on the selected
+ mini_window. */
+ for (i = 1; i < minibuf_level; i++)
+ set_window_buffer (XFRAME (mini_frame)->minibuffer_window,
+ nth_minibuffer (i), 0, 0);
+ }
+
/* Display this minibuffer in the proper window. */
/* Use set_window_buffer instead of Fset_window_buffer (see
discussion of bug#11984, bug#12025, bug#12026). */
@@ -729,6 +837,20 @@ read_minibuf (Lisp_Object map, Lisp_Object initial,
Lisp_Object prompt,
recursive_edit_1 ();
+ /* We've exited the recursive edit without an error, so switch the
+ current window away from the expired minibuffer window. */
+ {
+ Lisp_Object prev = Fprevious_window (minibuf_window, Qnil, Qnil);
+ /* PREV can be on a different frame when we have a minibuffer only
+ frame, the other frame's minibuffer window is MINIBUF_WINDOW,
+ and its "focus window" is also MINIBUF_WINDOW. */
+ while (!EQ (prev, minibuf_window)
+ && !EQ (selected_frame, WINDOW_FRAME (XWINDOW (prev))))
+ prev = Fprevious_window (prev, Qnil, Qnil);
+ if (!EQ (prev, minibuf_window))
+ Fset_frame_selected_window (selected_frame, prev, Qnil);
+ }
+
/* If cursor is on the minibuffer line,
show the user we have exited by putting it in column 0. */
if (XWINDOW (minibuf_window)->cursor.vpos >= 0
@@ -767,6 +889,12 @@ read_minibuf (Lisp_Object map, Lisp_Object initial,
Lisp_Object prompt,
in set-window-configuration. */
unbind_to (count, Qnil);
+ /* Switch the frame back to the calling frame. */
+ if (!EQ (selected_frame, calling_frame)
+ && FRAMEP (calling_frame)
+ && FRAME_LIVE_P (XFRAME (calling_frame)))
+ call2 (intern ("select-frame-set-input-focus"), calling_frame, Qnil);
+
/* Add the value to the appropriate history list, if any. This is
done after the previous buffer has been made current again, in
case the history variable is buffer-local. */
@@ -790,6 +918,14 @@ is_minibuffer (EMACS_INT depth, Lisp_Object buf)
&& EQ (Fcar (tail), buf);
}
+/* Return the DEPTHth minibuffer, or nil if such does not yet exist. */
+static Lisp_Object
+nth_minibuffer (EMACS_INT depth)
+{
+ Lisp_Object tail = Fnthcdr (make_fixnum (depth), Vminibuffer_list);
+ return XCAR (tail);
+}
+
/* Return a buffer to be used as the minibuffer at depth `depth'.
depth = 0 is the lowest allowed argument, and that is the value
used for nonrecursive minibuffer invocations. */
@@ -939,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.
@@ -983,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,
@@ -998,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;
@@ -1071,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));
@@ -2032,13 +2186,15 @@ For example, `eval-expression' uses this. */);
The function is called with the arguments passed to `read-buffer'. */);
Vread_buffer_function = Qnil;
- DEFVAR_BOOL ("minibuffer-follows-selected-frame",
minibuffer_follows_selected_frame,
- doc: /* Non-nil means the active minibuffer always displays on
the selected frame.
+ DEFVAR_LISP ("minibuffer-follows-selected-frame",
minibuffer_follows_selected_frame,
+ doc: /* t means the active minibuffer always displays on the
selected frame.
Nil means that a minibuffer will appear only in the frame which created it.
+Any other value means the minibuffer will move onto another frame, but
+only when the user starts using a minibuffer there.
Any buffer local or dynamic binding of this variable is ignored. Only the
default top level value is used. */);
- minibuffer_follows_selected_frame = 1;
+ minibuffer_follows_selected_frame = Qt;
DEFVAR_BOOL ("read-buffer-completion-ignore-case",
read_buffer_completion_ignore_case,
@@ -2183,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);
@@ -2196,6 +2361,8 @@ uses to hide passwords. */);
defsubr (&Sminibuffer_prompt);
defsubr (&Sminibufferp);
+ defsubr (&Sinnermost_minibuffer_p);
+ defsubr (&Sabort_minibuffers);
defsubr (&Sminibuffer_prompt_end);
defsubr (&Sminibuffer_contents);
defsubr (&Sminibuffer_contents_no_properties);
diff --git a/src/nsselect.m b/src/nsselect.m
index 27db924..5ab3ef7 100644
--- a/src/nsselect.m
+++ b/src/nsselect.m
@@ -78,7 +78,13 @@ ns_string_to_symbol (NSString *t)
return QSECONDARY;
if ([t isEqualToString: NSPasteboardTypeString])
return QTEXT;
- if ([t isEqualToString: NSFilenamesPboardType])
+ if ([t isEqualToString:
+#if NS_USE_NSPasteboardTypeFileURL != 0
+ NSPasteboardTypeFileURL
+#else
+ NSFilenamesPboardType
+#endif
+ ])
return QFILE_NAME;
if ([t isEqualToString: NSPasteboardTypeTabularText])
return QTEXT;
@@ -467,7 +473,12 @@ nxatoms_of_nsselect (void)
[NSNumber numberWithLong:0], NXPrimaryPboard,
[NSNumber numberWithLong:0], NXSecondaryPboard,
[NSNumber numberWithLong:0], NSPasteboardTypeString,
- [NSNumber numberWithLong:0], NSFilenamesPboardType,
+ [NSNumber numberWithLong:0],
+#if NS_USE_NSPasteboardTypeFileURL != 0
+ NSPasteboardTypeFileURL,
+#else
+ NSFilenamesPboardType,
+#endif
[NSNumber numberWithLong:0], NSPasteboardTypeTabularText,
nil] retain];
}
diff --git a/src/nsterm.h b/src/nsterm.h
index 2c9d8e8..eae1d07 100644
--- a/src/nsterm.h
+++ b/src/nsterm.h
@@ -39,6 +39,15 @@ typedef CGFloat EmacsCGFloat;
typedef float EmacsCGFloat;
#endif
+/* NSFilenamesPboardType is deprecated in macOS 10.14, but
+ NSPasteboardTypeFileURL is only available in 10.13 (and GNUstep
+ probably lacks it too). */
+#if defined NS_IMPL_COCOA && MAC_OS_X_VERSION_MIN_REQUIRED >= 101300
+#define NS_USE_NSPasteboardTypeFileURL 1
+#else
+#define NS_USE_NSPasteboardTypeFileURL 0
+#endif
+
/* ==========================================================================
Trace support
diff --git a/src/nsterm.m b/src/nsterm.m
index 2defb9e..c5815ce 100644
--- a/src/nsterm.m
+++ b/src/nsterm.m
@@ -5602,7 +5602,11 @@ ns_term_init (Lisp_Object display_name)
ns_drag_types = [[NSArray arrayWithObjects:
NSPasteboardTypeString,
NSPasteboardTypeTabularText,
+#if NS_USE_NSPasteboardTypeFileURL != 0
+ NSPasteboardTypeFileURL,
+#else
NSFilenamesPboardType,
+#endif
NSPasteboardTypeURL, nil] retain];
/* If fullscreen is in init/default-frame-alist, focus isn't set
@@ -8533,9 +8537,19 @@ not_in_argv (NSString *arg)
{
return NO;
}
- /* FIXME: NSFilenamesPboardType is deprecated in 10.14, but the
- NSURL method can only handle one file at a time. Stick with the
- existing code at the moment. */
+#if NS_USE_NSPasteboardTypeFileURL != 0
+ else if ([type isEqualToString: NSPasteboardTypeFileURL])
+ {
+ type_sym = Qfile;
+
+ NSArray *urls = [pb readObjectsForClasses: @[[NSURL self]]
+ options: nil];
+ NSEnumerator *uenum = [urls objectEnumerator];
+ NSURL *url;
+ while ((url = [uenum nextObject]))
+ strings = Fcons ([[url path] lispString], strings);
+ }
+#else // !NS_USE_NSPasteboardTypeFileURL
else if ([type isEqualToString: NSFilenamesPboardType])
{
NSArray *files;
@@ -8551,6 +8565,7 @@ not_in_argv (NSString *arg)
while ( (file = [fenum nextObject]) )
strings = Fcons ([file lispString], strings);
}
+#endif // !NS_USE_NSPasteboardTypeFileURL
else if ([type isEqualToString: NSPasteboardTypeURL])
{
NSURL *url = [NSURL URLFromPasteboard: pb];
diff --git a/src/pdumper.c b/src/pdumper.c
index 116cc28..c1388eb 100644
--- a/src/pdumper.c
+++ b/src/pdumper.c
@@ -5273,7 +5273,7 @@ pdumper_load (const char *dump_filename)
eassert (!dump_loaded_p ());
int err;
- int dump_fd = emacs_open (dump_filename, O_RDONLY, 0);
+ int dump_fd = emacs_open_noquit (dump_filename, O_RDONLY, 0);
if (dump_fd < 0)
{
err = (errno == ENOENT || errno == ENOTDIR
diff --git a/src/process.c b/src/process.c
index 25883f9..4ab194b 100644
--- a/src/process.c
+++ b/src/process.c
@@ -283,6 +283,16 @@ static int max_desc;
the file descriptor of a socket that is already bound. */
static int external_sock_fd;
+/* File descriptor that becomes readable when we receive SIGCHLD. */
+static int child_signal_read_fd = -1;
+/* The write end thereof. The SIGCHLD handler writes to this file
+ descriptor to notify `wait_reading_process_output' of process
+ status changes. */
+static int child_signal_write_fd = -1;
+static void child_signal_init (void);
+static void child_signal_read (int, void *);
+static void child_signal_notify (void);
+
/* Indexed by descriptor, gives the process (if any) for that descriptor. */
static Lisp_Object chan_process[FD_SETSIZE];
static void wait_for_socket_fds (Lisp_Object, char const *);
@@ -2060,6 +2070,10 @@ create_process (Lisp_Object process, char **new_argv,
Lisp_Object current_dir)
Lisp_Object lisp_pty_name = Qnil;
sigset_t oldset;
+ /* Ensure that the SIGCHLD handler can notify
+ `wait_reading_process_output'. */
+ child_signal_init ();
+
inchannel = outchannel = -1;
if (p->pty_flag)
@@ -5309,6 +5323,15 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
compute_input_wait_mask (&Atemp);
compute_write_mask (&Ctemp);
+ /* If a process status has changed, the child signal pipe
+ will likely be readable. We want to ignore it for now,
+ because otherwise we wouldn't run into a timeout
+ below. */
+ int fd = child_signal_read_fd;
+ eassert (fd < FD_SETSIZE);
+ if (0 <= fd)
+ FD_CLR (fd, &Atemp);
+
timeout = make_timespec (0, 0);
if ((thread_select (pselect, max_desc + 1,
&Atemp,
@@ -5395,6 +5418,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
@@ -7118,7 +7149,72 @@ 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]);
+ if (fcntl (fds[0], F_SETFL, O_NONBLOCK) != 0)
+ emacs_perror ("fcntl");
+ 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
@@ -7156,6 +7252,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. */
@@ -7178,6 +7275,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);
@@ -7195,6 +7293,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;
@@ -7214,6 +7313,10 @@ handle_child_signal (int sig)
}
}
+ if (changed)
+ /* Wake up `wait_reading_process_output'. */
+ child_signal_notify ();
+
lib_child_handler (sig);
#ifdef NS_IMPL_GNUSTEP
/* NSTask in GNUstep sets its child handler each time it is called.
diff --git a/src/sysdep.c b/src/sysdep.c
index 6ede06b..941b4e2 100644
--- a/src/sysdep.c
+++ b/src/sysdep.c
@@ -53,6 +53,10 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
# include <sys/sysctl.h>
#endif
+#if defined __OpenBSD__
+# include <sys/proc.h>
+#endif
+
#ifdef DARWIN_OS
# include <libproc.h>
#endif
@@ -2316,6 +2320,28 @@ emacs_open (char const *file, int oflags, int mode)
return emacs_openat (AT_FDCWD, file, oflags, mode);
}
+/* Same as above, but doesn't allow the user to quit. */
+
+static int
+emacs_openat_noquit (int dirfd, const char *file, int oflags,
+ int mode)
+{
+ int fd;
+ if (! (oflags & O_TEXT))
+ oflags |= O_BINARY;
+ oflags |= O_CLOEXEC;
+ do
+ fd = openat (dirfd, file, oflags, mode);
+ while (fd < 0 && errno == EINTR);
+ return fd;
+}
+
+int
+emacs_open_noquit (char const *file, int oflags, int mode)
+{
+ return emacs_openat_noquit (AT_FDCWD, file, oflags, mode);
+}
+
/* Open FILE as a stream for Emacs use, with mode MODE.
Act like emacs_open with respect to threads, signals, and quits. */
@@ -2972,6 +2998,14 @@ make_lisp_timeval (struct timeval t)
return make_lisp_time (timeval_to_timespec (t));
}
+#elif defined __OpenBSD__
+
+static Lisp_Object
+make_lisp_timeval (long sec, long usec)
+{
+ return make_lisp_time(make_timespec(sec, usec * 1000));
+}
+
#endif
#ifdef GNU_LINUX
@@ -3661,6 +3695,189 @@ system_process_attributes (Lisp_Object pid)
return attrs;
}
+#elif defined __OpenBSD__
+
+Lisp_Object
+system_process_attributes (Lisp_Object pid)
+{
+ int proc_id, nentries, fscale, i;
+ int pagesize = getpagesize ();
+ int mib[6];
+ size_t len;
+ double pct;
+ char *ttyname, args[ARG_MAX];
+ struct kinfo_proc proc;
+ struct passwd *pw;
+ struct group *gr;
+ struct timespec t;
+ struct uvmexp uvmexp;
+
+ Lisp_Object attrs = Qnil;
+ Lisp_Object decoded_comm;
+
+ CHECK_NUMBER (pid);
+ CONS_TO_INTEGER (pid, int, proc_id);
+
+ len = sizeof proc;
+ mib[0] = CTL_KERN;
+ mib[1] = KERN_PROC;
+ mib[2] = KERN_PROC_PID;
+ mib[3] = proc_id;
+ mib[4] = len;
+ mib[5] = 1;
+ if (sysctl (mib, 6, &proc, &len, NULL, 0) != 0)
+ return attrs;
+
+ attrs = Fcons (Fcons (Qeuid, INT_TO_INTEGER (proc.p_uid)), attrs);
+
+ block_input ();
+ pw = getpwuid (proc.p_uid);
+ unblock_input ();
+ if (pw)
+ attrs = Fcons (Fcons (Quser, build_string(pw->pw_name)), attrs);
+
+ attrs = Fcons (Fcons (Qegid, INT_TO_INTEGER(proc.p_svgid)), attrs);
+
+ block_input ();
+ gr = getgrgid (proc.p_svgid);
+ unblock_input ();
+ if (gr)
+ attrs = Fcons (Fcons (Qgroup, build_string (gr->gr_name)), attrs);
+
+ AUTO_STRING (comm, proc.p_comm);
+ decoded_comm = code_convert_string_norecord (comm, Vlocale_coding_system, 0);
+ attrs = Fcons (Fcons (Qcomm, decoded_comm), attrs);
+
+ {
+ char state[2] = {'\0', '\0'};
+ switch (proc.p_stat) {
+ case SIDL:
+ state[0] = 'I';
+ break;
+ case SRUN:
+ state[0] = 'R';
+ break;
+ case SSLEEP:
+ state[0] = 'S';
+ break;
+ case SSTOP:
+ state[0] = 'T';
+ break;
+ case SZOMB:
+ state[0] = 'Z';
+ break;
+ case SDEAD:
+ state[0] = 'D';
+ break;
+ }
+ attrs = Fcons (Fcons (Qstate, build_string (state)), attrs);
+ }
+
+ attrs = Fcons (Fcons (Qppid, INT_TO_INTEGER (proc.p_ppid)), attrs);
+ attrs = Fcons (Fcons (Qpgrp, INT_TO_INTEGER (proc.p_gid)), attrs);
+ attrs = Fcons (Fcons (Qsess, INT_TO_INTEGER (proc.p_sid)), attrs);
+
+ block_input ();
+ ttyname = proc.p_tdev == NODEV ? NULL : devname (proc.p_tdev, S_IFCHR);
+ unblock_input ();
+ if (ttyname)
+ attrs = Fcons (Fcons (Qttname, build_string (ttyname)), attrs);
+
+ attrs = Fcons (Fcons (Qtpgid, INT_TO_INTEGER (proc.p_tpgid)), attrs);
+ attrs = Fcons (Fcons (Qminflt, INT_TO_INTEGER (proc.p_uru_minflt)),
+ attrs);
+ attrs = Fcons (Fcons (Qmajflt, INT_TO_INTEGER (proc.p_uru_majflt)),
+ attrs);
+
+ /* FIXME: missing cminflt, cmajflt. */
+
+ attrs = Fcons (Fcons (Qutime, make_lisp_timeval (proc.p_uutime_sec,
+ proc.p_uutime_usec)),
+ attrs);
+ attrs = Fcons (Fcons (Qstime, make_lisp_timeval (proc.p_ustime_sec,
+ proc.p_ustime_usec)),
+ attrs);
+ t = timespec_add (make_timespec (proc.p_uutime_sec,
+ proc.p_uutime_usec * 1000),
+ make_timespec (proc.p_ustime_sec,
+ proc.p_ustime_usec * 1000));
+ attrs = Fcons (Fcons (Qtime, make_lisp_time (t)), attrs);
+
+ attrs = Fcons (Fcons (Qcutime, make_lisp_timeval (proc.p_uctime_sec,
+ proc.p_uctime_usec)),
+ attrs);
+
+ /* FIXME: missing cstime and thus ctime. */
+
+ attrs = Fcons (Fcons (Qpri, make_fixnum (proc.p_priority)), attrs);
+ attrs = Fcons (Fcons (Qnice, make_fixnum (proc.p_nice)), attrs);
+
+ /* FIXME: missing thcount (thread count) */
+
+ attrs = Fcons (Fcons (Qstart, make_lisp_timeval (proc.p_ustart_sec,
+ proc.p_ustart_usec)),
+ attrs);
+
+ len = (proc.p_vm_tsize + proc.p_vm_dsize + proc.p_vm_ssize) * pagesize >> 10;
+ attrs = Fcons (Fcons (Qvsize, make_fixnum (len)), attrs);
+
+ attrs = Fcons (Fcons (Qrss, make_fixnum (proc.p_vm_rssize * pagesize >>
10)),
+ attrs);
+
+ t = make_timespec (proc.p_ustart_sec,
+ proc.p_ustart_usec * 1000);
+ t = timespec_sub (current_timespec (), t);
+ attrs = Fcons (Fcons (Qetime, make_lisp_time (t)), attrs);
+
+ len = sizeof (fscale);
+ mib[0] = CTL_KERN;
+ mib[1] = KERN_FSCALE;
+ if (sysctl (mib, 2, &fscale, &len, NULL, 0) != -1)
+ {
+ pct = (double)proc.p_pctcpu / fscale * 100.0;
+ attrs = Fcons (Fcons (Qpcpu, make_float (pct)), attrs);
+ }
+
+ len = sizeof (uvmexp);
+ mib[0] = CTL_VM;
+ mib[1] = VM_UVMEXP;
+ if (sysctl (mib, 2, &uvmexp, &len, NULL, 0) != -1)
+ {
+ pct = (100.0 * (double)proc.p_vm_rssize / uvmexp.npages);
+ attrs = Fcons (Fcons (Qpmem, make_float (pct)), attrs);
+ }
+
+ len = sizeof args;
+ mib[0] = CTL_KERN;
+ mib[1] = KERN_PROC_ARGS;
+ mib[2] = proc_id;
+ mib[3] = KERN_PROC_ARGV;
+ if (sysctl (mib, 4, &args, &len, NULL, 0) == 0 && len != 0)
+ {
+ char **argv = (char**)args;
+
+ /* concatenate argv reusing the existing storage storage.
+ sysctl(8) guarantees that "the buffer pointed to by oldp is
+ filled with an array of char pointers followed by the strings
+ themselves." */
+ for (i = 0; argv[i] != NULL; ++i)
+ {
+ if (argv[i+1] != NULL)
+ {
+ len = strlen (argv[i]);
+ argv[i][len] = ' ';
+ }
+ }
+
+ AUTO_STRING (comm, *argv);
+ decoded_comm = code_convert_string_norecord (comm,
+ Vlocale_coding_system, 0);
+ attrs = Fcons (Fcons (Qargs, decoded_comm), attrs);
+ }
+
+ return attrs;
+}
+
#elif defined DARWIN_OS
Lisp_Object
diff --git a/src/term.c b/src/term.c
index a87f9c7..2e2ab2b 100644
--- a/src/term.c
+++ b/src/term.c
@@ -2382,7 +2382,6 @@ frame's terminal). */)
#ifdef HAVE_GPM
-#ifndef HAVE_WINDOW_SYSTEM
void
term_mouse_moveto (int x, int y)
{
@@ -2396,7 +2395,6 @@ term_mouse_moveto (int x, int y)
last_mouse_x = x;
last_mouse_y = y; */
}
-#endif /* HAVE_WINDOW_SYSTEM */
/* Implementation of draw_row_with_mouse_face for TTY/GPM. */
void
@@ -4246,8 +4244,8 @@ use the Bourne shell command 'TERM=...; export TERM'
(C-shell:\n\
#ifdef HAVE_GPM
terminal->mouse_position_hook = term_mouse_position;
- tty->mouse_highlight.mouse_face_window = Qnil;
#endif
+ tty->mouse_highlight.mouse_face_window = Qnil;
terminal->kboard = allocate_kboard (Qnil);
terminal->kboard->reference_count++;
diff --git a/src/termhooks.h b/src/termhooks.h
index 0cab7bd..524590f 100644
--- a/src/termhooks.h
+++ b/src/termhooks.h
@@ -371,9 +371,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;
diff --git a/src/w32term.c b/src/w32term.c
index e5a8a82..109aa58 100644
--- a/src/w32term.c
+++ b/src/w32term.c
@@ -7507,7 +7507,8 @@ w32_initialize (void)
}
#ifdef CYGWIN
- if ((w32_message_fd = emacs_open ("/dev/windows", O_RDWR, 0)) == -1)
+ if ((w32_message_fd = emacs_open_noquit ("/dev/windows", O_RDWR, 0))
+ == -1)
fatal ("opening /dev/windows: %s", strerror (errno));
#endif /* CYGWIN */
diff --git a/src/window.c b/src/window.c
index 5e78aa4..e025e0b 100644
--- a/src/window.c
+++ b/src/window.c
@@ -2663,12 +2663,15 @@ static void
decode_next_window_args (Lisp_Object *window, Lisp_Object *minibuf,
Lisp_Object *all_frames)
{
struct window *w = decode_live_window (*window);
+ Lisp_Object miniwin = XFRAME (w->frame)->minibuffer_window;
XSETWINDOW (*window, w);
/* MINIBUF nil may or may not include minibuffers. Decide if it
does. */
if (NILP (*minibuf))
- *minibuf = minibuf_level ? minibuf_window : Qlambda;
+ *minibuf = this_minibuffer_depth (XWINDOW (miniwin)->contents)
+ ? miniwin
+ : Qlambda;
else if (!EQ (*minibuf, Qt))
*minibuf = Qlambda;
diff --git a/src/window.h b/src/window.h
index fbdec0d..4271fc8 100644
--- a/src/window.h
+++ b/src/window.h
@@ -1124,10 +1124,6 @@ extern Lisp_Object echo_area_window;
extern EMACS_INT command_loop_level;
-/* Depth in minibuffer invocations. */
-
-extern EMACS_INT minibuf_level;
-
/* Non-zero if we should redraw the mode lines on the next redisplay.
Usually set to a unique small integer so we can track the main causes of
full redisplays in `redisplay--mode-lines-cause'. */
diff --git a/src/xdisp.c b/src/xdisp.c
index d070c5a..592bdb7 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -9285,8 +9285,8 @@ move_it_in_display_line_to (struct it *it,
if (may_wrap && char_can_wrap_before (it))
{
/* We have reached a glyph that follows one or more
- whitespace characters or a character that allows
- wrapping after it. If this character allows
+ whitespace characters or characters that allow
+ wrapping after them. If this character allows
wrapping before it, save this position as a
wrapping point. */
if (atpos_it.sp >= 0)
@@ -9303,7 +9303,6 @@ move_it_in_display_line_to (struct it *it,
}
/* Otherwise, we can wrap here. */
SAVE_IT (wrap_it, *it, wrap_data);
- next_may_wrap = false;
}
/* Update may_wrap for the next iteration. */
may_wrap = next_may_wrap;
@@ -10650,9 +10649,10 @@ include the height of both, if present, in the return
value. */)
bpos = BEGV_BYTE;
while (bpos < ZV_BYTE)
{
- c = fetch_char_advance (&start, &bpos);
+ c = FETCH_BYTE (bpos);
if (!(c == ' ' || c == '\t' || c == '\n' || c == '\r'))
break;
+ inc_both (&start, &bpos);
}
while (bpos > BEGV_BYTE)
{
@@ -10681,7 +10681,10 @@ include the height of both, if present, in the return
value. */)
dec_both (&end, &bpos);
c = FETCH_BYTE (bpos);
if (!(c == ' ' || c == '\t' || c == '\n' || c == '\r'))
- break;
+ {
+ inc_both (&end, &bpos);
+ break;
+ }
}
while (bpos < ZV_BYTE)
{
@@ -20819,9 +20822,8 @@ try_window_id (struct window *w)
+ window_wants_header_line (w)
+ window_internal_height (w));
-#if defined (HAVE_GPM) || defined (MSDOS)
gui_clear_window_mouse_face (w);
-#endif
+
/* Perform the operation on the screen. */
if (dvpos > 0)
{
diff --git a/src/xfaces.c b/src/xfaces.c
index 217aa0a..d383284 100644
--- a/src/xfaces.c
+++ b/src/xfaces.c
@@ -3317,7 +3317,8 @@ FRAME 0 means change the face on all frames, and change
the default
}
else if (EQ (k, QCstyle))
{
- if (!EQ (v, Qpressed_button) && !EQ (v, Qreleased_button))
+ if (!EQ (v, Qpressed_button) && !EQ (v, Qreleased_button)
+ && !EQ(v, Qflat_button))
break;
}
else
@@ -6055,6 +6056,10 @@ realize_gui_face (struct face_cache *cache, Lisp_Object
attrs[LFACE_VECTOR_SIZE]
face->box = FACE_RAISED_BOX;
else if (EQ (value, Qpressed_button))
face->box = FACE_SUNKEN_BOX;
+ else if (EQ (value, Qflat_button)) {
+ face->box = FACE_SIMPLE_BOX;
+ face->box_color = face->background;
+ }
}
}
}
@@ -6943,6 +6948,7 @@ syms_of_xfaces (void)
DEFSYM (Qwave, "wave");
DEFSYM (Qreleased_button, "released-button");
DEFSYM (Qpressed_button, "pressed-button");
+ DEFSYM (Qflat_button, "flat-button");
DEFSYM (Qnormal, "normal");
DEFSYM (Qextra_light, "extra-light");
DEFSYM (Qlight, "light");
diff --git a/test/Makefile.in b/test/Makefile.in
index fc40dad..c5e86df 100644
--- a/test/Makefile.in
+++ b/test/Makefile.in
@@ -246,6 +246,18 @@ endef
$(foreach test,${TESTS},$(eval $(call test_template,${test})))
+## Get the tests for only a specific directory.
+SUBDIRS = $(sort $(shell find lib-src lisp src -type d ! -path "*resources*"
-print))
+
+define subdir_template
+ .PHONY: check-$(subst /,-,$(1))
+ check-$(subst /,-,$(1)):
+ @${MAKE} check LOGFILES="$(patsubst %.el,%.log, \
+ $(patsubst $(srcdir)/%,%,$(wildcard $(1)/*.el)))"
+endef
+
+$(foreach subdir, $(SUBDIRS), $(eval $(call subdir_template,$(subdir))))
+
ifeq (@HAVE_MODULES@, yes)
# -fPIC is a no-op on Windows, but causes a compiler warning
ifeq ($(SO),.dll)
@@ -312,10 +324,10 @@ check-doit:
ifeq ($(TEST_INTERACTIVE), yes)
HOME=$(TEST_HOME) $(emacs) \
-l ert ${ert_opts} \
- $(patsubst %,-l %,$(if $(findstring
$(TEST_LOAD_EL),yes),$ELFILES,$(ELFILES:.el=))) \
+ $(patsubst %,-l %,$(if $(findstring
$(TEST_LOAD_EL),yes),$ELFILES,$(ELFILES:.el=))) \
$(TEST_RUN_ERT)
else
- -@${MAKE} -k ${LOGFILES}
+ -@${MAKE} -k ${LOGFILES}
@$(emacs) --batch -l ert --eval \
"(ert-summarize-tests-batch-and-exit ${SUMMARIZE_TESTS})" ${LOGFILES}
endif
diff --git a/test/README b/test/README
index ec566cb..5f3c10a 100644
--- a/test/README
+++ b/test/README
@@ -39,6 +39,11 @@ The Makefile in this directory supports the following
targets:
* make check-all
Like "make check", but run all tests.
+* make check-<dirname>
+ Like "make check", but run only the tests in test/<dirname>/*.el.
+ <dirname> is a relative directory path, which has replaced "/" by "-",
+ like in "check-src" or "check-lisp-net".
+
* 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
@@ -55,7 +60,9 @@
https://www.gnu.org/software/emacs/manual/html_node/ert/Test-Selectors.html
You could use predefined selectors of the Makefile. "make <filename>
SELECTOR='$(SELECTOR_DEFAULT)'" runs all tests for <filename>.el
-except the tests tagged as expensive or unstable.
+except the tests tagged as expensive or unstable. Other predefined
+selectors are $(SELECTOR_EXPENSIVE) (run all tests except unstable
+ones) and $(SELECTOR_ALL) (run all tests).
If your test file contains the tests "test-foo", "test2-foo" and
"test-foo-remote", and you want to run only the former two tests, you
diff --git a/test/file-organization.org b/test/file-organization.org
index 64c0755..7cf5b88 100644
--- a/test/file-organization.org
+++ b/test/file-organization.org
@@ -17,13 +17,15 @@ Sub-directories are in many cases themed after packages
(~gnus~, ~org~,
~calc~), related functionality (~net~, ~emacs-lisp~, ~progmodes~) or status
(~obsolete~).
-C source is stored in the ~src~ directory, which is flat.
+C source is stored in the ~src~ directory, which is flat. Source for
+utility programs is stored in the ~lib-src~ directory.
** Test Files
Automated tests should be stored in the ~test/lisp~ directory for
-tests of functionality implemented in Lisp, and in the ~test/src~
-directory for functionality implemented in C. Tests should reflect
+tests of functionality implemented in Lisp, in the ~test/src~
+directory for functionality implemented in C, and in the
+~test/lib-src~ directory for utility programs. Tests should reflect
the directory structure of the source tree; so tests for files in the
~lisp/emacs-lisp~ source directory should reside in the
~test/lisp/emacs-lisp~ directory.
@@ -36,10 +38,10 @@ files of any name which are themselves placed in a
directory named
after the feature with ~-tests~ appended, such as
~/test/lisp/emacs-lisp/eieio-tests~
-Similarly, features implemented in C should reside in ~/test/src~ and
-be named after the C file with ~-tests.el~ added to the base-name of
-the tested source file. Thus, tests for ~src/fileio.c~ should be in
-~test/src/fileio-tests.el~.
+Similarly, tests of features implemented in C should reside in
+~/test/src~ or in ~test/lib-src~ and be named after the C file with
+~-tests.el~ added to the base-name of the tested source file. Thus,
+tests for ~src/fileio.c~ should be in ~test/src/fileio-tests.el~.
There are also some test materials that cannot be run automatically
(i.e. via ert). These should be placed in ~/test/manual~; they are
@@ -57,3 +59,8 @@ directory called ~test/lisp/progmodes/flymake-resources~.
No guidance is given for the organization of resource files inside the
~-resources~ directory; files can be organized at the author's
discretion.
+
+** Testing Infrastructure Files
+
+Files used to support testing infrastructure such as EMBA should be
+placed in ~infra~.
diff --git a/test/infra/Dockerfile.emba b/test/infra/Dockerfile.emba
new file mode 100644
index 0000000..421264d
--- /dev/null
+++ b/test/infra/Dockerfile.emba
@@ -0,0 +1,71 @@
+# Copyright (C) 2021 Free Software Foundation, Inc.
+#
+# This file is part of GNU Emacs.
+#
+# GNU Emacs is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# GNU Emacs is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with GNU Emacs. If not, see <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
diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml
new file mode 100644
index 0000000..ddabacf
--- /dev/null
+++ b/test/infra/gitlab-ci.yml
@@ -0,0 +1,243 @@
+# 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}"
+ # We don't use ${CI_COMMIT_SHA} to be able to do one bootstrap across
multiple builds
+ BUILD_TAG: ${CI_COMMIT_REF_SLUG}
+
+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:
+ 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
+ # 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"
+ # using the variables for each job
+ script:
+ - docker pull ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG}
+ # 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}-${BUILD_TAG} make ${make_params}
+
+.build-template:
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "web"'
+ when: always
+ - changes:
+ - "**/Makefile.in"
+ - .gitlab-ci.yml
+ - aclocal.m4
+ - autogen.sh
+ - configure.ac
+ - lib/*.{h,c}
+ - lisp/emacs-lisp/*.el
+ - src/*.{h,c}
+ - test/infra/*
+ - 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
+ script:
+ - docker build --pull --target ${target} -t
${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} -f test/infra/Dockerfile.emba .
+ - docker push ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG}
+
+.gnustep-template:
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "web"'
+ - 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 == "web"'
+ - 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
+
+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]
+ 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]
+ variables:
+ target: emacs-inotify
+ make_params: "-C test check-lisp"
+
+test-lisp-net-inotify:
+ stage: normal
+ extends: [.job-template]
+ variables:
+ target: emacs-inotify
+ make_params: "-C test check-lisp-net"
+
+test-filenotify-gio:
+ # This tests file monitor libraries gfilemonitor and gio.
+ stage: platforms
+ extends: [.job-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, .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]
+ rules:
+ # note there's no "changes" section, so this always runs on a schedule
+ - if: '$CI_PIPELINE_SOURCE == "web"'
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ variables:
+ target: emacs-inotify
+ make_params: check-expensive
diff --git a/test/lisp/calendar/lunar-tests.el
b/test/lisp/calendar/lunar-tests.el
index 5f1f678..268dcfd 100644
--- a/test/lisp/calendar/lunar-tests.el
+++ b/test/lisp/calendar/lunar-tests.el
@@ -27,39 +27,37 @@
(defmacro with-lunar-test (&rest body)
`(let ((calendar-latitude 40.1)
(calendar-longitude -88.2)
- (calendar-location-name "Urbana, IL")
- (calendar-time-zone -360)
- (calendar-standard-time-zone-name "CST")
- (calendar-time-display-form '(12-hours ":" minutes am-pm)))
+ (calendar-location-name "Paris")
+ (calendar-time-zone 0)
+ (calendar-standard-time-zone-name "UTC")
+ ;; Make sure daylight saving is disabled to avoid interference
+ ;; from the system settings (see bug#45818).
+ (calendar-daylight-savings-starts nil)
+ (calendar-time-display-form '(24-hours ":" minutes)))
,@body))
(ert-deftest lunar-test-phase ()
(with-lunar-test
(should (equal (lunar-phase 1)
- '((1 7 1900) "11:40pm" 1 "")))))
+ '((1 8 1900) "05:40" 1 "")))))
(ert-deftest lunar-test-eclipse-check ()
(with-lunar-test
(should (equal (eclipse-check 1 1) "** Eclipse **"))))
-;; This fails in certain time zones.
-;; Eg TZ=America/Phoenix make lisp/calendar/lunar-tests
-;; Similarly with TZ=UTC.
-;; Daylight saving related?
(ert-deftest lunar-test-phase-list ()
- :tags '(:unstable)
(with-lunar-test
(should (equal (lunar-phase-list 3 1871)
- '(((3 20 1871) "11:03pm" 0 "")
- ((3 29 1871) "1:46am" 1 "** Eclipse **")
- ((4 5 1871) "9:20am" 2 "")
- ((4 12 1871) "12:57am" 3 "** Eclipse possible **")
- ((4 19 1871) "2:06pm" 0 "")
- ((4 27 1871) "6:49pm" 1 "")
- ((5 4 1871) "5:57pm" 2 "")
- ((5 11 1871) "9:29am" 3 "")
- ((5 19 1871) "5:46am" 0 "")
- ((5 27 1871) "8:02am" 1 ""))))))
+ '(((3 21 1871) "04:03" 0 "")
+ ((3 29 1871) "06:46" 1 "** Eclipse **")
+ ((4 5 1871) "14:20" 2 "")
+ ((4 12 1871) "05:57" 3 "** Eclipse possible **")
+ ((4 19 1871) "19:06" 0 "")
+ ((4 27 1871) "23:49" 1 "")
+ ((5 4 1871) "22:57" 2 "")
+ ((5 11 1871) "14:29" 3 "")
+ ((5 19 1871) "10:46" 0 "")
+ ((5 27 1871) "13:02" 1 ""))))))
(ert-deftest lunar-test-new-moon-time ()
(with-lunar-test
diff --git a/test/lisp/calendar/solar-tests.el
b/test/lisp/calendar/solar-tests.el
index 7a37f8d..337deb8 100644
--- a/test/lisp/calendar/solar-tests.el
+++ b/test/lisp/calendar/solar-tests.el
@@ -26,7 +26,9 @@
(calendar-longitude 75.8)
(calendar-time-zone +330)
(calendar-standard-time-zone-name "IST")
- (calendar-daylight-time-zone-name "IST")
+ ;; Make sure our clockwork isn't confused by daylight saving rules
+ ;; in effect for any other time zone (bug#45818).
+ (calendar-daylight-savings-starts nil)
(epsilon (/ 60.0))) ; Minute accuracy is good enough.
(let* ((sunrise-sunset (solar-sunrise-sunset '(12 30 2020)))
(sunrise (car (nth 0 sunrise-sunset)))
diff --git a/test/lisp/cedet/semantic-utest.el
b/test/lisp/cedet/semantic-utest.el
index c009938..67de4a5 100644
--- a/test/lisp/cedet/semantic-utest.el
+++ b/test/lisp/cedet/semantic-utest.el
@@ -577,10 +577,8 @@ INSERTME is the text to be inserted after the deletion."
(ert-deftest semantic-utest-Javascript()
- (if (fboundp 'javascript-mode)
- (semantic-utest-generic (semantic-utest-fname "javascripttest.js")
semantic-utest-Javascript-buffer-contents
semantic-utest-Javascript-name-contents '("fun2") "//1" "//deleted line")
- (message "Skipping JavaScript test: NO major mode."))
- )
+ (skip-unless (fboundp 'javascript-mode))
+ (semantic-utest-generic (semantic-utest-fname "javascripttest.js")
semantic-utest-Javascript-buffer-contents
semantic-utest-Javascript-name-contents '("fun2") "//1" "//deleted line"))
(ert-deftest semantic-utest-Java()
;; If JDE is installed, it might mess things up depending on the version
diff --git a/test/lisp/cedet/srecode-utest-getset.el
b/test/lisp/cedet/srecode-utest-getset.el
index 0497dea..1c65780 100644
--- a/test/lisp/cedet/srecode-utest-getset.el
+++ b/test/lisp/cedet/srecode-utest-getset.el
@@ -128,7 +128,6 @@ private:
(srecode-utest-getset-jumptotag "miscFunction"))
(let ((pos (point)))
- (skip-chars-backward " \t\n") ; xemacs forward-comment is different.
(forward-comment -1)
(re-search-forward "miscFunction" pos))
diff --git a/test/lisp/cedet/srecode-utest-template.el
b/test/lisp/cedet/srecode-utest-template.el
index 57d8a64..f97ff18 100644
--- a/test/lisp/cedet/srecode-utest-template.el
+++ b/test/lisp/cedet/srecode-utest-template.el
@@ -307,13 +307,9 @@ INSIDE SECTION: ARG HANDLER ONE")
(should (srecode-table major-mode))
;; Loop over the output testpoints.
-
(dolist (p srecode-utest-output-entries)
- (set-buffer testbuff) ;; XEmacs causes a buffer switch. I don't know
why
- (should-not (srecode-utest-test p))
- )
+ (should-not (srecode-utest-test p)))))
- ))
(when (file-exists-p srecode-utest-testfile)
(delete-file srecode-utest-testfile)))
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el
b/test/lisp/emacs-lisp/bytecomp-tests.el
index a07af18..263736a 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -617,13 +617,13 @@ Subtests signal errors if something goes wrong."
(make-obsolete-variable 'bytecomp--tests-obsolete-var nil "99.99")
(bytecomp--define-warning-file-test "warn-obsolete-hook.el"
- "bytecomp--tests-obs.*obsolete.*99.99")
+ "bytecomp--tests-obs.*obsolete[^z-a]*99.99")
(bytecomp--define-warning-file-test "warn-obsolete-variable-same-file.el"
"foo-obs.*obsolete.*99.99" t)
(bytecomp--define-warning-file-test "warn-obsolete-variable.el"
- "bytecomp--tests-obs.*obsolete.*99.99")
+ "bytecomp--tests-obs.*obsolete[^z-a]*99.99")
(bytecomp--define-warning-file-test "warn-obsolete-variable-bound.el"
"bytecomp--tests-obs.*obsolete.*99.99" t)
diff --git a/test/lisp/emacs-lisp/pcase-tests.el
b/test/lisp/emacs-lisp/pcase-tests.el
index 1b06c6e..e6f4c09 100644
--- a/test/lisp/emacs-lisp/pcase-tests.el
+++ b/test/lisp/emacs-lisp/pcase-tests.el
@@ -32,6 +32,10 @@
(should (equal (pcase '(2 . 3) ;bug#18554
(`(,hd . ,(and (pred atom) tl)) (list hd tl))
((pred consp) nil))
+ '(2 3)))
+ (should (equal (pcase '(2 . 3)
+ (`(,hd . ,(and (pred (not consp)) tl)) (list hd tl))
+ ((pred consp) nil))
'(2 3))))
(pcase-defmacro pcase-tests-plus (pat n)
diff --git a/test/lisp/emacs-lisp/timer-tests.el
b/test/lisp/emacs-lisp/timer-tests.el
index 74da33e..7856c21 100644
--- a/test/lisp/emacs-lisp/timer-tests.el
+++ b/test/lisp/emacs-lisp/timer-tests.el
@@ -36,8 +36,8 @@
(ert-deftest timer-tests-debug-timer-check ()
;; This function exists only if --enable-checking.
- (if (fboundp 'debug-timer-check)
- (should (debug-timer-check)) t))
+ (skip-unless (fboundp 'debug-timer-check))
+ (should (debug-timer-check)))
(ert-deftest timer-test-multiple-of-time ()
(should (time-equal-p
diff --git a/test/lisp/gnus/mm-decode-resources/win1252-multipart.bin
b/test/lisp/gnus/mm-decode-resources/win1252-multipart.bin
new file mode 100644
index 0000000..d3c5026
--- /dev/null
+++ b/test/lisp/gnus/mm-decode-resources/win1252-multipart.bin
@@ -0,0 +1,44 @@
+To: example <example@example.org>
+From: example <example@example.org>
+Date: Tue, 5 Jan 2021 10:30:34 +0100
+MIME-Version: 1.0
+Content-Type: multipart/mixed; boundary="------------FB569A4368539497CC91D1DC"
+Content-Language: fr
+Subject: test
+
+--------------FB569A4368539497CC91D1DC
+Content-Type: multipart/alternative;
+ boundary="------------61C81A7DC7592E4C6F856A85"
+
+
+--------------61C81A7DC7592E4C6F856A85
+Content-Type: text/plain; charset=windows-1252; format=flowed
+Content-Transfer-Encoding: 8bit
+
+d�j� rat�
+
+--------------61C81A7DC7592E4C6F856A85
+Content-Type: text/html; charset=windows-1252
+Content-Transfer-Encoding: 8bit
+
+<html>
+ <head>
+ <meta http-equiv="content-type" content="text/html; charset=windows-1252">
+ </head>
+ <body>
+ d�j� rat�
+ </body>
+</html>
+
+--------------61C81A7DC7592E4C6F856A85--
+
+--------------FB569A4368539497CC91D1DC
+Content-Type: text/plain; charset="us-ascii"
+MIME-Version: 1.0
+Content-Transfer-Encoding: 7bit
+Content-Disposition: inline
+
+mailing list signature
+
+--------------FB569A4368539497CC91D1DC--
+
diff --git a/test/lisp/gnus/mm-decode-tests.el
b/test/lisp/gnus/mm-decode-tests.el
index 74591f9..7d059cb 100644
--- a/test/lisp/gnus/mm-decode-tests.el
+++ b/test/lisp/gnus/mm-decode-tests.el
@@ -70,20 +70,33 @@
'charset)))
"ääää\n"))))))
-(ert-deftest test-mm-with-part-multibyte ()
+(ert-deftest test-mm-dissect-buffer-win1252 ()
(with-temp-buffer
- (set-buffer-multibyte t)
- (nnheader-insert-file-contents (ert-resource-file "8bit-multipart.bin"))
- (while (search-forward "\r\n" nil t)
- (replace-match "\n"))
+ (set-buffer-multibyte nil)
+ (insert-file-contents-literally (ert-resource-file
"win1252-multipart.bin"))
(let ((handle (mm-dissect-buffer)))
+ (should (equal (mm-handle-media-type handle) "multipart/mixed"))
+ ;; Skip multipart type.
+ (pop handle)
+ (setq handle (car handle))
(pop handle)
(let ((part (pop handle)))
- (should (equal (decode-coding-string
- (mm-with-part part
- (buffer-string))
- (intern (mail-content-type-get (mm-handle-type part)
- 'charset)))
- "ääää\n"))))))
+ (should (equal (mm-handle-media-type part) "text/plain"))
+ (should (eq (mm-handle-encoding part) '8bit))
+ (with-current-buffer (mm-handle-buffer part)
+ (should (equal (decode-coding-string
+ (buffer-string)
+ (intern (mail-content-type-get (mm-handle-type part)
+ 'charset)))
+ "déjà raté\n"))))
+ (let ((part (pop handle)))
+ (should (equal (mm-handle-media-type part) "text/html"))
+ (should (eq (mm-handle-encoding part) '8bit))
+ (with-current-buffer (mm-handle-buffer part)
+ (should (equal (decode-coding-string
+ (buffer-string)
+ (intern (mail-content-type-get (mm-handle-type part)
+ 'charset)))
+ "<html>\n <head>\n <meta
http-equiv=\"content-type\" content=\"text/html; charset=windows-1252\">\n
</head>\n <body>\n déjà raté\n </body>\n</html>\n")))))))
;;; mm-decode-tests.el ends here
diff --git a/test/lisp/help-mode-tests.el b/test/lisp/help-mode-tests.el
index e0e82c9..43db59d 100644
--- a/test/lisp/help-mode-tests.el
+++ b/test/lisp/help-mode-tests.el
@@ -72,14 +72,19 @@ Lisp concepts such as car, cdr, cons cell and list.")
#'info)))))
(ert-deftest help-mode-tests-xref-button ()
- (with-temp-buffer
- (insert "See also the function ‘interactive’.")
- (string-match help-xref-symbol-regexp (buffer-string))
- (help-xref-button 8 'help-function)
- (should-not (button-at 22))
- (should-not (button-at 35))
- (let ((button (button-at 30)))
- (should (eq (button-type button) 'help-function)))))
+ (let* ((fmt "See also the function ‘%s’.")
+ ;; 1+ translates string index to buffer position.
+ (beg (1+ (string-search "%" fmt))))
+ (with-temp-buffer
+ (dolist (fn '(interactive \` = + - * / %))
+ (erase-buffer)
+ (insert (format fmt fn))
+ (goto-char (point-min))
+ (re-search-forward help-xref-symbol-regexp)
+ (help-xref-button 8 'help-function)
+ (should-not (button-at (1- beg)))
+ (should-not (button-at (+ beg (length (symbol-name fn)))))
+ (should (eq (button-type (button-at beg)) 'help-function))))))
(ert-deftest help-mode-tests-insert-xref-button ()
(with-temp-buffer
diff --git a/test/lisp/help-tests.el b/test/lisp/help-tests.el
index 835d9fe..8034764 100644
--- a/test/lisp/help-tests.el
+++ b/test/lisp/help-tests.el
@@ -95,7 +95,7 @@
key binding
--- -------
-C-g abort-recursive-edit
+C-g abort-minibuffers
TAB minibuffer-complete
C-j minibuffer-complete-and-exit
RET minibuffer-complete-and-exit
@@ -122,7 +122,7 @@ M-s next-matching-history-element
(ert-deftest help-tests-substitute-command-keys/keymap-change ()
(with-substitute-command-keys-test
- (test "\\<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
diff --git a/test/lisp/net/nsm-tests.el b/test/lisp/net/nsm-tests.el
index 88c30c2..ff45331 100644
--- a/test/lisp/net/nsm-tests.el
+++ b/test/lisp/net/nsm-tests.el
@@ -49,15 +49,17 @@
(should (eq nil (nsm-should-check "127.0.0.1")))
(should (eq nil (nsm-should-check "localhost"))))))
-(defun nsm-ipv6-is-available ()
+;; This will need updating when IANA assign more IPv6 global ranges.
+(defun ipv6-is-available ()
(and (featurep 'make-network-process '(:family ipv6))
(cl-rassoc-if
(lambda (elt)
- (eq 9 (length elt)))
+ (and (eq 9 (length elt))
+ (= (logand (aref elt 0) #xe000) #x2000)))
(network-interface-list))))
(ert-deftest nsm-check-local-subnet-ipv6 ()
- (skip-unless (nsm-ipv6-is-available))
+ (skip-unless (ipv6-is-available))
(let ((local-ip '[123 456 789 11 172 26 128 160 0])
(mask '[255 255 255 255 255 255 255 0 0])
diff --git a/test/lisp/net/socks-tests.el b/test/lisp/net/socks-tests.el
new file mode 100644
index 0000000..b378ed2
--- /dev/null
+++ b/test/lisp/net/socks-tests.el
@@ -0,0 +1,103 @@
+;;; socks-tests.el --- tests for SOCKS -*- coding: utf-8; lexical-binding: t;
-*-
+
+;; Copyright (C) 2021 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'socks)
+(require 'url-http)
+
+(defvar socks-tests-canned-server-port nil)
+
+(defun socks-tests-canned-server-create (verbatim patterns)
+ "Create a fake SOCKS server and return the process.
+
+`VERBATIM' and `PATTERNS' are dotted alists containing responses.
+Requests are tried in order. On failure, an error is raised."
+ (let* ((buf (generate-new-buffer "*canned-socks-server*"))
+ (filt (lambda (proc line)
+ (let ((resp (or (assoc-default line verbatim
+ (lambda (k s) ; s is line
+ (string= (concat k) s)))
+ (assoc-default line patterns
+ (lambda (p s)
+ (string-match-p p s))))))
+ (unless resp
+ (error "Unknown request: %s" line))
+ (let ((print-escape-control-characters t))
+ (princ (format "<- %s\n" (prin1-to-string line)) buf)
+ (princ (format "-> %s\n" (prin1-to-string resp)) buf))
+ (process-send-string proc (concat resp)))))
+ (srv (make-network-process :server 1
+ :buffer buf
+ :filter filt
+ :name "server"
+ :family 'ipv4
+ :host 'local
+ :service socks-tests-canned-server-port)))
+ (set-process-query-on-exit-flag srv nil)
+ (princ (format "[%s] Listening on localhost:10080\n" srv) buf)
+ srv))
+
+;; Add ([5 3 0 1 2] . [5 2]) to the `verbatim' list below to validate
+;; against curl 7.71 with the following options:
+;; $ curl --verbose -U foo:bar --proxy socks5h://127.0.0.1:10080 example.com
+;;
+;; If later implementing version 4a, try these:
+;; [4 1 0 80 0 0 0 1 0 ?e ?x ?a ?m ?p ?l ?e ?. ?c ?o ?m 0] . [0 90 0 0 0 0 0 0]
+;; $ curl --verbose --proxy socks4a://127.0.0.1:10080 example.com
+
+(ert-deftest socks-tests-auth-filter-url-http ()
+ "Verify correct handling of SOCKS5 user/pass authentication."
+ (let* ((socks-server '("server" "127.0.0.1" 10080 5))
+ (socks-username "foo")
+ (socks-password "bar")
+ (url-gateway-method 'socks)
+ (url (url-generic-parse-url "http://example.com";))
+ (verbatim '(([5 2 0 2] . [5 2])
+ ([1 3 ?f ?o ?o 3 ?b ?a ?r] . [1 0])
+ ([5 1 0 3 11 ?e ?x ?a ?m ?p ?l ?e ?. ?c ?o ?m 0 80]
+ . [5 0 0 1 0 0 0 0 0 0])))
+ (patterns
+ `(("^GET /" . ,(concat "HTTP/1.1 200 OK\r\n"
+ "Content-Type: text/plain; charset=UTF-8\r\n"
+ "Content-Length: 13\r\n\r\n"
+ "Hello World!\n"))))
+ (socks-tests-canned-server-port 10080)
+ (server (socks-tests-canned-server-create verbatim patterns))
+ (tries 10)
+ ;;
+ done
+ ;;
+ (cb (lambda (&rest _r)
+ (goto-char (point-min))
+ (should (search-forward "Hello World" nil t))
+ (setq done t)))
+ (buf (url-http url cb '(nil))))
+ (ert-info ("Connect to HTTP endpoint over SOCKS5 with USER/PASS method")
+ (while (and (not done) (< 0 (cl-decf tries))) ; cl-lib via url-http
+ (sleep-for 0.1)))
+ (should done)
+ (delete-process server)
+ (kill-buffer (process-buffer server))
+ (kill-buffer buf)
+ (ignore url-gateway-method)))
+
+;;; socks-tests.el ends here
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index e1cb993..5deee65 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -78,6 +78,8 @@
;; Needed for Emacs 27.
(defvar process-file-return-signal-string)
(defvar shell-command-dont-erase-buffer)
+;; Needed for Emacs 28.
+(defvar dired-copy-dereference)
;; Beautify batch mode.
(when noninteractive
@@ -98,7 +100,6 @@
'("mock"
(tramp-login-program "sh")
(tramp-login-args (("-i")))
- (tramp-direct-async-args (("-c")))
(tramp-remote-shell "/bin/sh")
(tramp-remote-shell-args ("-c"))
(tramp-connection-timeout 10)))
@@ -2271,8 +2272,8 @@ This checks also `file-name-as-directory',
`file-name-directory',
(delete-file tmp-name)
(should-not (file-exists-p tmp-name))
- ;; Trashing files doesn't work for crypted remote files.
- (unless (tramp--test-crypt-p)
+ ;; Trashing files doesn't work on MS Windows, and for crypted remote
files.
+ (unless (or (tramp--test-windows-nt-p) (tramp--test-crypt-p))
(let ((trash-directory (tramp--test-make-temp-name 'local quoted))
(delete-by-moving-to-trash t))
(make-directory trash-directory)
@@ -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))
@@ -2785,9 +2786,9 @@ This tests also `file-directory-p' and
`file-accessible-directory-p'."
(should-not (file-directory-p tmp-name1))
;; Trashing directories works only since Emacs 27.1. It doesn't
- ;; work for crypted remote directories and for ange-ftp.
- (when (and (not (tramp--test-crypt-p)) (not (tramp--test-ftp-p))
- (tramp--test-emacs27-p))
+ ;; work on MS Windows, for crypted remote directories and for ange-ftp.
+ (when (and (not (tramp--test-windows-nt-p)) (not (tramp--test-crypt-p))
+ (not (tramp--test-ftp-p)) (tramp--test-emacs27-p))
(let ((trash-directory (tramp--test-make-temp-name 'local quoted))
(delete-by-moving-to-trash t))
(make-directory trash-directory)
@@ -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))
@@ -3067,9 +3069,7 @@ This tests also `file-directory-p' and
`file-accessible-directory-p'."
(regexp-opt (directory-files tmp-name1))
(length (directory-files tmp-name1)))))))
- ;; Check error case. We do not check for the error type,
- ;; because ls-lisp returns `file-error', and native Tramp
- ;; returns `file-missing'.
+ ;; Check error case.
(delete-directory tmp-name1 'recursive)
(with-temp-buffer
(should-error
@@ -3188,6 +3188,59 @@ This tests also `file-directory-p' and
`file-accessible-directory-p'."
(ignore-errors (delete-directory tmp-name1 'recursive))
(ignore-errors (delete-directory tmp-name2 'recursive))))))
+;; The following test is inspired by Bug#45691.
+(ert-deftest tramp-test17-insert-directory-one-file ()
+ "Check `insert-directory' inside directory listing."
+ (skip-unless (tramp--test-enabled))
+
+ (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
+ (let* ((tmp-name1
+ (expand-file-name (tramp--test-make-temp-name nil quoted)))
+ (tmp-name2 (expand-file-name "foo" tmp-name1))
+ (tmp-name3 (expand-file-name "bar" tmp-name1))
+ (dired-copy-preserve-time t)
+ (dired-recursive-copies 'top)
+ dired-copy-dereference
+ buffer)
+ (unwind-protect
+ (progn
+ (make-directory tmp-name1)
+ (write-region "foo" nil tmp-name2)
+ (should (file-directory-p tmp-name1))
+ (should (file-exists-p tmp-name2))
+
+ ;; Check, that `insert-directory' works properly.
+ (with-current-buffer
+ (setq buffer (dired-noselect tmp-name1 "--dired -al"))
+ (read-only-mode -1)
+ (goto-char (point-min))
+ (while (not (or (eobp)
+ (string-equal
+ (dired-get-filename 'localp 'no-error)
+ (file-name-nondirectory tmp-name2))))
+ (forward-line 1))
+ (should-not (eobp))
+ (copy-file tmp-name2 tmp-name3)
+ (insert-directory
+ (file-name-nondirectory tmp-name3) "--dired -al -d")
+ ;; Point shall still be the recent file.
+ (should
+ (string-equal
+ (dired-get-filename 'localp 'no-error)
+ (file-name-nondirectory tmp-name2)))
+ (should-not (re-search-forward "dired" nil t))
+ ;; The copied file has been inserted the line before.
+ (forward-line -1)
+ (should
+ (string-equal
+ (dired-get-filename 'localp 'no-error)
+ (file-name-nondirectory tmp-name3))))
+ (kill-buffer buffer))
+
+ ;; Cleanup.
+ (ignore-errors (kill-buffer buffer))
+ (ignore-errors (delete-directory tmp-name1 'recursive))))))
+
;; Method "smb" supports `make-symbolic-link' only if the remote host
;; has CIFS capabilities. tramp-adb.el, tramp-gvfs.el and
;; tramp-rclone.el do not support symbolic links at all.
@@ -3561,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 ()
@@ -4337,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")
@@ -4405,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)))
@@ -4424,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
@@ -4446,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)))
@@ -4488,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.
@@ -4535,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)))
@@ -4556,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
@@ -4580,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)))
@@ -4607,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)))
@@ -4631,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.
@@ -4658,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.
@@ -4801,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)
@@ -4992,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
@@ -5003,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"))))
@@ -5021,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
@@ -5029,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
@@ -5074,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))))))
@@ -5202,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)
@@ -5337,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)
@@ -5681,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)
@@ -5695,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.
@@ -5758,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))))
@@ -6021,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))
@@ -6032,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)))
@@ -6050,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)))
@@ -6072,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
@@ -6140,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))
@@ -6155,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)))
@@ -6177,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)))
@@ -6202,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
@@ -6284,6 +6349,7 @@ process sentinels. They shall not disturb each other."
(tramp--test-sh-p)))
(skip-unless (not (tramp--test-crypt-p)))
(skip-unless (not (tramp--test-docker-p)))
+ (skip-unless (not (tramp--test-windows-nt-p)))
(with-timeout
(tramp--test-asynchronous-requests-timeout (tramp--test-timeout-handler))
@@ -6293,12 +6359,11 @@ process sentinels. They shall not disturb each other."
(shell-file-name (if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh"))
;; It doesn't work on w32 systems.
(watchdog
- (unless (tramp--test-windows-nt-p)
- (start-process-shell-command
- "*watchdog*" nil
- (format
- "sleep %d; kill -USR1 %d"
- tramp--test-asynchronous-requests-timeout (emacs-pid)))))
+ (start-process-shell-command
+ "*watchdog*" nil
+ (format
+ "sleep %d; kill -USR1 %d"
+ tramp--test-asynchronous-requests-timeout (emacs-pid))))
(tmp-name (tramp--test-make-temp-name))
(default-directory tmp-name)
;; Do not cache Tramp properties.
@@ -6490,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
@@ -6521,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)
@@ -6547,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
@@ -6572,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
@@ -6619,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.
@@ -6631,15 +6696,15 @@ Since it unloads Tramp, it shall be the last test to
run."
(mapatoms
(lambda (x)
(and (functionp x)
- (string-match "tramp-file-name" (symbol-name x))
+ (string-match-p "tramp-file-name" (symbol-name x))
(ert-fail (format "Structure function `%s' still exists" x)))))
;; There shouldn't be left a hook function containing a Tramp
;; function. We do not regard the Tramp unload hooks.
(mapatoms
(lambda (x)
(and (boundp x)
- (string-match "-\\(hook\\|function\\)s?$" (symbol-name x))
- (not (string-match "unload-hook$" (symbol-name x)))
+ (string-match-p "-\\(hook\\|function\\)s?$" (symbol-name x))
+ (not (string-match-p "unload-hook$" (symbol-name x)))
(consp (symbol-value x))
(ignore-errors (all-completions "tramp" (symbol-value x)))
(ert-fail (format "Hook `%s' still contains Tramp function" x))))))
diff --git a/test/lisp/progmodes/elisp-mode-tests.el
b/test/lisp/progmodes/elisp-mode-tests.el
index a10d5da..fd43707 100644
--- a/test/lisp/progmodes/elisp-mode-tests.el
+++ b/test/lisp/progmodes/elisp-mode-tests.el
@@ -314,7 +314,19 @@
(let* ((xref (pop xrefs))
(expected (pop expected-xrefs))
(expected-xref (or (when (consp expected) (car expected)) expected))
- (expected-source (when (consp expected) (cdr expected))))
+ (expected-source (when (consp expected) (cdr expected)))
+ (xref-file (xref-elisp-location-file (oref xref location)))
+ (expected-file (xref-elisp-location-file
+ (oref expected-xref location))))
+
+ ;; Make sure file names compare as strings.
+ (when (file-name-absolute-p xref-file)
+ (setf (xref-elisp-location-file (oref xref location))
+ (file-truename (xref-elisp-location-file (oref xref location)))))
+ (when (file-name-absolute-p expected-file)
+ (setf (xref-elisp-location-file (oref expected-xref location))
+ (file-truename (xref-elisp-location-file
+ (oref expected-xref location)))))
;; Downcase the filenames for case-insensitive file systems.
(when xref--case-insensitive
diff --git a/test/lisp/progmodes/tcl-tests.el b/test/lisp/progmodes/tcl-tests.el
index 8ff8547..cf1ed28 100644
--- a/test/lisp/progmodes/tcl-tests.el
+++ b/test/lisp/progmodes/tcl-tests.el
@@ -50,14 +50,14 @@
(insert "proc notinthis {} {\n # nothing\n}\n\n")
(should-not (add-log-current-defun))))
-(ert-deftest tcl-mode-function-name ()
+(ert-deftest tcl-mode-function-name-2 ()
(with-temp-buffer
(tcl-mode)
(insert "proc simple {} {\n # nothing\n}")
(backward-char 3)
(should (equal "simple" (add-log-current-defun)))))
-(ert-deftest tcl-mode-function-name ()
+(ert-deftest tcl-mode-function-name-3 ()
(with-temp-buffer
(tcl-mode)
(insert "proc inthis {} {\n # nothing\n")
@@ -72,6 +72,16 @@
(indent-region (point-min) (point-max))
(should (equal (buffer-string) text)))))
+;; From bug#44834
+(ert-deftest tcl-mode-namespace-indent-2 ()
+ :expected-result :failed
+ (with-temp-buffer
+ (tcl-mode)
+ (let ((text "namespace eval Foo {\n proc foo {} {}\n\n proc bar
{}{}}\n"))
+ (insert text)
+ (indent-region (point-min) (point-max))
+ (should (equal (buffer-string) text)))))
+
(provide 'tcl-tests)
;;; tcl-tests.el ends here
diff --git a/test/lisp/replace-tests.el b/test/lisp/replace-tests.el
index 8c2682a..2db570c 100644
--- a/test/lisp/replace-tests.el
+++ b/test/lisp/replace-tests.el
@@ -587,5 +587,18 @@ bound to HIGHLIGHT-LOCUS."
(get-text-property (point) 'occur-target))
(should (funcall check-overlays has-overlay)))))))
+(ert-deftest replace-regexp-bug45973 ()
+ "Test for https://debbugs.gnu.org/45973 ."
+ (let ((before "1RB 1LC 1RC 1RB 1RD 0LE 1LA 1LD 1RH 0LA")
+ (after "1LB 1RC 1LC 1LB 1LD 0RE 1RA 1RD 1LH 0RA"))
+ (with-temp-buffer
+ (insert before)
+ (goto-char (point-min))
+ (replace-regexp
+ "\\(\\(L\\)\\|\\(R\\)\\)"
+ '(replace-eval-replacement
+ replace-quote
+ (if (match-string 2) "R" "L")))
+ (should (equal (buffer-string) after)))))
;;; replace-tests.el ends here
diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el
index e082620..fc5a1eb 100644
--- a/test/lisp/subr-tests.el
+++ b/test/lisp/subr-tests.el
@@ -87,6 +87,17 @@
;; Returns the symbol.
(should (eq (define-prefix-command 'foo-bar) 'foo-bar)))
+(ert-deftest subr-test-local-key-binding ()
+ (with-temp-buffer
+ (emacs-lisp-mode)
+ (should (keymapp (local-key-binding [menu-bar])))
+ (should-not (local-key-binding [f12]))))
+
+(ert-deftest subr-test-global-key-binding ()
+ (should (eq (global-key-binding [f1]) 'help-command))
+ (should (eq (global-key-binding "x") 'self-insert-command))
+ (should-not (global-key-binding [f12])))
+
;;;; Mode hooks.
diff --git a/test/lisp/textmodes/fill-tests.el
b/test/lisp/textmodes/fill-tests.el
index f2c63a9..21efe62 100644
--- a/test/lisp/textmodes/fill-tests.el
+++ b/test/lisp/textmodes/fill-tests.el
@@ -44,6 +44,37 @@
(fill-paragraph)
(should (string= (buffer-string) "Abc\nd efg\n(h ijk)."))))
+(ert-deftest fill-test-unbreakable-paragraph ()
+ (with-temp-buffer
+ (let ((string "aaa = baaaaaaaaaaaaaaaaaaaaaaaaaaaa\n"))
+ (insert string)
+ (goto-char (point-min))
+ (search-forward "b")
+ (let* ((pos (point))
+ (beg (line-beginning-position))
+ (end (line-end-position))
+ (fill-prefix (make-string (- pos beg) ?\s))
+ ;; `fill-column' is too small to accomodate the current line
+ (fill-column (- end beg 10)))
+ (fill-region-as-paragraph beg end nil nil pos))
+ (should (equal (buffer-string) string)))))
+
+(ert-deftest fill-test-breakable-paragraph ()
+ (with-temp-buffer
+ (let ((string "aaa = baaaaaaaa aaaaaaaaaa aaaaaaaaaa\n"))
+ (insert string)
+ (goto-char (point-min))
+ (search-forward "b")
+ (let* ((pos (point))
+ (beg (line-beginning-position))
+ (end (line-end-position))
+ (fill-prefix (make-string (- pos beg) ?\s))
+ ;; `fill-column' is too small to accomodate the current line
+ (fill-column (- end beg 10)))
+ (fill-region-as-paragraph beg end nil nil pos))
+ (should (equal
+ (buffer-string)
+ "aaa = baaaaaaaa aaaaaaaaaa\n aaaaaaaaaa\n")))))
(provide 'fill-tests)
diff --git a/test/lisp/time-stamp-tests.el b/test/lisp/time-stamp-tests.el
index 81488c3..4ae3c19 100644
--- a/test/lisp/time-stamp-tests.el
+++ b/test/lisp/time-stamp-tests.el
@@ -262,40 +262,48 @@
(ert-deftest time-stamp-format-day-of-week ()
"Test time-stamp formats for named day of week."
(with-time-stamp-test-env
- ;; implemented and documented since 1997
- (should (equal (time-stamp-string "%3a" ref-time1) "Mon"))
- (should (equal (time-stamp-string "%#A" ref-time1) "MONDAY"))
- ;; documented 1997-2019
- (should (equal (time-stamp-string "%3A" ref-time1) "MON"))
- (should (equal (time-stamp-string "%:a" ref-time1) "Monday"))
- ;; implemented since 2001, documented since 2019
- (should (equal (time-stamp-string "%#a" ref-time1) "MON"))
- (should (equal (time-stamp-string "%:A" ref-time1) "Monday"))
- ;; allowed but undocumented since 2019 (warned 1997-2019)
- (should (equal (time-stamp-string "%^A" ref-time1) "MONDAY"))
- ;; warned 1997-2019, changed in 2019
- (should (equal (time-stamp-string "%a" ref-time1) "Mon"))
- (should (equal (time-stamp-string "%^a" ref-time1) "MON"))
- (should (equal (time-stamp-string "%A" ref-time1) "Monday"))))
+ (let ((Mon (format-time-string "%a" ref-time1 t))
+ (MON (format-time-string "%^a" ref-time1 t))
+ (Monday (format-time-string "%A" ref-time1 t))
+ (MONDAY (format-time-string "%^A" ref-time1 t)))
+ ;; implemented and documented since 1997
+ (should (equal (time-stamp-string "%3a" ref-time1) Mon))
+ (should (equal (time-stamp-string "%#A" ref-time1) MONDAY))
+ ;; documented 1997-2019
+ (should (equal (time-stamp-string "%3A" ref-time1) MON))
+ (should (equal (time-stamp-string "%:a" ref-time1) Monday))
+ ;; implemented since 2001, documented since 2019
+ (should (equal (time-stamp-string "%#a" ref-time1) MON))
+ (should (equal (time-stamp-string "%:A" ref-time1) Monday))
+ ;; allowed but undocumented since 2019 (warned 1997-2019)
+ (should (equal (time-stamp-string "%^A" ref-time1) MONDAY))
+ ;; warned 1997-2019, changed in 2019
+ (should (equal (time-stamp-string "%a" ref-time1) Mon))
+ (should (equal (time-stamp-string "%^a" ref-time1) MON))
+ (should (equal (time-stamp-string "%A" ref-time1) Monday)))))
(ert-deftest time-stamp-format-month-name ()
"Test time-stamp formats for month name."
(with-time-stamp-test-env
- ;; implemented and documented since 1997
- (should (equal (time-stamp-string "%3b" ref-time1) "Jan"))
- (should (equal (time-stamp-string "%#B" ref-time1) "JANUARY"))
- ;; documented 1997-2019
- (should (equal (time-stamp-string "%3B" ref-time1) "JAN"))
- (should (equal (time-stamp-string "%:b" ref-time1) "January"))
- ;; implemented since 2001, documented since 2019
- (should (equal (time-stamp-string "%#b" ref-time1) "JAN"))
- (should (equal (time-stamp-string "%:B" ref-time1) "January"))
- ;; allowed but undocumented since 2019 (warned 1997-2019)
- (should (equal (time-stamp-string "%^B" ref-time1) "JANUARY"))
- ;; warned 1997-2019, changed in 2019
- (should (equal (time-stamp-string "%b" ref-time1) "Jan"))
- (should (equal (time-stamp-string "%^b" ref-time1) "JAN"))
- (should (equal (time-stamp-string "%B" ref-time1) "January"))))
+ (let ((Jan (format-time-string "%b" ref-time1 t))
+ (JAN (format-time-string "%^b" ref-time1 t))
+ (January (format-time-string "%B" ref-time1 t))
+ (JANUARY (format-time-string "%^B" ref-time1 t)))
+ ;; implemented and documented since 1997
+ (should (equal (time-stamp-string "%3b" ref-time1) Jan))
+ (should (equal (time-stamp-string "%#B" ref-time1) JANUARY))
+ ;; documented 1997-2019
+ (should (equal (time-stamp-string "%3B" ref-time1) JAN))
+ (should (equal (time-stamp-string "%:b" ref-time1) January))
+ ;; implemented since 2001, documented since 2019
+ (should (equal (time-stamp-string "%#b" ref-time1) JAN))
+ (should (equal (time-stamp-string "%:B" ref-time1) January))
+ ;; allowed but undocumented since 2019 (warned 1997-2019)
+ (should (equal (time-stamp-string "%^B" ref-time1) JANUARY))
+ ;; warned 1997-2019, changed in 2019
+ (should (equal (time-stamp-string "%b" ref-time1) Jan))
+ (should (equal (time-stamp-string "%^b" ref-time1) JAN))
+ (should (equal (time-stamp-string "%B" ref-time1) January)))))
(ert-deftest time-stamp-format-day-of-month ()
"Test time-stamp formats for day of month."
@@ -483,14 +491,18 @@
(ert-deftest time-stamp-format-am-pm ()
"Test time-stamp formats for AM and PM strings."
(with-time-stamp-test-env
- ;; implemented and documented since 1997
- (should (equal (time-stamp-string "%#p" ref-time1) "pm"))
- (should (equal (time-stamp-string "%#p" ref-time3) "am"))
- (should (equal (time-stamp-string "%P" ref-time1) "PM"))
- (should (equal (time-stamp-string "%P" ref-time3) "AM"))
- ;; warned 1997-2019, changed in 2019
- (should (equal (time-stamp-string "%p" ref-time1) "PM"))
- (should (equal (time-stamp-string "%p" ref-time3) "AM"))))
+ (let ((pm (format-time-string "%#p" ref-time1 t))
+ (am (format-time-string "%#p" ref-time3 t))
+ (PM (format-time-string "%p" ref-time1 t))
+ (AM (format-time-string "%p" ref-time3 t)))
+ ;; implemented and documented since 1997
+ (should (equal (time-stamp-string "%#p" ref-time1) pm))
+ (should (equal (time-stamp-string "%#p" ref-time3) am))
+ (should (equal (time-stamp-string "%P" ref-time1) PM))
+ (should (equal (time-stamp-string "%P" ref-time3) AM))
+ ;; warned 1997-2019, changed in 2019
+ (should (equal (time-stamp-string "%p" ref-time1) PM))
+ (should (equal (time-stamp-string "%p" ref-time3) AM)))))
(ert-deftest time-stamp-format-day-number-in-week ()
"Test time-stamp formats for day number in week."
@@ -567,10 +579,15 @@
(ert-deftest time-stamp-format-ignored-modifiers ()
"Test additional args allowed (but ignored) to allow for future expansion."
(with-time-stamp-test-env
- ;; allowed modifiers
- (should (equal (time-stamp-string "%.,@-+_ ^(stuff)P" ref-time3) "AM"))
- ;; not all punctuation is allowed
- (should-not (equal (time-stamp-string "%&P" ref-time3) "AM"))))
+ (let ((May (format-time-string "%B" ref-time3 t)))
+ ;; allowed modifiers
+ (should (equal (time-stamp-string "%.,@+ (stuff)B" ref-time3) May))
+ ;; parens nest
+ (should (equal (time-stamp-string "%(st(u)ff)B" ref-time3) May))
+ ;; escaped parens do not change the nesting level
+ (should (equal (time-stamp-string "%(st\\)u\\(ff)B" ref-time3) May))
+ ;; not all punctuation is allowed
+ (should-not (equal (time-stamp-string "%&B" ref-time3) May)))))
(ert-deftest time-stamp-format-non-conversions ()
"Test that without a %, the text is copied literally."
@@ -580,16 +597,22 @@
(ert-deftest time-stamp-format-string-width ()
"Test time-stamp string width modifiers."
(with-time-stamp-test-env
- ;; strings truncate on the right or are blank-padded on the left
- (should (equal (time-stamp-string "%0P" ref-time3) ""))
- (should (equal (time-stamp-string "%1P" ref-time3) "A"))
- (should (equal (time-stamp-string "%2P" ref-time3) "AM"))
- (should (equal (time-stamp-string "%3P" ref-time3) " AM"))
- (should (equal (time-stamp-string "%0%" ref-time3) ""))
- (should (equal (time-stamp-string "%1%" ref-time3) "%"))
- (should (equal (time-stamp-string "%2%" ref-time3) " %"))
- (should (equal (time-stamp-string "%#3a" ref-time3) "SUN"))
- (should (equal (time-stamp-string "%#3b" ref-time2) "NOV"))))
+ (let ((May (format-time-string "%b" ref-time3 t))
+ (SUN (format-time-string "%^a" ref-time3 t))
+ (NOV (format-time-string "%^b" ref-time2 t)))
+ ;; strings truncate on the right or are blank-padded on the left
+ (should (equal (time-stamp-string "%0b" ref-time3) ""))
+ (should (equal (time-stamp-string "%1b" ref-time3) (substring May 0 1)))
+ (should (equal (time-stamp-string "%2b" ref-time3) (substring May 0 2)))
+ (should (equal (time-stamp-string "%3b" ref-time3) May))
+ (should (equal (time-stamp-string "%4b" ref-time3) (concat " " May)))
+ (should (equal (time-stamp-string "%0%" ref-time3) ""))
+ (should (equal (time-stamp-string "%1%" ref-time3) "%"))
+ (should (equal (time-stamp-string "%2%" ref-time3) " %"))
+ (should (equal (time-stamp-string "%9%" ref-time3) " %"))
+ (should (equal (time-stamp-string "%10%" ref-time3) " %"))
+ (should (equal (time-stamp-string "%#3a" ref-time3) SUN))
+ (should (equal (time-stamp-string "%#3b" ref-time2) NOV)))))
;;; Tests of helper functions
diff --git a/test/lisp/wid-edit-tests.el b/test/lisp/wid-edit-tests.el
index 17fdfef..f843649 100644
--- a/test/lisp/wid-edit-tests.el
+++ b/test/lisp/wid-edit-tests.el
@@ -322,4 +322,15 @@ return nil, even with a non-nil bubblep argument."
(widget-backward 1)
(should (string= "Second" (widget-value (widget-at))))))
+(ert-deftest widget-test-color-match ()
+ "Test that the :match function for the color widget works."
+ (let ((widget (widget-convert 'color)))
+ (should (widget-apply widget :match "red"))
+ (should (widget-apply widget :match "#fa3"))
+ (should (widget-apply widget :match "#ff0000"))
+ (should (widget-apply widget :match "#111222333"))
+ (should (widget-apply widget :match "#111122223333"))
+ (should-not (widget-apply widget :match "someundefinedcolorihope"))
+ (should-not (widget-apply widget :match "#11223"))))
+
;;; wid-edit-tests.el ends here
diff --git a/test/src/decompress-tests.el b/test/src/decompress-tests.el
index 67a7fef..520445c 100644
--- a/test/src/decompress-tests.el
+++ b/test/src/decompress-tests.el
@@ -29,16 +29,16 @@
(ert-deftest zlib--decompress ()
"Test decompressing a gzipped file."
- (when (and (fboundp 'zlib-available-p)
- (zlib-available-p))
- (should (string=
- (with-temp-buffer
- (set-buffer-multibyte nil)
- (insert-file-contents-literally
- (expand-file-name "foo.gz" zlib-tests-data-directory))
- (zlib-decompress-region (point-min) (point-max))
- (buffer-string))
- "foo\n"))))
+ (skip-unless (and (fboundp 'zlib-available-p)
+ (zlib-available-p)))
+ (should (string=
+ (with-temp-buffer
+ (set-buffer-multibyte nil)
+ (insert-file-contents-literally
+ (expand-file-name "foo.gz" zlib-tests-data-directory))
+ (zlib-decompress-region (point-min) (point-max))
+ (buffer-string))
+ "foo\n")))
(provide 'decompress-tests)
diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el
index a9daf87..e0aed2a 100644
--- a/test/src/fns-tests.el
+++ b/test/src/fns-tests.el
@@ -1040,3 +1040,61 @@
(let ((list (list 1)))
(setcdr list list)
(length< list #x1fffe))))
+
+(defun approx-equal (list1 list2)
+ (and (equal (length list1) (length list2))
+ (cl-loop for v1 in list1
+ for v2 in list2
+ when (not (or (= v1 v2)
+ (< (abs (- v1 v2)) 0.1)))
+ return nil
+ finally return t)))
+
+(ert-deftest test-buffer-line-stats-nogap ()
+ (with-temp-buffer
+ (insert "")
+ (should (approx-equal (buffer-line-statistics) '(0 0 0))))
+ (with-temp-buffer
+ (insert "123\n")
+ (should (approx-equal (buffer-line-statistics) '(1 3 3))))
+ (with-temp-buffer
+ (insert "123\n12345\n123\n")
+ (should (approx-equal (buffer-line-statistics) '(3 5 3.66))))
+ (with-temp-buffer
+ (insert "123\n12345\n123")
+ (should (approx-equal (buffer-line-statistics) '(3 5 3.66))))
+ (with-temp-buffer
+ (insert "123\n12345")
+ (should (approx-equal (buffer-line-statistics) '(2 5 4))))
+
+ (with-temp-buffer
+ (insert "123\n12é45\n123\n")
+ (should (approx-equal (buffer-line-statistics) '(3 6 4))))
+
+ (with-temp-buffer
+ (insert "\n\n\n")
+ (should (approx-equal (buffer-line-statistics) '(3 0 0)))))
+
+(ert-deftest test-buffer-line-stats-gap ()
+ (with-temp-buffer
+ (dotimes (_ 1000)
+ (insert "12345678901234567890123456789012345678901234567890\n"))
+ (goto-char (point-min))
+ ;; This should make a gap appear.
+ (insert "123\n")
+ (delete-region (point-min) (point))
+ (should (approx-equal (buffer-line-statistics) '(1000 50 50.0))))
+ (with-temp-buffer
+ (dotimes (_ 1000)
+ (insert "12345678901234567890123456789012345678901234567890\n"))
+ (goto-char (point-min))
+ (insert "123\n")
+ (should (approx-equal (buffer-line-statistics) '(1001 50 49.9))))
+ (with-temp-buffer
+ (dotimes (_ 1000)
+ (insert "12345678901234567890123456789012345678901234567890\n"))
+ (goto-char (point-min))
+ (insert "123\n")
+ (goto-char (point-max))
+ (insert "fóo")
+ (should (approx-equal (buffer-line-statistics) '(1002 50 49.9)))))
diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el
index edf8821..f2a60bc 100644
--- a/test/src/lread-tests.el
+++ b/test/src/lread-tests.el
@@ -190,4 +190,10 @@ literals (Bug#20852)."
(ert-deftest lread-circular-hash ()
(should-error (read "#s(hash-table data #0=(#0# . #0#))")))
+(ert-deftest test-inhibit-interaction ()
+ (let ((inhibit-interaction t))
+ (should-error (read-char "foo: "))
+ (should-error (read-event "foo: "))
+ (should-error (read-char-exclusive "foo: "))))
+
;;; lread-tests.el ends here
diff --git a/test/src/minibuf-tests.el b/test/src/minibuf-tests.el
index b9cd255..28119fc 100644
--- a/test/src/minibuf-tests.el
+++ b/test/src/minibuf-tests.el
@@ -410,5 +410,20 @@
(should (equal (try-completion "baz" '("bAz" "baz"))
(try-completion "baz" '("baz" "bAz"))))))
+(ert-deftest test-inhibit-interaction ()
+ (let ((inhibit-interaction t))
+ (should-error (read-from-minibuffer "foo: "))
+
+ (should-error (y-or-n-p "foo: "))
+ (should-error (yes-or-no-p "foo: "))
+ (should-error (read-blanks-no-input "foo: "))
+
+ ;; See that we get the expected error.
+ (should (eq (condition-case nil
+ (read-from-minibuffer "foo: ")
+ (inhibited-interaction 'inhibit)
+ (error nil))
+ 'inhibit))))
+
;;; minibuf-tests.el ends here
diff --git a/test/src/process-tests.el b/test/src/process-tests.el
index 921bcd5..949f735 100644
--- a/test/src/process-tests.el
+++ b/test/src/process-tests.el
@@ -28,6 +28,7 @@
(require 'puny)
(require 'rx)
(require 'subr-x)
+(require 'dns)
;; Timeout in seconds; the test fails if the timeout is reached.
(defvar process-test-sentinel-wait-timeout 2.0)
@@ -350,14 +351,23 @@ See Bug#30460."
;; All the following tests require working DNS, which appears not to
;; be the case for hydra.nixos.org, so disable them there for now.
+;; This will need updating when IANA assign more IPv6 global ranges.
+(defun ipv6-is-available ()
+ (and (featurep 'make-network-process '(:family ipv6))
+ (cl-rassoc-if
+ (lambda (elt)
+ (and (eq 9 (length elt))
+ (= (logand (aref elt 0) #xe000) #x2000)))
+ (network-interface-list))))
+
(ert-deftest lookup-family-specification ()
"`network-lookup-address-info' should only accept valid family symbols."
(skip-unless (not (getenv "EMACS_HYDRA_CI")))
(with-timeout (60 (ert-fail "Test timed out"))
- (should-error (network-lookup-address-info "google.com" 'both))
- (should (network-lookup-address-info "google.com" 'ipv4))
- (when (featurep 'make-network-process '(:family ipv6))
- (should (network-lookup-address-info "google.com" 'ipv6)))))
+ (should-error (network-lookup-address-info "localhost" 'both))
+ (should (network-lookup-address-info "localhost" 'ipv4))
+ (when (ipv6-is-available)
+ (should (network-lookup-address-info "localhost" 'ipv6)))))
(ert-deftest lookup-unicode-domains ()
"Unicode domains should fail."
@@ -380,7 +390,8 @@ See Bug#30460."
(addresses-v4 (network-lookup-address-info "google.com" 'ipv4)))
(should addresses-both)
(should addresses-v4))
- (when (featurep 'make-network-process '(:family ipv6))
+ (when (and (ipv6-is-available)
+ (dns-query "google.com" 'AAAA))
(should (network-lookup-address-info "google.com" 'ipv6)))))
(ert-deftest non-existent-lookup-failure ()
@@ -565,11 +576,6 @@ FD_SETSIZE file descriptors (Bug#24325)."
(should (memq (process-status process) '(run exit)))
(when (process-live-p process)
(process-send-eof process))
- ;; FIXME: This `sleep-for' shouldn't be needed. It
- ;; indicates a bug in Emacs; perhaps SIGCHLD is
- ;; received in parallel with `accept-process-output',
- ;; causing the latter to hang.
- (sleep-for 0.1)
(while (accept-process-output process))
(should (eq (process-status process) 'exit))
;; If there's an error between fork and exec, Emacs
@@ -728,5 +734,120 @@ Return nil if that can't be determined."
(match-string-no-properties 1))))))
process-tests--EMFILE-message)
+(ert-deftest process-tests/sentinel-called ()
+ "Check that sentinels are called after processes finish"
+ (let ((command (process-tests--emacs-command)))
+ (skip-unless command)
+ (dolist (conn-type '(pipe pty))
+ (ert-info ((format "Connection type: %s" conn-type))
+ (process-tests--with-processes processes
+ (let* ((calls ())
+ (process (make-process
+ :name "echo"
+ :command (process-tests--eval
+ command '(print "first"))
+ :noquery t
+ :connection-type conn-type
+ :coding 'utf-8-unix
+ :sentinel (lambda (process message)
+ (push (list process message)
+ calls)))))
+ (push process processes)
+ (while (accept-process-output process))
+ (should (equal calls
+ (list (list process "finished\n"))))))))))
+
+(ert-deftest process-tests/sentinel-with-multiple-processes ()
+ "Check that sentinels are called in time even when other processes
+have written output."
+ (let ((command (process-tests--emacs-command)))
+ (skip-unless command)
+ (dolist (conn-type '(pipe pty))
+ (ert-info ((format "Connection type: %s" conn-type))
+ (process-tests--with-processes processes
+ (let* ((calls ())
+ (process (make-process
+ :name "echo"
+ :command (process-tests--eval
+ command '(print "first"))
+ :noquery t
+ :connection-type conn-type
+ :coding 'utf-8-unix
+ :sentinel (lambda (process message)
+ (push (list process message)
+ calls)))))
+ (push process processes)
+ (push (make-process
+ :name "bash"
+ :command (process-tests--eval
+ command
+ '(progn (sleep-for 10) (print "second")))
+ :noquery t
+ :connection-type conn-type)
+ processes)
+ (while (accept-process-output process))
+ (should (equal calls
+ (list (list process "finished\n"))))))))))
+
+(defun process-tests--eval (command form)
+ "Return a command that evaluates FORM in an Emacs subprocess.
+COMMAND must be a list returned by
+`process-tests--emacs-command'."
+ (let ((print-gensym t)
+ (print-circle t)
+ (print-length nil)
+ (print-level nil)
+ (print-escape-control-characters t)
+ (print-escape-newlines t)
+ (print-escape-multibyte t)
+ (print-escape-nonascii t))
+ `(,@command "--quick" "--batch" ,(format "--eval=%S" form))))
+
+(defun process-tests--emacs-command ()
+ "Return a command to reinvoke the current Emacs instance.
+Return nil if that doesn't appear to be possible."
+ (when-let ((binary (process-tests--emacs-binary))
+ (dump (process-tests--dump-file)))
+ (cons binary
+ (unless (eq dump :not-needed)
+ (list (concat "--dump-file="
+ (file-name-unquote dump)))))))
+
+(defun process-tests--emacs-binary ()
+ "Return the filename of the currently running Emacs binary.
+Return nil if that can't be determined."
+ (and (stringp invocation-name)
+ (not (file-remote-p invocation-name))
+ (not (file-name-absolute-p invocation-name))
+ (stringp invocation-directory)
+ (not (file-remote-p invocation-directory))
+ (file-name-absolute-p invocation-directory)
+ (when-let ((file (process-tests--usable-file-for-reinvoke
+ (expand-file-name invocation-name
+ invocation-directory))))
+ (and (file-executable-p file) file))))
+
+(defun process-tests--dump-file ()
+ "Return the filename of the dump file used to start Emacs.
+Return nil if that can't be determined. Return `:not-needed' if
+Emacs wasn't started with a dump file."
+ (if-let ((stats (and (fboundp 'pdumper-stats) (pdumper-stats))))
+ (when-let ((file (process-tests--usable-file-for-reinvoke
+ (cdr (assq 'dump-file-name stats)))))
+ (and (file-readable-p file) file))
+ :not-needed))
+
+(defun process-tests--usable-file-for-reinvoke (filename)
+ "Return a version of FILENAME that can be used to reinvoke Emacs.
+Return nil if FILENAME doesn't exist."
+ (when (and (stringp filename)
+ (not (file-remote-p filename)))
+ (cl-callf file-truename filename)
+ (and (stringp filename)
+ (not (file-remote-p filename))
+ (file-name-absolute-p filename)
+ (file-regular-p filename)
+ filename)))
+
(provide 'process-tests)
;;; process-tests.el ends here
diff --git a/test/src/xdisp-tests.el b/test/src/xdisp-tests.el
index d13ce77..4e7d2ad 100644
--- a/test/src/xdisp-tests.el
+++ b/test/src/xdisp-tests.el
@@ -72,4 +72,31 @@
(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")
+ (switch-to-buffer (current-buffer))
+ (let* ((char-width (frame-char-width))
+ (size (window-text-pixel-size nil t t))
+ (width-in-chars (/ (car size) char-width)))
+ (should (equal width-in-chars 3)))))
+
+(ert-deftest xdisp-tests--window-text-pixel-size-leading-space () ;; bug#45748
+ (with-temp-buffer
+ (insert " xx")
+ (switch-to-buffer (current-buffer))
+ (let* ((char-width (frame-char-width))
+ (size (window-text-pixel-size nil t t))
+ (width-in-chars (/ (car size) char-width)))
+ (should (equal width-in-chars 3)))))
+
+(ert-deftest xdisp-tests--window-text-pixel-size-trailing-space () ;; bug#45748
+ (with-temp-buffer
+ (insert "xx ")
+ (switch-to-buffer (current-buffer))
+ (let* ((char-width (frame-char-width))
+ (size (window-text-pixel-size nil t t))
+ (width-in-chars (/ (car size) char-width)))
+ (should (equal width-in-chars 3)))))
+
;;; xdisp-tests.el ends here
diff --git a/test/src/xml-tests.el b/test/src/xml-tests.el
index 632cf96..a35b4d2 100644
--- a/test/src/xml-tests.el
+++ b/test/src/xml-tests.el
@@ -44,12 +44,12 @@
(ert-deftest libxml-tests ()
"Test libxml."
- (when (fboundp 'libxml-parse-xml-region)
- (with-temp-buffer
- (dolist (test libxml-tests--data-comments-preserved)
- (erase-buffer)
- (insert (car test))
- (should (equal (cdr test)
- (libxml-parse-xml-region (point-min) (point-max))))))))
+ (skip-unless (fboundp 'libxml-parse-xml-region))
+ (with-temp-buffer
+ (dolist (test libxml-tests--data-comments-preserved)
+ (erase-buffer)
+ (insert (car test))
+ (should (equal (cdr test)
+ (libxml-parse-xml-region (point-min) (point-max)))))))
;;; libxml-tests.el ends here