summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSean Whitton <spwhitton@spwhitton.name>2022-09-07 09:00:55 -0700
committerSean Whitton <spwhitton@spwhitton.name>2022-09-07 09:00:55 -0700
commit9f6c8c7d6d1aa0f87d7e7dcc073f783fd11447ef (patch)
treec21372ffc630eecca91e6685b73aadde7ba59e3e
parente5e8694c699bf57c352212791dd304531695feaf (diff)
parent40e32d74fcbbfa694c30014af140a24ab112fd8a (diff)
downloademacs-9f6c8c7d6d1aa0f87d7e7dcc073f783fd11447ef.tar.gz
Merge branch 'athena/unstable' into athena/bullseye-backports
-rw-r--r--.dir-locals.el3
-rw-r--r--.gitignore1
-rw-r--r--debian/changelog6
-rw-r--r--doc/emacs/ack.texi5
-rw-r--r--doc/emacs/commands.texi49
-rw-r--r--doc/emacs/emacs.texi33
-rw-r--r--doc/emacs/frames.texi10
-rw-r--r--doc/emacs/help.texi5
-rw-r--r--doc/emacs/maintaining.texi48
-rw-r--r--doc/emacs/mark.texi43
-rw-r--r--doc/emacs/mini.texi8
-rw-r--r--doc/emacs/misc.texi9
-rw-r--r--doc/emacs/programs.texi14
-rw-r--r--doc/lispref/display.texi4
-rw-r--r--doc/lispref/nonascii.texi7
-rw-r--r--doc/lispref/sequences.texi44
-rw-r--r--doc/lispref/windows.texi32
-rw-r--r--doc/man/emacsclient.111
-rw-r--r--doc/misc/ediff.texi2
-rw-r--r--doc/misc/efaq.texi108
-rw-r--r--doc/misc/eshell.texi203
-rw-r--r--doc/misc/flymake.texi4
-rw-r--r--doc/misc/url.texi36
-rw-r--r--doc/misc/viper.texi2
-rw-r--r--etc/NEWS151
-rw-r--r--etc/PROBLEMS7
-rw-r--r--etc/publicsuffix.txt72
-rw-r--r--etc/refcards/orgcard.tex2
-rw-r--r--lib-src/emacsclient.c75
-rw-r--r--lisp/cedet/semantic/fw.el2
-rw-r--r--lisp/char-fold.el78
-rw-r--r--lisp/cus-edit.el7
-rw-r--r--lisp/dired-aux.el4
-rw-r--r--lisp/dired.el5
-rw-r--r--lisp/disp-table.el63
-rw-r--r--lisp/doc-view.el2
-rw-r--r--lisp/emacs-lisp/cl-macs.el10
-rw-r--r--lisp/emacs-lisp/comp.el9
-rw-r--r--lisp/emacs-lisp/easy-mmode.el12
-rw-r--r--lisp/emacs-lisp/generate-lisp-file.el14
-rw-r--r--lisp/emacs-lisp/gv.el6
-rw-r--r--lisp/emacs-lisp/loaddefs-gen.el1
-rw-r--r--lisp/emacs-lisp/macroexp.el3
-rw-r--r--lisp/emacs-lisp/re-builder.el3
-rw-r--r--lisp/emacs-lisp/seq.el65
-rw-r--r--lisp/emacs-lisp/shortdoc.el7
-rw-r--r--lisp/emulation/viper-macs.el5
-rw-r--r--lisp/eshell/em-term.el2
-rw-r--r--lisp/eshell/esh-arg.el27
-rw-r--r--lisp/eshell/esh-cmd.el13
-rw-r--r--lisp/eshell/esh-io.el228
-rw-r--r--lisp/eshell/esh-proc.el169
-rw-r--r--lisp/faces.el37
-rw-r--r--lisp/files.el4
-rw-r--r--lisp/find-file.el36
-rw-r--r--lisp/help-fns.el15
-rw-r--r--lisp/image/image-dired-dired.el390
-rw-r--r--lisp/image/image-dired-external.el472
-rw-r--r--lisp/image/image-dired-tags.el379
-rw-r--r--lisp/image/image-dired-util.el162
-rw-r--r--lisp/image/image-dired.el (renamed from lisp/image-dired.el)1970
-rw-r--r--lisp/info.el9
-rw-r--r--lisp/international/characters.el19
-rw-r--r--lisp/international/latin1-disp.el4
-rw-r--r--lisp/international/mule-cmds.el10
-rw-r--r--lisp/isearch.el3
-rw-r--r--lisp/jit-lock.el7
-rw-r--r--lisp/ldefs-boot.el84
-rw-r--r--lisp/loadhist.el7
-rw-r--r--lisp/minibuf-eldef.el2
-rw-r--r--lisp/net/ldap.el8
-rw-r--r--lisp/net/mailcap.el56
-rw-r--r--lisp/net/tramp-adb.el20
-rw-r--r--lisp/net/tramp-archive.el4
-rw-r--r--lisp/net/tramp-cache.el2
-rw-r--r--lisp/net/tramp-cmds.el4
-rw-r--r--lisp/net/tramp-gvfs.el19
-rw-r--r--lisp/net/tramp-integration.el10
-rw-r--r--lisp/net/tramp-sh.el27
-rw-r--r--lisp/net/tramp-smb.el116
-rw-r--r--lisp/net/tramp.el192
-rw-r--r--lisp/obsolete/url-about.el2
-rw-r--r--lisp/org/org-version.el4
-rw-r--r--lisp/org/org.el2
-rw-r--r--lisp/outline.el35
-rw-r--r--lisp/paren.el19
-rw-r--r--lisp/play/gamegrid.el6
-rw-r--r--lisp/progmodes/cc-engine.el14
-rw-r--r--lisp/progmodes/cc-fonts.el21
-rw-r--r--lisp/progmodes/gdb-mi.el11
-rw-r--r--lisp/progmodes/gud.el225
-rw-r--r--lisp/progmodes/python.el348
-rw-r--r--lisp/recentf.el3
-rw-r--r--lisp/replace.el45
-rw-r--r--lisp/simple.el10
-rw-r--r--lisp/startup.el2
-rw-r--r--lisp/subr.el58
-rw-r--r--lisp/t-mouse.el7
-rw-r--r--lisp/term/fbterm.el27
-rw-r--r--lisp/term/linux.el10
-rw-r--r--lisp/textmodes/emacs-news-mode.el6
-rw-r--r--lisp/textmodes/ispell.el10
-rw-r--r--lisp/textmodes/paragraphs.el6
-rw-r--r--lisp/url/url-gw.el15
-rw-r--r--lisp/url/url-misc.el8
-rw-r--r--lisp/url/url-vars.el2
-rw-r--r--lisp/vc/vc-git.el66
-rw-r--r--lisp/wid-edit.el9
-rw-r--r--lisp/window.el66
-rw-r--r--src/character.c12
-rw-r--r--src/comp.c2
-rw-r--r--src/fns.c38
-rw-r--r--src/keyboard.c52
-rw-r--r--src/lread.c35
-rw-r--r--src/widget.c16
-rw-r--r--src/widgetprv.h2
-rw-r--r--src/window.c3
-rw-r--r--src/xdisp.c20
-rw-r--r--src/xfaces.c21
-rw-r--r--src/xfns.c12
-rw-r--r--src/xselect.c46
-rw-r--r--src/xterm.c204
-rw-r--r--src/xterm.h4
-rw-r--r--test/lisp/emacs-lisp/cl-lib-tests.el3
-rw-r--r--test/lisp/emacs-lisp/cl-macs-tests.el15
-rw-r--r--test/lisp/emacs-lisp/seq-tests.el15
-rw-r--r--test/lisp/eshell/esh-cmd-tests.el19
-rw-r--r--test/lisp/eshell/esh-io-tests.el292
-rw-r--r--test/lisp/eshell/esh-proc-tests.el149
-rw-r--r--test/lisp/eshell/eshell-tests-helpers.el10
-rw-r--r--test/lisp/eshell/eshell-tests.el19
-rw-r--r--test/lisp/filenotify-tests.el8
-rw-r--r--test/lisp/image/image-dired-tests.el (renamed from test/lisp/image-dired-tests.el)0
-rw-r--r--test/lisp/net/mailcap-tests.el405
-rw-r--r--test/lisp/net/tramp-archive-tests.el8
-rw-r--r--test/lisp/net/tramp-tests.el10
-rw-r--r--test/src/buffer-tests.el193
-rw-r--r--test/src/fns-tests.el10
138 files changed, 5661 insertions, 2796 deletions
diff --git a/.dir-locals.el b/.dir-locals.el
index 7812beb001c..1c90ddcf567 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -17,7 +17,8 @@
(electric-quote-string . nil)
(mode . bug-reference-prog)))
(log-edit-mode . ((log-edit-font-lock-gnu-style . t)
- (log-edit-setup-add-author . t)))
+ (log-edit-setup-add-author . t)
+ (vc-git-log-edit-summary-target-len . 50)))
(change-log-mode . ((add-log-time-zone-rule . t)
(fill-column . 74)
(mode . bug-reference)))
diff --git a/.gitignore b/.gitignore
index b35439604fb..a1dd83ce871 100644
--- a/.gitignore
+++ b/.gitignore
@@ -335,3 +335,4 @@ manual/
# Ignore a directory used by dap-mode.
.vscode
+/test/gmp.h
diff --git a/debian/changelog b/debian/changelog
index d11e20be0e6..8d2ad545bb5 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+emacs-snapshot (29~git20220905.1) unstable; urgency=medium
+
+ * Package git snapshot.
+
+ -- Sean Whitton <spwhitton@spwhitton.name> Wed, 07 Sep 2022 08:58:50 -0700
+
emacs-snapshot (29~git20220828.1~bpo11+1~athena1) bullseye-backports; urgency=medium
* Rebuild for athena's apt repository.
diff --git a/doc/emacs/ack.texi b/doc/emacs/ack.texi
index d0f2cc343b1..52ce8a16e6e 100644
--- a/doc/emacs/ack.texi
+++ b/doc/emacs/ack.texi
@@ -245,6 +245,11 @@ Theresa O'Connor wrote @file{json.el}, a file for parsing and
generating JSON files.
@item
+Andrea Corallo wrote the native compilation support in @file{comp.c}
+and @file{comp.el}, for compiling Emacs Lisp to native code using
+@samp{libgccjit}.
+
+@item
Georges Brun-Cottan and Stefan Monnier wrote @file{easy-mmode.el}, a
package for easy definition of major and minor modes.
diff --git a/doc/emacs/commands.texi b/doc/emacs/commands.texi
index 431cc2e5ce3..df3c47504a7 100644
--- a/doc/emacs/commands.texi
+++ b/doc/emacs/commands.texi
@@ -24,8 +24,8 @@ input.
GNU Emacs is primarily designed for use with the keyboard. While it
is possible to use the mouse to issue editing commands through the
-menu bar and tool bar, that is not as efficient as using the keyboard.
-Therefore, this manual mainly documents how to edit with the keyboard.
+menu bar and tool bar, that is usually not as efficient as using the
+keyboard.
@cindex control character
Keyboard input into Emacs is based on a heavily-extended version of
@@ -67,6 +67,10 @@ where the @key{Meta} key does not function reliably.
Emacs supports 3 additional modifier keys, see @ref{Modifier Keys}.
+ Emacs has extensive support for using mouse buttons, mouse wheels
+and other pointing devices like touchpads and touch screens.
+@xref{Mouse Input}, for details.
+
@cindex keys stolen by window manager
@cindex window manager, keys stolen by
On graphical displays, the window manager might block some keyboard
@@ -135,6 +139,47 @@ exception to this rule is @key{ESC}: @kbd{@key{ESC} C-h} is equivalent
to @kbd{C-M-h}, which does something else entirely. You can, however,
use @key{F1} to display a list of commands starting with @key{ESC}.
+@node Mouse Input
+@section Mouse Input
+@cindex mouse input
+
+ By default, Emacs supports all the normal mouse actions like setting
+the cursor by clicking on the left mouse button, and selecting an area
+by dragging the mouse pointer. All mouse actions can be used to bind
+commands in the same way you bind them to keyboard events
+(@pxref{Keys}). This section provides a general overview of using the
+mouse in Emacs; @pxref{Mouse Commands}, and the sections that follow
+it, for more details about mouse commands in Emacs.
+
+ When you click the left mouse button, Emacs receives a
+@code{mouse-1} event. To see what command is bound to that event, you
+can type @kbd{C-h c} and then press the left mouse button. Similarly,
+the middle mouse button is @code{mouse-2} and the right mouse button is
+@code{mouse-3}. If you have a mouse with a wheel, the wheel events
+are commonly bound to either @code{wheel-down} or @code{wheel-up}, or
+@code{mouse-4} and @code{mouse-5}, but that depends on the operating
+system configuration.
+
+ In general, legacy X systems and terminals (@pxref{Text-Only Mouse})
+will report @code{mouse-4} and @code{mouse-5}, while all other systems
+will report @code{wheel-down} and @code{wheel-up}.
+
+ Some mice also have a horizontal scroll wheel, and touchpads usually
+support scrolling horizontally as well. These events are reported as
+@code{wheel-left} and @code{wheel-right} on all systems other than
+terminals and legacy X systems, where they are @code{mouse-6} and
+@code{mouse-7}.
+
+ You can also combine keyboard modifiers with mouse events, so you
+can bind a special command that triggers when you, for instance, holds
+down the Meta key and then uses the middle mouse button. In that
+case, the event name will be @code{M-mouse-2}.
+
+@cindex touchscreen events
+ On some systems, you can also bind commands for handling touch
+screen events. In that case, the events are called
+@code{touchscreen-update} and @code{touchscreen-end}.
+
@node Commands
@section Keys and Commands
diff --git a/doc/emacs/emacs.texi b/doc/emacs/emacs.texi
index b43c966f872..6206dee4850 100644
--- a/doc/emacs/emacs.texi
+++ b/doc/emacs/emacs.texi
@@ -148,6 +148,7 @@ Important General Concepts
function keys).
* Keys:: Key sequences: what you type to request one
editing action.
+* Mouse Input:: Using the mouse and keypads.
* Commands:: Named functions run by key sequences to do editing.
* Entering Emacs:: Starting Emacs from the shell.
* Exiting:: Stopping or killing Emacs.
@@ -1414,23 +1415,23 @@ USA
@c It's hard to update this fairly.
@c I wonder if it would be better to drop it in favor of AUTHORS?
-Contributors to GNU Emacs include Jari Aalto, Per Abrahamsen, Tomas
+Contributors to GNU Emacs include Jari Aalto, Eric Abrahamsen, Per Abrahamsen, Tomas
Abrahamsson, Jay K. Adams, Alon Albert, Michael Albinus, Nagy
Andras, Benjamin Andresen, Ralf Angeli, Dmitry Antipov, Joe Arceneaux, Emil Åström,
Miles Bader, David Bakhash, Juanma Barranquero, Eli Barzilay, Thomas
Baumann, Steven L. Baur, Jay Belanger, Alexander L. Belikoff,
-Thomas Bellman, Scott Bender, Boaz Ben-Zvi, Sergey Berezin, Stephen Berman, Karl
+Thomas Bellman, Scott Bender, Boaz Ben-Zvi, Sergey Berezin, Stephen Berman, Jonas Bernoulli, Karl
Berry, Anna M. Bigatti, Ray Blaak, Martin Blais, Jim Blandy, Johan
Bockgård, Jan Böcker, Joel Boehland, Lennart Borgman, Per Bothner,
Terrence Brannon, Frank Bresz, Peter Breton, Emmanuel Briot, Kevin
Broadey, Vincent Broman, Michael Brouwer, David M. Brown, Ken Brown, Stefan Bruda,
-Daniel Colascione,
+Damien Cassou, Daniel Colascione,
Georges Brun-Cottan, Joe Buehler, Scott Byer, Włodek Bzyl, Tino Calancha,
Bill Carpenter, Per Cederqvist, Hans Chalupsky, Chris Chase, Bob
Chassell, Andrew Choi, Chong Yidong, Sacha Chua, Stewart Clamen, James
-Clark, Mike Clarkson, Glynn Clements, Andrew Cohen, Daniel Colascione,
+Clark, Mike Clarkson, Glynn Clements, Andrea Corallo, Andrew Cohen, Daniel Colascione,
Christoph Conrad, Ludovic Courtès, Andrew Csillag,
-Toby Cubitt, Baoqiu Cui, Doug Cutting, Mathias Dahl, Julien Danjou, Satyaki
+Toby Cubitt, Baoqiu Cui, Doug Cutting, Mathias Dahl, Yue Daian, Julien Danjou, Satyaki
Das, Vivek Dasmohapatra, Dan Davison, Michael DeCorte, Gary Delp, Nachum
Dershowitz, Dave Detlefs, Matthieu Devin, Christophe de Dinechin, Eri
Ding, Jan Djärv, Lawrence R. Dodd, Carsten Dominik, Scott Draves,
@@ -1438,36 +1439,36 @@ Benjamin Drieu, Viktor Dukhovni, Jacques Duthen, Dmitry Dzhus, John
Eaton, Rolf Ebert, Carl Edman, David Edmondson, Paul Eggert, Stephen
Eglen, Christian Egli, Torbjörn Einarsson, Tsugutomo Enami, David
Engster, Hans Henrik Eriksen, Michael Ernst, Ata Etemadi, Frederick
-Farnbach, Oscar Figueiredo, Fred Fish, Steve Fisk, Karl Fogel, Gary
+Farnbach, Oscar Figueiredo, Fred Fish, Steve Fisk, Thomas Fitzsimmons, Karl Fogel, Gary
Foster, Eric S. Fraga, Romain Francoise, Noah Friedman, Andreas
Fuchs, Shigeru Fukaya, Xue Fuqiao, Hallvard Furuseth, Keith Gabryelski, Peter S.
Galbraith, Kevin Gallagher, Fabián E. Gallina, Kevin Gallo, Juan León Lahoz García,
Howard Gayle, Daniel German, Stephen Gildea, Julien Gilles, David
-Gillespie, Bob Glickstein, Deepak Goel, David De La Harpe Golden, Boris
+Gillespie, Bob Glickstein, Nicolas Goaziou, Deepak Goel, David De La Harpe Golden, Boris
Goldowsky, David Goodger, Chris Gray, Kevin Greiner, Michelangelo Grigni, Odd
Gripenstam, Kai Großjohann, Michael Gschwind, Bastien Guerry, Henry
Guillaume, Dmitry Gutov, Doug Gwyn, Bruno Haible, Ken'ichi Handa, Lars Hansen, Chris
Hanson, Jesper Harder, Alexandru Harsanyi, K. Shane Hartman, John
Heidemann, Jon K. Hellan, Magnus Henoch, Markus Heritsch, Dirk
-Herrmann, Karl Heuer, Manabu Higashida, Konrad Hinsen, Anders Holst,
-Jeffrey C. Honig, Tassilo Horn, Kurt Hornik, Khaled Hosny, Tom Houlder, Joakim
+Herrmann, Karl Heuer, Manabu Higashida, Konrad Hinsen, Torsten Hilbrich, Anders Holst,
+Jeffrey C. Honig, Jürgen Hötzel, Tassilo Horn, Kurt Hornik, Khaled Hosny, Tom Houlder, Joakim
Hove, Denis Howe, Lars Ingebrigtsen, Andrew Innes, Seiichiro Inoue,
Philip Jackson, Martyn Jago, Pavel Janik, Paul Jarc, Ulf Jasper,
Thorsten Jolitz, Michael K. Johnson, Kyle Jones, Terry Jones, Simon
Josefsson, Alexandre Julliard, Arne Jørgensen, Tomoji Kagatani,
-Brewster Kahle, Tokuya Kameshima, Lute Kamstra, Ivan Kanis, David
+Brewster Kahle, Tokuya Kameshima, Lute Kamstra, Stefan Kangas, Ivan Kanis, David
Kastrup, David Kaufman, Henry Kautz, Taichi Kawabata, Taro Kawagishi,
Howard Kaye, Michael Kifer, Richard King, Peter Kleiweg, Karel
Klíč, Shuhei Kobayashi, Pavel Kobyakov, Larry K. Kolodney, David
M. Koppelman, Koseki Yoshinori, Robert Krawitz, Sebastian Kremer,
-Ryszard Kubiak, Igor Kuzmin, David Kågedal, Daniel LaLiberte, Karl
-Landstrom, Mario Lang, Aaron Larson, James R. Larus, Vinicius Jose
+Ryszard Kubiak, Tak Kunihiro, Igor Kuzmin, David Kågedal, Daniel LaLiberte, Karl
+Landstrom, Mario Lang, Aaron Larson, James R. Larus, Gemini Lasswell, Vinicius Jose
Latorre, Werner Lemberg, Frederic Lepied, Peter Liljenberg, Christian
Limpach, Lars Lindberg, Chris Lindblad, Anders Lindgren, Thomas Link,
Juri Linkov, Francis Litterio, Sergey Litvinov, Leo Liu, Emilio C. Lopes,
-Martin Lorentzon, Dave Love, Eric Ludlam, Károly Lőrentey, Sascha
+Martin Lorentzson, Dave Love, Eric Ludlam, Károly Lőrentey, Sascha
Lüdecke, Greg McGary, Roland McGrath, Michael McNamara, Alan Mackenzie,
-Christopher J. Madsen, Neil M. Mager, Artur Malabarba, Ken Manheimer, Bill Mann,
+Christopher J. Madsen, Neil M. Mager, Arni Magnusson, Artur Malabarba, Ken Manheimer, Bill Mann,
Brian Marick, Simon Marshall, Bengt Martensson, Charlie Martin,
Yukihiro Matsumoto, Tomohiro Matsuyama, David Maus, Thomas May, Will Mengarini, David
Megginson, Jimmy Aguilar Mena, Stefan Merten, Ben A. Mesander, Wayne Mesard, Brad
@@ -1483,7 +1484,7 @@ Jeff Peck, Damon Anton Permezel, Tom Perrine, William M. Perry, Per
Persson, Jens Petersen, Nicolas Petton, Daniel Pfeiffer, Justus Piater, Richard L.
Pieri, Fred Pierresteguy, François Pinard, Daniel Pittman, Christian
Plaunt, Alexander Pohoyda, David Ponce, Noam Postavsky, Francesco A. Potortì,
-Michael D. Prange, Mukesh Prasad, Ken Raeburn, Marko Rahamaa, Ashwin
+Michael D. Prange, Mukesh Prasad, Steve Purcell, Ken Raeburn, Marko Rahamaa, Ashwin
Ram, Eric S. Raymond, Paul Reilly, Edward M. Reingold, David
Reitter, Alex Rezinsky, Rob Riepel, Lara Rios, Adrian Robert, Nick
Roberts, Roland B. Roberts, John Robinson, Denis B. Roegel, Danny
@@ -1497,7 +1498,7 @@ Rainer Schöpf, Raymond Scholz, Eric Schulte, Andreas Schwab, Randal
Schwartz, Oliver Seidel, Manuel Serrano, Paul Sexton, Hovav Shacham,
Stanislav Shalunov, Marc Shapiro, Richard Sharman, Olin Shivers, Tibor
Šimko, Espen Skoglund, Rick Sladkey, Lynn Slater, Chris Smith,
-David Smith, Paul D. Smith, Wilson Snyder, William Sommerfeld, Simon
+David Smith, JD Smith, Paul D. Smith, Wilson Snyder, William Sommerfeld, Simon
South, Andre Spiegel, Michael Staats, Thomas Steffen, Ulf Stegemann,
Reiner Steib, Sam Steingold, Ake Stenhoff, Philipp Stephani, Peter Stephenson, Ken
Stevens, Andy Stewart, Jonathan Stigelman, Martin Stjernholm, Kim F.
diff --git a/doc/emacs/frames.texi b/doc/emacs/frames.texi
index d78cbffaa71..8a255fa40fb 100644
--- a/doc/emacs/frames.texi
+++ b/doc/emacs/frames.texi
@@ -215,6 +215,10 @@ deactivating the mark. @xref{Shift Selection}.
@vindex mouse-wheel-follow-mouse
@vindex mouse-wheel-scroll-amount
@vindex mouse-wheel-progressive-speed
+@cindex wheel-up, a mouse event
+@cindex wheel-down, a mouse event
+@cindex wheel-left, a mouse event
+@cindex wheel-right, a mouse event
Some mice have a ``wheel'' which can be used for scrolling. Emacs
supports scrolling windows with the mouse wheel, by default, on most
graphical displays. To toggle this feature, use @kbd{M-x
@@ -224,7 +228,11 @@ buffers are scrolled. The variable
@code{mouse-wheel-progressive-speed} determines whether the scroll
speed is linked to how fast you move the wheel. This mode also
supports increasing or decreasing the font size, by default bound to
-scrolling with the @key{Ctrl} modifier.
+scrolling with the @key{Ctrl} modifier. When this mode is enabled,
+mouse wheel produces special events like @code{wheel-up} and
+@code{wheel-down}. (Some older systems report them as @code{mouse-4}
+and @code{mouse-5}.) If the mouse has a horizontal scroll wheel, it
+produces @code{wheel-left} and @code{wheel-right} events as well.
@vindex mouse-wheel-scroll-amount-horizontal
Emacs also supports horizontal scrolling with the @key{Shift}
diff --git a/doc/emacs/help.texi b/doc/emacs/help.texi
index d206dee3859..84b082825c2 100644
--- a/doc/emacs/help.texi
+++ b/doc/emacs/help.texi
@@ -47,7 +47,7 @@ window displaying the @samp{*Help*} buffer will be reused instead.
If you are looking for a certain feature, but don't know what it is
called or where to look, we recommend three methods. First, try an
apropos command, then try searching the manual index, then look in the
-FAQ and the package keywords.
+FAQ and the package keywords, and finally try listing external packages.
@table @kbd
@item C-h a @var{topics} @key{RET}
@@ -70,6 +70,9 @@ This displays the Emacs FAQ, using Info.
@item C-h p
This displays the available Emacs packages based on keywords.
@xref{Package Keywords}.
+
+@item M-x list-packages
+This displays a list of external packages. @xref{Packages}.
@end table
@kbd{C-h} or @key{F1} mean ``help'' in various other contexts as
diff --git a/doc/emacs/maintaining.texi b/doc/emacs/maintaining.texi
index 60169d8d8c8..343cc83ce5d 100644
--- a/doc/emacs/maintaining.texi
+++ b/doc/emacs/maintaining.texi
@@ -170,26 +170,12 @@ which it refers to as @dfn{back ends}:
@itemize @bullet
-@cindex SCCS
-@item
-SCCS was the first version control system ever built, and was long ago
-superseded by more advanced ones. VC compensates for certain features
-missing in SCCS (e.g., tag names for releases) by implementing them
-itself. Other VC features, such as multiple branches, are simply
-unavailable. Since SCCS is non-free, we recommend avoiding it.
-
-@cindex CSSC
-@item
-CSSC is a free replacement for SCCS@. You should use CSSC only if, for
-some reason, you cannot use a more recent and better-designed version
-control system.
-
-@cindex RCS
+@cindex git
@item
-RCS is the free version control system around which VC was initially
-built. It is relatively primitive: it cannot be used over the
-network, and works at the level of individual files. Almost
-everything you can do with RCS can be done through VC.
+Git is a decentralized version control system originally invented by
+Linus Torvalds to support development of Linux (his kernel). VC
+supports many common Git operations, but others, such as repository
+syncing, must be done from the command line.
@cindex CVS
@item
@@ -208,12 +194,26 @@ similar to CVS but without its problems (e.g., it supports atomic
commits of filesets, and versioning of directories, symbolic links,
meta-data, renames, copies, and deletes).
-@cindex git
+@cindex SCCS
@item
-Git is a decentralized version control system originally invented by
-Linus Torvalds to support development of Linux (his kernel). VC
-supports many common Git operations, but others, such as repository
-syncing, must be done from the command line.
+SCCS was the first version control system ever built, and was long ago
+superseded by more advanced ones. VC compensates for certain features
+missing in SCCS (e.g., tag names for releases) by implementing them
+itself. Other VC features, such as multiple branches, are simply
+unavailable. Since SCCS is non-free, we recommend avoiding it.
+
+@cindex CSSC
+@item
+CSSC is a free replacement for SCCS@. You should use CSSC only if, for
+some reason, you cannot use a more recent and better-designed version
+control system.
+
+@cindex RCS
+@item
+RCS is the free version control system around which VC was initially
+built. It is relatively primitive: it cannot be used over the
+network, and works at the level of individual files. Almost
+everything you can do with RCS can be done through VC.
@cindex hg
@cindex Mercurial
diff --git a/doc/emacs/mark.texi b/doc/emacs/mark.texi
index ad25ed6a8aa..db96093a171 100644
--- a/doc/emacs/mark.texi
+++ b/doc/emacs/mark.texi
@@ -8,26 +8,29 @@
@cindex setting a mark
@cindex region
- Many Emacs commands operate on an arbitrary contiguous part of the
-current buffer. To specify the text for such a command to operate on,
-you set @dfn{the mark} at one end of it, and move point to the other
-end. The text between point and the mark is called @dfn{the region}.
-The region always extends between point and the mark, no matter which
-one comes earlier in the text; each time you move point, the region
-changes.
+ Emacs, like many other applications, lets you select some arbitrary
+part of the buffer text and invoke commands that operate on such
+@dfn{selected text}. In Emacs, we call the selected text @dfn{the
+region}; its handling is very similar to that of selected text in
+other programs, but there are also important differences.
@cindex active region
@cindex activating the mark
- Setting the mark at a position in the text also @dfn{activates} it.
-When the mark is active, we say also that the region is active; Emacs
+ The region is the portion of the buffer between @dfn{the mark} and
+the current @dfn{point}. You define a region by setting the mark
+somewhere (with, for instance, the @kbd{C-SPC} command), and then
+moving point to where you want the region to end. (Or you can use the
+mouse to define a region.)
+
+ The region always extends between point and the mark, no matter
+which of them comes earlier in the text; each time you move point, the
+region changes.
+
+ Setting the mark at a position in the text @dfn{activates} it. When
+the mark is active, we say also that the region is active; Emacs
indicates its extent by highlighting the text within it, using the
@code{region} face (@pxref{Face Customization}).
-This is one of the few faces that has the @code{:extend t} attribute
-by default, which implies that the same face is used to highlight the
-text and space between end of line and the window border. To
-highlight only the text you could set this attribute to @code{nil}.
-
@cindex deactivating the mark
After certain non-motion commands, including any command that
changes the text in the buffer, Emacs automatically @dfn{deactivates}
@@ -35,6 +38,18 @@ the mark; this turns off the highlighting. You can also explicitly
deactivate the mark at any time, by typing @kbd{C-g}
(@pxref{Quitting}).
+ Many commands limit the text on which they operate to the active
+region. For instance, the @kbd{M-%} command (which replaces matching
+text) normally works on the entire accessible portion of the buffer,
+but if you have an active region, it'll work only on that region
+instead.
+
+ The mark is useful even if it is not active. For example, you can
+move to previous mark locations using the mark ring. @xref{Mark
+Ring}. Additionally, some commands will have an effect even on an
+inactive region (for example @dfn{upcase-region}). You can also
+reactivate the region with commands like @kbd{C-x C-x}.
+
The above default behavior is known as Transient Mark mode.
Disabling Transient Mark mode switches Emacs to an alternative
behavior, in which the region is usually not highlighted.
diff --git a/doc/emacs/mini.texi b/doc/emacs/mini.texi
index e71d653210a..90e50a41d53 100644
--- a/doc/emacs/mini.texi
+++ b/doc/emacs/mini.texi
@@ -58,12 +58,8 @@ the default argument is shown with the user option
Emacs hides the default argument as soon as you modify the contents of
the minibuffer (since typing @key{RET} would no longer submit that
default). If you ever bring back the original minibuffer text, the
-prompt again shows the default. Furthermore, if you change the
-variable @code{minibuffer-eldef-shorten-default} to a non-@code{nil}
-value, the default argument is displayed as @samp{[@var{default-arg}]}
-instead of @samp{(default @var{default-arg})}, saving some screen
-space. To enable this minor mode, type @kbd{M-x
-minibuffer-electric-default-mode}.
+prompt again shows the default. To enable this minor mode, type
+@kbd{M-x minibuffer-electric-default-mode}.
Since the minibuffer appears in the echo area, it can conflict with
other uses of the echo area. If an error message or an informative
diff --git a/doc/emacs/misc.texi b/doc/emacs/misc.texi
index da1b87b48bd..d8ad0bee34f 100644
--- a/doc/emacs/misc.texi
+++ b/doc/emacs/misc.texi
@@ -936,7 +936,7 @@ Coding}.
@cindex @env{INSIDE_EMACS} environment variable
Emacs sets the environment variable @env{INSIDE_EMACS} in the
subshell to @samp{@var{version},comint}, where @var{version} is the
-Emacs version (e.g., @samp{24.1}). Programs can check this variable
+Emacs version (e.g., @samp{28.1}). Programs can check this variable
to determine whether they are running inside an Emacs subshell.
@node Shell Mode
@@ -2089,6 +2089,13 @@ all server buffers are finished. You can take as long as you like to
edit the server buffers within Emacs, and they are @emph{not} killed
when you type @kbd{C-x #} in them.
+@item -w
+@itemx --timeout=@var{N}
+Wait for a response from Emacs for @var{N} seconds before giving up.
+If there is no response within that time, @command{emacsclient} will
+display a warning and exit. The default is @samp{0}, which means to
+wait forever.
+
@item --parent-id @var{id}
Open an @command{emacsclient} frame as a client frame in the parent X
window with id @var{id}, via the XEmbed protocol. Currently, this
diff --git a/doc/emacs/programs.texi b/doc/emacs/programs.texi
index 795aabee743..b87c659483a 100644
--- a/doc/emacs/programs.texi
+++ b/doc/emacs/programs.texi
@@ -834,10 +834,16 @@ of automatic matching. Whenever point is before an opening delimiter
or after a closing delimiter, the delimiter, its matching delimiter,
and optionally the text between them are highlighted. To toggle Show
Paren mode globally, type @kbd{M-x show-paren-mode}. To toggle it
-only in the current buffer, type @kbd{M-x show-paren-local-mode}. To
-customize it, type @w{@kbd{M-x customize-group @key{RET} paren-showing}}.
-The customizable options which control the operation of this mode
-include:
+only in the current buffer, type @kbd{M-x show-paren-local-mode}.
+
+@vindex show-paren-predicate
+ By default, this mode is switched on in all buffers that are meant
+for editing, but is not enabled in buffers that show data. This is
+controlled by the @code{show-paren-predicate} user option.
+
+ To customize the mode, type @w{@kbd{M-x customize-group @key{RET}
+paren-showing}}. The customizable options which control the operation
+of this mode include:
@itemize @bullet
@item
diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi
index db58cd14c63..69b752688ea 100644
--- a/doc/lispref/display.texi
+++ b/doc/lispref/display.texi
@@ -8554,6 +8554,7 @@ Display with @var{graphical} on graphical displays, and with
must be one of the display methods described above.
@end table
+@vindex glyphless-char@r{ face}
@noindent
The @code{thin-space}, @code{empty-box}, @code{hex-code}, and
@acronym{ASCII} string display methods are drawn with the
@@ -8618,7 +8619,8 @@ codepoints (typically emojis).
@item no-font
Characters for which there is no suitable font, or which cannot be
-encoded by the terminal's coding system.
+encoded by the terminal's coding system, or those for which the
+text-mode terminal has no glyphs.
@end table
@c FIXME: this can also be 'acronym', but that's not currently
diff --git a/doc/lispref/nonascii.texi b/doc/lispref/nonascii.texi
index 6dc23637a79..71fee45c4a5 100644
--- a/doc/lispref/nonascii.texi
+++ b/doc/lispref/nonascii.texi
@@ -404,9 +404,12 @@ This returns @code{t} if @var{charcode} is a valid character, and
@cindex maximum value of character codepoint
@cindex codepoint, largest value
-@defun max-char
+@defun max-char &optional unicode
This function returns the largest value that a valid character
-codepoint can have.
+codepoint can have in Emacs. If the optional argument @var{unicode}
+is non-@code{nil}, it returns the largest character codepoint defined
+by the Unicode Standard (which is smaller than the maximum codepoint
+supported by Emacs).
@example
@group
diff --git a/doc/lispref/sequences.texi b/doc/lispref/sequences.texi
index 39230d0adc4..12c15e6f9a2 100644
--- a/doc/lispref/sequences.texi
+++ b/doc/lispref/sequences.texi
@@ -446,8 +446,7 @@ useful example of @code{sort}.
@cindex seq library
@cindex sequences, generalized
The @file{seq.el} library provides the following additional sequence
-manipulation macros and functions, prefixed with @code{seq-}. To use
-them, you must first load the @file{seq} library.
+manipulation macros and functions, prefixed with @code{seq-}.
All functions defined in this library are free of side-effects;
i.e., they do not modify any sequence (list, vector, or string) that
@@ -681,6 +680,24 @@ for which @var{predicate} returns @code{nil}.
@end example
@end defun
+@defun seq-remove-at-position sequence n
+@cindex removing from sequences
+This function returns a copy of @var{sequence} where the element at
+(zero-based) index @var{n} got removed. The result is a sequence of
+the same type as @var{sequence}.
+
+@example
+@group
+(seq-remove-at-position [1 -1 3 -3 5] 0)
+@result{} [-1 3 -3 5]
+@end group
+@group
+(seq-remove-at-position [1 -1 3 -3 5] 3)
+@result{} [1 -1 3 5]
+@end group
+@end example
+@end defun
+
@defun seq-reduce function sequence initial-value
@cindex reducing sequences
This function returns the result of calling @var{function} with
@@ -864,7 +881,7 @@ arguments to use instead of the default @code{equal}.
@end defun
@defun seq-position sequence elt &optional function
- This function returns the index of the first element in
+ This function returns the (zero-based) index of the first element in
@var{sequence} that is equal to @var{elt}. If the optional argument
@var{function} is non-@code{nil}, it is a function of two arguments to
use instead of the default @code{equal}.
@@ -881,6 +898,27 @@ use instead of the default @code{equal}.
@end example
@end defun
+@defun seq-positions sequence elt &optional testfn
+ This function returns a list of the (zero-based) indices of the
+elements in @var{sequence} for which @var{testfn} returns
+non-@code{nil} when passed the element and @var{elt} as
+arguments. @var{testfn} defaults to @code{equal}.
+
+@example
+@group
+(seq-positions '(a b c a d) 'a)
+@result{} (0 3)
+@end group
+@group
+(seq-positions '(a b c a d) 'z)
+@result{} nil
+@end group
+@group
+(seq-positions '(11 5 7 12 9 15) 10 #'>=)
+@result{} (0 3 5)
+@end group
+@end example
+@end defun
@defun seq-uniq sequence &optional function
This function returns a list of the elements of @var{sequence} with
diff --git a/doc/lispref/windows.texi b/doc/lispref/windows.texi
index c7f014e2f3b..33d0150a939 100644
--- a/doc/lispref/windows.texi
+++ b/doc/lispref/windows.texi
@@ -1472,20 +1472,36 @@ the new root window.
For interactive use, Emacs provides two commands which always split
the selected window. These call @code{split-window} internally.
-@deffn Command split-window-right &optional size
-This function splits the selected window into two side-by-side
-windows, putting the selected window on the left. If @var{size} is
-positive, the left window gets @var{size} columns; if @var{size} is
+@deffn Command split-window-right &optional size window-to-split
+This function splits the window @var{window-to-split} into two
+side-by-side windows, putting @var{window-to-split} on the left.
+@var{window-to-split} defaults to the selected window. If @var{size}
+is positive, the left window gets @var{size} columns; if @var{size} is
negative, the right window gets @minus{}@var{size} columns.
@end deffn
-@deffn Command split-window-below &optional size
-This function splits the selected window into two windows, one above
-the other, leaving the upper window selected. If @var{size} is
-positive, the upper window gets @var{size} lines; if @var{size} is
+@deffn Command split-window-below &optional size window-to-split
+This function splits the window @var{window-to-split} into two
+windows, one above the other, leaving the upper window selected.
+@var{window-to-split} defaults to the selected window. If @var{size}
+is positive, the upper window gets @var{size} lines; if @var{size} is
negative, the lower window gets @minus{}@var{size} lines.
@end deffn
+@deffn Command split-root-window-below &optional size
+This function splits the whole frame in two. The current window
+configuration is retained on the top, and a new window is created
+below, taking up the whole width of the frame. @var{size} is treated
+as by @code{split-window-below}.
+@end deffn
+
+@deffn Command split-root-window-right &optional size
+This function splits the whole frame in two. The current window
+configuration is retained on the left, and a new window is created on
+the right, taking up the whole height of the frame. @var{size} is treated
+as by @code{split-window-right}.
+@end deffn
+
@defopt split-window-keep-point
If the value of this variable is non-@code{nil} (the default),
@code{split-window-below} behaves as described above.
diff --git a/doc/man/emacsclient.1 b/doc/man/emacsclient.1
index e5d1bbe09ae..83c8a366f8b 100644
--- a/doc/man/emacsclient.1
+++ b/doc/man/emacsclient.1
@@ -1,5 +1,5 @@
.\" See section COPYING for conditions for redistribution.
-.TH EMACSCLIENT 1 "2021-11-05" "GNU Emacs" "GNU"
+.TH EMACSCLIENT 1 "2022-09-05" "GNU Emacs" "GNU"
.\" NAME should be all caps, SECTION should be 1-8, maybe w/ subsection
.\" other params are allowed: see man(7), man(1)
.SH NAME
@@ -87,9 +87,12 @@ Use TCP configuration file FILENAME for communication.
This can also be specified via the EMACS_SERVER_FILE environment variable.
.TP
.B \-n, \-\-no-wait
-Return
-immediately without waiting for you to "finish" the buffer in Emacs.
-If combined with --eval, this option is ignored.
+Return immediately without waiting for you to "finish" the buffer in
+Emacs. If combined with --eval, this option is ignored.
+.TP
+.B \-w, \-\-timeout=N
+How long to wait, in seconds, for Emacs to respond before giving up.
+The default is 0, which means to wait forever.
.TP
.B \-nw, \-t, \-\-tty
Open a new Emacs frame on the current terminal.
diff --git a/doc/misc/ediff.texi b/doc/misc/ediff.texi
index cbc7556aa82..23334479b0c 100644
--- a/doc/misc/ediff.texi
+++ b/doc/misc/ediff.texi
@@ -50,7 +50,7 @@ modify this GNU manual.''
@titlepage
@title Ediff User's Manual
@sp 4
-@subtitle Ediff version 2.81.2
+@subtitle Ediff version 2.81.6
@sp 1
@subtitle November 2008
@sp 5
diff --git a/doc/misc/efaq.texi b/doc/misc/efaq.texi
index a3459abd041..8ec23a529df 100644
--- a/doc/misc/efaq.texi
+++ b/doc/misc/efaq.texi
@@ -1602,6 +1602,7 @@ is better to write ``Emacs and XEmacs.''
* Filling paragraphs with a single space::
* Escape sequences in shell output::
* Fullscreen mode on MS-Windows::
+* Emacs in a Linux console::
@end menu
@node Setting up a customization file
@@ -2363,16 +2364,7 @@ new paragraph. There are many packages available to deal with this
@cindex Pairs of parentheses, highlighting
@cindex Matching parentheses
-Call @code{show-paren-mode} in your init file (@pxref{Setting up a
-customization file}):
-
-@lisp
-(show-paren-mode 1)
-@end lisp
-
-You can also enable this mode by selecting the @samp{Paren Match
-Highlighting} option from the @samp{Options} menu of the Emacs menu bar
-at the top of any Emacs frame.
+By default, @code{show-paren-mode} is enabled in all editing buffers.
Alternatives to this mode include:
@@ -3031,6 +3023,102 @@ To compute the correct values for width and height, first maximize the
Emacs frame and then evaluate @code{(frame-height)} and
@code{(frame-width)} with @kbd{M-:}.
+@node Emacs in a Linux console
+@section How can I alleviate the limitations of the Linux console?
+@cindex Console, Linux console, TTY, fbterm
+
+If possible, we recommend running Emacs inside @command{fbterm}, when
+in a Linux console. This brings the Linux console on par with most
+terminal emulators under X. To do this, install @command{fbterm}, for
+example with the package manager of your GNU/Linux distribution, and
+execute the command
+
+@example
+$ fbterm
+@end example
+
+This will create a sample configuration file @file{~/.fbtermrc} in
+your home directory. Edit that file and change the options
+@code{font-names} and @code{font-size} if necessary. For the former,
+you can choose one or more of the lines in the output of the following
+command, separated by commas:
+
+@example
+$ fc-list :spacing=mono family | sed 's/ /\\ /g'
+@end example
+
+You can now start Emacs inside @command{fbterm} with the command
+
+@example
+$ fbterm -- env TERM=fbterm emacs
+@end example
+
+In some versions of @command{fbterm}, setting @env{TERM} to
+@samp{fbterm} can be omitted. To check whether it is needed, start
+Emacs inside @command{fbterm} with the command
+
+@example
+$ fbterm -- emacs
+@end example
+
+@noindent
+and type @kbd{M-x list-colors-display}. If only 8 colors are
+displayed, it is necessary; if 256 colors are displayed, it isn't.
+
+You may want to add an alias for that command in your shell
+configuration file. For example, if you use Bash, you can add the
+following line to your @file{~/.bashrc} file:
+
+@example
+alias emacs="fbterm -- env TERM=fbterm emacs"
+@end example
+
+@noindent
+or, if you use Emacs both in the Linux console and under X:
+
+@example
+[[ "$(tty)" =~ "/dev/tty" ]] && alias emacs="fbterm -- env TERM=fbterm emacs"
+@end example
+
+The @command{fbterm} terminal emulator may define a number of key
+bindings for its own use, some of which conflict with those that Emacs
+uses. Execute the following two commands as root to ensure that
+@command{fbterm} does not define these key bindings:
+
+@example
+# chmod a-s `which fbterm`
+# setcap cap_sys_tty_config=-ep `which fbterm`
+@end example
+
+If you use Emacs as root, the above is not enough however, because the
+root user has all privileges. You can use the following command to
+start Emacs inside @command{fbterm} as root while ensuring that
+@command{fbterm} does not define any key bindings for its own use:
+
+@example
+# capsh --drop=cap_sys_tty_config -- -c "fbterm -- env TERM=fbterm emacs"
+@end example
+
+Again you may want to add a shortcut for that command in the shell
+configuration file of the root user. In this case however, it is not
+possible to use an alias, because the command line arguments passed to
+Emacs need to be inserted in the string at the end of the command. A
+wrapper script or a function can be used to do that. For example, if
+you use Bash, you can add the following function in the root user
+@file{~/.bashrc} file:
+
+@example
+function emacs ()
+@{
+ CMD="fbterm -- env TERM=fbterm emacs "
+ for ARG in "$@@"
+ do
+ CMD="$CMD '$ARG' "
+ done
+ capsh --drop=cap_sys_tty_config -- -c "$CMD"
+@}
+@end example
+
@c ------------------------------------------------------------
@node Bugs and problems
@chapter Bugs and problems
diff --git a/doc/misc/eshell.texi b/doc/misc/eshell.texi
index 13f13163dd7..bc3b21d019e 100644
--- a/doc/misc/eshell.texi
+++ b/doc/misc/eshell.texi
@@ -256,7 +256,6 @@ as an argument will ``spread'' the elements into multiple arguments:
@end example
@subsection Quoting and escaping
-
As with other shells, you can escape special characters and spaces
with by prefixing the character with a backslash (@code{\}), or by
surrounding the string with apostrophes (@code{''}) or double quotes
@@ -268,6 +267,40 @@ When using expansions (@pxref{Expansion}) in an Eshell command, the
result may potentially be of any data type. To ensure that the result
is always a string, the expansion can be surrounded by double quotes.
+@subsection Special argument types
+In addition to strings and numbers, Eshell supports a number of
+special argument types. These let you refer to various other Emacs
+Lisp data types, such as lists or buffers.
+
+@table @code
+
+@item #'@var{lisp-form}
+This refers to the quoted Emacs Lisp form @var{lisp-form}. Though
+this looks similar to the ``sharp quote'' syntax for functions
+(@pxref{Special Read Syntax, , , elisp, The Emacs Lisp Reference
+Manual}), it instead corresponds to @code{quote} and can be used for
+any quoted form.@footnote{Eshell would interpret a bare apostrophe
+(@code{'}) as the start of a single-quoted string.}
+
+@item `@var{lisp-form}
+This refers to the backquoted Emacs Lisp form @var{lisp-form}
+(@pxref{Backquote, , , elisp, The Emacs Lisp Reference Manual}). As
+in Emacs Lisp, you can use @samp{,} and @samp{,@@} to refer to
+non-constant values.
+
+@item #<buffer @var{name}>
+@itemx #<@var{name}>
+Return the buffer named @var{name}. This is equivalent to
+@samp{$(get-buffer-create "@var{name}")} (@pxref{Creating Buffers, , ,
+elisp, The Emacs Lisp Reference Manual}).
+
+@item #<process @var{name}>
+Return the process named @var{name}. This is equivalent to
+@samp{$(get-process "@var{name}")} (@pxref{Process Information, , ,
+elisp, The Emacs Lisp Reference Manual}).
+
+@end table
+
@node Built-ins
@section Built-in commands
Several commands are built-in in Eshell. In order to call the
@@ -1560,6 +1593,13 @@ Reverses the order of a list of values.
Since Eshell does not communicate with a terminal like most command
shells, IO is a little different.
+@menu
+* Visual Commands::
+* Redirection::
+* Pipelines::
+@end menu
+
+@node Visual Commands
@section Visual Commands
If you try to run programs from within Eshell that are not
line-oriented, such as programs that use ncurses, you will just get
@@ -1592,40 +1632,142 @@ program exits, customize the variable
@code{eshell-destroy-buffer-when-process-dies} to a non-@code{nil}
value; the default is @code{nil}.
+@node Redirection
@section Redirection
-Redirection is mostly the same in Eshell as it is in other command
-shells. The output redirection operators @code{>} and @code{>>} as
-well as pipes are supported, but there is not yet any support for
-input redirection. Output can also be redirected to buffers, using
-the @code{>>>} redirection operator, and Elisp functions, using
-virtual devices.
-
-The buffer redirection operator, @code{>>>}, expects a buffer object
-on the right-hand side, into which it inserts the output of the
-left-hand side. e.g., @samp{echo hello >>> #<buffer *scratch*>}
-inserts the string @code{"hello"} into the @file{*scratch*} buffer.
-The convenience shorthand variant @samp{#<@var{buffer-name}>}, as in
-@samp{#<*scratch*>}, is also accepted.
-
-@code{eshell-virtual-targets} is a list of mappings of virtual device
-names to functions. Eshell comes with two virtual devices:
-@file{/dev/kill}, which sends the text to the kill ring, and
-@file{/dev/clip}, which sends text to the clipboard.
+Redirection in Eshell is similar to that of other command shells. You
+can use the output redirection operators @code{>} and @code{>>}, but
+there is not yet any support for input redirection. In the cases
+below, @var{fd} specifies the file descriptor to redirect; if not
+specified, file descriptor 1 (standard output) will be used by
+default.
+
+@table @code
+
+@item > @var{dest}
+@itemx @var{fd}> @var{dest}
+Redirect output to @var{dest}, overwriting its contents with the new
+output.
+
+@item >> @var{dest}
+@itemx @var{fd}>> @var{dest}
+Redirect output to @var{dest}, appending it to the existing contents
+of @var{dest}.
+
+@item >>> @var{buffer}
+@itemx @var{fd}>>> @var{buffer}
+Redirect output to @var{dest}, inserting it at the current mark if
+@var{dest} is a buffer, at the beginning of the file if @var{dest} is
+a file, or otherwise behaving the same as @code{>>}.
+
+@item &> @var{file}
+@itemx >& @var{file}
+Redirect both standard output and standard error to @var{dest},
+overwriting its contents with the new output.
+
+@item &>> @var{file}
+@itemx >>& @var{file}
+Redirect both standard output and standard error to @var{dest},
+appending it to the existing contents of @var{dest}.
+
+@item &>>> @var{file}
+@itemx >>>& @var{file}
+Redirect both standard output and standard error to @var{dest},
+inserting it like with @code{>>> @var{file}}.
+
+@item >&@var{other-fd}
+@itemx @var{fd}>&@var{other-fd}
+Duplicate the file descriptor @var{other-fd} to @var{fd} (or 1 if
+unspecified). The order in which this is used is signficant, so
+
+@example
+@var{command} > @var{file} 2>&1
+@end example
+
+redirects both standard output and standard error to @var{file},
+whereas
+
+@example
+@var{command} 2>&1 > @var{file}
+@end example
+
+only redirects standard output to @var{file} (and sends standard error
+to the display via standard output's original handle).
+
+@end table
+
+Eshell supports redirecting output to several different types of
+targets:
+
+@itemize @bullet
+@item
+files, including virtual targets (see below);
+
+@item
+buffers (@pxref{Buffers, , , elisp, GNU Emacs Lisp Reference Manual});
+
+@item
+markers (@pxref{Markers, , , elisp, GNU Emacs Lisp Reference Manual});
+
+@item
+processes (@pxref{Processes, , , elisp, GNU Emacs Lisp Reference
+Manual}); and
+
+@item
+symbols (@pxref{Symbols, , , elisp, GNU Emacs Lisp Reference Manual}).
+
+@end itemize
+
+@subsection Virtual Targets
+Virtual targets are mapping of device names to functions. Eshell
+comes with four virtual devices:
+
+@table @file
+
+@item /dev/null
+Does nothing with the output passed to it.
+
+@item /dev/eshell
+Writes the text passed to it to the display.
+
+@item /dev/kill
+Adds the text passed to it to the kill ring.
+
+@item /dev/clip
+Adds the text passed to it to the clipboard.
+
+@end table
+
+@vindex eshell-virtual-targets
You can, of course, define your own virtual targets. They are defined
-by adding a list of the form @samp{("/dev/name" @var{function} @var{mode})} to
-@code{eshell-virtual-targets}. The first element is the device name;
-@var{function} may be either a lambda or a function name. If
-@var{mode} is @code{nil}, then the function is the output function; if it is
-non-@code{nil}, then the function is passed the redirection mode as a
-symbol--@code{overwrite} for @code{>}, @code{append} for @code{>>}, or
-@code{insert} for @code{>>>}--and the function is expected to return
-the output function.
+by adding a list of the form @samp{("/dev/name" @var{function}
+@var{mode})} to @code{eshell-virtual-targets}. The first element is
+the device name; @var{function} may be either a lambda or a function
+name. If @var{mode} is @code{nil}, then the function is the output
+function; if it is non-@code{nil}, then the function is passed the
+redirection mode as a symbol--@code{overwrite} for @code{>},
+@code{append} for @code{>>}, or @code{insert} for @code{>>>}--and the
+function is expected to return the output function.
The output function is called once on each line of output until
@code{nil} is passed, indicating end of output.
-@section Running Shell Pipelines Natively
+@node Pipelines
+@section Pipelines
+As with most other shells, Eshell supports pipelines to pass the
+output of one command the input of the next command. You can send the
+standard output of one command to the standard input of another using
+the @code{|} operator. For example,
+
+@example
+~ $ echo hello | rev
+olleh
+@end example
+
+To send both the standard output and standard error of a command to
+another command's input, you can use the @code{|&} operator.
+
+@subsection Running Shell Pipelines Natively
When constructing shell pipelines that will move a lot of data, it is
a good idea to bypass Eshell's own pipelining support and use the
operating system shell's instead. This is especially relevant when
@@ -2113,10 +2255,9 @@ current being used.
@item How can Eshell learn if a background process has requested input?
-@item Support @samp{2>&1} and @samp{>&} and @samp{2>} and @samp{|&}
+@item Make a customizable syntax table for redirects
-The syntax table for parsing these should be customizable, such that the
-user could change it to use rc syntax: @samp{>[2=1]}.
+This way, the user could change it to use rc syntax: @samp{>[2=1]}.
@item Allow @samp{$_[-1]}, which would indicate the last element of the array
diff --git a/doc/misc/flymake.texi b/doc/misc/flymake.texi
index 953e4605e98..b4e7f3a41f8 100644
--- a/doc/misc/flymake.texi
+++ b/doc/misc/flymake.texi
@@ -1,8 +1,8 @@
\input texinfo @c -*- mode: texinfo; coding: utf-8 -*-
@comment %**start of header
@setfilename ../../info/flymake.info
-@set VERSION 1.2
-@set UPDATED September 2021
+@set VERSION 1.2.2
+@set UPDATED November 2021
@settitle GNU Flymake @value{VERSION}
@include docstyle.texi
@syncodeindex pg cp
diff --git a/doc/misc/url.texi b/doc/misc/url.texi
index 5644027f952..546639b0172 100644
--- a/doc/misc/url.texi
+++ b/doc/misc/url.texi
@@ -380,7 +380,7 @@ for specific schemes.
* info:: Emacs "Info" pages.
* mailto:: Sending email.
* news/nntp/snews:: Usenet news.
-* rlogin/telnet/tn3270:: Remote host connectivity.
+* telnet/tn3270:: Remote host connectivity.
* irc:: Internet Relay Chat.
* data:: Embedded data URLs.
* nfs:: Networked File System.
@@ -675,9 +675,8 @@ environment variable @samp{NNTPSERVER}, or @samp{news} if that
environment variable is unset.
@end defopt
-@node rlogin/telnet/tn3270
-@section rlogin, telnet and tn3270
-@cindex rlogin
+@node telnet/tn3270
+@section telnet and tn3270
@cindex telnet
@cindex tn3270
@cindex terminal emulation
@@ -694,10 +693,10 @@ telnet://@var{user}:@var{password}@@@var{host}:@var{port}
but the @var{password} component is ignored. By default, the
@code{telnet} scheme is handled via Tramp (@pxref{Tramp}).
-To handle rlogin, telnet and tn3270 URLs, a @code{rlogin},
-@code{telnet} or @code{tn3270} (the program names and arguments are
-hardcoded) session is run in a @code{terminal-emulator} buffer.
-Well-known ports are used if the URL does not specify a port.
+To handle telnet and tn3270 URLs, a @code{telnet} or @code{tn3270}
+(the program names and arguments are hardcoded) session is run in a
+@code{terminal-emulator} buffer. Well-known ports are used if the URL
+does not specify a port.
@node irc
@section irc
@@ -1039,12 +1038,6 @@ a list of symbols. Possible values are:
Use this method if you must first telnet and log into a gateway host,
and then run telnet from that host to connect to outside machines.
-@item rlogin
-@cindex @command{rlogin}
-This method is identical to @code{telnet}, but uses @command{rlogin}
-to log into the remote machine without having to send the username and
-password over the wire every time.
-
@item socks
@cindex @sc{socks}
Use if the firewall has a @sc{socks} gateway running on it. The
@@ -1087,19 +1080,6 @@ The password to send when logging in.
This is a regular expression that matches the shell prompt.
@end defopt
-@defopt url-gateway-rlogin-host
-Host to @samp{rlogin} to before telnetting out.
-@end defopt
-@defopt url-gateway-rlogin-parameters
-Parameters to pass to @samp{rsh}.
-@end defopt
-@defopt url-gateway-rlogin-user-name
-User name to use when logging in to the gateway.
-@end defopt
-@defopt url-gateway-prompt-pattern
-This is a regular expression that matches the shell prompt.
-@end defopt
-
@defopt socks-server
This specifies the default server, it takes the form
@w{@code{("Default server" @var{server} @var{port} @var{version})}}
@@ -1327,8 +1307,6 @@ from the local machine. The supported methods are:
@table @code
@item telnet
Run telnet in a subprocess to connect;
-@item rlogin
-Rlogin to another machine to connect;
@item socks
Connect through a socks server;
@item ssl
diff --git a/doc/misc/viper.texi b/doc/misc/viper.texi
index 0703667ecce..7b91f887bbf 100644
--- a/doc/misc/viper.texi
+++ b/doc/misc/viper.texi
@@ -34,7 +34,7 @@ modify this GNU manual.''
@titlepage
@title Viper Is a Package for Emacs Rebels
@subtitle a Vi emulator for Emacs
-@subtitle November 2008, Viper Version 3.11.2
+@subtitle July 2013, Viper Version 3.14.2
@author Michael Kifer (Viper)
@author Aamod Sane (VIP 4.4)
diff --git a/etc/NEWS b/etc/NEWS
index b27f0760d12..b61b88d6fbe 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -30,6 +30,13 @@ This uses the popular sqlite3 library, and can be disabled by using
the '--without-sqlite3' option to the 'configure' script.
+++
+** Support for the WebP image format.
+This support is built by default when the libwebp library is
+available, and includes support for animated WebP images. To disable
+WebP support, use the '--without-webp' configure flag. Image
+specifiers can now use ':type webp'.
+
++++
** Emacs has been ported to the Haiku operating system.
The configuration process should automatically detect and build for
Haiku. There is also an optional window-system port to Haiku, which
@@ -109,6 +116,12 @@ files when the Emacs session which locked it crashes, or was otherwise
interrupted, and didn't exit gracefully. See the "(emacs) Saving
Emacs Sessions" node in the Emacs manual for more details.
+** Miscellaneous
+
++++
+*** User option 'minibuffer-eldef-shorten-default' is now obsolete.
+Customize the user option 'minibuffer-default-prompt-format' instead.
+
* Startup Changes in Emacs 29.1
@@ -162,6 +175,17 @@ of 'user-emacs-directory'.
* Incompatible changes in Emacs 29.1
+---
+*** 'show-paren-mode' is now disabled in 'special-mode' buffers.
+In Emacs versions previous to Emacs 28.1, 'show-paren-mode' defaulted
+off. In Emacs 28.1, the mode was switched on in all buffers. In
+Emacs 29.1, this was changed to be switched on in all editing-related
+buffers, but not in buffers that inherit from 'special-mode'. To get
+back to how things worked in Emacs 28.1, put the following in your
+init file:
+
+ (setopt show-paren-predicate t)
+
+++
*** Explicitly-set read-only state is preserved when reverting a buffer.
If you use the 'C-x C-q' command to change the read-only state of the
@@ -297,6 +321,10 @@ been restricted to "...", '...', /.../, |...|, (...), [...], <...>,
and {...}. See the "(eshell) Argument Predication and Modification"
node in the Eshell manual for more details.
++++
+*** Eshell pipelines now only pipe stdout by default.
+To pipe both stdout and stderr, use the '|&' operator instead of '|'.
+
---
** The 'delete-forward-char' command now deletes by grapheme clusters.
This command is by default bound to the <Delete> function key
@@ -340,6 +368,18 @@ startup. Previously, these functions ignored
'initial-scratch-message' and left "*scratch*" in 'fundamental-mode'.
---
+** The 'rlogin' method in the URL library is now obsolete.
+Emacs will now display a warning if you request a URL like
+"rlogin://foo@example.org".
+
+---
+** Setting 'url-gateway-method' to 'rlogin' is now obsolete.
+Emacs will now display a warning when setting it to that value.
+The user options 'url-gateway-rlogin-host',
+'url-gateway-rlogin-parameters', and 'url-gateway-rlogin-user-name'
+are also obsolete.
+
+---
** The autoarg.el library is now marked obsolete.
This library provides the 'autoarg-mode' and 'autoarg-kp-mode' minor
modes to emulate the behavior of the historical editor Twenex Emacs.
@@ -720,6 +760,15 @@ saved to the X primary selection, following the
'select-active-regions' variable. This support is enabled when
'tty-select-active-regions' is non-nil.
+---
+*** New command to set up display of unsupported characters.
+The new command 'standard-display-by-replacement-char' produces Lisp
+code that sets up the 'standard-display-table' to use a replacement
+character for display of characters that the text-mode terminal
+doesn't support. It is most useful with the Linux console and similar
+terminals, where Emacs has a reliable way of determining which
+characters have glyphs in the font loaded into the terminal's memory.
+
** ERT
+++
@@ -892,16 +941,14 @@ If non-nil, Outline Minor Mode will use buttons to hide/show outlines
in addition to the ellipsis. The default is nil in editing modes, but
non-nil in 'special-mode' and its derivatives.
-+++
-** Support for the WebP image format.
-This support is built by default when the libwebp library is
-available, and includes support for animated WebP images. To disable
-WebP support, use the '--without-webp' configure flag. Image
-specifiers can now use ':type webp'.
-
** Windows
+++
+*** New commands 'split-root-window-below' and 'split-root-window-right'.
+These commands split the root window in to, and are are bound to 'C-x
+7' and 'C-x 9' respectively.
+
++++
*** New user option 'display-buffer-avoid-small-windows'.
If non-nil, this should be a window height, a number. Windows smaller
than this will be avoided by 'display-buffer', if possible.
@@ -956,11 +1003,16 @@ suspicious and could be malicious.
** Emacs server and client changes
+++
-*** New command-line option '-r' for emacsclient.
+*** New command-line option '-r'/'--reuse-frame' for emacsclient.
With this command-line option, Emacs reuses an existing graphical client
frame if one exists; otherwise it creates a new frame.
+++
+*** New command-line option '-w N'/'--timeout=N' for emacsclient.
+With this command-line option, emacsclient will exit if Emacs does not
+respond within N seconds. The default is to wait forever.
+
++++
*** 'server-stop-automatically' can be used to automatically stop the server.
The Emacs server will be automatically stopped when certain conditions
are met. The conditions are given by the argument, which can be
@@ -1518,6 +1570,9 @@ with 'C-s C-s', but also after typing a character.
Non-nil means that the default definitions of equivalent characters
are overridden.
+*** New command 'describe-char-fold-equivalences'.
+It displays character equivalences used by `char-fold-to-regexp'.
+
+++
*** New command 'isearch-emoji-by-name'.
It is bound to 'C-x 8 e RET' during an incremental search. The
@@ -1532,13 +1587,13 @@ completion, and adds the Emoji into the search string.
This allows an easy way to toggle seeing all glyphless characters in
the current buffer.
-+++
+---
*** The extra slot of 'glyphless-char-display' can now have cons values.
The extra slot of the 'glyphless-char-display' char-table can now have
values that are cons cells, specifying separate values for text-mode
and GUI terminals.
----
++++
*** "Replacement character" feature for undisplayable characters on TTYs.
The 'acronym' method of displaying glyphless characters on text-mode
frames treats single-character acronyms specially: they are displayed
@@ -1580,11 +1635,16 @@ info node. This command only works for the Emacs and Emacs Lisp manuals.
This command marks files based on a regexp. If given a prefix
argument, unmark instead.
-*** 'C-x v v' on a diff buffer commits it as a patch.
-You can create a diff buffer by e.g. 'C-x v D' ('vc-root-diff'),
-then remove unnecessary hunks, and commit only part of your changes
-by typing 'C-x v v' in that diff buffer. Currently this works only
-with Git.
+---
+*** 'C-x v v' in a diffs buffer allows to commit only some of the changes.
+This command is intended to allow you to commit only some of the
+changes you have in your working tree. Begin by creating a buffer
+with the changes against the last commit, e.g. with 'C-x v D'
+('vc-root-diff'). Then edit the diffs to remove the hunks you don't
+want to commit. Finally, type 'C-x v v' in that diff buffer to commit
+only part of your changes, those whose hunks were left in the buffer.
+
+Currently this feature works only with the Git as 'vc-backend'.
---
*** 'C-x v v' on an unregistered file will now use the most specific backend.
@@ -1594,6 +1654,12 @@ directory in "~/foo/bar", using 'C-x v v' on a new, unregistered file
in the Git repository in "~/foo/bar". This makes this command
consistent with 'vc-responsible-backend'.
+---
+*** Log Edit now font locks long Git commit summary lines.
+Writing shorter summary lines avoids truncation in contexts in which
+Git commands display summary lines. See the two new variables
+'vc-git-log-edit-summary-target-len' and 'vc-git-log-edit-summary-max-len'.
+
** Message
---
@@ -1986,13 +2052,12 @@ This replaces the message most navigation commands in the thumbnail
buffer used to show at the bottom of the screen.
+++
-*** 'image-dired-show-all-from-dir-max-files' has been increased to 500.
-This option controls asking for confirmation when starting Image-Dired
-in a directory with many files. However, Image-Dired creates
-thumbnails in the background these days, so this is not as important
-as it used to be, back when entering a large directory could lock up
-Emacs for tens of seconds. In addition, you can now customize this
-option to nil to disable this confirmation completely.
+*** 'image-dired-show-all-from-dir-max-files' increased to 1000.
+This user option controls asking for confirmation when starting
+Image-Dired in a directory with many files. Since Image-Dired creates
+thumbnails in the background in recent versions, this is not as
+important as it used to be. You can now also customize this option to
+nil to disable this confirmation completely.
---
*** 'image-dired-rotate-thumbnail-(left|right)' is now obsolete.
@@ -2000,6 +2065,13 @@ Instead, use commands 'image-dired-refresh-thumb' to generate a new
thumbnail, or 'image-rotate' to rotate the thumbnail without updating
the thumbnail file.
+---
+*** HTML image gallery generation is now obsolete.
+The 'image-dired-gallery-generate' command and these user options are
+now obsolete: 'image-dired-gallery-thumb-image-root-url',
+'image-dired-gallery-hidden-tags', 'image-dired-gallery-dir',
+'image-dired-gallery-image-root-url'.
+
** Dired
---
@@ -2147,6 +2219,18 @@ the Galeon web browser was released in September, 2008.
Note that this historical web browser is different from Mozilla
Firefox; it is its predecessor.
+** Python Mode
+
++++
+*** Project shells and a new user option 'python-shell-dedicated'.
+When called with a prefix argument, 'run-python' now offers the choice
+of creating a shell dedicated to the current project. This shell runs
+in the project root directory and is shared among all project buffers.
+
+Without a prefix argument, the kind of shell (buffer-dedicated,
+project-dedicated or global) is specified by the new
+'python-shell-dedicated' variable.
+
** Ruby Mode
---
@@ -2174,6 +2258,13 @@ commands are Lisp function or external when supplying absolute file
name arguments. See "Electric forward slash" in the Eshell manual.
+++
+*** Improved support for redirection operators in Eshell.
+Eshell now supports a wider variety of redirection operators. For
+example, you can now redirect both stdout and stderr via '&>' or
+duplicate one output handle to another via 'NEW-FD>&OLD-FD'. For more
+information, see "Redirections" in the Eshell manual.
+
++++
*** Double-quoting an Eshell expansion now treats the result as a single string.
If an Eshell expansion like '$FOO' is surrounded by double quotes, the
result will always be a single string, no matter the type that would
@@ -2680,6 +2771,11 @@ These can be used for buttons in buffers and the like. See the
"(elisp) Icons" and "(emacs) Icons" nodes in the manuals for details.
+++
+** New function 'seq-positions'.
+This returns a list of the (zero-based) indices of elements matching a
+given predicate in the specified sequence.
+
++++
** New arguments MESSAGE and TIMEOUT of 'set-transient-map'.
MESSAGE specifies a message to display after activating the transient
map, including a special formatting spec to list available keys.
@@ -2692,6 +2788,11 @@ The default timeout value can be defined by the new variable
This returns a list of sub-sequences of the specified sequence.
+++
+** New function 'seq-remove-at-position'.
+This function returns a copy of the specified sequence where the
+element at a given (zero-based) index got removed.
+
++++
** 'plist-get', 'plist-put' and 'plist-member' are no longer limited to 'eq'.
These function now take an optional comparison predicate argument.
@@ -2746,6 +2847,12 @@ request the name of the ".eln" file which defined a given symbol.
+++
** New macro 'with-memoization' provides a very primitive form of memoization.
++++
+** 'max-char' can now report the maximum codepoint according to Unicode.
+When called with a new optional argument UNICODE non-nil, 'max-char'
+will now report the maximum valid codepoint defined by the Unicode
+Standard.
+
** Themes
---
diff --git a/etc/PROBLEMS b/etc/PROBLEMS
index 6624f747c87..ed2bc1ae051 100644
--- a/etc/PROBLEMS
+++ b/etc/PROBLEMS
@@ -2267,6 +2267,13 @@ term/xterm.el) for more details.
*** Linux console problems with double-width characters
+If possible, we recommend running Emacs inside fbterm, when in a Linux
+console (see the node "Emacs in a Linux console" in the Emacs FAQ).
+Most Unicode characters should then be displayed correctly.
+
+If that is not possible, the following may be useful to alleviate the
+problem of displaying Unicode characters in a raw console.
+
The Linux console declares UTF-8 encoding, but supports only a limited
number of Unicode characters, and can cause Emacs produce corrupted or
garbled display with some unusual characters and sequences. Emacs 28
diff --git a/etc/publicsuffix.txt b/etc/publicsuffix.txt
index b5a89c65ccd..626c7993907 100644
--- a/etc/publicsuffix.txt
+++ b/etc/publicsuffix.txt
@@ -1315,7 +1315,9 @@ web.id
ie
gov.ie
-// il : http://www.isoc.org.il/domains/
+// il : http://www.isoc.org.il/domains/
+// see also: https://en.isoc.org.il/il-cctld/registration-rules
+// ISOC-IL (operated by .il Registry)
il
ac.il
co.il
@@ -1325,6 +1327,16 @@ k12.il
muni.il
net.il
org.il
+// xn--4dbrk0ce ("Israel", Hebrew) : IL
+ישראל
+// xn--4dbgdty6c.xn--4dbrk0ce.
+אקדמיה.ישראל
+// xn--5dbhl8d.xn--4dbrk0ce.
+ישוב.ישראל
+// xn--8dbq2a.xn--4dbrk0ce.
+צהל.ישראל
+// xn--hebda8b.xn--4dbrk0ce.
+ממשל.ישראל
// im : https://www.nic.im/
// Submitted by registry <info@nic.im>
@@ -1344,18 +1356,47 @@ tv.im
// Please note, that nic.in is not an official eTLD, but used by most
// government institutions.
in
+5g.in
+6g.in
+ac.in
+ai.in
+am.in
+bihar.in
+biz.in
+business.in
+ca.in
+cn.in
co.in
+com.in
+coop.in
+cs.in
+delhi.in
+dr.in
+edu.in
+er.in
firm.in
-net.in
-org.in
gen.in
+gov.in
+gujarat.in
ind.in
+info.in
+int.in
+internet.in
+io.in
+me.in
+mil.in
+net.in
nic.in
-ac.in
-edu.in
+org.in
+pg.in
+post.in
+pro.in
res.in
-gov.in
-mil.in
+travel.in
+tv.in
+uk.in
+up.in
+us.in
// info : https://en.wikipedia.org/wiki/.info
info
@@ -10871,6 +10912,10 @@ theshop.jp
shopselect.net
base.shop
+// BeagleBoard.org Foundation : https://beagleboard.org
+// Submitted by Jason Kridner <jkridner@beagleboard.org>
+beagleboard.io
+
// Beget Ltd
// Submitted by Lev Nekrasov <lnekrasov@beget.com>
*.beget.app
@@ -11649,6 +11694,11 @@ dynv6.net
// Submitted by Vladimir Dudr <info@e4you.cz>
e4.cz
+// Easypanel : https://easypanel.io
+// Submitted by Andrei Canta <andrei@easypanel.io>
+easypanel.app
+easypanel.host
+
// eero : https://eero.com/
// Submitted by Yue Kang <eero-dynamic-dns@amazon.com>
eero.online
@@ -11943,6 +11993,10 @@ id.forgerock.io
// Submitted by Koen Rouwhorst <koenrh@framer.com>
framer.app
framercanvas.com
+framer.media
+framer.photos
+framer.website
+framer.wiki
// Frusky MEDIA&PR : https://www.frusky.de
// Submitted by Victor Pupynin <hallo@frusky.de>
@@ -13554,6 +13608,10 @@ small-web.org
// Submitted by Dan Kozak <dan@smoove.io>
vp4.me
+// Snowflake Inc : https://www.snowflake.com/
+// Submitted by Faith Olapade <faith.olapade@snowflake.com>
+streamlitapp.com
+
// Snowplow Analytics : https://snowplowanalytics.com/
// Submitted by Ian Streeter <ian@snowplowanalytics.com>
try-snowplow.com
diff --git a/etc/refcards/orgcard.tex b/etc/refcards/orgcard.tex
index bb4bc5b25df..9462df8574c 100644
--- a/etc/refcards/orgcard.tex
+++ b/etc/refcards/orgcard.tex
@@ -1,5 +1,5 @@
% Reference Card for Org Mode
-\def\orgversionnumber{9.5.4}
+\def\orgversionnumber{9.5.5}
\def\versionyear{2021} % latest update
\input emacsver.tex
diff --git a/lib-src/emacsclient.c b/lib-src/emacsclient.c
index 73c8e45a865..15acb4589a9 100644
--- a/lib-src/emacsclient.c
+++ b/lib-src/emacsclient.c
@@ -1,6 +1,6 @@
/* Client process that communicates with GNU Emacs acting as server.
-Copyright (C) 1986-1987, 1994, 1999-2022 Free Software Foundation, Inc.
+Copyright (C) 1986-2022 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -55,6 +55,8 @@ char *w32_getenv (const char *);
# include <sys/socket.h>
# include <sys/un.h>
+# define DEFAULT_TIMEOUT (30)
+
# define SOCKETS_IN_FILE_SYSTEM
# define INVALID_SOCKET (-1)
@@ -144,6 +146,9 @@ static char const *socket_name;
/* If non-NULL, the filename of the authentication file. */
static char const *server_file;
+/* Seconds to wait before timing out (0 means wait forever). */
+static uintmax_t timeout;
+
/* If non-NULL, the tramp prefix emacs must use to find the files. */
static char const *tramp_prefix;
@@ -178,6 +183,7 @@ static struct option const longopts[] =
{ "server-file", required_argument, NULL, 'f' },
{ "display", required_argument, NULL, 'd' },
{ "parent-id", required_argument, NULL, 'p' },
+ { "timeout", required_argument, NULL, 'w' },
{ "tramp", required_argument, NULL, 'T' },
{ 0, 0, 0, 0 }
};
@@ -185,7 +191,7 @@ static struct option const longopts[] =
/* Short options, in the same order as the corresponding long options.
There is no '-p' short option. */
static char const shortopts[] =
- "nqueHVtca:F:"
+ "nqueHVtca:F:w:"
#ifdef SOCKETS_IN_FILE_SYSTEM
"s:"
#endif
@@ -497,6 +503,7 @@ decode_options (int argc, char **argv)
if (opt < 0)
break;
+ char* endptr;
switch (opt)
{
case 0:
@@ -530,6 +537,17 @@ decode_options (int argc, char **argv)
nowait = true;
break;
+ case 'w':
+ timeout = strtoumax (optarg, &endptr, 10);
+ if (timeout <= 0 ||
+ ((timeout == INTMAX_MAX || timeout == INTMAX_MIN)
+ && errno == ERANGE))
+ {
+ fprintf (stderr, "Invalid timeout: \"%s\"\n", optarg);
+ exit (EXIT_FAILURE);
+ }
+ break;
+
case 'e':
eval = true;
break;
@@ -671,6 +689,7 @@ The following OPTIONS are accepted:\n\
Set the parameters of a new frame\n\
-e, --eval Evaluate the FILE arguments as ELisp expressions\n\
-n, --no-wait Don't wait for the server to return\n\
+-w, --timeout Seconds to wait before timing out\n\
-q, --quiet Don't display messages on success\n\
-u, --suppress-output Don't display return values from the server\n\
-d DISPLAY, --display=DISPLAY\n\
@@ -1870,6 +1889,33 @@ start_daemon_and_retry_set_socket (void)
return emacs_socket;
}
+static void
+set_socket_timeout (HSOCKET socket, int seconds)
+{
+#ifndef WINDOWSNT
+ struct timeval timeout;
+ timeout.tv_sec = seconds;
+ timeout.tv_usec = 0;
+ setsockopt (socket, SOL_SOCKET, SO_RCVTIMEO, &timeout, sizeof timeout);
+#else
+ DWORD timeout = seconds * 1000;
+ setsockopt (socket, SOL_SOCKET, SO_RCVTIMEO, (char *) &timeout, sizeof timeout);
+#endif
+}
+
+static bool
+check_socket_timeout (int rl)
+{
+#ifndef WINDOWSNT
+ return (rl == -1)
+ && (errno == EAGAIN)
+ && (errno == EWOULDBLOCK);
+#else
+ return (rl == SOCKET_ERROR)
+ && (WSAGetLastError() == WSAETIMEDOUT);
+#endif
+}
+
int
main (int argc, char **argv)
{
@@ -2086,19 +2132,42 @@ main (int argc, char **argv)
}
fflush (stdout);
+ set_socket_timeout (emacs_socket, timeout > 0 ? timeout : DEFAULT_TIMEOUT);
+ bool saw_response = false;
/* Now, wait for an answer and print any messages. */
while (exit_status == EXIT_SUCCESS)
{
+ bool retry = true;
+ bool msg_showed = quiet;
do
{
act_on_signals (emacs_socket);
rl = recv (emacs_socket, string, BUFSIZ, 0);
+ retry = check_socket_timeout (rl);
+ if (retry)
+ {
+ if (timeout > 0 && !saw_response)
+ {
+ /* Don't retry if we were given a --timeout flag. */
+ fprintf (stderr, "\nServer not responding; timed out after %lu seconds",
+ timeout);
+ retry = false;
+ }
+ else if (!msg_showed)
+ {
+ msg_showed = true;
+ fprintf (stderr, "\nServer not responding; use Ctrl+C to break");
+ }
+ }
}
- while (rl < 0 && errno == EINTR);
+ while ((rl < 0 && errno == EINTR) || retry);
if (rl <= 0)
break;
+ if (msg_showed)
+ fprintf (stderr, "\nGot response from server");
+ saw_response = true;
string[rl] = '\0';
/* Loop over all NL-terminated messages. */
diff --git a/lisp/cedet/semantic/fw.el b/lisp/cedet/semantic/fw.el
index 113323cb339..9917c4c5be6 100644
--- a/lisp/cedet/semantic/fw.el
+++ b/lisp/cedet/semantic/fw.el
@@ -339,7 +339,7 @@ calling this one."
"Call `find-file-noselect' with various features turned off.
Use this when referencing a file that will be soon deleted.
FILE, NOWARN, RAWFILE, and WILDCARDS are passed into `find-file-noselect'."
- (let* ((recentf-exclude #'always)
+ (let* ((recentf-exclude '(always))
;; This is a brave statement. Don't waste time loading in
;; lots of modes. Especially decoration mode can waste a lot
;; of time for a buffer we intend to kill.
diff --git a/lisp/char-fold.el b/lisp/char-fold.el
index 05ae52cae0d..43e3cd45ecb 100644
--- a/lisp/char-fold.el
+++ b/lisp/char-fold.el
@@ -24,6 +24,8 @@
;;; Code:
+(eval-when-compile (require 'subr-x))
+
(eval-and-compile
(put 'char-fold-table 'char-table-extra-slots 1)
(defconst char-fold--default-override nil)
@@ -48,6 +50,7 @@
(eval-and-compile
+ (defvar char-fold--no-regexp nil)
(defun char-fold--make-table ()
(let* ((equiv (make-char-table 'char-fold-table))
(equiv-multi (make-char-table 'char-fold-table))
@@ -201,11 +204,14 @@
symmetric)))
;; Convert the lists of characters we compiled into regexps.
- (map-char-table
- (lambda (char decomp-list)
- (let ((re (regexp-opt (cons (char-to-string char) decomp-list))))
- (aset equiv char re)))
- equiv)
+ (unless char-fold--no-regexp
+ ;; Non-nil `char-fold--no-regexp' unoptimized for regexp
+ ;; is used by `describe-char-fold-equivalences'.
+ (map-char-table
+ (lambda (char decomp-list)
+ (let ((re (regexp-opt (cons (char-to-string char) decomp-list))))
+ (aset equiv char re)))
+ equiv))
equiv)))
(defconst char-fold-table
@@ -421,6 +427,68 @@ BOUND NOERROR COUNT are passed to `re-search-backward'."
(interactive "sSearch: ")
(re-search-backward (char-fold-to-regexp string) bound noerror count))
+
+;;;###autoload
+(defun describe-char-fold-equivalences (char &optional lax)
+ "Display characters equivalent to CHAR under character-folding.
+Prompt for CHAR (using `read-char-by-name', which see for how to
+specify the character). With no input, i.e. when CHAR is nil,
+describe all available character equivalences of `char-fold-to-regexp'.
+Optional argument LAX (interactively, the prefix argument), if
+non-nil, means also include partially matching ligatures and
+non-canonical equivalences."
+ (interactive (list (ignore-errors
+ (read-char-by-name
+ (format-prompt "Unicode name, single char, or hex"
+ "all")
+ t))
+ current-prefix-arg))
+ (require 'help-fns)
+ (let ((help-buffer-under-preparation t))
+ (help-setup-xref (list #'describe-char-fold-equivalences)
+ (called-interactively-p 'interactive))
+ (let* ((equivalences nil)
+ (char-fold--no-regexp t)
+ (table (char-fold--make-table))
+ (extra (char-table-extra-slot table 0)))
+ (if (not char)
+ (map-char-table
+ (lambda (char list)
+ (when lax
+ (setq list (append list (mapcar (lambda (entry)
+ (cdr entry))
+ (aref extra char)))))
+ (setq equivalences (cons (cons char list)
+ equivalences)))
+ table)
+ (setq equivalences (aref table char))
+ (when lax
+ (setq equivalences (append equivalences
+ (mapcar (lambda (entry)
+ (cdr entry))
+ (aref extra char)))))
+ (setq equivalences (cons (char-to-string char) equivalences)))
+ (with-help-window (help-buffer)
+ (with-current-buffer standard-output
+ (if char
+ (insert
+ (mapconcat
+ (lambda (c)
+ (format "%s: %s\n"
+ c
+ (mapconcat
+ (lambda (ch)
+ (format "?\\N{%s}"
+ (or (get-char-code-property ch 'name)
+ (get-char-code-property ch 'old-name))))
+ c)))
+ equivalences))
+ (insert "A list of char-fold equivalences for `char-fold-to-regexp':\n\n")
+ (setq-local bidi-paragraph-direction 'left-to-right)
+ (dolist (equiv (nreverse equivalences))
+ (insert (format "%c: %s\n" (car equiv)
+ (string-join (cdr equiv) " "))))))))))
+
(provide 'char-fold)
;;; char-fold.el ends here
diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el
index d3768766be0..ee32c9c945e 100644
--- a/lisp/cus-edit.el
+++ b/lisp/cus-edit.el
@@ -4298,7 +4298,12 @@ restoring it to the state of a face that has never been customized."
"A Lisp fringe bitmap name."
:format "%v"
:tag "Fringe bitmap"
- :match (lambda (_widget value) (fringe-bitmap-p value))
+ :match (lambda (_widget value)
+ ;; In no-X builds (where `fringe-bitmaps' is undefined),
+ ;; allow anything. This ensures that customizations set on
+ ;; a with-X build aren't considered invalid under no-X.
+ (or (not (boundp 'fringe-bitmaps))
+ (fringe-bitmap-p value)))
:completions (apply-partially #'completion-table-with-predicate
obarray #'fringe-bitmap-p 'strict)
:prompt-match 'fringe-bitmap-p
diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el
index 06f0b86fc43..0e8062af528 100644
--- a/lisp/dired-aux.el
+++ b/lisp/dired-aux.el
@@ -987,7 +987,7 @@ Also see the `dired-confirm-shell-command' variable."
;; Add 'wait' to force those POSIX shells to wait until
;; all commands finish.
(or (and parallel-in-background (not w32-shell)
- "&wait")
+ " &wait")
"")))
(t
(let ((files (mapconcat #'shell-quote-argument
@@ -999,7 +999,7 @@ Also see the `dired-confirm-shell-command' variable."
;; Be consistent in how we treat inputs to commands -- do
;; the same here as in the `on-each' case.
(if (and in-background (not w32-shell))
- "&wait"
+ " &wait"
"")))))
(or (and in-background "&")
""))))
diff --git a/lisp/dired.el b/lisp/dired.el
index fa06c8fd441..facfb35ab45 100644
--- a/lisp/dired.el
+++ b/lisp/dired.el
@@ -3746,7 +3746,10 @@ non-empty directories is allowed."
(progress-reporter-update progress-reporter succ)
(dired-fun-in-all-buffers
(file-name-directory fn) (file-name-nondirectory fn)
- #'dired-delete-entry fn))
+ #'dired-delete-entry fn)
+ ;; For when FN's directory name is different
+ ;; from the current buffer's dired-directory.
+ (dired-delete-entry fn))
(quit (throw '--delete-cancel (message "OK, canceled")))
(error ;; catch errors from failed deletions
(dired-log "%s: %s\n" (car err) (error-message-string err))
diff --git a/lisp/disp-table.el b/lisp/disp-table.el
index 422728c61c5..53dff1e7097 100644
--- a/lisp/disp-table.el
+++ b/lisp/disp-table.el
@@ -296,6 +296,69 @@ in `.emacs'."
(if (coding-system-p c) c 'latin-1))))
(standard-display-european-internal)))
+
+;;;###autoload
+(defun standard-display-by-replacement-char (&optional repl from to)
+ "Produce code to display characters between FROM and TO using REPL.
+This function produces a buffer with code to set up `standard-display-table'
+such that characters that cannot be displayed by the terminal, and
+don't already have their display set up in `standard-display-table', will
+be represented by a replacement character. You can evaluate the produced
+code to use the setup for the current Emacs session, or copy the code
+into your init file, to make Emacs use it for subsequent sessions.
+
+Interactively, the produced code arranges for any character in
+the range [#x100..#x10FFFF] that the terminal cannot display to
+be represented by the #xFFFD Unicode replacement character.
+
+When called from Lisp, FROM and TO define the range of characters for
+which to produce the setup code for `standard-display-table'. If they
+are omitted, they default to #x100 and #x10FFFF respectively, covering
+the entire non-ASCII range of Unicode characters.
+REPL is the replacement character to use. If it's omitted, it defaults
+to #xFFFD, the Unicode replacement character, usually displayed as a
+black diamond with a question mark inside.
+The produced code sets up `standard-display-table' to show REPL with
+the `homoglyph' face, making the replacements stand out on display.
+
+This command is most useful with text-mode terminals, such as the
+Linux console, for which Emacs has a reliable way of determining
+which characters can be displayed and which cannot."
+ (interactive)
+ (or repl
+ (setq repl #xfffd))
+ (or (and from to (<= from to))
+ (setq from #x100
+ to (max-char 'unicode)))
+ (let ((buf (get-buffer-create "*Display replacements*"))
+ (ch from)
+ (tbl standard-display-table)
+ first)
+ (with-current-buffer buf
+ (erase-buffer)
+ (insert "(let ((tbl standard-display-table))\n")
+ (while (<= ch to)
+ (cond
+ ((or (char-displayable-p ch)
+ (aref tbl ch))
+ (setq ch (1+ ch)))
+ (t
+ (setq first ch)
+ (while (and (<= ch to)
+ (not (or (char-displayable-p ch)
+ (aref tbl ch))))
+ (setq ch (1+ ch)))
+ (insert
+ " (set-char-table-range tbl '("
+ (format "#x%x" first)
+ " . "
+ (format "#x%x" (1- ch))
+ ")\n\ (vconcat (list (make-glyph-code "
+ (format "#x%x" repl) " 'homoglyph))))\n"))))
+ (insert ")\n"))
+ (pop-to-buffer buf)))
+
+
(provide 'disp-table)
;;; disp-table.el ends here
diff --git a/lisp/doc-view.el b/lisp/doc-view.el
index 29da3b42977..aa0f9fd3838 100644
--- a/lisp/doc-view.el
+++ b/lisp/doc-view.el
@@ -153,7 +153,7 @@
"In-buffer document viewer.
The viewer handles PDF, PostScript, DVI, DJVU, ODF, EPUB, CBZ,
FB2, XPS and OXPS files, if the appropriate converter programs
-are available (see Info node `(emacs)Document View')"
+are available (see Info node `(emacs)Document View')."
:link '(function-link doc-view)
:version "22.2"
:group 'applications
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 80ca43c902a..9755c2636de 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2762,7 +2762,7 @@ Each PLACE may be a symbol, or any generalized variable allowed by `setf'.
(funcall setter vold)))
binds))))
(let* ((binding (car bindings))
- (place (macroexpand (car binding) macroexpand-all-environment)))
+ (place (car binding)))
(gv-letplace (getter setter) place
(macroexp-let2 nil vnew (cadr binding)
(if (symbolp place)
@@ -3105,7 +3105,7 @@ To see the documentation for a defined struct type, use
`(and ,pred-form t)))
forms)
(push `(eval-and-compile
- (put ',name 'cl-deftype-satisfies ',predicate))
+ (define-symbol-prop ',name 'cl-deftype-satisfies ',predicate))
forms))
(let ((pos 0) (descp descs))
(while descp
@@ -3570,7 +3570,7 @@ and then returning foo."
(cl-defun ,fname ,(if (memq '&whole args) (delq '&whole args)
(cons '_cl-whole-arg args))
,@body)
- (put ',func 'compiler-macro #',fname))))
+ (define-symbol-prop ',func 'compiler-macro #',fname))))
;;;###autoload
(defun cl-compiler-macroexpand (form)
@@ -3679,8 +3679,8 @@ macro that returns its `&whole' argument."
The type name can then be used in `cl-typecase', `cl-check-type', etc."
(declare (debug cl-defmacro) (doc-string 3) (indent 2))
`(cl-eval-when (compile load eval)
- (put ',name 'cl-deftype-handler
- (cl-function (lambda (&cl-defs ('*) ,@arglist) ,@body)))))
+ (define-symbol-prop ',name 'cl-deftype-handler
+ (cl-function (lambda (&cl-defs ('*) ,@arglist) ,@body)))))
(cl-deftype extended-char () '(and character (not base-char)))
;; Define fixnum so `cl-typep' recognize it and the type check emitted
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index e10443588e4..a9087313b18 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -462,7 +462,7 @@ Useful to hook into pass checkers.")
(marker-buffer (function (marker) (or buffer null)))
(markerp (function (t) boolean))
(max (function ((or number marker) &rest (or number marker)) number))
- (max-char (function () fixnum))
+ (max-char (function (&optional t) fixnum))
(member (function (t list) list))
(memory-limit (function () integer))
(memq (function (t list) list))
@@ -3935,8 +3935,11 @@ display a message."
when (or native-comp-always-compile
load ; Always compile when the compilation is
; commanded for late load.
- (file-newer-than-file-p
- source-file (comp-el-to-eln-filename source-file)))
+ ;; Skip compilation if `comp-el-to-eln-filename' fails
+ ;; to find a writable directory.
+ (with-demoted-errors "Async compilation :%S"
+ (file-newer-than-file-p
+ source-file (comp-el-to-eln-filename source-file))))
do (let* ((expr `((require 'comp)
(setq comp-async-compilation t)
(setq warning-fill-column most-positive-fixnum)
diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el
index c3a4e9fc7ab..7d54a84687b 100644
--- a/lisp/emacs-lisp/easy-mmode.el
+++ b/lisp/emacs-lisp/easy-mmode.el
@@ -417,7 +417,12 @@ No problems result if this variable is not bound.
`(defvar ,keymap-sym
(let ((m ,keymap))
(cond ((keymapp m) m)
- ((listp m) (easy-mmode-define-keymap m))
+ ;; FIXME: `easy-mmode-define-keymap' is obsolete,
+ ;; so this form should also be obsolete somehow.
+ ((listp m)
+ (with-suppressed-warnings ((obsolete
+ easy-mmode-define-keymap))
+ (easy-mmode-define-keymap m)))
(t (error "Invalid keymap %S" m))))
,(format "Keymap for `%s'." mode-name)))
@@ -679,6 +684,7 @@ Valid keywords and arguments are:
:group Ignored.
:suppress Non-nil to call `suppress-keymap' on keymap,
`nodigits' to suppress digits as prefix arguments."
+ (declare (obsolete define-keymap "29.1"))
(let (inherit dense suppress)
(while args
(let ((key (pop args))
@@ -719,9 +725,7 @@ The M, BS, and ARGS arguments are as per that function. DOC is
the constant's documentation.
This macro is deprecated; use `defvar-keymap' instead."
- ;; FIXME: Declare obsolete in favor of `defvar-keymap'. It is still
- ;; used for `gud-menu-map' and `gud-minor-mode-map', so fix that first.
- (declare (doc-string 3) (indent 1))
+ (declare (doc-string 3) (indent 1) (obsolete defvar-keymap "29.1"))
`(defconst ,m
(easy-mmode-define-keymap ,bs nil (if (boundp ',m) ,m) ,(cons 'list args))
,doc))
diff --git a/lisp/emacs-lisp/generate-lisp-file.el b/lisp/emacs-lisp/generate-lisp-file.el
index 8896a3f7019..7b087a4ecbd 100644
--- a/lisp/emacs-lisp/generate-lisp-file.el
+++ b/lisp/emacs-lisp/generate-lisp-file.el
@@ -63,12 +63,12 @@ inserted."
(cl-defun generate-lisp-file-trailer (file &key version inhibit-provide
(coding 'utf-8-emacs-unix) autoloads
- compile provide)
+ compile provide inhibit-native-compile)
"Insert a standard trailer for FILE.
By default, this trailer inhibits version control, byte
compilation, updating autoloads, and uses a `utf-8-emacs-unix'
coding system. These can be inhibited by providing non-nil
-values to the VERSION, NO-PROVIDE, AUTOLOADS and COMPILE
+values to the VERSION, AUTOLOADS, COMPILE and NATIVE-COMPILE
keyword arguments.
CODING defaults to `utf-8-emacs-unix'. Use a nil value to
@@ -79,7 +79,11 @@ If PROVIDE is non-nil, use that in the `provide' statement
instead of using FILE as the basis.
If `standard-output' is bound to a buffer, insert in that buffer.
-If no, insert at point in the current buffer."
+If no, insert at point in the current buffer.
+
+If INHITBIT-NATIVE-COMPILE is non-nil, add a cookie to inhibit
+native compilation. (By default, a file will be native-compiled
+if it's also byte-compiled)."
(with-current-buffer (if (bufferp standard-output)
standard-output
(current-buffer))
@@ -96,9 +100,11 @@ If no, insert at point in the current buffer."
(unless version
(insert ";; version-control: never\n"))
(unless compile
- (insert ";; no-byte-" "compile: t\n")) ;; #$ is byte-compiled into nil.
+ (insert ";; no-byte-" "compile: t\n"))
(unless autoloads
(insert ";; no-update-autoloads: t\n"))
+ (when inhibit-native-compile
+ (insert ";; no-native-" "compile: t\n"))
(when coding
(insert (format ";; coding: %s\n"
(if (eq coding t)
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index eaab6439adb..1db9d96d999 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -87,7 +87,11 @@ with a (not necessarily copyable) Elisp expression that returns the value to
set it to.
DO must return an Elisp expression."
(cond
- ((symbolp place) (funcall do place (lambda (v) `(setq ,place ,v))))
+ ((symbolp place)
+ (let ((me (macroexpand-1 place macroexpand-all-environment)))
+ (if (eq me place)
+ (funcall do place (lambda (v) `(setq ,place ,v)))
+ (gv-get me do))))
((not (consp place)) (signal 'gv-invalid-place (list place)))
(t
(let* ((head (car place))
diff --git a/lisp/emacs-lisp/loaddefs-gen.el b/lisp/emacs-lisp/loaddefs-gen.el
index e13b92bab8c..005a46c2d75 100644
--- a/lisp/emacs-lisp/loaddefs-gen.el
+++ b/lisp/emacs-lisp/loaddefs-gen.el
@@ -504,6 +504,7 @@ If COMPILE, don't include a \"don't compile\" cookie."
(generate-lisp-file-trailer
file :provide (and (stringp feature) feature)
:compile compile
+ :inhibit-native-compile t
:inhibit-provide (not feature))
(buffer-string))))
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index c3ba1b36d44..f4df40249de 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -110,7 +110,8 @@ each clause."
(let ((symbols-with-pos-enabled t))
(apply handler form (cdr form)))
(error
- (message "Compiler-macro error for %S: Handler: %S\n%S" (car form) handler err)
+ (message "Warning: Optimization failure for %S: Handler: %S\n%S"
+ (car form) handler err)
form)))
(defun macroexp--funcall-if-compiled (_form)
diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el
index e6e8bb202da..897c35b5b19 100644
--- a/lisp/emacs-lisp/re-builder.el
+++ b/lisp/emacs-lisp/re-builder.el
@@ -369,7 +369,8 @@ provided in the Commentary section of this library."
(get-buffer-create reb-buffer)
`((display-buffer-in-direction)
(direction . ,dir)
- (dedicated . t))))))
+ (dedicated . t)
+ (window-height . fit-window-to-buffer))))))
(font-lock-mode 1)
(reb-initialize-buffer)))
diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el
index b6f0f66e5b1..31dcfa98b40 100644
--- a/lisp/emacs-lisp/seq.el
+++ b/lisp/emacs-lisp/seq.el
@@ -347,6 +347,20 @@ list."
sequence))
;;;###autoload
+(cl-defgeneric seq-remove-at-position (sequence n)
+ "Return a copy of SEQUENCE where the element at N got removed.
+
+N is the (zero-based) index of the element that should not be in
+the result.
+
+The result is a sequence of the same type as SEQUENCE."
+ (seq-concatenate
+ (let ((type (type-of sequence)))
+ (if (eq type 'cons) 'list type))
+ (seq-subseq sequence 0 n)
+ (seq-subseq sequence (1+ n))))
+
+;;;###autoload
(cl-defgeneric seq-reduce (function sequence initial-value)
"Reduce the function FUNCTION across SEQUENCE, starting with INITIAL-VALUE.
@@ -409,7 +423,7 @@ found or not."
(cl-defgeneric seq-contains (sequence elt &optional testfn)
"Return the first element in SEQUENCE that is equal to ELT.
-Equality is defined by TESTFN if non-nil or by `equal' if nil."
+Equality is defined by the function TESTFN, which defaults to `equal'."
(declare (obsolete seq-contains-p "27.1"))
(seq-some (lambda (e)
(when (funcall (or testfn #'equal) elt e)
@@ -418,7 +432,7 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil."
(cl-defgeneric seq-contains-p (sequence elt &optional testfn)
"Return non-nil if SEQUENCE contains an element equal to ELT.
-Equality is defined by TESTFN if non-nil or by `equal' if nil."
+Equality is defined by the function TESTFN, which defaults to `equal'."
(catch 'seq--break
(seq-doseq (e sequence)
(let ((r (funcall (or testfn #'equal) e elt)))
@@ -429,14 +443,14 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil."
(cl-defgeneric seq-set-equal-p (sequence1 sequence2 &optional testfn)
"Return non-nil if SEQUENCE1 and SEQUENCE2 contain the same elements.
This does not depend on the order of the elements.
-Equality is defined by TESTFN if non-nil or by `equal' if nil."
+Equality is defined by the function TESTFN, which defaults to `equal'."
(and (seq-every-p (lambda (item1) (seq-contains-p sequence2 item1 testfn)) sequence1)
(seq-every-p (lambda (item2) (seq-contains-p sequence1 item2 testfn)) sequence2)))
;;;###autoload
(cl-defgeneric seq-position (sequence elt &optional testfn)
- "Return the index of the first element in SEQUENCE that is equal to ELT.
-Equality is defined by TESTFN if non-nil or by `equal' if nil."
+ "Return the (zero-based) index of the first element in SEQUENCE equal to ELT.
+Equality is defined by the function TESTFN, which defaults to `equal'."
(let ((index 0))
(catch 'seq--break
(seq-doseq (e sequence)
@@ -446,6 +460,23 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil."
nil)))
;;;###autoload
+(cl-defgeneric seq-positions (sequence elt &optional testfn)
+ "Return indices for which (TESTFN (seq-elt SEQUENCE index) ELT) is non-nil.
+
+TESTFN is a two-argument function which is passed each element of
+SEQUENCE as first argument and ELT as second. TESTFN defaults to
+`equal'.
+
+The result is a list of (zero-based) indices."
+ (let ((result '()))
+ (seq-do-indexed
+ (lambda (e index)
+ (when (funcall (or testfn #'equal) e elt)
+ (push index result)))
+ sequence)
+ (nreverse result)))
+
+;;;###autoload
(cl-defgeneric seq-uniq (sequence &optional testfn)
"Return a list of the elements of SEQUENCE with duplicates removed.
TESTFN is used to compare elements, or `equal' if TESTFN is nil."
@@ -502,7 +533,7 @@ negative integer or 0, nil is returned."
;;;###autoload
(cl-defgeneric seq-union (sequence1 sequence2 &optional testfn)
"Return a list of all elements that appear in either SEQUENCE1 or SEQUENCE2.
-Equality is defined by TESTFN if non-nil or by `equal' if nil."
+Equality is defined by the function TESTFN, which defaults to `equal'."
(let* ((accum (lambda (acc elt)
(if (seq-contains-p acc elt testfn)
acc
@@ -514,7 +545,7 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil."
;;;###autoload
(cl-defgeneric seq-intersection (sequence1 sequence2 &optional testfn)
"Return a list of the elements that appear in both SEQUENCE1 and SEQUENCE2.
-Equality is defined by TESTFN if non-nil or by `equal' if nil."
+Equality is defined by the function TESTFN, which defaults to `equal'."
(seq-reduce (lambda (acc elt)
(if (seq-contains-p sequence2 elt testfn)
(cons elt acc)
@@ -524,7 +555,7 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil."
(cl-defgeneric seq-difference (sequence1 sequence2 &optional testfn)
"Return a list of the elements that appear in SEQUENCE1 but not in SEQUENCE2.
-Equality is defined by TESTFN if non-nil or by `equal' if nil."
+Equality is defined by the function TESTFN, which defaults to `equal'."
(seq-reduce (lambda (acc elt)
(if (seq-contains-p sequence2 elt testfn)
acc
@@ -618,13 +649,7 @@ Signal an error if SEQUENCE is empty."
(cl-defmethod seq-take ((list list) n)
"Optimized implementation of `seq-take' for lists."
- (if (eval-when-compile (fboundp 'take))
- (take n list)
- (let ((result '()))
- (while (and list (> n 0))
- (setq n (1- n))
- (push (pop list) result))
- (nreverse result))))
+ (take n list))
(cl-defmethod seq-drop-while (pred (list list))
"Optimized implementation of `seq-drop-while' for lists."
@@ -655,16 +680,6 @@ Signal an error if SEQUENCE is empty."
sequence
(concat sequence)))
-(defun seq--activate-font-lock-keywords ()
- "Activate font-lock keywords for some symbols defined in seq."
- (font-lock-add-keywords 'emacs-lisp-mode
- '("\\<seq-doseq\\>" "\\<seq-let\\>")))
-
-(unless (fboundp 'elisp--font-lock-flush-elisp-buffers)
- ;; In Emacs≥25, (via elisp--font-lock-flush-elisp-buffers and a few others)
- ;; we automatically highlight macros.
- (add-hook 'emacs-lisp-mode-hook #'seq--activate-font-lock-keywords))
-
(defun seq-split (sequence length)
"Split SEQUENCE into a list of sub-sequences of at most LENGTH.
All the sub-sequences will be of LENGTH, except the last one,
diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el
index 990dabe351a..2472479bad6 100644
--- a/lisp/emacs-lisp/shortdoc.el
+++ b/lisp/emacs-lisp/shortdoc.el
@@ -846,6 +846,10 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'),
:eval (seq-find #'numberp '(a b 3 4 f 6)))
(seq-position
:eval (seq-position '(a b c) 'c))
+ (seq-positions
+ :eval (seq-positions '(a b c a d) 'a)
+ :eval (seq-positions '(a b c a d) 'z)
+ :eval (seq-positions '(11 5 7 12 9 15) 10 #'>=))
(seq-length
:eval (seq-length "abcde"))
(seq-max
@@ -888,6 +892,9 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'),
:eval (seq-filter #'numberp '(a b 3 4 f 6)))
(seq-remove
:eval (seq-remove #'numberp '(1 2 c d 5)))
+ (seq-remove-at-position
+ :eval (seq-remove-at-position '(a b c d e) 3)
+ :eval (seq-remove-at-position [a b c d e] 0))
(seq-group-by
:eval (seq-group-by #'cl-plusp '(-1 2 3 -4 -5 6)))
(seq-union
diff --git a/lisp/emulation/viper-macs.el b/lisp/emulation/viper-macs.el
index 06130afa7da..9c2aae1fe9f 100644
--- a/lisp/emulation/viper-macs.el
+++ b/lisp/emulation/viper-macs.el
@@ -66,9 +66,8 @@
The previous command is accessible, as usual, via `.'. The command before this
can be invoked as `<this key> 1', and the command before that, and the command
before that one is accessible as `<this key> 2'.
-The notation for these keys is borrowed from XEmacs. Basically,
-a key is a symbol, e.g., `a', `\\1', `f2', etc., or a list, e.g.,
-`(meta control f1)'."
+Basically, a key is a symbol, e.g., `a', `\\1', `f2', etc., or a
+list, e.g., `(meta control f1)'."
:type 'sexp
:group 'viper)
diff --git a/lisp/eshell/em-term.el b/lisp/eshell/em-term.el
index a4fa699aa90..6811e703137 100644
--- a/lisp/eshell/em-term.el
+++ b/lisp/eshell/em-term.el
@@ -153,7 +153,7 @@ behavior for short-lived processes, see bug#18108."
If either COMMAND or a subcommand in ARGS (e.g. git log) is a
visual command, returns non-nil."
(let ((command (file-name-nondirectory command)))
- (and (eshell-interactive-output-p)
+ (and (eshell-interactive-output-p 'all)
(or (member command eshell-visual-commands)
(member (car args)
(cdr (assoc command eshell-visual-subcommands)))
diff --git a/lisp/eshell/esh-arg.el b/lisp/eshell/esh-arg.el
index 8e44a88459f..576d32b8c5d 100644
--- a/lisp/eshell/esh-arg.el
+++ b/lisp/eshell/esh-arg.el
@@ -29,6 +29,9 @@
(require 'esh-util)
+(eval-when-compile
+ (require 'cl-lib))
+
(defgroup eshell-arg nil
"Argument parsing involves transforming the arguments passed on the
command line into equivalent Lisp forms that, when evaluated, will
@@ -147,6 +150,10 @@ return the result of the parse as a sexp. It is also responsible for
moving the point forward to reflect the amount of input text that was
parsed.
+If the hook determines that it has reached the end of an argument, it
+should call `eshell-finish-arg' to complete processing of the current
+argument and proceed to the next.
+
If no function handles the current character at point, it will be
treated as a literal character."
:type 'hook
@@ -244,10 +251,16 @@ convert the result to a number as well."
eshell-current-modifiers (cdr eshell-current-modifiers))))
(setq eshell-current-modifiers nil))
-(defun eshell-finish-arg (&optional argument)
- "Finish the current ARGUMENT being processed."
- (if argument
- (setq eshell-current-argument argument))
+(defun eshell-finish-arg (&rest arguments)
+ "Finish the current argument being processed.
+If any ARGUMENTS are specified, they will be added to the final
+argument list in place of the value of the current argument."
+ (when arguments
+ (if (= (length arguments) 1)
+ (setq eshell-current-argument (car arguments))
+ (cl-assert (and (not eshell-arg-listified)
+ (not eshell-current-modifiers)))
+ (setq eshell-current-argument (cons 'eshell-flatten-args arguments))))
(throw 'eshell-arg-done t))
(defun eshell-quote-argument (string)
@@ -287,7 +300,11 @@ Point is left at the end of the arguments."
(if (= (point) here)
(error "Failed to parse argument `%s'"
(buffer-substring here (point-max))))
- (and arg (nconc args (list arg)))))))
+ (when arg
+ (nconc args
+ (if (eq (car-safe arg) 'eshell-flatten-args)
+ (cdr arg)
+ (list arg))))))))
(throw 'eshell-incomplete (if (listp delim)
delim
(list delim (point) (cdr args)))))
diff --git a/lisp/eshell/esh-cmd.el b/lisp/eshell/esh-cmd.el
index 2f77f3f4974..413336e3eb5 100644
--- a/lisp/eshell/esh-cmd.el
+++ b/lisp/eshell/esh-cmd.el
@@ -810,8 +810,6 @@ This macro calls itself recursively, with NOTFIRST non-nil."
`(let ((nextproc
(eshell-do-pipelines (quote ,(cdr pipeline)) t)))
(eshell-set-output-handle ,eshell-output-handle
- 'append nextproc)
- (eshell-set-output-handle ,eshell-error-handle
'append nextproc)))
,(let ((head (car pipeline)))
(if (memq (car head) '(let progn))
@@ -842,8 +840,6 @@ This is used on systems where async subprocesses are not supported."
,(when (cdr pipeline)
`(let ((output-marker ,(point-marker)))
(eshell-set-output-handle ,eshell-output-handle
- 'append output-marker)
- (eshell-set-output-handle ,eshell-error-handle
'append output-marker)))
,(let ((head (car pipeline)))
(if (memq (car head) '(let progn))
@@ -1347,6 +1343,15 @@ case."
(apply func-or-form args)))))
(and result (funcall printer result))
result)
+ (eshell-pipe-broken
+ ;; If FUNC-OR-FORM tried and failed to write some output to a
+ ;; process, it will raise an `eshell-pipe-broken' signal (this is
+ ;; analogous to SIGPIPE on POSIX systems). In this case, set the
+ ;; command status to some non-zero value to indicate an error; to
+ ;; match GNU/Linux, we use 141, which the numeric value of
+ ;; SIGPIPE on GNU/Linux (13) with the high bit (2^7) set.
+ (setq eshell-last-command-status 141)
+ nil)
(error
(setq eshell-last-command-status 1)
(let ((msg (error-message-string err)))
diff --git a/lisp/eshell/esh-io.el b/lisp/eshell/esh-io.el
index e5977c95807..4620565f857 100644
--- a/lisp/eshell/esh-io.el
+++ b/lisp/eshell/esh-io.el
@@ -154,6 +154,14 @@ not be added to this variable."
;;; Internal Variables:
+(defconst eshell-redirection-operators-alist
+ '(("<" . input) ; FIXME: Not supported yet.
+ (">" . overwrite)
+ (">>" . append)
+ (">>>" . insert))
+ "An association list of redirection operators to symbols
+describing the mode, e.g. for using with `eshell-get-target'.")
+
(defvar eshell-current-handles nil)
(defvar eshell-last-command-status 0
@@ -173,53 +181,104 @@ not be added to this variable."
(defun eshell-io-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the I/O subsystem code."
(add-hook 'eshell-parse-argument-hook
- 'eshell-parse-redirection nil t)
+ #'eshell-parse-redirection nil t)
(make-local-variable 'eshell-current-redirections)
(add-hook 'eshell-pre-rewrite-command-hook
- 'eshell-strip-redirections nil t)
+ #'eshell-strip-redirections nil t)
(add-function :filter-return (local 'eshell-post-rewrite-command-function)
#'eshell--apply-redirections))
(defun eshell-parse-redirection ()
- "Parse an output redirection, such as `2>'."
- (if (and (not eshell-current-quoted)
- (looking-at "\\([0-9]\\)?\\(<\\|>+\\)&?\\([0-9]\\)?\\s-*"))
+ "Parse an output redirection, such as `2>' or `>&'."
+ (when (not eshell-current-quoted)
+ (cond
+ ;; Copying a handle (e.g. `2>&1').
+ ((looking-at (rx (? (group digit))
+ (group (or "<" ">"))
+ "&" (group digit)
+ (* (syntax whitespace))))
+ (let ((source (string-to-number (or (match-string 1) "1")))
+ (mode (cdr (assoc (match-string 2)
+ eshell-redirection-operators-alist)))
+ (target (string-to-number (match-string 3))))
+ (when (eq mode 'input)
+ (error "Eshell does not support input redirection"))
+ (goto-char (match-end 0))
+ (eshell-finish-arg (list 'eshell-copy-output-handle
+ source target))))
+ ;; Shorthand for redirecting both stdout and stderr (e.g. `&>').
+ ((looking-at (rx (or (seq (group (** 1 3 ">")) "&")
+ (seq "&" (group-n 1 (** 1 3 ">"))))
+ (* (syntax whitespace))))
+ (if eshell-current-argument
+ (eshell-finish-arg)
+ (goto-char (match-end 0))
+ (eshell-finish-arg
+ (let ((mode (cdr (assoc (match-string 1)
+ eshell-redirection-operators-alist))))
+ (list 'eshell-set-all-output-handles
+ (list 'quote mode))))))
+ ;; Shorthand for piping both stdout and stderr (i.e. `|&').
+ ((looking-at (rx "|&" (* (syntax whitespace))))
+ (if eshell-current-argument
+ (eshell-finish-arg)
+ (goto-char (match-end 0))
+ (eshell-finish-arg
+ '(eshell-copy-output-handle eshell-error-handle
+ eshell-output-handle)
+ '(eshell-operator "|"))))
+ ;; Regular redirecting (e.g. `2>').
+ ((looking-at (rx (? (group digit))
+ (group (or "<" (** 1 3 ">")))
+ (* (syntax whitespace))))
(if eshell-current-argument
- (eshell-finish-arg)
- (let ((sh (match-string 1))
- (oper (match-string 2))
-; (th (match-string 3))
- )
- (if (string= oper "<")
- (error "Eshell does not support input redirection"))
- (eshell-finish-arg
- (prog1
- (list 'eshell-set-output-handle
- (or (and sh (string-to-number sh)) 1)
- (list 'quote
- (aref [overwrite append insert]
- (1- (length oper)))))
- (goto-char (match-end 0))))))))
+ (eshell-finish-arg)
+ (let ((source (if (match-string 1)
+ (string-to-number (match-string 1))
+ eshell-output-handle))
+ (mode (cdr (assoc (match-string 2)
+ eshell-redirection-operators-alist))))
+ (when (eq mode 'input)
+ (error "Eshell does not support input redirection"))
+ (goto-char (match-end 0))
+ (eshell-finish-arg
+ ;; Note: the target will be set later by
+ ;; `eshell-strip-redirections'.
+ (list 'eshell-set-output-handle
+ source (list 'quote mode)))))))))
(defun eshell-strip-redirections (terms)
"Rewrite any output redirections in TERMS."
(setq eshell-current-redirections (list t))
(let ((tl terms)
- (tt (cdr terms)))
+ (tt (cdr terms)))
(while tt
- (if (not (and (consp (car tt))
- (eq (caar tt) 'eshell-set-output-handle)))
- (setq tt (cdr tt)
- tl (cdr tl))
- (unless (cdr tt)
- (error "Missing redirection target"))
- (nconc eshell-current-redirections
- (list (list 'ignore
- (append (car tt) (list (cadr tt))))))
- (setcdr tl (cddr tt))
- (setq tt (cddr tt))))
+ (cond
+ ;; Strip `eshell-copy-output-handle'.
+ ((and (consp (car tt))
+ (eq (caar tt) 'eshell-copy-output-handle))
+ (nconc eshell-current-redirections
+ (list (car tt)))
+ (setcdr tl (cddr tt))
+ (setq tt (cdr tt)))
+ ;; Strip `eshell-set-output-handle' or
+ ;; `eshell-set-all-output-handles' and the term immediately
+ ;; after (the redirection target).
+ ((and (consp (car tt))
+ (memq (caar tt) '(eshell-set-output-handle
+ eshell-set-all-output-handles)))
+ (unless (cdr tt)
+ (error "Missing redirection target"))
+ (nconc eshell-current-redirections
+ (list (list 'ignore
+ (append (car tt) (list (cadr tt))))))
+ (setcdr tl (cddr tt))
+ (setq tt (cddr tt)))
+ (t
+ (setq tt (cdr tt)
+ tl (cdr tl)))))
(setq eshell-current-redirections
- (cdr eshell-current-redirections))))
+ (cdr eshell-current-redirections))))
(defun eshell--apply-redirections (cmd)
"Apply any redirection which were specified for COMMAND."
@@ -236,22 +295,21 @@ The default location for standard output and standard error will go to
STDOUT and STDERR, respectively.
OUTPUT-MODE and ERROR-MODE are either `overwrite', `append' or `insert';
a nil value of mode defaults to `insert'."
- (let ((handles (make-vector eshell-number-of-handles nil))
- (output-target (eshell-get-target stdout output-mode))
- (error-target (eshell-get-target stderr error-mode)))
+ (let* ((handles (make-vector eshell-number-of-handles nil))
+ (output-target (eshell-get-target stdout output-mode))
+ (error-target (if stderr
+ (eshell-get-target stderr error-mode)
+ output-target)))
(aset handles eshell-output-handle (cons output-target 1))
- (aset handles eshell-error-handle
- (cons (if stderr error-target output-target) 1))
+ (aset handles eshell-error-handle (cons error-target 1))
handles))
(defun eshell-protect-handles (handles)
"Protect the handles in HANDLES from a being closed."
- (let ((idx 0))
- (while (< idx eshell-number-of-handles)
- (if (aref handles idx)
- (setcdr (aref handles idx)
- (1+ (cdr (aref handles idx)))))
- (setq idx (1+ idx))))
+ (dotimes (idx eshell-number-of-handles)
+ (when (aref handles idx)
+ (setcdr (aref handles idx)
+ (1+ (cdr (aref handles idx))))))
handles)
(defun eshell-close-handles (&optional exit-code result handles)
@@ -278,6 +336,40 @@ the value already set in `eshell-last-command-result'."
(eshell-close-target target (= eshell-last-command-status 0)))
(setcar handle nil))))))
+(defun eshell-set-output-handle (index mode &optional target handles)
+ "Set handle INDEX for the current HANDLES to point to TARGET using MODE.
+If HANDLES is nil, use `eshell-current-handles'."
+ (when target
+ (let ((handles (or handles eshell-current-handles)))
+ (if (and (stringp target)
+ (string= target (null-device)))
+ (aset handles index nil)
+ (let ((where (eshell-get-target target mode))
+ (current (car (aref handles index))))
+ (if (listp current)
+ (unless (member where current)
+ (setq current (append current (list where))))
+ (setq current (list where)))
+ (if (not (aref handles index))
+ (aset handles index (cons nil 1)))
+ (setcar (aref handles index) current))))))
+
+(defun eshell-copy-output-handle (index index-to-copy &optional handles)
+ "Copy the handle INDEX-TO-COPY to INDEX for the current HANDLES.
+If HANDLES is nil, use `eshell-current-handles'."
+ (let* ((handles (or handles eshell-current-handles))
+ (handle-to-copy (car (aref handles index-to-copy))))
+ (setcar (aref handles index)
+ (if (listp handle-to-copy)
+ (copy-sequence handle-to-copy)
+ handle-to-copy))))
+
+(defun eshell-set-all-output-handles (mode &optional target handles)
+ "Set output and error HANDLES to point to TARGET using MODE.
+If HANDLES is nil, use `eshell-current-handles'."
+ (eshell-set-output-handle eshell-output-handle mode target handles)
+ (eshell-copy-output-handle eshell-error-handle eshell-output-handle handles))
+
(defun eshell-close-target (target status)
"Close an output TARGET, passing STATUS as the result.
STATUS should be non-nil on successful termination of the output."
@@ -390,28 +482,20 @@ it defaults to `insert'."
(error "Invalid redirection target: %s"
(eshell-stringify target)))))
-(defun eshell-set-output-handle (index mode &optional target)
- "Set handle INDEX, using MODE, to point to TARGET."
- (when target
- (if (and (stringp target)
- (string= target (null-device)))
- (aset eshell-current-handles index nil)
- (let ((where (eshell-get-target target mode))
- (current (car (aref eshell-current-handles index))))
- (if (and (listp current)
- (not (member where current)))
- (setq current (append current (list where)))
- (setq current (list where)))
- (if (not (aref eshell-current-handles index))
- (aset eshell-current-handles index (cons nil 1)))
- (setcar (aref eshell-current-handles index) current)))))
-
-(defun eshell-interactive-output-p ()
- "Return non-nil if current handles are bound for interactive display."
- (and (eq (car (aref eshell-current-handles
- eshell-output-handle)) t)
- (eq (car (aref eshell-current-handles
- eshell-error-handle)) t)))
+(defun eshell-interactive-output-p (&optional index handles)
+ "Return non-nil if the specified handle is bound for interactive display.
+HANDLES is the set of handles to check; if nil, use
+`eshell-current-handles'.
+
+INDEX is the handle index to check. If nil, check
+`eshell-output-handle'. If `all', check both
+`eshell-output-handle' and `eshell-error-handle'."
+ (let ((handles (or handles eshell-current-handles))
+ (index (or index eshell-output-handle)))
+ (if (eq index 'all)
+ (and (eq (car (aref handles eshell-output-handle)) t)
+ (eq (car (aref handles eshell-error-handle)) t))
+ (eq (car (aref handles index)) t))))
(defvar eshell-print-queue nil)
(defvar eshell-print-queue-count -1)
@@ -498,10 +582,16 @@ Returns what was actually sent, or nil if nothing was sent."
((eshell-processp target)
(unless (stringp object)
(setq object (eshell-stringify object)))
- (condition-case nil
+ (condition-case err
(process-send-string target object)
- ;; If `process-send-string' raises an error, treat it as a broken pipe.
- (error (signal 'eshell-pipe-broken (list target)))))
+ (error
+ ;; If `process-send-string' raises an error and the process has
+ ;; finished, treat it as a broken pipe. Otherwise, just
+ ;; re-throw the signal.
+ (if (memq (process-status target)
+ '(run stop open closed))
+ (signal (car err) (cdr err))
+ (signal 'eshell-pipe-broken (list target))))))
((consp target)
(apply (car target) object (cdr target))))
diff --git a/lisp/eshell/esh-proc.el b/lisp/eshell/esh-proc.el
index c367b5cd643..7e005a0fc1c 100644
--- a/lisp/eshell/esh-proc.el
+++ b/lisp/eshell/esh-proc.el
@@ -99,7 +99,13 @@ information, for example."
(defvar eshell-current-subjob-p nil)
(defvar eshell-process-list nil
- "A list of the current status of subprocesses.")
+ "A list of the current status of subprocesses.
+Each element has the form (PROC . SUBJOB-P), where PROC is the
+process object and SUBJOB-P is non-nil if the process is a
+subjob.
+
+To add or remove elements of this list, see
+`eshell-record-process-object' and `eshell-remove-process-entry'.")
(declare-function eshell-send-eof-to-process "esh-mode")
(declare-function eshell-tail-process "esh-cmd")
@@ -229,21 +235,30 @@ The prompt will be set to PROMPT."
(declare-function eshell-interactive-print "esh-mode" (string))
(eshell-interactive-print
(format "[%s] %d\n" (process-name object) (process-id object))))
- (setq eshell-process-list
- (cons (list object eshell-current-handles
- eshell-current-subjob-p nil nil)
- eshell-process-list)))
+ (push (cons object eshell-current-subjob-p) eshell-process-list))
(defun eshell-remove-process-entry (entry)
"Record the process ENTRY as fully completed."
(if (and (eshell-processp (car entry))
- (nth 2 entry)
+ (cdr entry)
eshell-done-messages-in-minibuffer)
(message "[%s]+ Done %s" (process-name (car entry))
(process-command (car entry))))
(setq eshell-process-list
(delq entry eshell-process-list)))
+(defun eshell-record-process-properties (process &optional index)
+ "Record Eshell bookkeeping properties for PROCESS.
+`eshell-insertion-filter' and `eshell-sentinel' will use these to
+do their jobs.
+
+INDEX is the index of the output handle to use for writing; if
+nil, write to `eshell-output-handle'."
+ (process-put process :eshell-handles eshell-current-handles)
+ (process-put process :eshell-handle-index (or index eshell-output-handle))
+ (process-put process :eshell-pending nil)
+ (process-put process :eshell-busy nil))
+
(defvar eshell-scratch-buffer " *eshell-scratch*"
"Scratch buffer for holding Eshell's input/output.")
(defvar eshell-last-sync-output-start nil
@@ -262,9 +277,21 @@ Used only on systems which do not support async subprocesses.")
eshell-delete-exited-processes
delete-exited-processes))
(process-environment (eshell-environment-variables))
- proc decoding encoding changed)
+ proc stderr-proc decoding encoding changed)
(cond
((fboundp 'make-process)
+ (unless (equal (car (aref eshell-current-handles eshell-output-handle))
+ (car (aref eshell-current-handles eshell-error-handle)))
+ (eshell-protect-handles eshell-current-handles)
+ (setq stderr-proc
+ (make-pipe-process
+ :name (concat (file-name-nondirectory command) "-stderr")
+ :buffer (current-buffer)
+ :filter (if (eshell-interactive-output-p eshell-error-handle)
+ #'eshell-output-filter
+ #'eshell-insertion-filter)
+ :sentinel #'eshell-sentinel))
+ (eshell-record-process-properties stderr-proc eshell-error-handle))
(setq proc
(let ((command (file-local-name (expand-file-name command)))
(conn-type (pcase (bound-and-true-p eshell-in-pipeline-p)
@@ -281,8 +308,10 @@ Used only on systems which do not support async subprocesses.")
#'eshell-insertion-filter)
:sentinel #'eshell-sentinel
:connection-type conn-type
+ :stderr stderr-proc
:file-handler t)))
(eshell-record-process-object proc)
+ (eshell-record-process-properties proc)
(run-hook-with-args 'eshell-exec-hook proc)
(when (fboundp 'process-coding-system)
(let ((coding-systems (process-coding-system proc)))
@@ -363,36 +392,36 @@ PROC is the process for which we're inserting output. STRING is the
output."
(when (buffer-live-p (process-buffer proc))
(with-current-buffer (process-buffer proc)
- (let ((entry (assq proc eshell-process-list)))
- (when entry
- (setcar (nthcdr 3 entry)
- (concat (nth 3 entry) string))
- (unless (nth 4 entry) ; already being handled?
- (while (nth 3 entry)
- (let ((data (nth 3 entry)))
- (setcar (nthcdr 3 entry) nil)
- (setcar (nthcdr 4 entry) t)
- (unwind-protect
- (condition-case nil
- (eshell-output-object data nil (cadr entry))
- ;; FIXME: We want to send SIGPIPE to the process
- ;; here. However, remote processes don't
- ;; currently support that, and not all systems
- ;; have SIGPIPE in the first place (e.g. MS
- ;; Windows). In these cases, just delete the
- ;; process; this is reasonably close to the
- ;; right behavior, since the default action for
- ;; SIGPIPE is to terminate the process. For use
- ;; cases where SIGPIPE is truly needed, using an
- ;; external pipe operator (`*|') may work
- ;; instead (e.g. when working with remote
- ;; processes).
- (eshell-pipe-broken
- (if (or (process-get proc 'remote-pid)
- (eq system-type 'windows-nt))
- (delete-process proc)
- (signal-process proc 'SIGPIPE))))
- (setcar (nthcdr 4 entry) nil))))))))))
+ (process-put proc :eshell-pending
+ (concat (process-get proc :eshell-pending)
+ string))
+ (unless (process-get proc :eshell-busy) ; Already being handled?
+ (while (process-get proc :eshell-pending)
+ (let ((handles (process-get proc :eshell-handles))
+ (index (process-get proc :eshell-handle-index))
+ (data (process-get proc :eshell-pending)))
+ (process-put proc :eshell-pending nil)
+ (process-put proc :eshell-busy t)
+ (unwind-protect
+ (condition-case nil
+ (eshell-output-object data index handles)
+ ;; FIXME: We want to send SIGPIPE to the process
+ ;; here. However, remote processes don't currently
+ ;; support that, and not all systems have SIGPIPE in
+ ;; the first place (e.g. MS Windows). In these
+ ;; cases, just delete the process; this is
+ ;; reasonably close to the right behavior, since the
+ ;; default action for SIGPIPE is to terminate the
+ ;; process. For use cases where SIGPIPE is truly
+ ;; needed, using an external pipe operator (`*|')
+ ;; may work instead (e.g. when working with remote
+ ;; processes).
+ (eshell-pipe-broken
+ (if (or (process-get proc 'remote-pid)
+ (eq system-type 'windows-nt))
+ (delete-process proc)
+ (signal-process proc 'SIGPIPE))))
+ (process-put proc :eshell-busy nil))))))))
(defun eshell-sentinel (proc string)
"Generic sentinel for command processes. Reports only signals.
@@ -400,37 +429,39 @@ PROC is the process that's exiting. STRING is the exit message."
(when (buffer-live-p (process-buffer proc))
(with-current-buffer (process-buffer proc)
(unwind-protect
- (when-let ((entry (assq proc eshell-process-list)))
- (unwind-protect
- (unless (string= string "run")
- ;; Write the exit message if the status is
- ;; abnormal and the process is already writing
- ;; to the terminal.
- (when (and (eq proc (eshell-tail-process))
- (not (string-match "^\\(finished\\|exited\\)"
- string)))
- (funcall (process-filter proc) proc string))
- (let ((handles (nth 1 entry))
- (str (prog1 (nth 3 entry)
- (setf (nth 3 entry) nil)))
- (status (process-exit-status proc)))
- ;; If we're in the middle of handling output
- ;; from this process then schedule the EOF for
- ;; later.
- (letrec ((finish-io
- (lambda ()
- (if (nth 4 entry)
- (run-at-time 0 nil finish-io)
- (when str
- (ignore-error 'eshell-pipe-broken
- (eshell-output-object
- str nil handles)))
- (eshell-close-handles
- status (list 'quote (= status 0))
- handles)))))
- (funcall finish-io))))
- (eshell-remove-process-entry entry)))
- (eshell-kill-process-function proc string)))))
+ (unless (string= string "run")
+ ;; Write the exit message if the status is abnormal and
+ ;; the process is already writing to the terminal.
+ (when (and (eq proc (eshell-tail-process))
+ (not (string-match "^\\(finished\\|exited\\)"
+ string)))
+ (funcall (process-filter proc) proc string))
+ (let* ((handles (process-get proc :eshell-handles))
+ (index (process-get proc :eshell-handle-index))
+ (data (process-get proc :eshell-pending))
+ ;; Only get the status for the primary subprocess,
+ ;; not the pipe process (if any).
+ (status (when (= index eshell-output-handle)
+ (process-exit-status proc))))
+ (process-put proc :eshell-pending nil)
+ ;; If we're in the middle of handling output from this
+ ;; process then schedule the EOF for later.
+ (letrec ((finish-io
+ (lambda ()
+ (if (process-get proc :eshell-busy)
+ (run-at-time 0 nil finish-io)
+ (when data
+ (ignore-error 'eshell-pipe-broken
+ (eshell-output-object
+ data index handles)))
+ (eshell-close-handles
+ status
+ (when status (list 'quote (= status 0)))
+ handles)))))
+ (funcall finish-io))))
+ (when-let ((entry (assq proc eshell-process-list)))
+ (eshell-remove-process-entry entry))
+ (eshell-kill-process-function proc string)))))
(defun eshell-process-interact (func &optional all query)
"Interact with a process, using PROMPT if more than one, via FUNC.
@@ -441,7 +472,7 @@ If QUERY is non-nil, query the user with QUERY before calling FUNC."
(if (and (memq (process-status (car entry))
'(run stop open closed))
(or all
- (not (nth 2 entry)))
+ (not (cdr entry)))
(or (not query)
(y-or-n-p (format-message query
(process-name (car entry))))))
diff --git a/lisp/faces.el b/lisp/faces.el
index 336078b0403..f1d8f82fec5 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -666,21 +666,28 @@ If FACE is a face-alias, get the documentation for the target face."
(defun set-face-attribute (face frame &rest args)
"Set attributes of FACE on FRAME from ARGS.
-This function overrides the face attributes specified by FACE's
-face spec. It is mostly intended for internal use only.
-
-If FRAME is nil, set the attributes for all existing frames, as
-well as the default for new frames. If FRAME is t, change the
-default for new frames only. As an exception, to reset the value
-of some attribute to `unspecified' in a way that overrides the
-non-`unspecified' value defined by the face's spec in `defface',
-for new frames, you must explicitly call this function with FRAME
-set to t and the attribute's value set to `unspecified'; just
-using FRAME of nil will not affect new frames in this case.
-
-ARGS must come in pairs ATTRIBUTE VALUE. ATTRIBUTE must be a
-valid face attribute name. All attributes can be set to
-`unspecified'; this fact is not further mentioned below.
+This function overrides the face attributes specified by FACE's face spec.
+It is mostly intended for internal use.
+
+If FRAME is a frame, set the FACE's attributes only for that frame. If
+FRAME is nil, set attribute values for all existing frames, as well as
+the default for new frames. If FRAME is t, change the default values
+of attributes for new frames.
+
+ARGS must come in pairs ATTRIBUTE VALUE. ATTRIBUTE must be a valid face
+attribute name and VALUE must be a value that is valid for ATTRIBUTE,
+as described below for each attribute.
+
+In addition to the attribute values listed below, all attributes can
+also be set to the special value `unspecified', which means the face
+doesn't by itself specify a value for the attribute.
+
+When a new frame is created, attribute values in the FACE's `defface'
+spec normally override the `unspecified' values in the FACE's
+default attributes. To avoid that, i.e. to cause ATTRIBUTE's value
+be reset to `unspecified' when creating new frames, disregarding
+what the FACE's face spec says, call this function with FRAME set to
+t and the ATTRIBUTE's value set to `unspecified'.
The following attributes are recognized:
diff --git a/lisp/files.el b/lisp/files.el
index 740e09055bb..b084dca8b7d 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -5196,7 +5196,9 @@ to `default-directory', and the result will also be relative."
(cond
;; filename is at top-level, therefore no parent
((or (null parent)
- (file-equal-p parent expanded-filename))
+ ;; `equal' is enough, we don't need to resolve symlinks here
+ ;; with `file-equal-p', also for performance
+ (equal parent expanded-filename))
nil)
;; filename is relative, return relative parent
((not (file-name-absolute-p filename))
diff --git a/lisp/find-file.el b/lisp/find-file.el
index 614ff420f25..646779fc919 100644
--- a/lisp/find-file.el
+++ b/lisp/find-file.el
@@ -193,18 +193,32 @@ The value could be an alist or a symbol whose value is an alist.
Each element of the alist has the form
(REGEXP (EXTENSION...))
-or
- (REGEXP FUNCTION)
where REGEXP is the regular expression matching a file's extension,
-EXTENSIONs is the list of literal file-name extensions to search for,
-and FUNCTION is a function of one argument, the current file's name,
-that returns the list of extensions to search for.
-The list of extensions should contain the most used extensions before the
-others, since the search algorithm searches sequentially through each
-directory specified in `ff-search-directories'. If a file is not found,
-a new one is created with the first matching extension (`.cc' yields `.hh').
-This alist should be set by the major mode."
+and EXTENSIONs is the list of literal file-name extensions to search
+for. The list of extensions should contain the most used extensions
+before the others, since the search algorithm searches sequentially
+through each directory specified in `ff-search-directories'.
+
+Alist elements can also be of the form
+
+ (REGEXP FUNCTION)
+
+where FUNCTION is a function of one argument, the current file's name,
+that returns the list of possible names of the corresponding files, with
+or without leading directories. Note the difference: FUNCTION returns
+the list of file names, not their extensions. This is for the case when
+REGEXP is not enough to determine the file name of the other file.
+
+If a file is not found, a new one is created with the first
+matching extension or name (e.g., `.cc' yields `.hh').
+
+This alist should be set by the major mode.
+
+Note: if an element of the alist names a FUNCTION as its cdr, that
+function must return a non-nil list of file-names. It cannot
+return nil, nor can it signal in any way a failure to find a suitable
+list of file names."
:type '(choice (repeat (list regexp (choice (repeat string) function)))
symbol))
@@ -615,7 +629,7 @@ name of the first file found."
(while (and suffixes (not found))
(setq filename (concat fname-stub this-suffix))
- (setq file (concat dir "/" filename))
+ (setq file (expand-file-name filename dir))
(if (not ff-quiet-mode)
(message "Finding %s..." file))
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index 1ccf9bb4281..dac4a03cd94 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -229,7 +229,7 @@ interactive command."
(lambda (f) (if want-command
(commandp f)
(or (fboundp f) (get f 'function-documentation))))
- t nil nil
+ 'confirm nil nil
(and fn (symbol-name fn)))))
(unless (equal val "")
(setq fn (intern val)))
@@ -515,8 +515,11 @@ the C sources, too."
(let ((pt2 (with-current-buffer standard-output (point)))
(remapped (command-remapping function)))
(unless (memq remapped '(ignore undefined))
- (let* ((all-keys (where-is-internal
- (or remapped function) overriding-local-map nil nil))
+ (let* ((all-keys
+ (with-current-buffer
+ (or describe-function-orig-buffer (current-buffer))
+ (where-is-internal
+ (or remapped function) overriding-local-map nil nil)))
(seps (seq-group-by
(lambda (key)
(and (vectorp key)
@@ -2179,8 +2182,7 @@ documentation for the major and minor modes of that buffer."
;; Document the minor modes fully.
(insert (buttonize
(propertize pretty-minor-mode 'help-minor-mode mode)
- (lambda (mode)
- (describe-function mode))
+ #'describe-function
mode))
(let ((indicator
(format-mode-line (assq mode minor-mode-alist))))
@@ -2189,7 +2191,8 @@ documentation for the major and minor modes of that buffer."
"no indicator"
(format "indicator%s"
indicator)))))
- (insert (help-split-fundoc (documentation mode) nil 'doc)))))
+ (insert (or (help-split-fundoc (documentation mode) nil 'doc)
+ "No docstring")))))
(forward-line -1)
(fill-paragraph nil)
(forward-paragraph 1)
diff --git a/lisp/image/image-dired-dired.el b/lisp/image/image-dired-dired.el
new file mode 100644
index 00000000000..ef0323d1665
--- /dev/null
+++ b/lisp/image/image-dired-dired.el
@@ -0,0 +1,390 @@
+;;; image-dired-dired.el --- Dired specific commands for Image-Dired -*- lexical-binding: t -*-
+
+;; Copyright (C) 2005-2022 Free Software Foundation, Inc.
+
+;; Author: Mathias Dahl <mathias.rem0veth1s.dahl@gmail.com>
+;; Keywords: multimedia
+
+;; 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 'image-dired)
+
+(defgroup image-dired-dired nil
+ "Dired specific commands for Image-Dired."
+ :prefix "image-dired-dired-"
+ :link '(info-link "(emacs) Image-Dired")
+ :group 'image-dired)
+
+(define-obsolete-variable-alias 'image-dired-append-when-browsing
+ 'image-dired-dired-append-when-browsing "29.1")
+(defcustom image-dired-dired-append-when-browsing nil
+ "Append thumbnails in thumbnail buffer when browsing.
+If non-nil, using `image-dired-next-line-and-display' and
+`image-dired-previous-line-and-display' will leave a trail of thumbnail
+images in the thumbnail buffer. If you enable this and want to clean
+the thumbnail buffer because it is filled with too many thumbnails,
+just call `image-dired-display-thumb' to display only the image at point.
+This value can be toggled using `image-dired-toggle-append-browsing'."
+ :type 'boolean)
+
+(defcustom image-dired-dired-disp-props t
+ "If non-nil, display properties for Dired file when browsing.
+Used by `image-dired-next-line-and-display',
+`image-dired-previous-line-and-display' and `image-dired-mark-and-display-next'.
+If the database file is large, this can slow down image browsing in
+Dired and you might want to turn it off."
+ :type 'boolean)
+
+;;;###autoload
+(defun image-dired-dired-toggle-marked-thumbs (&optional arg)
+ "Toggle thumbnails in front of file names in the Dired buffer.
+If no marked file could be found, insert or hide thumbnails on the
+current line. ARG, if non-nil, specifies the files to use instead
+of the marked files. If ARG is an integer, use the next ARG (or
+previous -ARG, if ARG<0) files."
+ (interactive "P" dired-mode)
+ (dired-map-over-marks
+ (let ((image-pos (dired-move-to-filename))
+ (image-file (dired-get-filename nil t))
+ thumb-file
+ overlay)
+ (when (and image-file
+ (string-match-p (image-file-name-regexp) image-file))
+ (setq thumb-file (image-dired-get-thumbnail-image image-file))
+ ;; If image is not already added, then add it.
+ (let ((thumb-ov (cl-loop for ov in (overlays-in (point) (1+ (point)))
+ if (overlay-get ov 'thumb-file) return ov)))
+ (if thumb-ov
+ (delete-overlay thumb-ov)
+ (put-image thumb-file image-pos)
+ (setq overlay
+ (cl-loop for ov in (overlays-in (point) (1+ (point)))
+ if (overlay-get ov 'put-image) return ov))
+ (overlay-put overlay 'image-file image-file)
+ (overlay-put overlay 'thumb-file thumb-file)))))
+ arg ; Show or hide image on ARG next files.
+ 'show-progress) ; Update dired display after each image is updated.
+ (add-hook 'dired-after-readin-hook
+ 'image-dired-dired-after-readin-hook nil t))
+
+(defun image-dired-dired-after-readin-hook ()
+ "Relocate existing thumbnail overlays in Dired buffer after reverting.
+Move them to their corresponding files if they still exist.
+Otherwise, delete overlays.
+Used by `image-dired-dired-toggle-marked-thumbs'."
+ (mapc (lambda (overlay)
+ (when (overlay-get overlay 'put-image)
+ (let* ((image-file (overlay-get overlay 'image-file))
+ (image-pos (dired-goto-file image-file)))
+ (if image-pos
+ (move-overlay overlay image-pos image-pos)
+ (delete-overlay overlay)))))
+ (overlays-in (point-min) (point-max))))
+
+(defun image-dired-next-line-and-display ()
+ "Move to next Dired line and display thumbnail image."
+ (interactive nil dired-mode)
+ (dired-next-line 1)
+ (image-dired-display-thumbs t image-dired-dired-append-when-browsing t)
+ (if image-dired-dired-disp-props
+ (image-dired-dired-display-properties)))
+
+(defun image-dired-previous-line-and-display ()
+ "Move to previous Dired line and display thumbnail image."
+ (interactive nil dired-mode)
+ (dired-previous-line 1)
+ (image-dired-display-thumbs t image-dired-dired-append-when-browsing t)
+ (if image-dired-dired-disp-props
+ (image-dired-dired-display-properties)))
+
+(defun image-dired-toggle-append-browsing ()
+ "Toggle `image-dired-dired-append-when-browsing'."
+ (interactive nil dired-mode)
+ (setq image-dired-dired-append-when-browsing
+ (not image-dired-dired-append-when-browsing))
+ (message "Append browsing %s"
+ (if image-dired-dired-append-when-browsing
+ "on"
+ "off")))
+
+(defun image-dired-mark-and-display-next ()
+ "Mark current file in Dired and display next thumbnail image."
+ (interactive nil dired-mode)
+ (dired-mark 1)
+ (image-dired-display-thumbs t image-dired-dired-append-when-browsing t)
+ (if image-dired-dired-disp-props
+ (image-dired-dired-display-properties)))
+
+(defun image-dired-toggle-dired-display-properties ()
+ "Toggle `image-dired-dired-disp-props'."
+ (interactive nil dired-mode)
+ (setq image-dired-dired-disp-props
+ (not image-dired-dired-disp-props))
+ (message "Dired display properties %s"
+ (if image-dired-dired-disp-props
+ "on"
+ "off")))
+
+(defun image-dired-track-thumbnail ()
+ "Track current Dired file's thumb in `image-dired-thumbnail-buffer'.
+This is almost the same as what `image-dired-track-original-file' does,
+but the other way around."
+ (let ((file (dired-get-filename))
+ prop-val found window)
+ (when (get-buffer image-dired-thumbnail-buffer)
+ (with-current-buffer image-dired-thumbnail-buffer
+ (goto-char (point-min))
+ (while (and (not (eobp))
+ (not found))
+ (if (and (setq prop-val
+ (get-text-property (point) 'original-file-name))
+ (string= prop-val file))
+ (setq found t))
+ (if (not found)
+ (forward-char 1)))
+ (when found
+ (if (setq window (image-dired-thumbnail-window))
+ (set-window-point window (point)))
+ (image-dired-update-header-line))))))
+
+(defun image-dired-dired-next-line (&optional arg)
+ "Call `dired-next-line', then track thumbnail.
+This can safely replace `dired-next-line'.
+With prefix argument, move ARG lines."
+ (interactive "P" dired-mode)
+ (dired-next-line (or arg 1))
+ (if image-dired-track-movement
+ (image-dired-track-thumbnail)))
+
+(defun image-dired-dired-previous-line (&optional arg)
+ "Call `dired-previous-line', then track thumbnail.
+This can safely replace `dired-previous-line'.
+With prefix argument, move ARG lines."
+ (interactive "P" dired-mode)
+ (dired-previous-line (or arg 1))
+ (if image-dired-track-movement
+ (image-dired-track-thumbnail)))
+
+;;;###autoload
+(defun image-dired-jump-thumbnail-buffer ()
+ "Jump to thumbnail buffer."
+ (interactive nil dired-mode)
+ (let ((window (image-dired-thumbnail-window))
+ frame)
+ (if window
+ (progn
+ (if (not (equal (selected-frame) (setq frame (window-frame window))))
+ (select-frame-set-input-focus frame))
+ (select-window window))
+ (message "Thumbnail buffer not visible"))))
+
+(defvar-keymap image-dired-minor-mode-map
+ :doc "Keymap for `image-dired-minor-mode'."
+ ;; Hijack previous and next line movement. Let C-p and C-b be
+ ;; though...
+ "p" #'image-dired-dired-previous-line
+ "n" #'image-dired-dired-next-line
+ "<up>" #'image-dired-dired-previous-line
+ "<down>" #'image-dired-dired-next-line
+
+ "C-S-n" #'image-dired-next-line-and-display
+ "C-S-p" #'image-dired-previous-line-and-display
+ "C-S-m" #'image-dired-mark-and-display-next
+
+ "C-t d" #'image-dired-display-thumbs
+ "<tab>" #'image-dired-jump-thumbnail-buffer
+ "C-t i" #'image-dired-dired-display-image
+ "C-t x" #'image-dired-dired-display-external
+ "C-t a" #'image-dired-display-thumbs-append
+ "C-t ." #'image-dired-display-thumb
+ "C-t c" #'image-dired-dired-comment-files
+ "C-t f" #'image-dired-mark-tagged-files)
+
+(easy-menu-define image-dired-minor-mode-menu image-dired-minor-mode-map
+ "Menu for `image-dired-minor-mode'."
+ '("Image-dired"
+ ["Display thumb for next file" image-dired-next-line-and-display]
+ ["Display thumb for previous file" image-dired-previous-line-and-display]
+ ["Mark and display next" image-dired-mark-and-display-next]
+ "---"
+ ["Create thumbnails for marked files" image-dired-create-thumbs]
+ "---"
+ ["Display thumbnails append" image-dired-display-thumbs-append]
+ ["Display this thumbnail" image-dired-display-thumb]
+ ["Display image" image-dired-dired-display-image]
+ ["Display in external viewer" image-dired-dired-display-external]
+ "---"
+ ["Toggle display properties" image-dired-toggle-dired-display-properties
+ :style toggle
+ :selected image-dired-dired-disp-props]
+ ["Toggle append browsing" image-dired-toggle-append-browsing
+ :style toggle
+ :selected image-dired-dired-append-when-browsing]
+ ["Toggle movement tracking" image-dired-toggle-movement-tracking
+ :style toggle
+ :selected image-dired-track-movement]
+ "---"
+ ["Jump to thumbnail buffer" image-dired-jump-thumbnail-buffer]
+ ["Mark tagged files" image-dired-mark-tagged-files]
+ ["Comment files" image-dired-dired-comment-files]
+ ["Copy with EXIF file name" image-dired-copy-with-exif-file-name]))
+
+;;;###autoload
+(define-minor-mode image-dired-minor-mode
+ "Setup easy-to-use keybindings for the commands to be used in Dired mode.
+Note that n, p and <down> and <up> will be hijacked and bound to
+`image-dired-dired-next-line' and `image-dired-dired-previous-line'."
+ :keymap image-dired-minor-mode-map)
+
+(declare-function clear-image-cache "image.c" (&optional filter))
+
+(defun image-dired-create-thumbs (&optional arg)
+ "Create thumbnail images for all marked files in Dired.
+With prefix argument ARG, create thumbnails even if they already exist
+\(i.e. use this to refresh your thumbnails)."
+ (interactive "P" dired-mode)
+ (let (thumb-name)
+ (dolist (curr-file (dired-get-marked-files))
+ (setq thumb-name (image-dired-thumb-name curr-file))
+ ;; If the user overrides the exist check, we must clear the
+ ;; image cache so that if the user wants to display the
+ ;; thumbnail, it is not fetched from cache.
+ (when arg
+ (clear-image-cache (expand-file-name thumb-name)))
+ (when (or (not (file-exists-p thumb-name))
+ arg)
+ (image-dired-create-thumb curr-file thumb-name)))))
+
+;;;###autoload
+(defun image-dired-display-thumbs-append ()
+ "Append thumbnails to `image-dired-thumbnail-buffer'."
+ (interactive nil dired-mode)
+ (image-dired-display-thumbs nil t t))
+
+;;;###autoload
+(defun image-dired-display-thumb ()
+ "Shorthand for `image-dired-display-thumbs' with prefix argument."
+ (interactive nil dired-mode)
+ (image-dired-display-thumbs t nil t))
+
+;;;###autoload
+(defun image-dired-dired-display-external ()
+ "Display file at point using an external viewer."
+ (interactive nil dired-mode)
+ (let ((file (dired-get-filename)))
+ (start-process "image-dired-external" nil
+ image-dired-external-viewer file)))
+
+;;;###autoload
+(defun image-dired-dired-display-image (&optional _)
+ "Display current image file.
+See documentation for `image-dired-display-image' for more information."
+ (declare (advertised-calling-convention () "29.1"))
+ (interactive nil dired-mode)
+ (image-dired-display-image (dired-get-filename)))
+
+(defun image-dired-copy-with-exif-file-name ()
+ "Copy file with unique name to main image directory.
+Copy current or all marked files in Dired to a new file in your
+main image directory, using a file name generated by
+`image-dired-get-exif-file-name'. A typical usage for this if when
+copying images from a digital camera into the image directory.
+
+ Typically, you would open up the folder with the incoming
+digital images, mark the files to be copied, and execute this
+function. The result is a couple of new files in
+`image-dired-main-image-directory' called
+2005_05_08_12_52_00_dscn0319.jpg,
+2005_05_08_14_27_45_dscn0320.jpg etc."
+ (interactive nil dired-mode)
+ (let (new-name
+ (files (dired-get-marked-files)))
+ (mapc
+ (lambda (curr-file)
+ (setq new-name
+ (format "%s/%s"
+ (file-name-as-directory
+ (expand-file-name image-dired-main-image-directory))
+ (image-dired-get-exif-file-name curr-file)))
+ (message "Copying %s to %s" curr-file new-name)
+ (copy-file curr-file new-name))
+ files)))
+
+;;;###autoload
+(defun image-dired-mark-tagged-files (regexp)
+ "Use REGEXP to mark files with matching tag.
+A `tag' is a keyword, a piece of meta data, associated with an
+image file and stored in image-dired's database file. This command
+lets you input a regexp and this will be matched against all tags
+on all image files in the database file. The files that have a
+matching tag will be marked in the Dired buffer."
+ (interactive "sMark tagged files (regexp): " dired-mode)
+ (image-dired-sane-db-file)
+ (let ((hits 0)
+ files)
+ (image-dired--with-db-file
+ ;; Collect matches
+ (while (search-forward-regexp "\\(^[^;\n]+\\);\\(.*\\)" nil t)
+ (let ((file (match-string 1))
+ (tags (split-string (match-string 2) ";")))
+ (when (seq-find (lambda (tag)
+ (string-match-p regexp tag))
+ tags)
+ (push file files)))))
+ ;; Mark files
+ (dolist (curr-file files)
+ ;; I tried using `dired-mark-files-regexp' but it was waaaay to
+ ;; slow. Don't bother about hits found in other directories
+ ;; than the current one.
+ (when (string= (file-name-as-directory
+ (expand-file-name default-directory))
+ (file-name-as-directory
+ (file-name-directory curr-file)))
+ (setq curr-file (file-name-nondirectory curr-file))
+ (goto-char (point-min))
+ (when (search-forward-regexp (format "\\s %s$" curr-file) nil t)
+ (setq hits (+ hits 1))
+ (dired-mark 1))))
+ (message "%d files with matching tag marked" hits)))
+
+(defun image-dired-dired-display-properties ()
+ "Display properties for Dired file in the echo area."
+ (interactive nil dired-mode)
+ (let* ((file (dired-get-filename))
+ (file-name (file-name-nondirectory file))
+ (dired-buf (buffer-name (current-buffer)))
+ (props (mapconcat #'identity (image-dired-list-tags file) ", "))
+ (comment (image-dired-get-comment file))
+ (message-log-max nil))
+ (if file-name
+ (message "%s"
+ (image-dired-format-properties-string
+ dired-buf
+ file-name
+ props
+ comment)))))
+
+(provide 'image-dired-dired)
+
+;; Local Variables:
+;; nameless-current-name: "image-dired"
+;; End:
+
+;;; image-dired-dired.el ends here
diff --git a/lisp/image/image-dired-external.el b/lisp/image/image-dired-external.el
new file mode 100644
index 00000000000..c26cedc9f2c
--- /dev/null
+++ b/lisp/image/image-dired-external.el
@@ -0,0 +1,472 @@
+;;; image-dired-external.el --- External process support for Image-Dired -*- lexical-binding: t -*-
+
+;; Copyright (C) 2005-2022 Free Software Foundation, Inc.
+
+;; Author: Mathias Dahl <mathias.rem0veth1s.dahl@gmail.com>
+;; Keywords: multimedia
+
+;; 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 'dired)
+(require 'exif)
+
+(require 'image-dired-util)
+
+(declare-function image-dired-display-image "image-dired")
+
+(defvar image-dired-dir)
+(defvar image-dired-main-image-directory)
+(defvar image-dired-rotate-original-ask-before-overwrite)
+(defvar image-dired-thumb-height)
+(defvar image-dired-thumb-width)
+(defvar image-dired-thumbnail-storage)
+
+(defgroup image-dired-external nil
+ "External process support for Image-Dired."
+ :prefix "image-dired-"
+ :link '(info-link "(emacs) Image-Dired")
+ :group 'image-dired)
+
+(defcustom image-dired-cmd-create-thumbnail-program
+ (if (executable-find "gm") "gm" "convert")
+ "Executable used to create thumbnail.
+Used together with `image-dired-cmd-create-thumbnail-options'."
+ :type 'file
+ :version "29.1")
+
+(defcustom image-dired-cmd-create-thumbnail-options
+ (let ((opts '("-size" "%wx%h" "%f[0]"
+ "-resize" "%wx%h>"
+ "-strip" "jpeg:%t")))
+ (if (executable-find "gm") (cons "convert" opts) opts))
+ "Options of command used to create thumbnail image.
+Used with `image-dired-cmd-create-thumbnail-program'.
+Available format specifiers are: %w which is replaced by
+`image-dired-thumb-width', %h which is replaced by `image-dired-thumb-height',
+%f which is replaced by the file name of the original image and %t
+which is replaced by the file name of the thumbnail file."
+ :version "29.1"
+ :type '(repeat (string :tag "Argument")))
+
+(defcustom image-dired-cmd-pngnq-program
+ ;; Prefer pngquant to pngnq-s9 as it is faster on my machine.
+ ;; The project also seems more active than the alternatives.
+ ;; Prefer pngnq-s9 to pngnq as it fixes bugs in pngnq.
+ ;; The pngnq project seems dead (?) since 2011 or so.
+ (or (executable-find "pngquant")
+ (executable-find "pngnq-s9")
+ (executable-find "pngnq"))
+ "The file name of the `pngquant' or `pngnq' program.
+It quantizes colors of PNG images down to 256 colors or fewer
+using the NeuQuant algorithm."
+ :version "29.1"
+ :type '(choice (const :tag "Not Set" nil) file))
+
+(defcustom image-dired-cmd-pngnq-options
+ (if (executable-find "pngquant")
+ '("--ext" "-nq8.png" "%t") ; same extension as "pngnq"
+ '("-f" "%t"))
+ "Arguments to pass `image-dired-cmd-pngnq-program'.
+Available format specifiers are the same as in
+`image-dired-cmd-create-thumbnail-options'."
+ :type '(repeat (string :tag "Argument"))
+ :version "29.1")
+
+(defcustom image-dired-cmd-pngcrush-program (executable-find "pngcrush")
+ "The file name of the `pngcrush' program.
+It optimizes the compression of PNG images. Also it adds PNG textual chunks
+with the information required by the Thumbnail Managing Standard."
+ :type '(choice (const :tag "Not Set" nil) file))
+
+(defcustom image-dired-cmd-pngcrush-options
+ `("-q"
+ "-text" "b" "Description" "Thumbnail of file://%f"
+ "-text" "b" "Software" ,(emacs-version)
+ ;; "-text b \"Thumb::Image::Height\" \"%oh\" "
+ ;; "-text b \"Thumb::Image::Mimetype\" \"%mime\" "
+ ;; "-text b \"Thumb::Image::Width\" \"%ow\" "
+ "-text" "b" "Thumb::MTime" "%m"
+ ;; "-text b \"Thumb::Size\" \"%b\" "
+ "-text" "b" "Thumb::URI" "file://%f"
+ "%q" "%t")
+ "Arguments for `image-dired-cmd-pngcrush-program'.
+Available format specifiers are the same as in
+`image-dired-cmd-create-thumbnail-options', with %q for a
+temporary file name (typically generated by pnqnq)."
+ :version "26.1"
+ :type '(repeat (string :tag "Argument")))
+
+(defcustom image-dired-cmd-optipng-program (executable-find "optipng")
+ "The file name of the `optipng' program."
+ :version "26.1"
+ :type '(choice (const :tag "Not Set" nil) file))
+
+(defcustom image-dired-cmd-optipng-options '("-o5" "%t")
+ "Arguments passed to `image-dired-cmd-optipng-program'.
+Available format specifiers are described in
+`image-dired-cmd-create-thumbnail-options'."
+ :version "26.1"
+ :type '(repeat (string :tag "Argument"))
+ :link '(url-link "man:optipng(1)"))
+
+(defcustom image-dired-cmd-create-standard-thumbnail-options
+ (append '("-size" "%wx%h" "%f[0]")
+ (unless (or image-dired-cmd-pngcrush-program
+ image-dired-cmd-pngnq-program)
+ (list
+ "-set" "Thumb::MTime" "%m"
+ "-set" "Thumb::URI" "file://%f"
+ "-set" "Description" "Thumbnail of file://%f"
+ "-set" "Software" (emacs-version)))
+ '("-thumbnail" "%wx%h>" "png:%t"))
+ "Options for creating thumbnails according to the Thumbnail Managing Standard.
+Available format specifiers are the same as in
+`image-dired-cmd-create-thumbnail-options', with %m for file modification time."
+ :version "26.1"
+ :type '(repeat (string :tag "Argument")))
+
+(defcustom image-dired-cmd-rotate-original-program "jpegtran"
+ "Executable used to rotate original image.
+Used together with `image-dired-cmd-rotate-original-options'."
+ :type 'file)
+
+(defcustom image-dired-cmd-rotate-original-options
+ '("-rotate" "%d" "-copy" "all" "-outfile" "%t" "%o")
+ "Arguments of command used to rotate original image.
+Used with `image-dired-cmd-rotate-original-program'.
+Available format specifiers are: %d which is replaced by the
+number of (positive) degrees to rotate the image, normally 90 or
+270 \(for 90 degrees right and left), %o which is replaced by the
+original image file name and %t which is replaced by
+`image-dired-temp-image-file'."
+ :version "26.1"
+ :type '(repeat (string :tag "Argument")))
+
+(defcustom image-dired-temp-rotate-image-file
+ (expand-file-name ".image-dired_rotate_temp"
+ (locate-user-emacs-file "image-dired/"))
+ "Temporary file for rotate operations."
+ :type 'file)
+
+(defcustom image-dired-cmd-write-exif-data-program "exiftool"
+ "Program used to write EXIF data to image.
+Used together with `image-dired-cmd-write-exif-data-options'."
+ :type 'file)
+
+(defcustom image-dired-cmd-write-exif-data-options '("-%t=%v" "%f")
+ "Arguments of command used to write EXIF data.
+Used with `image-dired-cmd-write-exif-data-program'.
+Available format specifiers are: %f which is replaced by
+the image file name, %t which is replaced by the tag name and %v
+which is replaced by the tag value."
+ :version "26.1"
+ :type '(repeat (string :tag "Argument")))
+
+
+;;; Util functions
+
+(defun image-dired--check-executable-exists (executable)
+ (unless (executable-find (symbol-value executable))
+ (error "Executable %S not found" executable)))
+
+
+;;; Creating thumbnails
+
+(defun image-dired-thumb-size (dimension)
+ "Return thumb size depending on `image-dired-thumbnail-storage'.
+DIMENSION should be either the symbol `width' or `height'."
+ (cond
+ ((eq 'standard image-dired-thumbnail-storage) 128)
+ ((eq 'standard-large image-dired-thumbnail-storage) 256)
+ ((eq 'standard-x-large image-dired-thumbnail-storage) 512)
+ ((eq 'standard-xx-large image-dired-thumbnail-storage) 1024)
+ (t (cl-ecase dimension
+ (width image-dired-thumb-width)
+ (height image-dired-thumb-height)))))
+
+(defvar image-dired--generate-thumbs-start nil
+ "Time when `display-thumbs' was called.")
+
+(defvar image-dired-queue nil
+ "List of items in the queue.
+Each item has the form (ORIGINAL-FILE TARGET-FILE).")
+
+(defvar image-dired-queue-active-jobs 0
+ "Number of active jobs in `image-dired-queue'.")
+
+(defvar image-dired-queue-active-limit (min 4 (max 2 (/ (num-processors) 2)))
+ "Maximum number of concurrent jobs permitted for generating images.
+Increase at own risk. If you want to experiment with this,
+consider setting `image-dired-debug' to a non-nil value to see
+the time spent on generating thumbnails. Run `image-clear-cache'
+and remove the cached thumbnail files between each trial run.")
+
+(defun image-dired-pngnq-thumb (spec)
+ "Quantize thumbnail described by format SPEC with pngnq(1)."
+ (let ((process
+ (apply #'start-process "image-dired-pngnq" nil
+ image-dired-cmd-pngnq-program
+ (mapcar (lambda (arg) (format-spec arg spec))
+ image-dired-cmd-pngnq-options))))
+ (setf (process-sentinel process)
+ (lambda (process status)
+ (if (and (eq (process-status process) 'exit)
+ (zerop (process-exit-status process)))
+ ;; Pass off to pngcrush, or just rename the
+ ;; THUMB-nq8.png file back to THUMB.png
+ (if (and image-dired-cmd-pngcrush-program
+ (executable-find image-dired-cmd-pngcrush-program))
+ (image-dired-pngcrush-thumb spec)
+ (let ((nq8 (cdr (assq ?q spec)))
+ (thumb (cdr (assq ?t spec))))
+ (rename-file nq8 thumb t)))
+ (message "command %S %s" (process-command process)
+ (string-replace "\n" "" status)))))
+ process))
+
+(defun image-dired-pngcrush-thumb (spec)
+ "Optimize thumbnail described by format SPEC with pngcrush(1)."
+ ;; If pngnq wasn't run, then the THUMB-nq8.png file does not exist.
+ ;; pngcrush needs an infile and outfile, so we just copy THUMB to
+ ;; THUMB-nq8.png and use the latter as a temp file.
+ (when (not image-dired-cmd-pngnq-program)
+ (let ((temp (cdr (assq ?q spec)))
+ (thumb (cdr (assq ?t spec))))
+ (copy-file thumb temp)))
+ (let ((process
+ (apply #'start-process "image-dired-pngcrush" nil
+ image-dired-cmd-pngcrush-program
+ (mapcar (lambda (arg) (format-spec arg spec))
+ image-dired-cmd-pngcrush-options))))
+ (setf (process-sentinel process)
+ (lambda (process status)
+ (unless (and (eq (process-status process) 'exit)
+ (zerop (process-exit-status process)))
+ (message "command %S %s" (process-command process)
+ (string-replace "\n" "" status)))
+ (when (memq (process-status process) '(exit signal))
+ (let ((temp (cdr (assq ?q spec))))
+ (delete-file temp)))))
+ process))
+
+(defun image-dired-optipng-thumb (spec)
+ "Optimize thumbnail described by format SPEC with optipng(1)."
+ (let ((process
+ (apply #'start-process "image-dired-optipng" nil
+ image-dired-cmd-optipng-program
+ (mapcar (lambda (arg) (format-spec arg spec))
+ image-dired-cmd-optipng-options))))
+ (setf (process-sentinel process)
+ (lambda (process status)
+ (unless (and (eq (process-status process) 'exit)
+ (zerop (process-exit-status process)))
+ (message "command %S %s" (process-command process)
+ (string-replace "\n" "" status)))))
+ process))
+
+(defun image-dired-create-thumb-1 (original-file thumbnail-file)
+ "For ORIGINAL-FILE, create thumbnail image named THUMBNAIL-FILE."
+ (image-dired--check-executable-exists
+ 'image-dired-cmd-create-thumbnail-program)
+ (let* ((width (int-to-string (image-dired-thumb-size 'width)))
+ (height (int-to-string (image-dired-thumb-size 'height)))
+ (modif-time (format-time-string
+ "%s" (file-attribute-modification-time
+ (file-attributes original-file))))
+ (thumbnail-nq8-file (replace-regexp-in-string ".png\\'" "-nq8.png"
+ thumbnail-file))
+ (spec
+ (list
+ (cons ?w width)
+ (cons ?h height)
+ (cons ?m modif-time)
+ (cons ?f original-file)
+ (cons ?q thumbnail-nq8-file)
+ (cons ?t thumbnail-file)))
+ (thumbnail-dir (file-name-directory thumbnail-file))
+ process)
+ (when (not (file-exists-p thumbnail-dir))
+ (with-file-modes #o700
+ (make-directory thumbnail-dir t))
+ (message "Thumbnail directory created: %s" thumbnail-dir))
+
+ ;; Thumbnail file creation processes begin here and are marshaled
+ ;; in a queue by `image-dired-create-thumb'.
+ (setq process
+ (apply #'start-process "image-dired-create-thumbnail" nil
+ image-dired-cmd-create-thumbnail-program
+ (mapcar
+ (lambda (arg) (format-spec arg spec))
+ (if (memq image-dired-thumbnail-storage
+ image-dired--thumbnail-standard-sizes)
+ image-dired-cmd-create-standard-thumbnail-options
+ image-dired-cmd-create-thumbnail-options))))
+
+ (setf (process-sentinel process)
+ (lambda (process status)
+ ;; Trigger next in queue once a thumbnail has been created
+ (cl-decf image-dired-queue-active-jobs)
+ (image-dired-thumb-queue-run)
+ (when (= image-dired-queue-active-jobs 0)
+ (image-dired-debug-message
+ (format-time-string
+ "Generated thumbnails in %s.%3N seconds"
+ (time-subtract nil
+ image-dired--generate-thumbs-start))))
+ (if (not (and (eq (process-status process) 'exit)
+ (zerop (process-exit-status process))))
+ (message "Thumb could not be created for %s: %s"
+ (abbreviate-file-name original-file)
+ (string-replace "\n" "" status))
+ (set-file-modes thumbnail-file #o600)
+ (clear-image-cache thumbnail-file)
+ ;; PNG thumbnail has been created since we are
+ ;; following the XDG thumbnail spec, so try to optimize
+ (when (memq image-dired-thumbnail-storage
+ image-dired--thumbnail-standard-sizes)
+ (cond
+ ((and image-dired-cmd-pngnq-program
+ (executable-find image-dired-cmd-pngnq-program))
+ (image-dired-pngnq-thumb spec))
+ ((and image-dired-cmd-pngcrush-program
+ (executable-find image-dired-cmd-pngcrush-program))
+ (image-dired-pngcrush-thumb spec))
+ ((and image-dired-cmd-optipng-program
+ (executable-find image-dired-cmd-optipng-program))
+ (image-dired-optipng-thumb spec)))))))
+ process))
+
+(defun image-dired-thumb-queue-run ()
+ "Run a queued job if one exists and not too many jobs are running.
+Queued items live in `image-dired-queue'."
+ (while (and image-dired-queue
+ (< image-dired-queue-active-jobs
+ image-dired-queue-active-limit))
+ (cl-incf image-dired-queue-active-jobs)
+ (apply #'image-dired-create-thumb-1 (pop image-dired-queue))))
+
+(defun image-dired-create-thumb (original-file thumbnail-file)
+ "Add a job for generating ORIGINAL-FILE thumbnail to `image-dired-queue'.
+The new file will be named THUMBNAIL-FILE."
+ (setq image-dired-queue
+ (nconc image-dired-queue
+ (list (list original-file thumbnail-file))))
+ (run-at-time 0 nil #'image-dired-thumb-queue-run))
+
+(defun image-dired-refresh-thumb ()
+ "Force creation of new image for current thumbnail."
+ (interactive nil image-dired-thumbnail-mode)
+ (let* ((file (image-dired-original-file-name))
+ (thumb (expand-file-name (image-dired-thumb-name file))))
+ (clear-image-cache (expand-file-name thumb))
+ (image-dired-create-thumb file thumb)))
+
+(defun image-dired-rotate-original (degrees)
+ "Rotate original image DEGREES degrees."
+ (image-dired--check-executable-exists
+ 'image-dired-cmd-rotate-original-program)
+ (if (not (image-dired-image-at-point-p))
+ (message "No image at point")
+ (let* ((file (image-dired-original-file-name))
+ (spec
+ (list
+ (cons ?d degrees)
+ (cons ?o (expand-file-name file))
+ (cons ?t image-dired-temp-rotate-image-file))))
+ (unless (eq 'jpeg (image-type file))
+ (user-error "Only JPEG images can be rotated"))
+ (if (not (= 0 (apply #'call-process image-dired-cmd-rotate-original-program
+ nil nil nil
+ (mapcar (lambda (arg) (format-spec arg spec))
+ image-dired-cmd-rotate-original-options))))
+ (error "Could not rotate image")
+ (image-dired-display-image image-dired-temp-rotate-image-file)
+ (if (or (and image-dired-rotate-original-ask-before-overwrite
+ (y-or-n-p
+ "Rotate to temp file OK. Overwrite original image? "))
+ (not image-dired-rotate-original-ask-before-overwrite))
+ (progn
+ (copy-file image-dired-temp-rotate-image-file file t)
+ (image-dired-refresh-thumb))
+ (image-dired-display-image file))))))
+
+
+;;; EXIF support
+
+(defun image-dired-get-exif-file-name (file)
+ "Use the image's EXIF information to return a unique file name.
+The file name should be unique as long as you do not take more than
+one picture per second. The original file name is suffixed at the end
+for traceability. The format of the returned file name is
+YYYY_MM_DD_HH_MM_DD_ORIG_FILE_NAME.jpg. Used from
+`image-dired-copy-with-exif-file-name'."
+ (let (data no-exif-data-found)
+ (if (not (eq 'jpeg (image-type (expand-file-name file))))
+ (setq no-exif-data-found t
+ data (format-time-string
+ "%Y:%m:%d %H:%M:%S"
+ (file-attribute-modification-time
+ (file-attributes (expand-file-name file)))))
+ (setq data (exif-field 'date-time (exif-parse-file
+ (expand-file-name file)))))
+ (while (string-match "[ :]" data)
+ (setq data (replace-match "_" nil nil data)))
+ (format "%s%s%s" data
+ (if no-exif-data-found
+ "_noexif_"
+ "_")
+ (file-name-nondirectory file))))
+
+(defun image-dired-thumbnail-set-image-description ()
+ "Set the ImageDescription EXIF tag for the original image.
+If the image already has a value for this tag, it is used as the
+default value at the prompt."
+ (interactive nil image-dired-thumbnail-mode)
+ (if (not (image-dired-image-at-point-p))
+ (message "No thumbnail at point")
+ (let* ((file (image-dired-original-file-name))
+ (old-value (or (exif-field 'description (exif-parse-file file)) "")))
+ (if (eq 0
+ (image-dired-set-exif-data file "ImageDescription"
+ (read-string "Value of ImageDescription: "
+ old-value)))
+ (message "Successfully wrote ImageDescription tag")
+ (error "Could not write ImageDescription tag")))))
+
+(defun image-dired-set-exif-data (file tag-name tag-value)
+ "In FILE, set EXIF tag TAG-NAME to value TAG-VALUE."
+ (image-dired--check-executable-exists
+ 'image-dired-cmd-write-exif-data-program)
+ (let ((spec
+ (list
+ (cons ?f (expand-file-name file))
+ (cons ?t tag-name)
+ (cons ?v tag-value))))
+ (apply #'call-process image-dired-cmd-write-exif-data-program nil nil nil
+ (mapcar (lambda (arg) (format-spec arg spec))
+ image-dired-cmd-write-exif-data-options))))
+
+(provide 'image-dired-external)
+
+;; Local Variables:
+;; nameless-current-name: "image-dired"
+;; End:
+
+;;; image-dired-external.el ends here
diff --git a/lisp/image/image-dired-tags.el b/lisp/image/image-dired-tags.el
new file mode 100644
index 00000000000..ee3c63b009f
--- /dev/null
+++ b/lisp/image/image-dired-tags.el
@@ -0,0 +1,379 @@
+;;; image-dired-tags.el --- Tag support for Image-Dired -*- lexical-binding: t -*-
+
+;; Copyright (C) 2005-2022 Free Software Foundation, Inc.
+
+;; Author: Mathias Dahl <mathias.rem0veth1s.dahl@gmail.com>
+;; Keywords: multimedia
+
+;; 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 'dired)
+
+(require 'image-dired-util)
+
+(declare-function image-dired--with-marked "image-dired")
+
+(defvar image-dired-dir)
+(defvar image-dired-thumbnail-storage)
+(defvar image-dired-db-file)
+
+(defmacro image-dired--with-db-file (&rest body)
+ "Run BODY in a temp buffer containing `image-dired-db-file'.
+Return the last form in BODY."
+ (declare (indent 0) (debug t))
+ `(with-temp-buffer
+ (if (file-exists-p image-dired-db-file)
+ (insert-file-contents image-dired-db-file))
+ ,@body))
+
+(defun image-dired-sane-db-file ()
+ "Check if `image-dired-db-file' exists.
+If not, try to create it (including any parent directories).
+Signal error if there are problems creating it."
+ (or (file-exists-p image-dired-db-file)
+ (let (dir buf)
+ (unless (file-directory-p (setq dir (file-name-directory
+ image-dired-db-file)))
+ (with-file-modes #o700
+ (make-directory dir t)))
+ (with-current-buffer (setq buf (create-file-buffer
+ image-dired-db-file))
+ (with-file-modes #o600
+ (write-file image-dired-db-file)))
+ (kill-buffer buf)
+ (file-exists-p image-dired-db-file))
+ (error "Could not create %s" image-dired-db-file)))
+
+(defvar image-dired-tag-history nil "Variable holding the tag history.")
+
+(defun image-dired-write-tags (file-tags)
+ "Write file tags to database.
+Write each file and tag in FILE-TAGS to the database.
+FILE-TAGS is an alist in the following form:
+ ((FILE . TAG) ... )"
+ (image-dired-sane-db-file)
+ (let (end file tag)
+ (image-dired--with-db-file
+ (setq buffer-file-name image-dired-db-file)
+ (dolist (elt file-tags)
+ (setq file (car elt)
+ tag (cdr elt))
+ (goto-char (point-min))
+ (if (search-forward-regexp (format "^%s.*$" file) nil t)
+ (progn
+ (setq end (point))
+ (beginning-of-line)
+ (when (not (search-forward (format ";%s" tag) end t))
+ (end-of-line)
+ (insert (format ";%s" tag))))
+ (goto-char (point-max))
+ (insert (format "%s;%s\n" file tag))))
+ (save-buffer))))
+
+(defun image-dired-remove-tag (files tag)
+ "For all FILES, remove TAG from the image database."
+ (image-dired-sane-db-file)
+ (image-dired--with-db-file
+ (setq buffer-file-name image-dired-db-file)
+ (let (end)
+ (unless (listp files)
+ (if (stringp files)
+ (setq files (list files))
+ (error "Files must be a string or a list of strings!")))
+ (dolist (file files)
+ (goto-char (point-min))
+ (when (search-forward-regexp (format "^%s;" file) nil t)
+ (end-of-line)
+ (setq end (point))
+ (beginning-of-line)
+ (when (search-forward-regexp
+ (format "\\(;%s\\)\\($\\|;\\)" tag) end t)
+ (delete-region (match-beginning 1) (match-end 1))
+ ;; Check if file should still be in the database. If
+ ;; it has no tags or comments, it will be removed.
+ (end-of-line)
+ (setq end (point))
+ (beginning-of-line)
+ (when (not (search-forward ";" end t))
+ (kill-line 1))))))
+ (save-buffer)))
+
+(defun image-dired-list-tags (file)
+ "Read all tags for image FILE from the image database."
+ (image-dired-sane-db-file)
+ (image-dired--with-db-file
+ (let (end (tags ""))
+ (when (search-forward-regexp (format "^%s" file) nil t)
+ (end-of-line)
+ (setq end (point))
+ (beginning-of-line)
+ (if (search-forward ";" end t)
+ (if (search-forward "comment:" end t)
+ (if (search-forward ";" end t)
+ (setq tags (buffer-substring (point) end)))
+ (setq tags (buffer-substring (point) end)))))
+ (split-string tags ";"))))
+
+;;;###autoload
+(defun image-dired-tag-files (arg)
+ "Tag marked file(s) in Dired. With prefix ARG, tag file at point."
+ (interactive "P" dired-mode)
+ (let ((tag (completing-read
+ "Tags to add (separate tags with a semicolon): "
+ image-dired-tag-history nil nil nil 'image-dired-tag-history))
+ files)
+ (if arg
+ (setq files (list (dired-get-filename)))
+ (setq files (dired-get-marked-files)))
+ (image-dired-write-tags
+ (mapcar
+ (lambda (x)
+ (cons x tag))
+ files))))
+
+(defun image-dired-tag-thumbnail ()
+ "Tag current or marked thumbnails."
+ (interactive nil image-dired-thumbnail-mode)
+ (let ((tag (completing-read
+ "Tags to add (separate tags with a semicolon): "
+ image-dired-tag-history nil nil nil 'image-dired-tag-history)))
+ (image-dired--with-marked
+ (image-dired-write-tags
+ (list (cons (image-dired-original-file-name) tag)))
+ (image-dired-update-property
+ 'tags (image-dired-list-tags (image-dired-original-file-name))))))
+
+;;;###autoload
+(defun image-dired-delete-tag (arg)
+ "Remove tag for selected file(s).
+With prefix argument ARG, remove tag from file at point."
+ (interactive "P" dired-mode)
+ (let ((tag (completing-read "Tag to remove: " image-dired-tag-history
+ nil nil nil 'image-dired-tag-history))
+ files)
+ (if arg
+ (setq files (list (dired-get-filename)))
+ (setq files (dired-get-marked-files)))
+ (image-dired-remove-tag files tag)))
+
+(defun image-dired-tag-thumbnail-remove ()
+ "Remove tag from current or marked thumbnails."
+ (interactive nil image-dired-thumbnail-mode)
+ (let ((tag (completing-read "Tag to remove: " image-dired-tag-history
+ nil nil nil 'image-dired-tag-history)))
+ (image-dired--with-marked
+ (image-dired-remove-tag (image-dired-original-file-name) tag)
+ (image-dired-update-property
+ 'tags (image-dired-list-tags (image-dired-original-file-name))))))
+
+(defun image-dired-write-comments (file-comments)
+ "Write file comments to database.
+Write file comments to one or more files.
+FILE-COMMENTS is an alist on the following form:
+ ((FILE . COMMENT) ... )"
+ (image-dired-sane-db-file)
+ (let (end comment-beg-pos comment-end-pos file comment)
+ (image-dired--with-db-file
+ (setq buffer-file-name image-dired-db-file)
+ (dolist (elt file-comments)
+ (setq file (car elt)
+ comment (cdr elt))
+ (goto-char (point-min))
+ (if (search-forward-regexp (format "^%s.*$" file) nil t)
+ (progn
+ (setq end (point))
+ (beginning-of-line)
+ ;; Delete old comment, if any
+ (when (search-forward ";comment:" end t)
+ (setq comment-beg-pos (match-beginning 0))
+ ;; Any tags after the comment?
+ (if (search-forward ";" end t)
+ (setq comment-end-pos (- (point) 1))
+ (setq comment-end-pos end))
+ ;; Delete comment tag and comment
+ (delete-region comment-beg-pos comment-end-pos))
+ ;; Insert new comment
+ (beginning-of-line)
+ (unless (search-forward ";" end t)
+ (end-of-line)
+ (insert ";"))
+ (insert (format "comment:%s;" comment)))
+ ;; File does not exist in database - add it.
+ (goto-char (point-max))
+ (insert (format "%s;comment:%s\n" file comment))))
+ (save-buffer))))
+
+(defun image-dired-update-property (prop value)
+ "Update text property PROP with value VALUE at point."
+ (let ((inhibit-read-only t))
+ (put-text-property
+ (point) (1+ (point))
+ prop
+ value)))
+
+;;;###autoload
+(defun image-dired-dired-comment-files ()
+ "Add comment to current or marked files in Dired."
+ (interactive nil dired-mode)
+ (let ((comment (image-dired-read-comment)))
+ (image-dired-write-comments
+ (mapcar
+ (lambda (curr-file)
+ (cons curr-file comment))
+ (dired-get-marked-files)))))
+
+(defun image-dired-read-comment (&optional file)
+ "Read comment for an image.
+Optionally use old comment from FILE as initial value."
+ (let ((comment
+ (read-string
+ "Comment: "
+ (if file (image-dired-get-comment file)))))
+ comment))
+
+(defun image-dired-get-comment (file)
+ "Get comment for file FILE."
+ (image-dired-sane-db-file)
+ (image-dired--with-db-file
+ (let (end comment-beg-pos comment-end-pos comment)
+ (when (search-forward-regexp (format "^%s" file) nil t)
+ (end-of-line)
+ (setq end (point))
+ (beginning-of-line)
+ (when (search-forward ";comment:" end t)
+ (setq comment-beg-pos (point))
+ (if (search-forward ";" end t)
+ (setq comment-end-pos (- (point) 1))
+ (setq comment-end-pos end))
+ (setq comment (buffer-substring
+ comment-beg-pos comment-end-pos))))
+ comment)))
+
+
+;;; Tag support
+
+(defvar image-dired-widget-list nil
+ "List to keep track of meta data in edit buffer.")
+
+(declare-function widget-forward "wid-edit" (arg))
+
+;;;###autoload
+(defun image-dired-dired-edit-comment-and-tags ()
+ "Edit comment and tags of current or marked image files.
+Edit comment and tags for all marked image files in an
+easy-to-use form."
+ (interactive nil dired-mode)
+ (setq image-dired-widget-list nil)
+ ;; Setup buffer.
+ (let ((files (dired-get-marked-files)))
+ (pop-to-buffer-same-window "*Image-Dired Edit Meta Data*")
+ (kill-all-local-variables)
+ (let ((inhibit-read-only t))
+ (erase-buffer))
+ (remove-overlays)
+ ;; Some help for the user.
+ (widget-insert
+ "\nEdit comments and tags for each image. Separate multiple tags
+with a comma. Move forward between fields using TAB or RET.
+Move to the previous field using backtab (S-TAB). Save by
+activating the Save button at the bottom of the form or cancel
+the operation by activating the Cancel button.\n\n")
+ ;; Here comes all images and a comment and tag field for each
+ ;; image.
+ (let (thumb-file img comment-widget tag-widget)
+
+ (dolist (file files)
+
+ (setq thumb-file (image-dired-thumb-name file)
+ img (create-image thumb-file))
+
+ (insert-image img)
+ (widget-insert "\n\nComment: ")
+ (setq comment-widget
+ (widget-create 'editable-field
+ :size 60
+ :format "%v "
+ :value (or (image-dired-get-comment file) "")))
+ (widget-insert "\nTags: ")
+ (setq tag-widget
+ (widget-create 'editable-field
+ :size 60
+ :format "%v "
+ :value (or (mapconcat
+ #'identity
+ (image-dired-list-tags file)
+ ",") "")))
+ ;; Save information in all widgets so that we can use it when
+ ;; the user saves the form.
+ (setq image-dired-widget-list
+ (append image-dired-widget-list
+ (list (list file comment-widget tag-widget))))
+ (widget-insert "\n\n")))
+
+ ;; Footer with Save and Cancel button.
+ (widget-insert "\n")
+ (widget-create 'push-button
+ :notify
+ (lambda (&rest _ignore)
+ (image-dired-save-information-from-widgets)
+ (bury-buffer)
+ (message "Done"))
+ "Save")
+ (widget-insert " ")
+ (widget-create 'push-button
+ :notify
+ (lambda (&rest _ignore)
+ (bury-buffer)
+ (message "Operation canceled"))
+ "Cancel")
+ (widget-insert "\n")
+ (use-local-map widget-keymap)
+ (widget-setup)
+ ;; Jump to the first widget.
+ (widget-forward 1)))
+
+(defun image-dired-save-information-from-widgets ()
+ "Save information found in `image-dired-widget-list'.
+Use the information in `image-dired-widget-list' to save comments and
+tags to their respective image file. Internal function used by
+`image-dired-dired-edit-comment-and-tags'."
+ (let (file comment tag-string tag-list lst)
+ (image-dired-write-comments
+ (mapcar
+ (lambda (widget)
+ (setq file (car widget)
+ comment (widget-value (cadr widget)))
+ (cons file comment))
+ image-dired-widget-list))
+ (image-dired-write-tags
+ (dolist (widget image-dired-widget-list lst)
+ (setq file (car widget)
+ tag-string (widget-value (car (cddr widget)))
+ tag-list (split-string tag-string ","))
+ (dolist (tag tag-list)
+ (push (cons file tag) lst))))))
+
+(provide 'image-dired-tags)
+
+;; Local Variables:
+;; nameless-current-name: "image-dired"
+;; End:
+
+;;; image-dired-tags.el ends here
diff --git a/lisp/image/image-dired-util.el b/lisp/image/image-dired-util.el
new file mode 100644
index 00000000000..6eb5fa18ce7
--- /dev/null
+++ b/lisp/image/image-dired-util.el
@@ -0,0 +1,162 @@
+;;; image-dired-util.el --- util functions for Image-Dired -*- lexical-binding: t -*-
+
+;; Copyright (C) 2005-2022 Free Software Foundation, Inc.
+
+;; Author: Mathias Dahl <mathias.rem0veth1s.dahl@gmail.com>
+
+;; 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 'xdg)
+(eval-when-compile (require 'cl-lib))
+
+(defvar image-dired-dir)
+(defvar image-dired-thumbnail-storage)
+
+(defconst image-dired--thumbnail-standard-sizes
+ '( standard standard-large
+ standard-x-large standard-xx-large)
+ "List of symbols representing thumbnail sizes in Thumbnail Managing Standard.")
+
+(defvar image-dired-debug nil
+ "Non-nil means enable debug messages.")
+
+(defun image-dired-debug-message (&rest args)
+ "Display debug message ARGS when `image-dired-debug' is non-nil."
+ (when image-dired-debug
+ (apply #'message args)))
+
+(defun image-dired-dir ()
+ "Return the current thumbnail directory (from variable `image-dired-dir').
+Create the thumbnail directory if it does not exist."
+ (let ((image-dired-dir (file-name-as-directory
+ (expand-file-name image-dired-dir))))
+ (unless (file-directory-p image-dired-dir)
+ (with-file-modes #o700
+ (make-directory image-dired-dir t))
+ (message "Thumbnail directory created: %s" image-dired-dir))
+ image-dired-dir))
+
+(defun image-dired-thumb-name (file)
+ "Return absolute file name for thumbnail FILE.
+Depending on the value of `image-dired-thumbnail-storage', the
+file name of the thumbnail will vary:
+- For `use-image-dired-dir', make a SHA1-hash of the image file's
+ directory name and add that to make the thumbnail file name
+ unique.
+- For `per-directory' storage, just add a subdirectory.
+- For `standard' storage, produce the file name according to the
+ Thumbnail Managing Standard. Among other things, an MD5-hash
+ of the image file's directory name will be added to the
+ filename.
+See also `image-dired-thumbnail-storage'."
+ (cond ((memq image-dired-thumbnail-storage
+ image-dired--thumbnail-standard-sizes)
+ (let ((thumbdir (cl-case image-dired-thumbnail-storage
+ (standard "thumbnails/normal")
+ (standard-large "thumbnails/large")
+ (standard-x-large "thumbnails/x-large")
+ (standard-xx-large "thumbnails/xx-large"))))
+ (expand-file-name
+ ;; MD5 is mandated by the Thumbnail Managing Standard.
+ (concat (md5 (concat "file://" (expand-file-name file))) ".png")
+ (expand-file-name thumbdir (xdg-cache-home)))))
+ ((eq 'use-image-dired-dir image-dired-thumbnail-storage)
+ (let* ((f (expand-file-name file))
+ (hash
+ (md5 (file-name-as-directory (file-name-directory f)))))
+ (format "%s%s%s.thumb.%s"
+ (file-name-as-directory (expand-file-name (image-dired-dir)))
+ (file-name-base f)
+ (if hash (concat "_" hash) "")
+ (file-name-extension f))))
+ ((eq 'per-directory image-dired-thumbnail-storage)
+ (let ((f (expand-file-name file)))
+ (format "%s.image-dired/%s.thumb.%s"
+ (file-name-directory f)
+ (file-name-base f)
+ (file-name-extension f))))))
+
+(defvar image-dired-thumbnail-buffer "*image-dired*"
+ "Image-Dired's thumbnail buffer.")
+
+(defvar image-dired-display-image-buffer "*image-dired-display-image*"
+ "Where larger versions of the images are display.")
+
+(defun image-dired-original-file-name ()
+ "Get original file name for thumbnail or display image at point."
+ (get-text-property (point) 'original-file-name))
+
+(defun image-dired-file-name-at-point ()
+ "Get abbreviated file name for thumbnail or display image at point."
+ (when-let ((f (image-dired-original-file-name)))
+ (abbreviate-file-name f)))
+
+(defun image-dired-associated-dired-buffer ()
+ "Get associated Dired buffer at point."
+ (get-text-property (point) 'associated-dired-buffer))
+
+(defun image-dired-get-buffer-window (buf)
+ "Return window where buffer BUF is."
+ (get-window-with-predicate
+ (lambda (window)
+ (equal (window-buffer window) buf))
+ nil t))
+
+(defun image-dired-display-window ()
+ "Return window where `image-dired-display-image-buffer' is visible."
+ (get-window-with-predicate
+ (lambda (window)
+ (equal (buffer-name (window-buffer window)) image-dired-display-image-buffer))
+ nil t))
+
+(defun image-dired-thumbnail-window ()
+ "Return window where `image-dired-thumbnail-buffer' is visible."
+ (get-window-with-predicate
+ (lambda (window)
+ (equal (buffer-name (window-buffer window)) image-dired-thumbnail-buffer))
+ nil t))
+
+(defun image-dired-associated-dired-buffer-window ()
+ "Return window where associated Dired buffer is visible."
+ (let (buf)
+ (if (image-dired-image-at-point-p)
+ (progn
+ (setq buf (image-dired-associated-dired-buffer))
+ (get-window-with-predicate
+ (lambda (window)
+ (equal (window-buffer window) buf))))
+ (error "No thumbnail image at point"))))
+
+(defun image-dired-image-at-point-p ()
+ "Return non-nil if there is an `image-dired' thumbnail at point."
+ (get-text-property (point) 'image-dired-thumbnail))
+
+(defun image-dired-window-width-pixels (window)
+ "Calculate WINDOW width in pixels."
+ (declare (obsolete window-body-width "29.1"))
+ (* (window-width window) (frame-char-width)))
+
+(provide 'image-dired-util)
+
+;; Local Variables:
+;; nameless-current-name: "image-dired"
+;; End:
+
+;;; image-dired-util.el ends here
diff --git a/lisp/image-dired.el b/lisp/image/image-dired.el
index 9f12354111c..88f4ceaffb4 100644
--- a/lisp/image-dired.el
+++ b/lisp/image/image-dired.el
@@ -2,9 +2,9 @@
;; Copyright (C) 2005-2022 Free Software Foundation, Inc.
+;; Author: Mathias Dahl <mathias.rem0veth1s.dahl@gmail.com>
;; Version: 0.4.11
;; Keywords: multimedia
-;; Author: Mathias Dahl <mathias.rem0veth1s.dahl@gmail.com>
;; This file is part of GNU Emacs.
@@ -134,7 +134,6 @@
;;; Code:
(require 'dired)
-(require 'exif)
(require 'image-mode)
(require 'widget)
(require 'xdg)
@@ -143,6 +142,10 @@
(require 'cl-lib)
(require 'wid-edit))
+(require 'image-dired-external)
+(require 'image-dired-tags)
+(require 'image-dired-util)
+
;;; Customizable variables
@@ -200,135 +203,10 @@ https://specifications.freedesktop.org/thumbnail-spec/thumbnail-spec-latest.html
(const :tag "Per-directory" per-directory))
:version "29.1")
-(defconst image-dired--thumbnail-standard-sizes
- '( standard standard-large
- standard-x-large standard-xx-large)
- "List of symbols representing thumbnail sizes in Thumbnail Managing Standard.")
-
(defcustom image-dired-db-file
(expand-file-name ".image-dired_db" image-dired-dir)
"Database file where file names and their associated tags are stored."
- :type 'file)
-
-(defcustom image-dired-cmd-create-thumbnail-program
- (if (executable-find "gm") "gm" "convert")
- "Executable used to create thumbnail.
-Used together with `image-dired-cmd-create-thumbnail-options'."
- :type 'file
- :version "29.1")
-
-(defcustom image-dired-cmd-create-thumbnail-options
- (let ((opts '("-size" "%wx%h" "%f[0]"
- "-resize" "%wx%h>"
- "-strip" "jpeg:%t")))
- (if (executable-find "gm") (cons "convert" opts) opts))
- "Options of command used to create thumbnail image.
-Used with `image-dired-cmd-create-thumbnail-program'.
-Available format specifiers are: %w which is replaced by
-`image-dired-thumb-width', %h which is replaced by `image-dired-thumb-height',
-%f which is replaced by the file name of the original image and %t
-which is replaced by the file name of the thumbnail file."
- :version "29.1"
- :type '(repeat (string :tag "Argument")))
-
-(defcustom image-dired-cmd-pngnq-program
- ;; Prefer pngquant to pngnq-s9 as it is faster on my machine.
- ;; The project also seems more active than the alternatives.
- ;; Prefer pngnq-s9 to pngnq as it fixes bugs in pngnq.
- ;; The pngnq project seems dead (?) since 2011 or so.
- (or (executable-find "pngquant")
- (executable-find "pngnq-s9")
- (executable-find "pngnq"))
- "The file name of the `pngquant' or `pngnq' program.
-It quantizes colors of PNG images down to 256 colors or fewer
-using the NeuQuant algorithm."
- :version "29.1"
- :type '(choice (const :tag "Not Set" nil) file))
-
-(defcustom image-dired-cmd-pngnq-options
- (if (executable-find "pngquant")
- '("--ext" "-nq8.png" "%t") ; same extension as "pngnq"
- '("-f" "%t"))
- "Arguments to pass `image-dired-cmd-pngnq-program'.
-Available format specifiers are the same as in
-`image-dired-cmd-create-thumbnail-options'."
- :type '(repeat (string :tag "Argument"))
- :version "29.1")
-
-(defcustom image-dired-cmd-pngcrush-program (executable-find "pngcrush")
- "The file name of the `pngcrush' program.
-It optimizes the compression of PNG images. Also it adds PNG textual chunks
-with the information required by the Thumbnail Managing Standard."
- :type '(choice (const :tag "Not Set" nil) file))
-
-(defcustom image-dired-cmd-pngcrush-options
- `("-q"
- "-text" "b" "Description" "Thumbnail of file://%f"
- "-text" "b" "Software" ,(emacs-version)
- ;; "-text b \"Thumb::Image::Height\" \"%oh\" "
- ;; "-text b \"Thumb::Image::Mimetype\" \"%mime\" "
- ;; "-text b \"Thumb::Image::Width\" \"%ow\" "
- "-text" "b" "Thumb::MTime" "%m"
- ;; "-text b \"Thumb::Size\" \"%b\" "
- "-text" "b" "Thumb::URI" "file://%f"
- "%q" "%t")
- "Arguments for `image-dired-cmd-pngcrush-program'.
-Available format specifiers are the same as in
-`image-dired-cmd-create-thumbnail-options', with %q for a
-temporary file name (typically generated by pnqnq)."
- :version "26.1"
- :type '(repeat (string :tag "Argument")))
-
-(defcustom image-dired-cmd-optipng-program (executable-find "optipng")
- "The file name of the `optipng' program."
- :version "26.1"
- :type '(choice (const :tag "Not Set" nil) file))
-
-(defcustom image-dired-cmd-optipng-options '("-o5" "%t")
- "Arguments passed to `image-dired-cmd-optipng-program'.
-Available format specifiers are described in
-`image-dired-cmd-create-thumbnail-options'."
- :version "26.1"
- :type '(repeat (string :tag "Argument"))
- :link '(url-link "man:optipng(1)"))
-
-(defcustom image-dired-cmd-create-standard-thumbnail-options
- (append '("-size" "%wx%h" "%f[0]")
- (unless (or image-dired-cmd-pngcrush-program
- image-dired-cmd-pngnq-program)
- (list
- "-set" "Thumb::MTime" "%m"
- "-set" "Thumb::URI" "file://%f"
- "-set" "Description" "Thumbnail of file://%f"
- "-set" "Software" (emacs-version)))
- '("-thumbnail" "%wx%h>" "png:%t"))
- "Options for creating thumbnails according to the Thumbnail Managing Standard.
-Available format specifiers are the same as in
-`image-dired-cmd-create-thumbnail-options', with %m for file modification time."
- :version "26.1"
- :type '(repeat (string :tag "Argument")))
-
-(defcustom image-dired-cmd-rotate-original-program
- "jpegtran"
- "Executable used to rotate original image.
-Used together with `image-dired-cmd-rotate-original-options'."
- :type 'file)
-
-(defcustom image-dired-cmd-rotate-original-options
- '("-rotate" "%d" "-copy" "all" "-outfile" "%t" "%o")
- "Arguments of command used to rotate original image.
-Used with `image-dired-cmd-rotate-original-program'.
-Available format specifiers are: %d which is replaced by the
-number of (positive) degrees to rotate the image, normally 90 or
-270 \(for 90 degrees right and left), %o which is replaced by the
-original image file name and %t which is replaced by
-`image-dired-temp-image-file'."
- :version "26.1"
- :type '(repeat (string :tag "Argument")))
-
-(defcustom image-dired-temp-rotate-image-file
- (expand-file-name ".image-dired_rotate_temp" image-dired-dir)
- "Temporary file for rotate operations."
+ :group 'image-dired
:type 'file)
(defcustom image-dired-rotate-original-ask-before-overwrite t
@@ -337,22 +215,6 @@ If non-nil, ask user for confirmation before overwriting the
original file with `image-dired-temp-rotate-image-file'."
:type 'boolean)
-(defcustom image-dired-cmd-write-exif-data-program
- "exiftool"
- "Program used to write EXIF data to image.
-Used together with `image-dired-cmd-write-exif-data-options'."
- :type 'file)
-
-(defcustom image-dired-cmd-write-exif-data-options
- '("-%t=%v" "%f")
- "Arguments of command used to write EXIF data.
-Used with `image-dired-cmd-write-exif-data-program'.
-Available format specifiers are: %f which is replaced by
-the image file name, %t which is replaced by the tag name and %v
-which is replaced by the tag value."
- :version "26.1"
- :type '(repeat (string :tag "Argument")))
-
(defcustom image-dired-thumb-size
(cond
((eq 'standard image-dired-thumbnail-storage) 128)
@@ -419,8 +281,8 @@ the window containing the thumbnail buffer, Fixed means to use
and No line-up means that no automatic line-up will be done."
:type '(choice :tag "Default line-up method"
(const :tag "Dynamic" dynamic)
- (const :tag "Fixed" fixed)
- (const :tag "Interactive" interactive)
+ (const :tag "Fixed" fixed)
+ (const :tag "Interactive" interactive)
(const :tag "No line-up" none)))
(defcustom image-dired-thumbs-per-row 3
@@ -433,24 +295,6 @@ For more information, see the documentation for
`image-dired-toggle-movement-tracking'."
:type 'boolean)
-(defcustom image-dired-append-when-browsing nil
- "Append thumbnails in thumbnail buffer when browsing.
-If non-nil, using `image-dired-next-line-and-display' and
-`image-dired-previous-line-and-display' will leave a trail of thumbnail
-images in the thumbnail buffer. If you enable this and want to clean
-the thumbnail buffer because it is filled with too many thumbnails,
-just call `image-dired-display-thumb' to display only the image at point.
-This value can be toggled using `image-dired-toggle-append-browsing'."
- :type 'boolean)
-
-(defcustom image-dired-dired-disp-props t
- "If non-nil, display properties for Dired file when browsing.
-Used by `image-dired-next-line-and-display',
-`image-dired-previous-line-and-display' and `image-dired-mark-and-display-next'.
-If the database file is large, this can slow down image browsing in
-Dired and you might want to turn it off."
- :type 'boolean)
-
(defcustom image-dired-display-properties-format "%b: %f (%t): %c"
"Display format for thumbnail properties.
%b is replaced with associated Dired buffer name, %f with file
@@ -479,7 +323,7 @@ Used by `image-dired-copy-with-exif-file-name'."
:type 'string
:version "29.1")
-(defcustom image-dired-show-all-from-dir-max-files 500
+(defcustom image-dired-show-all-from-dir-max-files 1000
"Maximum number of files in directory before prompting.
If there are more image files than this in a selected directory,
@@ -504,34 +348,6 @@ This affects the following commands:
;;; Util functions
-(defvar image-dired-debug nil
- "Non-nil means enable debug messages.")
-
-(defun image-dired-debug-message (&rest args)
- "Display debug message ARGS when `image-dired-debug' is non-nil."
- (when image-dired-debug
- (apply #'message args)))
-
-(defmacro image-dired--with-db-file (&rest body)
- "Run BODY in a temp buffer containing `image-dired-db-file'.
-Return the last form in BODY."
- (declare (indent 0) (debug t))
- `(with-temp-buffer
- (if (file-exists-p image-dired-db-file)
- (insert-file-contents image-dired-db-file))
- ,@body))
-
-(defun image-dired-dir ()
- "Return the current thumbnail directory (from variable `image-dired-dir').
-Create the thumbnail directory if it does not exist."
- (let ((image-dired-dir (file-name-as-directory
- (expand-file-name image-dired-dir))))
- (unless (file-directory-p image-dired-dir)
- (with-file-modes #o700
- (make-directory image-dired-dir t))
- (message "Thumbnail directory created: %s" image-dired-dir))
- image-dired-dir))
-
(defun image-dired-insert-image (file type relief margin)
"Insert image FILE of image TYPE, using RELIEF and MARGIN, at point."
(let ((i `(image :type ,type
@@ -545,16 +361,16 @@ Create the thumbnail directory if it does not exist."
(unless (string-match-p (image-file-name-regexp) file)
(error "%s is not a valid image file" file))
(let* ((thumb-file (image-dired-thumb-name file))
- (thumb-attr (file-attributes thumb-file)))
+ (thumb-attr (file-attributes thumb-file)))
(when (or (not thumb-attr)
- (time-less-p (file-attribute-modification-time thumb-attr)
- (file-attribute-modification-time
- (file-attributes file))))
+ (time-less-p (file-attribute-modification-time thumb-attr)
+ (file-attribute-modification-time
+ (file-attributes file))))
(image-dired-create-thumb file thumb-file))
(create-image thumb-file)))
-(defun image-dired-insert-thumbnail (file original-file-name
- associated-dired-buffer)
+(defun image-dired-insert-thumbnail ( file original-file-name
+ associated-dired-buffer)
"Insert thumbnail image FILE.
Add text properties ORIGINAL-FILE-NAME and ASSOCIATED-DIRED-BUFFER."
(let (beg end)
@@ -582,234 +398,6 @@ Add text properties ORIGINAL-FILE-NAME and ASSOCIATED-DIRED-BUFFER."
'mouse-face 'highlight
'comment (image-dired-get-comment original-file-name)))))
-(defun image-dired-thumb-name (file)
- "Return absolute file name for thumbnail FILE.
-Depending on the value of `image-dired-thumbnail-storage', the
-file name of the thumbnail will vary:
-- For `use-image-dired-dir', make a SHA1-hash of the image file's
- directory name and add that to make the thumbnail file name
- unique.
-- For `per-directory' storage, just add a subdirectory.
-- For `standard' storage, produce the file name according to the
- Thumbnail Managing Standard. Among other things, an MD5-hash
- of the image file's directory name will be added to the
- filename.
-See also `image-dired-thumbnail-storage'."
- (cond ((memq image-dired-thumbnail-storage
- image-dired--thumbnail-standard-sizes)
- (let ((thumbdir (cl-case image-dired-thumbnail-storage
- (standard "thumbnails/normal")
- (standard-large "thumbnails/large")
- (standard-x-large "thumbnails/x-large")
- (standard-xx-large "thumbnails/xx-large"))))
- (expand-file-name
- ;; MD5 is mandated by the Thumbnail Managing Standard.
- (concat (md5 (concat "file://" (expand-file-name file))) ".png")
- (expand-file-name thumbdir (xdg-cache-home)))))
- ((eq 'use-image-dired-dir image-dired-thumbnail-storage)
- (let* ((f (expand-file-name file))
- (hash
- (md5 (file-name-as-directory (file-name-directory f)))))
- (format "%s%s%s.thumb.%s"
- (file-name-as-directory (expand-file-name (image-dired-dir)))
- (file-name-base f)
- (if hash (concat "_" hash) "")
- (file-name-extension f))))
- ((eq 'per-directory image-dired-thumbnail-storage)
- (let ((f (expand-file-name file)))
- (format "%s.image-dired/%s.thumb.%s"
- (file-name-directory f)
- (file-name-base f)
- (file-name-extension f))))))
-
-(defun image-dired--check-executable-exists (executable)
- (unless (executable-find (symbol-value executable))
- (error "Executable %S not found" executable)))
-
-
-;;; Creating thumbnails
-
-(defun image-dired-thumb-size (dimension)
- "Return thumb size depending on `image-dired-thumbnail-storage'.
-DIMENSION should be either the symbol `width' or `height'."
- (cond
- ((eq 'standard image-dired-thumbnail-storage) 128)
- ((eq 'standard-large image-dired-thumbnail-storage) 256)
- ((eq 'standard-x-large image-dired-thumbnail-storage) 512)
- ((eq 'standard-xx-large image-dired-thumbnail-storage) 1024)
- (t (cl-ecase dimension
- (width image-dired-thumb-width)
- (height image-dired-thumb-height)))))
-
-(defvar image-dired--generate-thumbs-start nil
- "Time when `display-thumbs' was called.")
-
-(defvar image-dired-queue nil
- "List of items in the queue.
-Each item has the form (ORIGINAL-FILE TARGET-FILE).")
-
-(defvar image-dired-queue-active-jobs 0
- "Number of active jobs in `image-dired-queue'.")
-
-(defvar image-dired-queue-active-limit (min 4 (max 2 (/ (num-processors) 2)))
- "Maximum number of concurrent jobs permitted for generating images.
-Increase at own risk. If you want to experiment with this,
-consider setting `image-dired-debug' to a non-nil value to see
-the time spent on generating thumbnails. Run `image-clear-cache'
-and remove the cached thumbnail files between each trial run.")
-
-(defun image-dired-pngnq-thumb (spec)
- "Quantize thumbnail described by format SPEC with pngnq(1)."
- (let ((process
- (apply #'start-process "image-dired-pngnq" nil
- image-dired-cmd-pngnq-program
- (mapcar (lambda (arg) (format-spec arg spec))
- image-dired-cmd-pngnq-options))))
- (setf (process-sentinel process)
- (lambda (process status)
- (if (and (eq (process-status process) 'exit)
- (zerop (process-exit-status process)))
- ;; Pass off to pngcrush, or just rename the
- ;; THUMB-nq8.png file back to THUMB.png
- (if (and image-dired-cmd-pngcrush-program
- (executable-find image-dired-cmd-pngcrush-program))
- (image-dired-pngcrush-thumb spec)
- (let ((nq8 (cdr (assq ?q spec)))
- (thumb (cdr (assq ?t spec))))
- (rename-file nq8 thumb t)))
- (message "command %S %s" (process-command process)
- (string-replace "\n" "" status)))))
- process))
-
-(defun image-dired-pngcrush-thumb (spec)
- "Optimize thumbnail described by format SPEC with pngcrush(1)."
- ;; If pngnq wasn't run, then the THUMB-nq8.png file does not exist.
- ;; pngcrush needs an infile and outfile, so we just copy THUMB to
- ;; THUMB-nq8.png and use the latter as a temp file.
- (when (not image-dired-cmd-pngnq-program)
- (let ((temp (cdr (assq ?q spec)))
- (thumb (cdr (assq ?t spec))))
- (copy-file thumb temp)))
- (let ((process
- (apply #'start-process "image-dired-pngcrush" nil
- image-dired-cmd-pngcrush-program
- (mapcar (lambda (arg) (format-spec arg spec))
- image-dired-cmd-pngcrush-options))))
- (setf (process-sentinel process)
- (lambda (process status)
- (unless (and (eq (process-status process) 'exit)
- (zerop (process-exit-status process)))
- (message "command %S %s" (process-command process)
- (string-replace "\n" "" status)))
- (when (memq (process-status process) '(exit signal))
- (let ((temp (cdr (assq ?q spec))))
- (delete-file temp)))))
- process))
-
-(defun image-dired-optipng-thumb (spec)
- "Optimize thumbnail described by format SPEC with optipng(1)."
- (let ((process
- (apply #'start-process "image-dired-optipng" nil
- image-dired-cmd-optipng-program
- (mapcar (lambda (arg) (format-spec arg spec))
- image-dired-cmd-optipng-options))))
- (setf (process-sentinel process)
- (lambda (process status)
- (unless (and (eq (process-status process) 'exit)
- (zerop (process-exit-status process)))
- (message "command %S %s" (process-command process)
- (string-replace "\n" "" status)))))
- process))
-
-(defun image-dired-create-thumb-1 (original-file thumbnail-file)
- "For ORIGINAL-FILE, create thumbnail image named THUMBNAIL-FILE."
- (image-dired--check-executable-exists
- 'image-dired-cmd-create-thumbnail-program)
- (let* ((width (int-to-string (image-dired-thumb-size 'width)))
- (height (int-to-string (image-dired-thumb-size 'height)))
- (modif-time (format-time-string
- "%s" (file-attribute-modification-time
- (file-attributes original-file))))
- (thumbnail-nq8-file (replace-regexp-in-string ".png\\'" "-nq8.png"
- thumbnail-file))
- (spec
- (list
- (cons ?w width)
- (cons ?h height)
- (cons ?m modif-time)
- (cons ?f original-file)
- (cons ?q thumbnail-nq8-file)
- (cons ?t thumbnail-file)))
- (thumbnail-dir (file-name-directory thumbnail-file))
- process)
- (when (not (file-exists-p thumbnail-dir))
- (with-file-modes #o700
- (make-directory thumbnail-dir t))
- (message "Thumbnail directory created: %s" thumbnail-dir))
-
- ;; Thumbnail file creation processes begin here and are marshaled
- ;; in a queue by `image-dired-create-thumb'.
- (setq process
- (apply #'start-process "image-dired-create-thumbnail" nil
- image-dired-cmd-create-thumbnail-program
- (mapcar
- (lambda (arg) (format-spec arg spec))
- (if (memq image-dired-thumbnail-storage
- image-dired--thumbnail-standard-sizes)
- image-dired-cmd-create-standard-thumbnail-options
- image-dired-cmd-create-thumbnail-options))))
-
- (setf (process-sentinel process)
- (lambda (process status)
- ;; Trigger next in queue once a thumbnail has been created
- (cl-decf image-dired-queue-active-jobs)
- (image-dired-thumb-queue-run)
- (when (= image-dired-queue-active-jobs 0)
- (image-dired-debug-message
- (format-time-string
- "Generated thumbnails in %s.%3N seconds"
- (time-subtract nil
- image-dired--generate-thumbs-start))))
- (if (not (and (eq (process-status process) 'exit)
- (zerop (process-exit-status process))))
- (message "Thumb could not be created for %s: %s"
- (abbreviate-file-name original-file)
- (string-replace "\n" "" status))
- (set-file-modes thumbnail-file #o600)
- (clear-image-cache thumbnail-file)
- ;; PNG thumbnail has been created since we are
- ;; following the XDG thumbnail spec, so try to optimize
- (when (memq image-dired-thumbnail-storage
- image-dired--thumbnail-standard-sizes)
- (cond
- ((and image-dired-cmd-pngnq-program
- (executable-find image-dired-cmd-pngnq-program))
- (image-dired-pngnq-thumb spec))
- ((and image-dired-cmd-pngcrush-program
- (executable-find image-dired-cmd-pngcrush-program))
- (image-dired-pngcrush-thumb spec))
- ((and image-dired-cmd-optipng-program
- (executable-find image-dired-cmd-optipng-program))
- (image-dired-optipng-thumb spec)))))))
- process))
-
-(defun image-dired-thumb-queue-run ()
- "Run a queued job if one exists and not too many jobs are running.
-Queued items live in `image-dired-queue'."
- (while (and image-dired-queue
- (< image-dired-queue-active-jobs
- image-dired-queue-active-limit))
- (cl-incf image-dired-queue-active-jobs)
- (apply #'image-dired-create-thumb-1 (pop image-dired-queue))))
-
-(defun image-dired-create-thumb (original-file thumbnail-file)
- "Add a job for generating ORIGINAL-FILE thumbnail to `image-dired-queue'.
-The new file will be named THUMBNAIL-FILE."
- (setq image-dired-queue
- (nconc image-dired-queue
- (list (list original-file thumbnail-file))))
- (run-at-time 0 nil #'image-dired-thumb-queue-run))
-
(defmacro image-dired--with-marked (&rest body)
"Eval BODY with point on each marked thumbnail.
If no marked file could be found, execute BODY on the current
@@ -826,101 +414,6 @@ thumbnail."
(unless found
,@body))))
-;;;###autoload
-(defun image-dired-dired-toggle-marked-thumbs (&optional arg)
- "Toggle thumbnails in front of file names in the Dired buffer.
-If no marked file could be found, insert or hide thumbnails on the
-current line. ARG, if non-nil, specifies the files to use instead
-of the marked files. If ARG is an integer, use the next ARG (or
-previous -ARG, if ARG<0) files."
- (interactive "P")
- (dired-map-over-marks
- (let ((image-pos (dired-move-to-filename))
- (image-file (dired-get-filename nil t))
- thumb-file
- overlay)
- (when (and image-file
- (string-match-p (image-file-name-regexp) image-file))
- (setq thumb-file (image-dired-get-thumbnail-image image-file))
- ;; If image is not already added, then add it.
- (let ((thumb-ov (cl-loop for ov in (overlays-in (point) (1+ (point)))
- if (overlay-get ov 'thumb-file) return ov)))
- (if thumb-ov
- (delete-overlay thumb-ov)
- (put-image thumb-file image-pos)
- (setq overlay
- (cl-loop for ov in (overlays-in (point) (1+ (point)))
- if (overlay-get ov 'put-image) return ov))
- (overlay-put overlay 'image-file image-file)
- (overlay-put overlay 'thumb-file thumb-file)))))
- arg ; Show or hide image on ARG next files.
- 'show-progress) ; Update dired display after each image is updated.
- (add-hook 'dired-after-readin-hook
- 'image-dired-dired-after-readin-hook nil t))
-
-(defun image-dired-dired-after-readin-hook ()
- "Relocate existing thumbnail overlays in Dired buffer after reverting.
-Move them to their corresponding files if they still exist.
-Otherwise, delete overlays."
- (mapc (lambda (overlay)
- (when (overlay-get overlay 'put-image)
- (let* ((image-file (overlay-get overlay 'image-file))
- (image-pos (dired-goto-file image-file)))
- (if image-pos
- (move-overlay overlay image-pos image-pos)
- (delete-overlay overlay)))))
- (overlays-in (point-min) (point-max))))
-
-(defun image-dired-next-line-and-display ()
- "Move to next Dired line and display thumbnail image."
- (interactive)
- (dired-next-line 1)
- (image-dired-display-thumbs
- t (or image-dired-append-when-browsing nil) t)
- (if image-dired-dired-disp-props
- (image-dired-dired-display-properties)))
-
-(defun image-dired-previous-line-and-display ()
- "Move to previous Dired line and display thumbnail image."
- (interactive)
- (dired-previous-line 1)
- (image-dired-display-thumbs
- t (or image-dired-append-when-browsing nil) t)
- (if image-dired-dired-disp-props
- (image-dired-dired-display-properties)))
-
-(defun image-dired-toggle-append-browsing ()
- "Toggle `image-dired-append-when-browsing'."
- (interactive)
- (setq image-dired-append-when-browsing
- (not image-dired-append-when-browsing))
- (message "Append browsing %s"
- (if image-dired-append-when-browsing
- "on"
- "off")))
-
-(defun image-dired-mark-and-display-next ()
- "Mark current file in Dired and display next thumbnail image."
- (interactive)
- (dired-mark 1)
- (image-dired-display-thumbs
- t (or image-dired-append-when-browsing nil) t)
- (if image-dired-dired-disp-props
- (image-dired-dired-display-properties)))
-
-(defun image-dired-toggle-dired-display-properties ()
- "Toggle `image-dired-dired-disp-props'."
- (interactive)
- (setq image-dired-dired-disp-props
- (not image-dired-dired-disp-props))
- (message "Dired display properties %s"
- (if image-dired-dired-disp-props
- "on"
- "off")))
-
-(defvar image-dired-thumbnail-buffer "*image-dired*"
- "Image-Dired's thumbnail buffer.")
-
(defun image-dired-create-thumbnail-buffer ()
"Create thumb buffer and set `image-dired-thumbnail-mode'."
(let ((buf (get-buffer-create image-dired-thumbnail-buffer)))
@@ -930,9 +423,6 @@ Otherwise, delete overlays."
(image-dired-thumbnail-mode)))
buf))
-(defvar image-dired-display-image-buffer "*image-dired-display-image*"
- "Where larger versions of the images are display.")
-
(defvar image-dired-saved-window-configuration nil
"Saved window configuration.")
@@ -1014,7 +504,7 @@ used or not. If non-nil, use `display-buffer' instead of
`image-dired-next-line-and-display' and
`image-dired-previous-line-and-display' where we do not want the
thumbnail buffer to be selected."
- (interactive "P")
+ (interactive "P" nil dired-mode)
(setq image-dired--generate-thumbs-start (current-time))
(let ((buf (image-dired-create-thumbnail-buffer))
thumb-name files dired-buf)
@@ -1070,177 +560,13 @@ never ask for confirmation."
(defalias 'image-dired 'image-dired-show-all-from-dir)
-;;; Tags
-
-(defun image-dired-sane-db-file ()
- "Check if `image-dired-db-file' exists.
-If not, try to create it (including any parent directories).
-Signal error if there are problems creating it."
- (or (file-exists-p image-dired-db-file)
- (let (dir buf)
- (unless (file-directory-p (setq dir (file-name-directory
- image-dired-db-file)))
- (with-file-modes #o700
- (make-directory dir t)))
- (with-current-buffer (setq buf (create-file-buffer
- image-dired-db-file))
- (with-file-modes #o600
- (write-file image-dired-db-file)))
- (kill-buffer buf)
- (file-exists-p image-dired-db-file))
- (error "Could not create %s" image-dired-db-file)))
-
-(defvar image-dired-tag-history nil "Variable holding the tag history.")
-
-(defun image-dired-write-tags (file-tags)
- "Write file tags to database.
-Write each file and tag in FILE-TAGS to the database.
-FILE-TAGS is an alist in the following form:
- ((FILE . TAG) ... )"
- (image-dired-sane-db-file)
- (let (end file tag)
- (image-dired--with-db-file
- (setq buffer-file-name image-dired-db-file)
- (dolist (elt file-tags)
- (setq file (car elt)
- tag (cdr elt))
- (goto-char (point-min))
- (if (search-forward-regexp (format "^%s.*$" file) nil t)
- (progn
- (setq end (point))
- (beginning-of-line)
- (when (not (search-forward (format ";%s" tag) end t))
- (end-of-line)
- (insert (format ";%s" tag))))
- (goto-char (point-max))
- (insert (format "%s;%s\n" file tag))))
- (save-buffer))))
-
-(defun image-dired-remove-tag (files tag)
- "For all FILES, remove TAG from the image database."
- (image-dired-sane-db-file)
- (image-dired--with-db-file
- (setq buffer-file-name image-dired-db-file)
- (let (end)
- (unless (listp files)
- (if (stringp files)
- (setq files (list files))
- (error "Files must be a string or a list of strings!")))
- (dolist (file files)
- (goto-char (point-min))
- (when (search-forward-regexp (format "^%s;" file) nil t)
- (end-of-line)
- (setq end (point))
- (beginning-of-line)
- (when (search-forward-regexp
- (format "\\(;%s\\)\\($\\|;\\)" tag) end t)
- (delete-region (match-beginning 1) (match-end 1))
- ;; Check if file should still be in the database. If
- ;; it has no tags or comments, it will be removed.
- (end-of-line)
- (setq end (point))
- (beginning-of-line)
- (when (not (search-forward ";" end t))
- (kill-line 1))))))
- (save-buffer)))
-
-(defun image-dired-list-tags (file)
- "Read all tags for image FILE from the image database."
- (image-dired-sane-db-file)
- (image-dired--with-db-file
- (let (end (tags ""))
- (when (search-forward-regexp (format "^%s" file) nil t)
- (end-of-line)
- (setq end (point))
- (beginning-of-line)
- (if (search-forward ";" end t)
- (if (search-forward "comment:" end t)
- (if (search-forward ";" end t)
- (setq tags (buffer-substring (point) end)))
- (setq tags (buffer-substring (point) end)))))
- (split-string tags ";"))))
-
-;;;###autoload
-(defun image-dired-tag-files (arg)
- "Tag marked file(s) in Dired. With prefix ARG, tag file at point."
- (interactive "P")
- (let ((tag (completing-read
- "Tags to add (separate tags with a semicolon): "
- image-dired-tag-history nil nil nil 'image-dired-tag-history))
- files)
- (if arg
- (setq files (list (dired-get-filename)))
- (setq files (dired-get-marked-files)))
- (image-dired-write-tags
- (mapcar
- (lambda (x)
- (cons x tag))
- files))))
-
-(defun image-dired-tag-thumbnail ()
- "Tag current or marked thumbnails."
- (interactive)
- (let ((tag (completing-read
- "Tags to add (separate tags with a semicolon): "
- image-dired-tag-history nil nil nil 'image-dired-tag-history)))
- (image-dired--with-marked
- (image-dired-write-tags
- (list (cons (image-dired-original-file-name) tag)))
- (image-dired-update-property
- 'tags (image-dired-list-tags (image-dired-original-file-name))))))
-
-;;;###autoload
-(defun image-dired-delete-tag (arg)
- "Remove tag for selected file(s).
-With prefix argument ARG, remove tag from file at point."
- (interactive "P")
- (let ((tag (completing-read "Tag to remove: " image-dired-tag-history
- nil nil nil 'image-dired-tag-history))
- files)
- (if arg
- (setq files (list (dired-get-filename)))
- (setq files (dired-get-marked-files)))
- (image-dired-remove-tag files tag)))
-
-(defun image-dired-tag-thumbnail-remove ()
- "Remove tag from current or marked thumbnails."
- (interactive)
- (let ((tag (completing-read "Tag to remove: " image-dired-tag-history
- nil nil nil 'image-dired-tag-history)))
- (image-dired--with-marked
- (image-dired-remove-tag (image-dired-original-file-name) tag)
- (image-dired-update-property
- 'tags (image-dired-list-tags (image-dired-original-file-name))))))
-
-
;;; Thumbnail mode (cont.)
-(defun image-dired-original-file-name ()
- "Get original file name for thumbnail or display image at point."
- (get-text-property (point) 'original-file-name))
-
-(defun image-dired-file-name-at-point ()
- "Get abbreviated file name for thumbnail or display image at point."
- (let ((f (image-dired-original-file-name)))
- (when f
- (abbreviate-file-name f))))
-
-(defun image-dired-associated-dired-buffer ()
- "Get associated Dired buffer at point."
- (get-text-property (point) 'associated-dired-buffer))
-
-(defun image-dired-get-buffer-window (buf)
- "Return window where buffer BUF is."
- (get-window-with-predicate
- (lambda (window)
- (equal (window-buffer window) buf))
- nil t))
-
(defun image-dired-track-original-file ()
"Track the original file in the associated Dired buffer.
See documentation for `image-dired-toggle-movement-tracking'.
Interactive use only useful if `image-dired-track-movement' is nil."
- (interactive)
+ (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode)
(let* ((dired-buf (image-dired-associated-dired-buffer))
(file-name (image-dired-original-file-name))
(window (image-dired-get-buffer-window dired-buf)))
@@ -1256,50 +582,10 @@ Tracking of the movements between thumbnail and Dired buffer so that
they are \"mirrored\" in the dired buffer. When this is on, moving
around in the thumbnail or dired buffer will find the matching
position in the other buffer."
- (interactive)
+ (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode)
(setq image-dired-track-movement (not image-dired-track-movement))
(message "Movement tracking %s" (if image-dired-track-movement "on" "off")))
-(defun image-dired-track-thumbnail ()
- "Track current Dired file's thumb in `image-dired-thumbnail-buffer'.
-This is almost the same as what `image-dired-track-original-file' does,
-but the other way around."
- (let ((file (dired-get-filename))
- prop-val found window)
- (when (get-buffer image-dired-thumbnail-buffer)
- (with-current-buffer image-dired-thumbnail-buffer
- (goto-char (point-min))
- (while (and (not (eobp))
- (not found))
- (if (and (setq prop-val
- (get-text-property (point) 'original-file-name))
- (string= prop-val file))
- (setq found t))
- (if (not found)
- (forward-char 1)))
- (when found
- (if (setq window (image-dired-thumbnail-window))
- (set-window-point window (point)))
- (image-dired-update-header-line))))))
-
-(defun image-dired-dired-next-line (&optional arg)
- "Call `dired-next-line', then track thumbnail.
-This can safely replace `dired-next-line'.
-With prefix argument, move ARG lines."
- (interactive "P")
- (dired-next-line (or arg 1))
- (if image-dired-track-movement
- (image-dired-track-thumbnail)))
-
-(defun image-dired-dired-previous-line (&optional arg)
- "Call `dired-previous-line', then track thumbnail.
-This can safely replace `dired-previous-line'.
-With prefix argument, move ARG lines."
- (interactive "P")
- (dired-previous-line (or arg 1))
- (if image-dired-track-movement
- (image-dired-track-thumbnail)))
-
(defun image-dired--display-thumb-properties-fun ()
(let ((old-buf (current-buffer))
(old-point (point)))
@@ -1317,7 +603,7 @@ On reaching end or beginning of buffer, stop and show a message.
If optional argument WRAP-AROUND is non-nil, wrap around: if
point is on the last image, move to the last one and vice versa."
- (interactive "p")
+ (interactive "p" image-dired-thumbnail-mode)
(setq arg (or arg 1))
(let (pos)
(dotimes (_ (abs arg))
@@ -1347,7 +633,7 @@ point is on the last image, move to the last one and vice versa."
Optional prefix ARG says how many images to move; the default is
one image. Negative means move forward.
On reaching end or beginning of buffer, stop and show a message."
- (interactive "p")
+ (interactive "p" image-dired-thumbnail-mode)
(image-dired-forward-image (- (or arg 1))))
(defun image-dired-next-line ()
@@ -1363,7 +649,6 @@ On reaching end or beginning of buffer, stop and show a message."
(image-dired-track-original-file))
(image-dired-update-header-line))
-
(defun image-dired-previous-line ()
"Move to previous line and display properties."
(interactive nil image-dired-thumbnail-mode)
@@ -1534,97 +819,64 @@ You probably want to use this together with
(select-window window))
(message "Associated dired buffer not visible"))))
-;;;###autoload
-(defun image-dired-jump-thumbnail-buffer ()
- "Jump to thumbnail buffer."
- (interactive)
- (let ((window (image-dired-thumbnail-window))
- frame)
- (if window
- (progn
- (if (not (equal (selected-frame) (setq frame (window-frame window))))
- (select-frame-set-input-focus frame))
- (select-window window))
- (message "Thumbnail buffer not visible"))))
-
-(defvar image-dired-thumbnail-mode-line-up-map
- (let ((map (make-sparse-keymap)))
- ;; map it to "g" so that the user can press it more quickly
- (define-key map "g" #'image-dired-line-up-dynamic)
- ;; "f" for "fixed" number of thumbs per row
- (define-key map "f" #'image-dired-line-up)
- ;; "i" for "interactive"
- (define-key map "i" #'image-dired-line-up-interactive)
- map)
- "Keymap for line-up commands in `image-dired-thumbnail-mode'.")
-
-(defvar image-dired-thumbnail-mode-tag-map
- (let ((map (make-sparse-keymap)))
- ;; map it to "t" so that the user can press it more quickly
- (define-key map "t" #'image-dired-tag-thumbnail)
- ;; "r" for "remove"
- (define-key map "r" #'image-dired-tag-thumbnail-remove)
- map)
- "Keymap for tag commands in `image-dired-thumbnail-mode'.")
-
-(defvar image-dired-thumbnail-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map [right] #'image-dired-forward-image)
- (define-key map [left] #'image-dired-backward-image)
- (define-key map [up] #'image-dired-previous-line)
- (define-key map [down] #'image-dired-next-line)
- (define-key map "\C-f" #'image-dired-forward-image)
- (define-key map "\C-b" #'image-dired-backward-image)
- (define-key map "\C-p" #'image-dired-previous-line)
- (define-key map "\C-n" #'image-dired-next-line)
-
- (define-key map "<" #'image-dired-beginning-of-buffer)
- (define-key map ">" #'image-dired-end-of-buffer)
- (define-key map (kbd "M-<") #'image-dired-beginning-of-buffer)
- (define-key map (kbd "M->") #'image-dired-end-of-buffer)
-
- (define-key map "d" #'image-dired-flag-thumb-original-file)
- (define-key map [delete] #'image-dired-flag-thumb-original-file)
- (define-key map "m" #'image-dired-mark-thumb-original-file)
- (define-key map "u" #'image-dired-unmark-thumb-original-file)
- (define-key map "U" #'image-dired-unmark-all-marks)
- (define-key map "." #'image-dired-track-original-file)
- (define-key map [tab] #'image-dired-jump-original-dired-buffer)
-
- ;; add line-up map
- (define-key map "g" image-dired-thumbnail-mode-line-up-map)
- ;; add tag map
- (define-key map "t" image-dired-thumbnail-mode-tag-map)
-
- (define-key map "\C-m" #'image-dired-display-thumbnail-original-image)
- (define-key map [C-return] #'image-dired-thumbnail-display-external)
-
- (define-key map "L" #'image-dired-rotate-original-left)
- (define-key map "R" #'image-dired-rotate-original-right)
-
- (define-key map "D" #'image-dired-thumbnail-set-image-description)
- (define-key map "S" #'image-dired-slideshow-start)
- (define-key map "\C-d" #'image-dired-delete-char)
- (define-key map " " #'image-dired-display-next-thumbnail-original)
- (define-key map (kbd "DEL") #'image-dired-display-previous-thumbnail-original)
- (define-key map "c" #'image-dired-comment-thumbnail)
-
- ;; Mouse
- (define-key map [mouse-2] #'image-dired-mouse-display-image)
- (define-key map [mouse-1] #'image-dired-mouse-select-thumbnail)
- (define-key map [mouse-3] #'image-dired-mouse-select-thumbnail)
- (define-key map [down-mouse-1] #'image-dired-mouse-select-thumbnail)
- (define-key map [down-mouse-2] #'image-dired-mouse-select-thumbnail)
- (define-key map [down-mouse-3] #'image-dired-mouse-select-thumbnail)
- ;; Seems I must first set C-down-mouse-1 to undefined, or else it
- ;; will trigger the buffer menu. If I try to instead bind
- ;; C-down-mouse-1 to `image-dired-mouse-toggle-mark', I get a message
- ;; about C-mouse-1 not being defined afterwards. Annoying, but I
- ;; probably do not completely understand mouse events.
- (define-key map [C-down-mouse-1] #'undefined)
- (define-key map [C-mouse-1] #'image-dired-mouse-toggle-mark)
- map)
- "Keymap for `image-dired-thumbnail-mode'.")
+(defvar-keymap image-dired-thumbnail-mode-map
+ :doc "Keymap for `image-dired-thumbnail-mode'."
+ "<right>" #'image-dired-forward-image
+ "<left>" #'image-dired-backward-image
+ "<up>" #'image-dired-previous-line
+ "<down>" #'image-dired-next-line
+ "C-f" #'image-dired-forward-image
+ "C-b" #'image-dired-backward-image
+ "C-p" #'image-dired-previous-line
+ "C-n" #'image-dired-next-line
+
+ "<" #'image-dired-beginning-of-buffer
+ ">" #'image-dired-end-of-buffer
+ "M-<" #'image-dired-beginning-of-buffer
+ "M->" #'image-dired-end-of-buffer
+
+ "d" #'image-dired-flag-thumb-original-file
+ "<delete>" #'image-dired-flag-thumb-original-file
+ "m" #'image-dired-mark-thumb-original-file
+ "u" #'image-dired-unmark-thumb-original-file
+ "U" #'image-dired-unmark-all-marks
+ "." #'image-dired-track-original-file
+ "<tab>" #'image-dired-jump-original-dired-buffer
+
+ "g g" #'image-dired-line-up-dynamic
+ "g f" #'image-dired-line-up
+ "g i" #'image-dired-line-up-interactive
+
+ "t t" #'image-dired-tag-thumbnail
+ "t r" #'image-dired-tag-thumbnail-remove
+
+ "RET" #'image-dired-display-thumbnail-original-image
+ "C-<return>" #'image-dired-thumbnail-display-external
+
+ "L" #'image-dired-rotate-original-left
+ "R" #'image-dired-rotate-original-right
+
+ "D" #'image-dired-thumbnail-set-image-description
+ "S" #'image-dired-slideshow-start
+ "C-d" #'image-dired-delete-char
+ "SPC" #'image-dired-display-next-thumbnail-original
+ "DEL" #'image-dired-display-previous-thumbnail-original
+ "c" #'image-dired-comment-thumbnail
+
+ ;; Mouse
+ "<mouse-2>" #'image-dired-mouse-display-image
+ "<mouse-1>" #'image-dired-mouse-select-thumbnail
+ "<mouse-3>" #'image-dired-mouse-select-thumbnail
+ "<down-mouse-1>" #'image-dired-mouse-select-thumbnail
+ "<down-mouse-2>" #'image-dired-mouse-select-thumbnail
+ "<down-mouse-3>" #'image-dired-mouse-select-thumbnail
+ ;; Seems I must first set C-down-mouse-1 to undefined, or else it
+ ;; will trigger the buffer menu. If I try to instead bind
+ ;; C-down-mouse-1 to `image-dired-mouse-toggle-mark', I get a message
+ ;; about C-mouse-1 not being defined afterwards. Annoying, but I
+ ;; probably do not completely understand mouse events.
+ "C-<down-mouse-1>" #'undefined
+ "C-<mouse-1>" #'image-dired-mouse-toggle-mark)
(easy-menu-define image-dired-thumbnail-mode-menu image-dired-thumbnail-mode-map
"Menu for `image-dired-thumbnail-mode'."
@@ -1658,21 +910,19 @@ You probably want to use this together with
["Refresh thumb" image-dired-refresh-thumb])
["Quit" quit-window]))
-(defvar image-dired-display-image-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map "S" #'image-dired-slideshow-start)
- (define-key map (kbd "SPC") #'image-dired-display-next-thumbnail-original)
- (define-key map (kbd "DEL") #'image-dired-display-previous-thumbnail-original)
- (define-key map "n" #'image-dired-display-next-thumbnail-original)
- (define-key map "p" #'image-dired-display-previous-thumbnail-original)
- (define-key map "m" #'image-dired-mark-thumb-original-file)
- (define-key map "d" #'image-dired-flag-thumb-original-file)
- (define-key map "u" #'image-dired-unmark-thumb-original-file)
- (define-key map "U" #'image-dired-unmark-all-marks)
- ;; Disable keybindings from `image-mode-map' that doesn't make sense here.
- (define-key map "o" nil) ; image-save
- map)
- "Keymap for `image-dired-display-image-mode'.")
+(defvar-keymap image-dired-display-image-mode-map
+ :doc "Keymap for `image-dired-display-image-mode'."
+ "S" #'image-dired-slideshow-start
+ "SPC" #'image-dired-display-next-thumbnail-original
+ "DEL" #'image-dired-display-previous-thumbnail-original
+ "n" #'image-dired-display-next-thumbnail-original
+ "p" #'image-dired-display-previous-thumbnail-original
+ "m" #'image-dired-mark-thumb-original-file
+ "d" #'image-dired-flag-thumb-original-file
+ "u" #'image-dired-unmark-thumb-original-file
+ "U" #'image-dired-unmark-all-marks
+ ;; Disable keybindings from `image-mode-map' that doesn't make sense here.
+ "o" nil) ; image-save
(define-derived-mode image-dired-thumbnail-mode
special-mode "image-dired-thumbnail"
@@ -1696,86 +946,6 @@ Resized or in full-size."
:interactive nil
(add-hook 'file-name-at-point-functions #'image-dired-file-name-at-point nil t))
-(defvar image-dired-minor-mode-map
- (let ((map (make-sparse-keymap)))
- ;; (set-keymap-parent map dired-mode-map)
- ;; Hijack previous and next line movement. Let C-p and C-b be
- ;; though...
- (define-key map "p" #'image-dired-dired-previous-line)
- (define-key map "n" #'image-dired-dired-next-line)
- (define-key map [up] #'image-dired-dired-previous-line)
- (define-key map [down] #'image-dired-dired-next-line)
-
- (define-key map (kbd "C-S-n") #'image-dired-next-line-and-display)
- (define-key map (kbd "C-S-p") #'image-dired-previous-line-and-display)
- (define-key map (kbd "C-S-m") #'image-dired-mark-and-display-next)
-
- (define-key map "\C-td" #'image-dired-display-thumbs)
- (define-key map [tab] #'image-dired-jump-thumbnail-buffer)
- (define-key map "\C-ti" #'image-dired-dired-display-image)
- (define-key map "\C-tx" #'image-dired-dired-display-external)
- (define-key map "\C-ta" #'image-dired-display-thumbs-append)
- (define-key map "\C-t." #'image-dired-display-thumb)
- (define-key map "\C-tc" #'image-dired-dired-comment-files)
- (define-key map "\C-tf" #'image-dired-mark-tagged-files)
- map)
- "Keymap for `image-dired-minor-mode'.")
-
-(easy-menu-define image-dired-minor-mode-menu image-dired-minor-mode-map
- "Menu for `image-dired-minor-mode'."
- '("Image-dired"
- ["Display thumb for next file" image-dired-next-line-and-display]
- ["Display thumb for previous file" image-dired-previous-line-and-display]
- ["Mark and display next" image-dired-mark-and-display-next]
- "---"
- ["Create thumbnails for marked files" image-dired-create-thumbs]
- "---"
- ["Display thumbnails append" image-dired-display-thumbs-append]
- ["Display this thumbnail" image-dired-display-thumb]
- ["Display image" image-dired-dired-display-image]
- ["Display in external viewer" image-dired-dired-display-external]
- "---"
- ["Toggle display properties" image-dired-toggle-dired-display-properties
- :style toggle
- :selected image-dired-dired-disp-props]
- ["Toggle append browsing" image-dired-toggle-append-browsing
- :style toggle
- :selected image-dired-append-when-browsing]
- ["Toggle movement tracking" image-dired-toggle-movement-tracking
- :style toggle
- :selected image-dired-track-movement]
- "---"
- ["Jump to thumbnail buffer" image-dired-jump-thumbnail-buffer]
- ["Mark tagged files" image-dired-mark-tagged-files]
- ["Comment files" image-dired-dired-comment-files]
- ["Copy with EXIF file name" image-dired-copy-with-exif-file-name]))
-
-;;;###autoload
-(define-minor-mode image-dired-minor-mode
- "Setup easy-to-use keybindings for the commands to be used in Dired mode.
-Note that n, p and <down> and <up> will be hijacked and bound to
-`image-dired-dired-next-line' and `image-dired-dired-previous-line'."
- :keymap image-dired-minor-mode-map)
-
-(declare-function clear-image-cache "image.c" (&optional filter))
-
-(defun image-dired-create-thumbs (&optional arg)
- "Create thumbnail images for all marked files in Dired.
-With prefix argument ARG, create thumbnails even if they already exist
-\(i.e. use this to refresh your thumbnails)."
- (interactive "P")
- (let (thumb-name)
- (dolist (curr-file (dired-get-marked-files))
- (setq thumb-name (image-dired-thumb-name curr-file))
- ;; If the user overrides the exist check, we must clear the
- ;; image cache so that if the user wants to display the
- ;; thumbnail, it is not fetched from cache.
- (when arg
- (clear-image-cache (expand-file-name thumb-name)))
- (when (or (not (file-exists-p thumb-name))
- arg)
- (image-dired-create-thumb curr-file thumb-name)))))
-
;;; Slideshow
@@ -1844,22 +1014,10 @@ With a negative prefix argument, prompt user for the delay."
(when (= (following-char) ?\s)
(delete-char 1))))
-;;;###autoload
-(defun image-dired-display-thumbs-append ()
- "Append thumbnails to `image-dired-thumbnail-buffer'."
- (interactive)
- (image-dired-display-thumbs nil t t))
-
-;;;###autoload
-(defun image-dired-display-thumb ()
- "Shorthand for `image-dired-display-thumbs' with prefix argument."
- (interactive)
- (image-dired-display-thumbs t nil t))
-
(defun image-dired-line-up ()
"Line up thumbnails according to `image-dired-thumbs-per-row'.
See also `image-dired-line-up-dynamic'."
- (interactive)
+ (interactive nil image-dired-thumbnail-mode)
(let ((inhibit-read-only t))
(goto-char (point-min))
(while (and (not (image-dired-image-at-point-p))
@@ -1886,7 +1044,7 @@ See also `image-dired-line-up-dynamic'."
(insert (propertize " " 'display `(space :align-to ,thumb-prev-pos)))
(cl-incf seen)
(when (and (= seen (- image-dired-thumbs-per-row 1))
- (not (eobp)))
+ (not (eobp)))
(forward-char)
(insert "\n")
(setq seen 0)
@@ -1896,21 +1054,21 @@ See also `image-dired-line-up-dynamic'."
(defun image-dired-line-up-dynamic ()
"Line up thumbnails images dynamically.
Calculate how many thumbnails fit."
- (interactive)
+ (interactive nil image-dired-thumbnail-mode)
(let* ((char-width (frame-char-width))
- (width (image-dired-window-width-pixels (image-dired-thumbnail-window)))
- (image-dired-thumbs-per-row
- (/ width
- (+ (* 2 image-dired-thumb-relief)
- (* 2 image-dired-thumb-margin)
- (image-dired-thumb-size 'width)
- char-width))))
+ (width (window-body-width (image-dired-thumbnail-window) t))
+ (image-dired-thumbs-per-row
+ (/ width
+ (+ (* 2 image-dired-thumb-relief)
+ (* 2 image-dired-thumb-margin)
+ (image-dired-thumb-size 'width)
+ char-width))))
(image-dired-line-up)))
(defun image-dired-line-up-interactive ()
"Line up thumbnails interactively.
Ask user how many thumbnails should be displayed per row."
- (interactive)
+ (interactive nil image-dired-thumbnail-mode)
(let ((image-dired-thumbs-per-row
(string-to-number (read-string "How many thumbs per row: "))))
(if (not (> image-dired-thumbs-per-row 0))
@@ -1919,7 +1077,7 @@ Ask user how many thumbnails should be displayed per row."
(defun image-dired-thumbnail-display-external ()
"Display original image for thumbnail at point using external viewer."
- (interactive)
+ (interactive nil image-dired-thumbnail-mode)
(let ((file (image-dired-original-file-name)))
(if (not (image-dired-image-at-point-p))
(message "No thumbnail at point")
@@ -1928,43 +1086,6 @@ Ask user how many thumbnails should be displayed per row."
(start-process "image-dired-thumb-external" nil
image-dired-external-viewer file)))))
-;;;###autoload
-(defun image-dired-dired-display-external ()
- "Display file at point using an external viewer."
- (interactive)
- (let ((file (dired-get-filename)))
- (start-process "image-dired-external" nil
- image-dired-external-viewer file)))
-
-(defun image-dired-window-width-pixels (window)
- "Calculate WINDOW width in pixels."
- (* (window-width window) (frame-char-width)))
-
-(defun image-dired-display-window ()
- "Return window where `image-dired-display-image-buffer' is visible."
- (get-window-with-predicate
- (lambda (window)
- (equal (buffer-name (window-buffer window)) image-dired-display-image-buffer))
- nil t))
-
-(defun image-dired-thumbnail-window ()
- "Return window where `image-dired-thumbnail-buffer' is visible."
- (get-window-with-predicate
- (lambda (window)
- (equal (buffer-name (window-buffer window)) image-dired-thumbnail-buffer))
- nil t))
-
-(defun image-dired-associated-dired-buffer-window ()
- "Return window where associated Dired buffer is visible."
- (let (buf)
- (if (image-dired-image-at-point-p)
- (progn
- (setq buf (image-dired-associated-dired-buffer))
- (get-window-with-predicate
- (lambda (window)
- (equal (window-buffer window) buf))))
- (error "No thumbnail image at point"))))
-
(defun image-dired-display-image (file &optional _ignored)
"Display image FILE in image buffer.
Use this when you want to display the image, in a new window.
@@ -1988,7 +1109,7 @@ based on `image-mode'."
"Display current thumbnail's original image in display buffer.
See documentation for `image-dired-display-image' for more information.
With prefix argument ARG, display image in its original size."
- (interactive "P")
+ (interactive "P" image-dired-thumbnail-mode)
(let ((file (image-dired-original-file-name)))
(if (not (string-equal major-mode "image-dired-thumbnail-mode"))
(message "Not in image-dired-thumbnail-mode")
@@ -1998,63 +1119,13 @@ With prefix argument ARG, display image in its original size."
(message "No original file name found")
(image-dired-display-image file arg))))))
-
-;;;###autoload
-(defun image-dired-dired-display-image (&optional arg)
- "Display current image file.
-See documentation for `image-dired-display-image' for more information.
-With prefix argument ARG, display image in its original size."
- (interactive "P")
- (image-dired-display-image (dired-get-filename) arg))
-
-(defun image-dired-image-at-point-p ()
- "Return non-nil if there is an `image-dired' thumbnail at point."
- (get-text-property (point) 'image-dired-thumbnail))
-
-(defun image-dired-refresh-thumb ()
- "Force creation of new image for current thumbnail."
- (interactive nil image-dired-thumbnail-mode)
- (let* ((file (image-dired-original-file-name))
- (thumb (expand-file-name (image-dired-thumb-name file))))
- (clear-image-cache (expand-file-name thumb))
- (image-dired-create-thumb file thumb)))
-
-(defun image-dired-rotate-original (degrees)
- "Rotate original image DEGREES degrees."
- (image-dired--check-executable-exists
- 'image-dired-cmd-rotate-original-program)
- (if (not (image-dired-image-at-point-p))
- (message "No image at point")
- (let* ((file (image-dired-original-file-name))
- (spec
- (list
- (cons ?d degrees)
- (cons ?o (expand-file-name file))
- (cons ?t image-dired-temp-rotate-image-file))))
- (unless (eq 'jpeg (image-type file))
- (user-error "Only JPEG images can be rotated"))
- (if (not (= 0 (apply #'call-process image-dired-cmd-rotate-original-program
- nil nil nil
- (mapcar (lambda (arg) (format-spec arg spec))
- image-dired-cmd-rotate-original-options))))
- (error "Could not rotate image")
- (image-dired-display-image image-dired-temp-rotate-image-file)
- (if (or (and image-dired-rotate-original-ask-before-overwrite
- (y-or-n-p
- "Rotate to temp file OK. Overwrite original image? "))
- (not image-dired-rotate-original-ask-before-overwrite))
- (progn
- (copy-file image-dired-temp-rotate-image-file file t)
- (image-dired-refresh-thumb))
- (image-dired-display-image file))))))
-
(defun image-dired-rotate-original-left ()
"Rotate original image left (counter clockwise) 90 degrees.
The result of the rotation is displayed in the image display area
and a confirmation is needed before the original image files is
overwritten. This confirmation can be turned off using
`image-dired-rotate-original-ask-before-overwrite'."
- (interactive)
+ (interactive nil image-dired-thumbnail-mode)
(image-dired-rotate-original "270"))
(defun image-dired-rotate-original-right ()
@@ -2063,94 +1134,9 @@ The result of the rotation is displayed in the image display area
and a confirmation is needed before the original image files is
overwritten. This confirmation can be turned off using
`image-dired-rotate-original-ask-before-overwrite'."
- (interactive)
+ (interactive nil image-dired-thumbnail-mode)
(image-dired-rotate-original "90"))
-
-;;; EXIF support
-
-(defun image-dired-get-exif-file-name (file)
- "Use the image's EXIF information to return a unique file name.
-The file name should be unique as long as you do not take more than
-one picture per second. The original file name is suffixed at the end
-for traceability. The format of the returned file name is
-YYYY_MM_DD_HH_MM_DD_ORIG_FILE_NAME.jpg. Used from
-`image-dired-copy-with-exif-file-name'."
- (let (data no-exif-data-found)
- (if (not (eq 'jpeg (image-type (expand-file-name file))))
- (setq no-exif-data-found t
- data (format-time-string
- "%Y:%m:%d %H:%M:%S"
- (file-attribute-modification-time
- (file-attributes (expand-file-name file)))))
- (setq data (exif-field 'date-time (exif-parse-file
- (expand-file-name file)))))
- (while (string-match "[ :]" data)
- (setq data (replace-match "_" nil nil data)))
- (format "%s%s%s" data
- (if no-exif-data-found
- "_noexif_"
- "_")
- (file-name-nondirectory file))))
-
-(defun image-dired-thumbnail-set-image-description ()
- "Set the ImageDescription EXIF tag for the original image.
-If the image already has a value for this tag, it is used as the
-default value at the prompt."
- (interactive)
- (if (not (image-dired-image-at-point-p))
- (message "No thumbnail at point")
- (let* ((file (image-dired-original-file-name))
- (old-value (or (exif-field 'description (exif-parse-file file)) "")))
- (if (eq 0
- (image-dired-set-exif-data file "ImageDescription"
- (read-string "Value of ImageDescription: "
- old-value)))
- (message "Successfully wrote ImageDescription tag")
- (error "Could not write ImageDescription tag")))))
-
-(defun image-dired-set-exif-data (file tag-name tag-value)
- "In FILE, set EXIF tag TAG-NAME to value TAG-VALUE."
- (image-dired--check-executable-exists
- 'image-dired-cmd-write-exif-data-program)
- (let ((spec
- (list
- (cons ?f (expand-file-name file))
- (cons ?t tag-name)
- (cons ?v tag-value))))
- (apply #'call-process image-dired-cmd-write-exif-data-program nil nil nil
- (mapcar (lambda (arg) (format-spec arg spec))
- image-dired-cmd-write-exif-data-options))))
-
-(defun image-dired-copy-with-exif-file-name ()
- "Copy file with unique name to main image directory.
-Copy current or all marked files in Dired to a new file in your
-main image directory, using a file name generated by
-`image-dired-get-exif-file-name'. A typical usage for this if when
-copying images from a digital camera into the image directory.
-
- Typically, you would open up the folder with the incoming
-digital images, mark the files to be copied, and execute this
-function. The result is a couple of new files in
-`image-dired-main-image-directory' called
-2005_05_08_12_52_00_dscn0319.jpg,
-2005_05_08_14_27_45_dscn0320.jpg etc."
- (interactive)
- (let (new-name
- (files (dired-get-marked-files)))
- (mapc
- (lambda (curr-file)
- (setq new-name
- (format "%s/%s"
- (file-name-as-directory
- (expand-file-name image-dired-main-image-directory))
- (image-dired-get-exif-file-name curr-file)))
- (message "Copying %s to %s" curr-file new-name)
- (copy-file curr-file new-name))
- files)))
-
-;;; Thumbnail mode (cont.)
-
(defun image-dired-display-next-thumbnail-original (&optional arg)
"Move to the next image in the thumbnail buffer and display it.
With prefix ARG, move that many thumbnails."
@@ -2168,136 +1154,15 @@ With prefix ARG, move that many thumbnails."
;;; Image Comments
-(defun image-dired-write-comments (file-comments)
- "Write file comments to database.
-Write file comments to one or more files.
-FILE-COMMENTS is an alist on the following form:
- ((FILE . COMMENT) ... )"
- (image-dired-sane-db-file)
- (let (end comment-beg-pos comment-end-pos file comment)
- (image-dired--with-db-file
- (setq buffer-file-name image-dired-db-file)
- (dolist (elt file-comments)
- (setq file (car elt)
- comment (cdr elt))
- (goto-char (point-min))
- (if (search-forward-regexp (format "^%s.*$" file) nil t)
- (progn
- (setq end (point))
- (beginning-of-line)
- ;; Delete old comment, if any
- (when (search-forward ";comment:" end t)
- (setq comment-beg-pos (match-beginning 0))
- ;; Any tags after the comment?
- (if (search-forward ";" end t)
- (setq comment-end-pos (- (point) 1))
- (setq comment-end-pos end))
- ;; Delete comment tag and comment
- (delete-region comment-beg-pos comment-end-pos))
- ;; Insert new comment
- (beginning-of-line)
- (unless (search-forward ";" end t)
- (end-of-line)
- (insert ";"))
- (insert (format "comment:%s;" comment)))
- ;; File does not exist in database - add it.
- (goto-char (point-max))
- (insert (format "%s;comment:%s\n" file comment))))
- (save-buffer))))
-
-(defun image-dired-update-property (prop value)
- "Update text property PROP with value VALUE at point."
- (let ((inhibit-read-only t))
- (put-text-property
- (point) (1+ (point))
- prop
- value)))
-
-;;;###autoload
-(defun image-dired-dired-comment-files ()
- "Add comment to current or marked files in Dired."
- (interactive)
- (let ((comment (image-dired-read-comment)))
- (image-dired-write-comments
- (mapcar
- (lambda (curr-file)
- (cons curr-file comment))
- (dired-get-marked-files)))))
-
(defun image-dired-comment-thumbnail ()
"Add comment to current thumbnail in thumbnail buffer."
- (interactive)
+ (interactive nil image-dired-comment-thumbnail image-dired-display-image-mode)
(let* ((file (image-dired-original-file-name))
(comment (image-dired-read-comment file)))
(image-dired-write-comments (list (cons file comment)))
(image-dired-update-property 'comment comment))
(image-dired-update-header-line))
-(defun image-dired-read-comment (&optional file)
- "Read comment for an image.
-Optionally use old comment from FILE as initial value."
- (let ((comment
- (read-string
- "Comment: "
- (if file (image-dired-get-comment file)))))
- comment))
-
-(defun image-dired-get-comment (file)
- "Get comment for file FILE."
- (image-dired-sane-db-file)
- (image-dired--with-db-file
- (let (end comment-beg-pos comment-end-pos comment)
- (when (search-forward-regexp (format "^%s" file) nil t)
- (end-of-line)
- (setq end (point))
- (beginning-of-line)
- (when (search-forward ";comment:" end t)
- (setq comment-beg-pos (point))
- (if (search-forward ";" end t)
- (setq comment-end-pos (- (point) 1))
- (setq comment-end-pos end))
- (setq comment (buffer-substring
- comment-beg-pos comment-end-pos))))
- comment)))
-
-;;;###autoload
-(defun image-dired-mark-tagged-files (regexp)
- "Use REGEXP to mark files with matching tag.
-A `tag' is a keyword, a piece of meta data, associated with an
-image file and stored in image-dired's database file. This command
-lets you input a regexp and this will be matched against all tags
-on all image files in the database file. The files that have a
-matching tag will be marked in the Dired buffer."
- (interactive "sMark tagged files (regexp): ")
- (image-dired-sane-db-file)
- (let ((hits 0)
- files)
- (image-dired--with-db-file
- ;; Collect matches
- (while (search-forward-regexp "\\(^[^;\n]+\\);\\(.*\\)" nil t)
- (let ((file (match-string 1))
- (tags (split-string (match-string 2) ";")))
- (when (seq-find (lambda (tag)
- (string-match-p regexp tag))
- tags)
- (push file files)))))
- ;; Mark files
- (dolist (curr-file files)
- ;; I tried using `dired-mark-files-regexp' but it was waaaay to
- ;; slow. Don't bother about hits found in other directories
- ;; than the current one.
- (when (string= (file-name-as-directory
- (expand-file-name default-directory))
- (file-name-as-directory
- (file-name-directory curr-file)))
- (setq curr-file (file-name-nondirectory curr-file))
- (goto-char (point-min))
- (when (search-forward-regexp (format "\\s %s$" curr-file) nil t)
- (setq hits (+ hits 1))
- (dired-mark 1))))
- (message "%d files with matching tag marked" hits)))
-
-
;;; Mouse support
@@ -2313,7 +1178,7 @@ non-nil."
(let ((file (image-dired-original-file-name)))
(when file
(if image-dired-track-movement
- (image-dired-track-original-file))
+ (image-dired-track-original-file))
(image-dired-display-image file))))
(defun image-dired-mouse-select-thumbnail (event)
@@ -2353,7 +1218,9 @@ for deletion instead."
(defun image-dired-delete-marked ()
"Delete current or marked thumbnails and associated images."
- (interactive)
+ (interactive nil image-dired-thumbnail-mode)
+ (unless (derived-mode-p 'image-dired-thumbnail-mode)
+ (user-error "Not in `image-dired-thumbnail-mode'"))
(image-dired--with-marked
(image-dired-delete-char)
(unless (bobp)
@@ -2408,362 +1275,6 @@ Track this in associated Dired buffer if
(image-dired-mouse-toggle-mark-1))
(image-dired-thumb-update-marks))
-(defun image-dired-dired-display-properties ()
- "Display properties for Dired file in the echo area."
- (interactive)
- (let* ((file (dired-get-filename))
- (file-name (file-name-nondirectory file))
- (dired-buf (buffer-name (current-buffer)))
- (props (mapconcat #'identity (image-dired-list-tags file) ", "))
- (comment (image-dired-get-comment file))
- (message-log-max nil))
- (if file-name
- (message "%s"
- (image-dired-format-properties-string
- dired-buf
- file-name
- props
- comment)))))
-
-
-
-;;; Gallery support
-
-;; TODO:
-;; * Support gallery creation when using per-directory thumbnail
-;; storage.
-;; * Enhanced gallery creation with basic CSS-support and pagination
-;; of tag pages with many pictures.
-
-(defgroup image-dired-gallery nil
- "Image-Dired support for generating a HTML gallery."
- :prefix "image-dired-"
- :group 'image-dired
- :version "29.1")
-
-(defcustom image-dired-gallery-dir
- (expand-file-name ".image-dired_gallery" image-dired-dir)
- "Directory to store generated gallery html pages.
-The name of this directory needs to be \"shared\" to the public
-so that it can access the index.html page that image-dired creates."
- :type 'directory)
-
-(defcustom image-dired-gallery-image-root-url
- "https://example.org/image-diredpics"
- "URL where the full size images are to be found on your web server.
-Note that this URL has to be configured on your web server.
-Image-Dired expects to find pictures in this directory.
-This is used by `image-dired-gallery-generate'."
- :type 'string
- :version "29.1")
-
-(defcustom image-dired-gallery-thumb-image-root-url
- "https://example.org/image-diredthumbs"
- "URL where the thumbnail images are to be found on your web server.
-Note that URL path has to be configured on your web server.
-Image-Dired expects to find pictures in this directory.
-This is used by `image-dired-gallery-generate'."
- :type 'string
- :version "29.1")
-
-(defcustom image-dired-gallery-hidden-tags
- (list "private" "hidden" "pending")
- "List of \"hidden\" tags.
-Used by `image-dired-gallery-generate' to leave out \"hidden\" images."
- :type '(repeat string))
-
-(defvar image-dired-tag-file-list nil
- "List to store tag-file structure.")
-
-(defvar image-dired-file-tag-list nil
- "List to store file-tag structure.")
-
-(defvar image-dired-file-comment-list nil
- "List to store file comments.")
-
-(defun image-dired--add-to-tag-file-lists (tag file)
- "Helper function used from `image-dired--create-gallery-lists'.
-
-Add TAG to FILE in one list and FILE to TAG in the other.
-
-Lisp structures look like the following:
-
-image-dired-file-tag-list:
-
- ((\"filename1\" \"tag1\" \"tag2\" \"tag3\" ...)
- (\"filename2\" \"tag1\" \"tag2\" \"tag3\" ...)
- ...)
-
-image-dired-tag-file-list:
-
- ((\"tag1\" \"filename1\" \"filename2\" \"filename3\" ...)
- (\"tag2\" \"filename1\" \"filename2\" \"filename3\" ...)
- ...)"
- ;; Add tag to file list
- (let (curr)
- (if image-dired-file-tag-list
- (if (setq curr (assoc file image-dired-file-tag-list))
- (setcdr curr (cons tag (cdr curr)))
- (setcdr image-dired-file-tag-list
- (cons (list file tag) (cdr image-dired-file-tag-list))))
- (setq image-dired-file-tag-list (list (list file tag))))
- ;; Add file to tag list
- (if image-dired-tag-file-list
- (if (setq curr (assoc tag image-dired-tag-file-list))
- (if (not (member file curr))
- (setcdr curr (cons file (cdr curr))))
- (setcdr image-dired-tag-file-list
- (cons (list tag file) (cdr image-dired-tag-file-list))))
- (setq image-dired-tag-file-list (list (list tag file))))))
-
-(defun image-dired--add-to-file-comment-list (file comment)
- "Helper function used from `image-dired--create-gallery-lists'.
-
-For FILE, add COMMENT to list.
-
-Lisp structure looks like the following:
-
-image-dired-file-comment-list:
-
- ((\"filename1\" . \"comment1\")
- (\"filename2\" . \"comment2\")
- ...)"
- (if image-dired-file-comment-list
- (if (not (assoc file image-dired-file-comment-list))
- (setcdr image-dired-file-comment-list
- (cons (cons file comment)
- (cdr image-dired-file-comment-list))))
- (setq image-dired-file-comment-list (list (cons file comment)))))
-
-(defun image-dired--create-gallery-lists ()
- "Create temporary lists used by `image-dired-gallery-generate'."
- (image-dired-sane-db-file)
- (image-dired--with-db-file
- (let (end beg file row-tags)
- (setq image-dired-tag-file-list nil)
- (setq image-dired-file-tag-list nil)
- (setq image-dired-file-comment-list nil)
- (goto-char (point-min))
- (while (search-forward-regexp "^." nil t)
- (end-of-line)
- (setq end (point))
- (beginning-of-line)
- (setq beg (point))
- (unless (search-forward ";" end nil)
- (error "Something is really wrong, check format of database"))
- (setq row-tags (split-string
- (buffer-substring beg end) ";"))
- (setq file (car row-tags))
- (dolist (x (cdr row-tags))
- (if (not (string-match "^comment:\\(.*\\)" x))
- (image-dired--add-to-tag-file-lists x file)
- (image-dired--add-to-file-comment-list file (match-string 1 x)))))))
- ;; Sort tag-file list
- (setq image-dired-tag-file-list
- (sort image-dired-tag-file-list
- (lambda (x y)
- (string< (car x) (car y))))))
-
-(defun image-dired--hidden-p (file)
- "Return t if image FILE has a \"hidden\" tag."
- (cl-loop for tag in (cdr (assoc file image-dired-file-tag-list))
- if (member tag image-dired-gallery-hidden-tags) return t))
-
-(defun image-dired-gallery-generate ()
- "Generate gallery pages.
-First we create a couple of Lisp structures from the database to make
-it easier to generate, then HTML-files are created in
-`image-dired-gallery-dir'."
- (interactive)
- (if (eq 'per-directory image-dired-thumbnail-storage)
- (error "Currently, gallery generation is not supported \
-when using per-directory thumbnail file storage"))
- (image-dired--create-gallery-lists)
- (let ((tags image-dired-tag-file-list)
- (index-file (format "%s/index.html" image-dired-gallery-dir))
- count tag tag-file
- comment file-tags tag-link tag-link-list)
- ;; Make sure gallery root exist
- (if (file-exists-p image-dired-gallery-dir)
- (if (not (file-directory-p image-dired-gallery-dir))
- (error "Variable image-dired-gallery-dir is not a directory"))
- ;; FIXME: Should we set umask to 077 here, as we do for thumbnails?
- (make-directory image-dired-gallery-dir))
- ;; Open index file
- (with-temp-file index-file
- (if (file-exists-p index-file)
- (insert-file-contents index-file))
- (insert "<html>\n")
- (insert " <body>\n")
- (insert " <h2>Image-Dired Gallery</h2>\n")
- (insert (format "<p>\n Gallery generated %s\n <p>\n"
- (current-time-string)))
- (insert " <h3>Tag index</h3>\n")
- (setq count 1)
- ;; Pre-generate list of all tag links
- (dolist (curr tags)
- (setq tag (car curr))
- (when (not (member tag image-dired-gallery-hidden-tags))
- (setq tag-link (format "<a href=\"%d.html\">%s</a>" count tag))
- (if tag-link-list
- (setq tag-link-list
- (append tag-link-list (list (cons tag tag-link))))
- (setq tag-link-list (list (cons tag tag-link))))
- (setq count (1+ count))))
- (setq count 1)
- ;; Main loop where we generated thumbnail pages per tag
- (dolist (curr tags)
- (setq tag (car curr))
- ;; Don't display hidden tags
- (when (not (member tag image-dired-gallery-hidden-tags))
- ;; Insert link to tag page in index
- (insert (format " %s<br>\n" (cdr (assoc tag tag-link-list))))
- ;; Open per-tag file
- (setq tag-file (format "%s/%s.html" image-dired-gallery-dir count))
- (with-temp-file tag-file
- (if (file-exists-p tag-file)
- (insert-file-contents tag-file))
- (erase-buffer)
- (insert "<html>\n")
- (insert " <body>\n")
- (insert " <p><a href=\"index.html\">Index</a></p>\n")
- (insert (format " <h2>Images with tag &quot;%s&quot;</h2>" tag))
- ;; Main loop for files per tag page
- (dolist (file (cdr curr))
- (unless (image-dired-hidden-p file)
- ;; Insert thumbnail with link to full image
- (insert
- (format "<a href=\"%s/%s\"><img src=\"%s/%s\"%s></a>\n"
- image-dired-gallery-image-root-url
- (file-name-nondirectory file)
- image-dired-gallery-thumb-image-root-url
- (file-name-nondirectory (image-dired-thumb-name file)) file))
- ;; Insert comment, if any
- (if (setq comment (cdr (assoc file image-dired-file-comment-list)))
- (insert (format "<br>\n%s<br>\n" comment))
- (insert "<br>\n"))
- ;; Insert links to other tags, if any
- (when (> (length
- (setq file-tags (assoc file image-dired-file-tag-list))) 2)
- (insert "[ ")
- (dolist (extra-tag file-tags)
- ;; Only insert if not file name or the main tag
- (if (and (not (equal extra-tag tag))
- (not (equal extra-tag file)))
- (insert
- (format "%s " (cdr (assoc extra-tag tag-link-list))))))
- (insert "]<br>\n"))))
- (insert " <p><a href=\"index.html\">Index</a></p>\n")
- (insert " </body>\n")
- (insert "</html>\n"))
- (setq count (1+ count))))
- (insert " </body>\n")
- (insert "</html>"))))
-
-
-;;; Tag support
-
-(defvar image-dired-widget-list nil
- "List to keep track of meta data in edit buffer.")
-
-(declare-function widget-forward "wid-edit" (arg))
-
-;;;###autoload
-(defun image-dired-dired-edit-comment-and-tags ()
- "Edit comment and tags of current or marked image files.
-Edit comment and tags for all marked image files in an
-easy-to-use form."
- (interactive)
- (setq image-dired-widget-list nil)
- ;; Setup buffer.
- (let ((files (dired-get-marked-files)))
- (pop-to-buffer-same-window "*Image-Dired Edit Meta Data*")
- (kill-all-local-variables)
- (let ((inhibit-read-only t))
- (erase-buffer))
- (remove-overlays)
- ;; Some help for the user.
- (widget-insert
-"\nEdit comments and tags for each image. Separate multiple tags
-with a comma. Move forward between fields using TAB or RET.
-Move to the previous field using backtab (S-TAB). Save by
-activating the Save button at the bottom of the form or cancel
-the operation by activating the Cancel button.\n\n")
- ;; Here comes all images and a comment and tag field for each
- ;; image.
- (let (thumb-file img comment-widget tag-widget)
-
- (dolist (file files)
-
- (setq thumb-file (image-dired-thumb-name file)
- img (create-image thumb-file))
-
- (insert-image img)
- (widget-insert "\n\nComment: ")
- (setq comment-widget
- (widget-create 'editable-field
- :size 60
- :format "%v "
- :value (or (image-dired-get-comment file) "")))
- (widget-insert "\nTags: ")
- (setq tag-widget
- (widget-create 'editable-field
- :size 60
- :format "%v "
- :value (or (mapconcat
- #'identity
- (image-dired-list-tags file)
- ",") "")))
- ;; Save information in all widgets so that we can use it when
- ;; the user saves the form.
- (setq image-dired-widget-list
- (append image-dired-widget-list
- (list (list file comment-widget tag-widget))))
- (widget-insert "\n\n")))
-
- ;; Footer with Save and Cancel button.
- (widget-insert "\n")
- (widget-create 'push-button
- :notify
- (lambda (&rest _ignore)
- (image-dired-save-information-from-widgets)
- (bury-buffer)
- (message "Done"))
- "Save")
- (widget-insert " ")
- (widget-create 'push-button
- :notify
- (lambda (&rest _ignore)
- (bury-buffer)
- (message "Operation canceled"))
- "Cancel")
- (widget-insert "\n")
- (use-local-map widget-keymap)
- (widget-setup)
- ;; Jump to the first widget.
- (widget-forward 1)))
-
-(defun image-dired-save-information-from-widgets ()
- "Save information found in `image-dired-widget-list'.
-Use the information in `image-dired-widget-list' to save comments and
-tags to their respective image file. Internal function used by
-`image-dired-dired-edit-comment-and-tags'."
- (let (file comment tag-string tag-list lst)
- (image-dired-write-comments
- (mapcar
- (lambda (widget)
- (setq file (car widget)
- comment (widget-value (cadr widget)))
- (cons file comment))
- image-dired-widget-list))
- (image-dired-write-tags
- (dolist (widget image-dired-widget-list lst)
- (setq file (car widget)
- tag-string (widget-value (car (cddr widget)))
- tag-list (split-string tag-string ","))
- (dolist (tag tag-list)
- (push (cons file tag) lst))))))
-
;;; bookmark.el support
@@ -2857,7 +1368,7 @@ completely fit)."
(defun image-dired-display-window-width (window)
"Return width, in pixels, of WINDOW."
(declare (obsolete nil "29.1"))
- (- (image-dired-window-width-pixels window)
+ (- (window-body-width window t)
image-dired-display-window-width-correction))
(defun image-dired-display-window-height (window)
@@ -2870,7 +1381,7 @@ completely fit)."
"Calculate WINDOW height in pixels."
(declare (obsolete nil "29.1"))
;; Note: The mode-line consumes one line
- (* (- (window-height window) 1) (frame-char-height)))
+ (* (- (window-height window) 1) (frame-char-height)))
(defcustom image-dired-cmd-read-exif-data-program "exiftool"
"Program used to read EXIF data to image.
@@ -2953,14 +1464,14 @@ of the thumbnail file."
(defun image-dired-rotate-thumbnail-left ()
"Rotate thumbnail left (counter clockwise) 90 degrees."
(declare (obsolete image-dired-refresh-thumb "29.1"))
- (interactive)
+ (interactive nil image-dired-thumbnail-mode)
(with-suppressed-warnings ((obsolete image-dired-rotate-thumbnail))
(image-dired-rotate-thumbnail "270")))
(defun image-dired-rotate-thumbnail-right ()
"Rotate thumbnail counter right (clockwise) 90 degrees."
(declare (obsolete image-dired-refresh-thumb "29.1"))
- (interactive)
+ (interactive nil image-dired-thumbnail-mode)
(with-suppressed-warnings ((obsolete image-dired-rotate-thumbnail))
(image-dired-rotate-thumbnail "90")))
@@ -2974,7 +1485,7 @@ Dired."
(dired-buf (image-dired-associated-dired-buffer)))
(if (not (and dired-buf file-name))
(message "No image, or image with correct properties, at point")
- (with-current-buffer dired-buf
+ (with-current-buffer dired-buf
(message "%s" file-name)
(when (dired-goto-file file-name)
(cond ((eq command 'mark) (dired-mark 1))
@@ -3008,6 +1519,10 @@ Dired."
(image-dired-display-image file))
(error "No original file name at point"))))
+(make-obsolete-variable 'image-dired-tag-file-list nil "29.1")
+(defvar image-dired-tag-file-list nil
+ "List to store tag-file structure.")
+
(defun image-dired-add-to-tag-file-list (tag file)
"Add relation between TAG and FILE."
(declare (obsolete nil "29.1"))
@@ -3020,10 +1535,8 @@ Dired."
(cons (list tag file) (cdr image-dired-tag-file-list))))
(setq image-dired-tag-file-list (list (list tag file))))))
-(defun image-dired-display-thumb-properties ()
- "Display thumbnail properties in the echo area."
- (declare (obsolete image-dired-update-header-line "29.1"))
- (image-dired-update-header-line))
+(define-obsolete-function-alias 'image-dired-display-thumb-properties
+ #'image-dired-update-header-line "29.1")
(defvar image-dired-slideshow-count 0
"Keeping track on number of images in slideshow.")
@@ -3033,16 +1546,247 @@ Dired."
"Number of pictures to display in slideshow.")
(make-obsolete-variable 'image-dired-slideshow-times "no longer used." "29.1")
+(make-obsolete-variable 'image-dired-gallery-dir nil "29.1")
+(defcustom image-dired-gallery-dir
+ (expand-file-name ".image-dired_gallery" image-dired-dir)
+ "Directory to store generated gallery html pages.
+The name of this directory needs to be \"shared\" to the public
+so that it can access the index.html page that image-dired creates."
+ :type 'directory)
+
+(make-obsolete-variable 'image-dired-gallery-image-root-url nil "29.1")
+(defcustom image-dired-gallery-image-root-url
+ "https://example.org/image-diredpics"
+ "URL where the full size images are to be found on your web server.
+Note that this URL has to be configured on your web server.
+Image-Dired expects to find pictures in this directory.
+This is used by `image-dired-gallery-generate'."
+ :type 'string
+ :version "29.1")
+
+(make-obsolete-variable 'image-dired-gallery-thumb-image-root-url nil "29.1")
+(defcustom image-dired-gallery-thumb-image-root-url
+ "https://example.org/image-diredthumbs"
+ "URL where the thumbnail images are to be found on your web server.
+Note that URL path has to be configured on your web server.
+Image-Dired expects to find pictures in this directory.
+This is used by `image-dired-gallery-generate'."
+ :type 'string
+ :version "29.1")
+
+(make-obsolete-variable 'image-dired-gallery-hidden-tags nil "29.1")
+(defcustom image-dired-gallery-hidden-tags
+ (list "private" "hidden" "pending")
+ "List of \"hidden\" tags.
+Used by `image-dired-gallery-generate' to leave out \"hidden\" images."
+ :type '(repeat string))
+
+(make-obsolete-variable 'image-dired-file-tag-list nil "29.1")
+(defvar image-dired-file-tag-list nil
+ "List to store file-tag structure.")
+
+(make-obsolete-variable 'image-dired-file-comment-list nil "29.1")
+(defvar image-dired-file-comment-list nil
+ "List to store file comments.")
+
+(defun image-dired--add-to-tag-file-lists (tag file)
+ "Helper function used from `image-dired--create-gallery-lists'.
+
+Add TAG to FILE in one list and FILE to TAG in the other.
+
+Lisp structures look like the following:
+
+image-dired-file-tag-list:
+
+ ((\"filename1\" \"tag1\" \"tag2\" \"tag3\" ...)
+ (\"filename2\" \"tag1\" \"tag2\" \"tag3\" ...)
+ ...)
+
+image-dired-tag-file-list:
+
+ ((\"tag1\" \"filename1\" \"filename2\" \"filename3\" ...)
+ (\"tag2\" \"filename1\" \"filename2\" \"filename3\" ...)
+ ...)"
+ (declare (obsolete nil "29.1"))
+ ;; Add tag to file list
+ (let (curr)
+ (if image-dired-file-tag-list
+ (if (setq curr (assoc file image-dired-file-tag-list))
+ (setcdr curr (cons tag (cdr curr)))
+ (setcdr image-dired-file-tag-list
+ (cons (list file tag) (cdr image-dired-file-tag-list))))
+ (setq image-dired-file-tag-list (list (list file tag))))
+ ;; Add file to tag list
+ (if image-dired-tag-file-list
+ (if (setq curr (assoc tag image-dired-tag-file-list))
+ (if (not (member file curr))
+ (setcdr curr (cons file (cdr curr))))
+ (setcdr image-dired-tag-file-list
+ (cons (list tag file) (cdr image-dired-tag-file-list))))
+ (setq image-dired-tag-file-list (list (list tag file))))))
+
+(defun image-dired--add-to-file-comment-list (file comment)
+ "Helper function used from `image-dired--create-gallery-lists'.
+
+For FILE, add COMMENT to list.
+
+Lisp structure looks like the following:
+
+image-dired-file-comment-list:
+
+ ((\"filename1\" . \"comment1\")
+ (\"filename2\" . \"comment2\")
+ ...)"
+ (declare (obsolete nil "29.1"))
+ (if image-dired-file-comment-list
+ (if (not (assoc file image-dired-file-comment-list))
+ (setcdr image-dired-file-comment-list
+ (cons (cons file comment)
+ (cdr image-dired-file-comment-list))))
+ (setq image-dired-file-comment-list (list (cons file comment)))))
+
+(defun image-dired--create-gallery-lists ()
+ "Create temporary lists used by `image-dired-gallery-generate'."
+ (declare (obsolete nil "29.1"))
+ (image-dired-sane-db-file)
+ (image-dired--with-db-file
+ (let (end beg file row-tags)
+ (setq image-dired-tag-file-list nil)
+ (setq image-dired-file-tag-list nil)
+ (setq image-dired-file-comment-list nil)
+ (goto-char (point-min))
+ (while (search-forward-regexp "^." nil t)
+ (end-of-line)
+ (setq end (point))
+ (beginning-of-line)
+ (setq beg (point))
+ (unless (search-forward ";" end nil)
+ (error "Something is really wrong, check format of database"))
+ (setq row-tags (split-string
+ (buffer-substring beg end) ";"))
+ (setq file (car row-tags))
+ (dolist (x (cdr row-tags))
+ (with-suppressed-warnings
+ ((obsolete image-dired--add-to-tag-file-lists
+ image-dired--add-to-file-comment-list))
+ (if (not (string-match "^comment:\\(.*\\)" x))
+ (image-dired--add-to-tag-file-lists x file)
+ (image-dired--add-to-file-comment-list file (match-string 1 x))))))))
+ ;; Sort tag-file list
+ (setq image-dired-tag-file-list
+ (sort image-dired-tag-file-list
+ (lambda (x y)
+ (string< (car x) (car y))))))
+
+(defun image-dired--hidden-p (file)
+ "Return t if image FILE has a \"hidden\" tag."
+ (declare (obsolete nil "29.1"))
+ (cl-loop for tag in (cdr (assoc file image-dired-file-tag-list))
+ if (member tag image-dired-gallery-hidden-tags) return t))
+
+(defun image-dired-gallery-generate ()
+ "Generate gallery pages.
+First we create a couple of Lisp structures from the database to make
+it easier to generate, then HTML-files are created in
+`image-dired-gallery-dir'."
+ (declare (obsolete nil "29.1"))
+ (interactive)
+ (if (eq 'per-directory image-dired-thumbnail-storage)
+ (error "Currently, gallery generation is not supported \
+when using per-directory thumbnail file storage"))
+ (with-suppressed-warnings ((obsolete image-dired--create-gallery-lists))
+ (image-dired--create-gallery-lists))
+ (let ((tags image-dired-tag-file-list)
+ (index-file (format "%s/index.html" image-dired-gallery-dir))
+ count tag tag-file
+ comment file-tags tag-link tag-link-list)
+ ;; Make sure gallery root exist
+ (if (file-exists-p image-dired-gallery-dir)
+ (if (not (file-directory-p image-dired-gallery-dir))
+ (error "Variable image-dired-gallery-dir is not a directory"))
+ ;; FIXME: Should we set umask to 077 here, as we do for thumbnails?
+ (make-directory image-dired-gallery-dir))
+ ;; Open index file
+ (with-temp-file index-file
+ (if (file-exists-p index-file)
+ (insert-file-contents index-file))
+ (insert "<html>\n")
+ (insert " <body>\n")
+ (insert " <h2>Image-Dired Gallery</h2>\n")
+ (insert (format "<p>\n Gallery generated %s\n <p>\n"
+ (current-time-string)))
+ (insert " <h3>Tag index</h3>\n")
+ (setq count 1)
+ ;; Pre-generate list of all tag links
+ (dolist (curr tags)
+ (setq tag (car curr))
+ (when (not (member tag image-dired-gallery-hidden-tags))
+ (setq tag-link (format "<a href=\"%d.html\">%s</a>" count tag))
+ (if tag-link-list
+ (setq tag-link-list
+ (append tag-link-list (list (cons tag tag-link))))
+ (setq tag-link-list (list (cons tag tag-link))))
+ (setq count (1+ count))))
+ (setq count 1)
+ ;; Main loop where we generated thumbnail pages per tag
+ (dolist (curr tags)
+ (setq tag (car curr))
+ ;; Don't display hidden tags
+ (when (not (member tag image-dired-gallery-hidden-tags))
+ ;; Insert link to tag page in index
+ (insert (format " %s<br>\n" (cdr (assoc tag tag-link-list))))
+ ;; Open per-tag file
+ (setq tag-file (format "%s/%s.html" image-dired-gallery-dir count))
+ (with-temp-file tag-file
+ (if (file-exists-p tag-file)
+ (insert-file-contents tag-file))
+ (erase-buffer)
+ (insert "<html>\n")
+ (insert " <body>\n")
+ (insert " <p><a href=\"index.html\">Index</a></p>\n")
+ (insert (format " <h2>Images with tag &quot;%s&quot;</h2>" tag))
+ ;; Main loop for files per tag page
+ (dolist (file (cdr curr))
+ (unless (image-dired-hidden-p file)
+ ;; Insert thumbnail with link to full image
+ (insert
+ (format "<a href=\"%s/%s\"><img src=\"%s/%s\"%s></a>\n"
+ image-dired-gallery-image-root-url
+ (file-name-nondirectory file)
+ image-dired-gallery-thumb-image-root-url
+ (file-name-nondirectory (image-dired-thumb-name file)) file))
+ ;; Insert comment, if any
+ (if (setq comment (cdr (assoc file image-dired-file-comment-list)))
+ (insert (format "<br>\n%s<br>\n" comment))
+ (insert "<br>\n"))
+ ;; Insert links to other tags, if any
+ (when (> (length
+ (setq file-tags (assoc file image-dired-file-tag-list))) 2)
+ (insert "[ ")
+ (dolist (extra-tag file-tags)
+ ;; Only insert if not file name or the main tag
+ (if (and (not (equal extra-tag tag))
+ (not (equal extra-tag file)))
+ (insert
+ (format "%s " (cdr (assoc extra-tag tag-link-list))))))
+ (insert "]<br>\n"))))
+ (insert " <p><a href=\"index.html\">Index</a></p>\n")
+ (insert " </body>\n")
+ (insert "</html>\n"))
+ (setq count (1+ count))))
+ (insert " </body>\n")
+ (insert "</html>"))))
+
(define-obsolete-function-alias 'image-dired-create-display-image-buffer
#'ignore "29.1")
(define-obsolete-function-alias 'image-dired-create-gallery-lists
- #'image-dired--create-gallery-lists "29.1")
+ 'image-dired--create-gallery-lists "29.1")
(define-obsolete-function-alias 'image-dired-add-to-file-comment-list
- #'image-dired--add-to-file-comment-list "29.1")
+ 'image-dired--add-to-file-comment-list "29.1")
(define-obsolete-function-alias 'image-dired-add-to-tag-file-lists
- #'image-dired--add-to-tag-file-lists "29.1")
+ 'image-dired--add-to-tag-file-lists "29.1")
(define-obsolete-function-alias 'image-dired-hidden-p
- #'image-dired--hidden-p "29.1")
+ 'image-dired--hidden-p "29.1")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;; TEST-SECTION ;;;;;;;;;;;
diff --git a/lisp/info.el b/lisp/info.el
index fb4c3fd7829..1a58910c3af 100644
--- a/lisp/info.el
+++ b/lisp/info.el
@@ -4451,9 +4451,12 @@ Advanced commands:
(setq buffer-read-only t)
(setq Info-tag-table-marker (make-marker))
(unless (or (display-multi-font-p)
- (coding-system-equal
- (coding-system-base (terminal-coding-system))
- 'utf-8))
+ (and (coding-system-equal
+ (coding-system-base (terminal-coding-system))
+ 'utf-8)
+ ;; The Linux console has limited character
+ ;; repertoire even when its encoding is UTF-8.
+ (not (equal (tty-type) "linux"))))
(dolist (elt info-symbols-and-replacements)
(let ((ch (car elt))
(repl (cdr elt)))
diff --git a/lisp/international/characters.el b/lisp/international/characters.el
index d6e83c81e74..245ade54e18 100644
--- a/lisp/international/characters.el
+++ b/lisp/international/characters.el
@@ -1661,12 +1661,14 @@ GROUP must be one of these symbols:
like U+2069 (PDI) and U+202B (RLE).
`variation-selectors':
Characters in the range U+FE00..U+FE0F and
- U+E0100..U+E01EF, used for selecting alternate glyph
- presentations, such as Emoji vs Text presentation, of
- the preceding character(s).
- `no-font': For GUI frames, characters for which no suitable
- font is found; for text-mode frames, characters
- that cannot be encoded by `terminal-coding-system'.
+ U+E0100..U+E01EF, used for choosing between
+ glyph variations, such as Emoji vs Text
+ presentation, of the preceding character(s).
+ `no-font': For GUI frames, characters for which no
+ suitable font is found; for text-mode frames,
+ characters that cannot be encoded by
+ `terminal-coding-system' or those for which
+ the terminal has no glyphs.
METHOD must be one of these symbols:
`zero-width': don't display.
@@ -1680,7 +1682,10 @@ METHOD must be one of these symbols:
Do not set its value directly from Lisp; the value takes effect
only via a custom `:set'
function (`update-glyphless-char-display'), which updates
-`glyphless-char-display'."
+`glyphless-char-display'.
+
+See also the `glyphless-char' face, which is used to display the
+visual representation of these characters."
:version "28.1"
:type '(alist :key-type (symbol :tag "Character Group")
:value-type (symbol :tag "Display Method"))
diff --git a/lisp/international/latin1-disp.el b/lisp/international/latin1-disp.el
index 4de1d6084fb..cb3b429957c 100644
--- a/lisp/international/latin1-disp.el
+++ b/lisp/international/latin1-disp.el
@@ -87,7 +87,7 @@ This option also treats some characters in the `mule-unicode-...'
charsets if you don't have a Unicode font with which to display them.
Setting this variable directly does not take effect;
-use either \\[customize] or the function `latin1-display'."
+use either \\[customize] or the command `latin1-display'."
:group 'latin1-display
:type 'boolean
:require 'latin1-disp
@@ -746,7 +746,7 @@ This uses the transliterations of the Lynx browser. The display isn't
changed if the display can render Unicode characters.
Setting this variable directly does not take effect;
-use either \\[customize] or the function `latin1-display'."
+use either \\[customize] or the command `latin1-display-ucs-per-lynx'."
:group 'latin1-display
:type 'boolean
:require 'latin1-disp
diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el
index 12896cc4b0e..41376425289 100644
--- a/lisp/international/mule-cmds.el
+++ b/lisp/international/mule-cmds.el
@@ -3195,7 +3195,7 @@ Defines the sorting order either by character names or their codepoints."
:group 'mule
:version "28.1")
-(defun read-char-by-name (prompt)
+(defun read-char-by-name (prompt &optional allow-single)
"Read a character by its Unicode name or hex number string.
Display PROMPT and read a string that represents a character by its
Unicode property `name' or `old-name'.
@@ -3216,7 +3216,10 @@ Accept a name like \"CIRCULATION FUNCTION\", a hexadecimal
number like \"2A10\", or a number in hash notation (e.g.,
\"#x2a10\" for hex, \"10r10768\" for decimal, or \"#o25020\" for
octal). Treat otherwise-ambiguous strings like \"BED\" (U+1F6CF)
-as names, not numbers."
+as names, not numbers.
+
+Optional arg ALLOW-SINGLE non-nil means to additionally allow
+single characters to be treated as standing for themselves."
(let* ((enable-recursive-minibuffers t)
(completion-ignore-case t)
(completion-tab-width 4)
@@ -3239,6 +3242,9 @@ as names, not numbers."
(char
(cond
((char-from-name input t))
+ ((and allow-single
+ (string-match-p "\\`.\\'" input)
+ (ignore-errors (string-to-char input))))
((string-match-p "\\`[[:xdigit:]]+\\'" input)
(ignore-errors (string-to-number input 16)))
((string-match-p "\\`#\\([bBoOxX]\\|[0-9]+[rR]\\)[0-9a-zA-Z]+\\'"
diff --git a/lisp/isearch.el b/lisp/isearch.el
index 9f1fbb14a4a..2ef35438e91 100644
--- a/lisp/isearch.el
+++ b/lisp/isearch.el
@@ -2389,8 +2389,7 @@ type \\[help-command] at that time."
(if (use-region-p) " in region" ""))
isearch-regexp)
t isearch-regexp (or delimited isearch-regexp-function) nil nil
- (if (use-region-p) (region-beginning))
- (if (use-region-p) (region-end))
+ (use-region-beginning) (use-region-end)
backward))
(and isearch-recursive-edit (exit-recursive-edit)))
diff --git a/lisp/jit-lock.el b/lisp/jit-lock.el
index be26ca55f0d..9543253cf24 100644
--- a/lisp/jit-lock.el
+++ b/lisp/jit-lock.el
@@ -45,9 +45,12 @@ Preserves the `buffer-modified-p' state of the current buffer."
:group 'font-lock)
(defcustom jit-lock-chunk-size 1500
- "Jit-lock fontifies chunks of at most this many characters at a time.
+ "Jit-lock asks to fontify chunks of at most this many characters at a time.
-This variable controls both `display-time' and stealth fontification.
+The actual size of the fontified chunk of text can be different,
+depending on what the `fontification-functions' actually decide to do.
+
+This variable controls both display-time and stealth fontifications.
The optimum value is a little over the typical number of buffer
characters which fit in a typical window."
diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el
index 07dfc23a092..b870494477c 100644
--- a/lisp/ldefs-boot.el
+++ b/lisp/ldefs-boot.el
@@ -4004,6 +4004,16 @@ FROM is for internal use. It specifies an index in the STRING
from which to start.
(fn STRING &optional LAX FROM)")
+(autoload 'describe-char-fold-equivalences "char-fold" "\
+Display characters equivalent to CHAR under character-folding.
+Prompt for CHAR (using `read-char-by-name', which see for how can
+you specify the character). With no input, i.e. when CHAR is nil,
+describe all available character equivalences of `char-fold-to-regexp'.
+Optional argument LAX (interactively, the prefix argument), if
+non-nil, means also include partially matching ligatures and
+non-canonical equivalences.
+
+(fn CHAR &optional LAX)" t)
(register-definition-prefixes "char-fold" '("char-fold-"))
@@ -5020,6 +5030,8 @@ evaluate `compilation-shell-minor-mode'.
The mode's hook is called both when the mode is enabled and when
it is disabled.
+\\{compilation-shell-minor-mode-map}
+
(fn &optional ARG)" t)
(autoload 'compilation-minor-mode "compile" "\
Toggle Compilation minor mode.
@@ -5043,6 +5055,8 @@ evaluate `compilation-minor-mode'.
The mode's hook is called both when the mode is enabled and when
it is disabled.
+\\{compilation-minor-mode-map}
+
(fn &optional ARG)" t)
(autoload 'compilation-next-error-function "compile" "\
Advance to the next error message and visit the file where the error was.
@@ -7242,6 +7256,7 @@ The mode's hook is called both when the mode is enabled and when
it is disabled.
(fn &optional ARG)" t)
+(autoload 'diff-vc-deduce-fileset "diff-mode")
(register-definition-prefixes "diff-mode" '("diff-"))
@@ -8389,7 +8404,7 @@ A second call of this function without changing point inserts the next match.
A call with prefix PREFIX reads the symbol to insert from the minibuffer with
completion.
-(fn PREFIX)" '("P"))
+(fn PREFIX)" t)
(autoload 'ebrowse-tags-loop-continue "ebrowse" "\
Repeat last operation on files in tree.
FIRST-TIME non-nil means this is not a repetition, but the first time.
@@ -9172,8 +9187,7 @@ the mode if ARG is nil, omitted, or is a positive number.
Disable the mode if ARG is a negative number.
To check whether the minor mode is enabled in the current buffer,
-evaluate `(buffer-local-value \\='electric-pair-mode
-(current-buffer))'.
+evaluate `electric-pair-mode'.
The mode's hook is called both when the mode is enabled and when
it is disabled.
@@ -9937,7 +9951,7 @@ When present, ID should be an opaque object used to identify the
connection unequivocally. This is rarely needed and not available
interactively.
-(fn &key (SERVER (erc-compute-server)) (PORT (erc-compute-port)) (NICK (erc-compute-nick)) (USER (erc-compute-user)) PASSWORD (FULL-NAME (erc-compute-full-name)) ID)" '((erc-select-read-args)))
+(fn &key (SERVER (erc-compute-server)) (PORT (erc-compute-port)) (NICK (erc-compute-nick)) (USER (erc-compute-user)) PASSWORD (FULL-NAME (erc-compute-full-name)) ID)" t)
(defalias 'erc-select #'erc)
(autoload 'erc-tls "erc" "\
ERC is a powerful, modular, and extensible IRC client.
@@ -9984,7 +9998,7 @@ symbol composed of letters from the Latin alphabet.) This option is
generally unneeded, however. See info node `(erc) Connecting' for use
cases. Not available interactively.
-(fn &key (SERVER (erc-compute-server)) (PORT (erc-compute-port)) (NICK (erc-compute-nick)) (USER (erc-compute-user)) PASSWORD (FULL-NAME (erc-compute-full-name)) CLIENT-CERTIFICATE ID)" '((let ((erc-default-port erc-default-port-tls)) (erc-select-read-args))))
+(fn &key (SERVER (erc-compute-server)) (PORT (erc-compute-port)) (NICK (erc-compute-nick)) (USER (erc-compute-user)) PASSWORD (FULL-NAME (erc-compute-full-name)) CLIENT-CERTIFICATE ID)" t)
(autoload 'erc-handle-irc-url "erc" "\
Use ERC to IRC on HOST:PORT in CHANNEL as USER with PASSWORD.
If ERC is already connected to HOST:PORT, simply /join CHANNEL.
@@ -10200,7 +10214,9 @@ it has to be wrapped in `(eval (quote ...))'.
If NAME is already defined as a test and Emacs is running
in batch mode, an error is signalled.
-(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] [:tags \\='(TAG...)] BODY...)" nil 'macro)
+(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] [:tags \\='(TAG...)] BODY...)" nil t)
+(function-put 'ert-deftest 'doc-string-elt 3)
+(function-put 'ert-deftest 'lisp-indent-function 2)
(autoload 'ert-run-tests-batch "ert" "\
Run the tests specified by SELECTOR, printing results to the terminal.
@@ -12271,6 +12287,8 @@ evaluate `flymake-mode'.
The mode's hook is called both when the mode is enabled and when
it is disabled.
+\\{flymake-mode-map}
+
(fn &optional ARG)" t)
(autoload 'flymake-mode-on "flymake" "\
Turn Flymake mode on.")
@@ -14186,7 +14204,9 @@ include it when specifying `grep-command'.
In interactive usage, the actual value of this variable is set up
by `grep-compute-defaults'; to change the default value, use
-\\[customize] or call the function `grep-apply-setting'.")
+\\[customize] or call the function `grep-apply-setting'.
+
+Also see `grep-command-position'.")
(custom-autoload 'grep-command "grep" nil)
(defvar grep-find-command nil "\
The default find command for \\[grep-find].
@@ -15394,7 +15414,9 @@ it is disabled.
(defvar hs-special-modes-alist (mapcar 'purecopy '((c-mode "{" "}" "/[*/]" nil nil) (c++-mode "{" "}" "/[*/]" nil nil) (bibtex-mode ("@\\S(*\\(\\s(\\)" 1)) (java-mode "{" "}" "/[*/]" nil nil) (js-mode "{" "}" "/[*/]" nil) (mhtml-mode "{\\|<[^/>]*?" "}\\|</[^/>]*[^/]>" "<!--" mhtml-forward nil))) "\
Alist for initializing the hideshow variables for different modes.
Each element has the form
- (MODE START END COMMENT-START FORWARD-SEXP-FUNC ADJUST-BEG-FUNC).
+ (MODE START END COMMENT-START FORWARD-SEXP-FUNC ADJUST-BEG-FUNC
+ FIND-BLOCK-BEGINNING-FUNC FIND-NEXT-BLOCK-FUNC
+ LOOKING-AT-BLOCK-START-P-FUNC).
If non-nil, hideshow will use these values as regexps to define blocks
and comments, respectively for major mode MODE.
@@ -15415,6 +15437,15 @@ cases, FORWARD-SEXP-FUNC specifies another function to use instead.
See the documentation for `hs-adjust-block-beginning' to see what is the
use of ADJUST-BEG-FUNC.
+See the documentation for `hs-find-block-beginning-func' to see
+what is the use of FIND-BLOCK-BEGINNING-FUNC.
+
+See the documentation for `hs-find-next-block-func' to see what
+is the use of FIND-NEXT-BLOCK-FUNC.
+
+See the documentation for `hs-looking-at-block-start-p-func' to
+see what is the use of LOOKING-AT-BLOCK-START-P-FUNC.
+
If any of the elements is left nil or omitted, hideshow tries to guess
appropriate values. The regexps should not contain leading or trailing
whitespace. Case does not matter.")
@@ -15871,7 +15902,8 @@ inlined into the compiled format versions. This means that if you
change its definition, you should explicitly call
`ibuffer-recompile-formats'.
-(fn SYMBOL (&key NAME INLINE PROPS SUMMARIZER) &rest BODY)" nil 'macro)
+(fn SYMBOL (&key NAME INLINE PROPS SUMMARIZER) &rest BODY)" nil t)
+(function-put 'define-ibuffer-column 'lisp-indent-function 'defun)
(autoload 'define-ibuffer-sorter "ibuf-macs" "\
Define a method of sorting named NAME.
DOCUMENTATION is the documentation of the function, which will be called
@@ -15882,7 +15914,9 @@ For sorting, the forms in BODY will be evaluated with `a' bound to one
buffer object, and `b' bound to another. BODY should return a non-nil
value if and only if `a' is \"less than\" `b'.
-(fn NAME DOCUMENTATION (&key DESCRIPTION) &rest BODY)" nil 'macro)
+(fn NAME DOCUMENTATION (&key DESCRIPTION) &rest BODY)" nil t)
+(function-put 'define-ibuffer-sorter 'lisp-indent-function 1)
+(function-put 'define-ibuffer-sorter 'doc-string-elt 2)
(autoload 'define-ibuffer-op "ibuf-macs" "\
Generate a function which operates on a buffer.
OP becomes the name of the function; if it doesn't begin with
@@ -15921,7 +15955,9 @@ BODY define the operation; they are forms to evaluate per each
marked buffer. BODY is evaluated with `buf' bound to the
buffer object.
-(fn OP ARGS DOCUMENTATION (&key INTERACTIVE MARK MODIFIER-P DANGEROUS OPSTRING ACTIVE-OPSTRING BEFORE AFTER COMPLEX) &rest BODY)" nil 'macro)
+(fn OP ARGS DOCUMENTATION (&key INTERACTIVE MARK MODIFIER-P DANGEROUS OPSTRING ACTIVE-OPSTRING BEFORE AFTER COMPLEX) &rest BODY)" nil t)
+(function-put 'define-ibuffer-op 'lisp-indent-function 2)
+(function-put 'define-ibuffer-op 'doc-string-elt 3)
(autoload 'define-ibuffer-filter "ibuf-macs" "\
Define a filter named NAME.
DOCUMENTATION is the documentation of the function.
@@ -15936,7 +15972,9 @@ not a particular buffer should be displayed or not. The forms in BODY
will be evaluated with BUF bound to the buffer object, and QUALIFIER
bound to the current value of the filter.
-(fn NAME DOCUMENTATION (&key READER DESCRIPTION) &rest BODY)" nil 'macro)
+(fn NAME DOCUMENTATION (&key READER DESCRIPTION) &rest BODY)" nil t)
+(function-put 'define-ibuffer-filter 'lisp-indent-function 2)
+(function-put 'define-ibuffer-filter 'doc-string-elt 2)
(register-definition-prefixes "ibuf-macs" '("ibuffer-"))
@@ -18468,6 +18506,15 @@ changed if the display can render Unicode characters.
Setting this variable directly does not take effect;
use either \\[customize] or the function `latin1-display'.")
(custom-autoload 'latin1-display-ucs-per-lynx "latin1-disp" nil)
+(autoload 'latin1-display-ucs-per-lynx "latin1-disp" "\
+Set up Latin-1/ASCII display for Unicode characters.
+This uses the transliterations of the Lynx browser.
+
+With argument ARG, turn such display on if ARG is positive, otherwise
+turn it off and display Unicode characters literally. The display
+isn't changed if the display can render Unicode characters.
+
+(fn ARG)" t)
(register-definition-prefixes "latin1-disp" '("latin1-display-"))
@@ -25313,6 +25360,8 @@ evaluate `rectangle-mark-mode'.
The mode's hook is called both when the mode is enabled and when
it is disabled.
+\\{rectangle-mark-mode-map}
+
(fn &optional ARG)" t)
(register-definition-prefixes "rect" '("apply-on-rectangle" "clear-rectangle-line" "delete-" "extract-rectangle-" "killed-rectangle" "ope" "rectangle-" "spaces-string" "string-rectangle-"))
@@ -31653,7 +31702,7 @@ the output buffer or changing the window configuration.
Whether Tramp is enabled.
If it is set to nil, all remote file names are used literally.")
(custom-autoload 'tramp-mode "tramp" t)
-(defconst tramp-initial-file-name-regexp "\\`/[^/:]+:[^/:]*:" "\
+(defconst tramp-initial-file-name-regexp (rx bos "/" (+ (not (any "/:"))) ":" (* (not (any "/:"))) ":") "\
Value for `tramp-file-name-regexp' for autoload.
It must match the initial `tramp-syntax' settings.")
(defvar tramp-file-name-regexp tramp-initial-file-name-regexp "\
@@ -31664,7 +31713,7 @@ initial value is overwritten by the car of `tramp-file-name-structure'.")
(defvar tramp-ignored-file-name-regexp nil "\
Regular expression matching file names that are not under Tramp's control.")
(custom-autoload 'tramp-ignored-file-name-regexp "tramp" t)
-(defconst tramp-autoload-file-name-regexp (concat "\\`/" (if (memq system-type '(cygwin windows-nt)) "\\(-\\|[^/|:]\\{2,\\}\\)" "[^/|:]+") ":") "\
+(defconst tramp-autoload-file-name-regexp (rx bos "/" (| "-" (>= 2 (not (any "/:|")))) ":") "\
Regular expression matching file names handled by Tramp autoload.
It must match the initial `tramp-syntax' settings. It should not
match file names at root of the underlying local file system,
@@ -31706,7 +31755,7 @@ It must be supported by libarchive(3).")
List of suffixes which indicate a compressed file.
It must be supported by libarchive(3).")
(defmacro tramp-archive-autoload-file-name-regexp nil "\
-Regular expression matching archive file names." '(concat "\\`" "\\(" ".+" "\\." (regexp-opt tramp-archive-suffixes) "\\(?:" "\\." (regexp-opt tramp-archive-compression-suffixes) "\\)*" "\\)" "\\(" "/" ".*" "\\)" "\\'"))
+Regular expression matching archive file names." '(rx bos (group (+ nonl) "." (regexp (regexp-opt tramp-archive-suffixes)) (32 "." (regexp (regexp-opt tramp-archive-compression-suffixes)))) (group "/" (* nonl)) eos))
(autoload 'tramp-archive-file-name-handler "tramp-archive")
(defun tramp-archive-autoload-file-name-handler (operation &rest args) "\
Load Tramp archive file name handler, and perform OPERATION." (defvar tramp-archive-autoload) (let ((default-directory temporary-file-directory) (tramp-archive-autoload tramp-archive-enabled)) (apply #'tramp-autoload-file-name-handler operation args)))
@@ -33030,9 +33079,10 @@ working revisions. With a prefix argument HISTORIC, it reads two revision
designators specifying which revisions to compare.
The optional argument NOT-URGENT non-nil means it is ok to say no to
-saving the buffer.
+saving the buffer. The optional argument FILESET can override the
+deduced fileset.
-(fn &optional HISTORIC NOT-URGENT)" t)
+(fn &optional HISTORIC NOT-URGENT FILESET)" t)
(autoload 'vc-diff-mergebase "vc" "\
Report diffs between the merge base of REV1 and REV2 revisions.
The merge base is a common ancestor between REV1 and REV2 revisions.
diff --git a/lisp/loadhist.el b/lisp/loadhist.el
index b4ed0432465..0cb02f072ea 100644
--- a/lisp/loadhist.el
+++ b/lisp/loadhist.el
@@ -171,6 +171,13 @@ unloading."
(cond
((null hist)
(defalias fun nil)
+ ;; FIXME: Arguably these properties should be applied via
+ ;; `define-symbol-prop', but most code still uses just `put'.
+ ;; FIXME: Maybe these properties should be attached to the
+ ;; function itself (as for `advertised-calling-convention')
+ ;; rather than to its symbol.
+ (if (get fun 'compiler-macro) (put fun 'compiler-macro nil))
+ (if (get fun 'gv-expander) (put fun 'gv-expander nil))
;; Override the change that `defalias' just recorded.
(put fun 'function-history nil))
((equal (car hist) loadhist-unload-filename)
diff --git a/lisp/minibuf-eldef.el b/lisp/minibuf-eldef.el
index 3f04a3e9219..ba7e68eb81d 100644
--- a/lisp/minibuf-eldef.el
+++ b/lisp/minibuf-eldef.el
@@ -64,6 +64,8 @@
:type 'boolean
:group 'minibuffer
:version "24.3")
+(make-obsolete-variable 'minibuffer-eldef-shorten-default
+ 'minibuffer-default-prompt-format "29.1")
(defvar minibuffer-default-in-prompt-regexps
(minibuffer-default--in-prompt-regexps)
diff --git a/lisp/net/ldap.el b/lisp/net/ldap.el
index 5e14589d19b..062ff05d69c 100644
--- a/lisp/net/ldap.el
+++ b/lisp/net/ldap.el
@@ -72,6 +72,9 @@ HOST is the hostname of an LDAP server (with an optional TCP port number
appended to it using a colon as a separator).
PROPn and VALn are property/value pairs describing parameters for the server.
Valid properties include:
+ `auth-source' specifies whether or not to look up, via the
+ `auth-source' library, options which are not otherwise provided
+ in this list. See `ldap-search-internal'.
`binddn' is the distinguished name of the user to bind as
(in RFC 1779 syntax).
`passwd' is the password to use for simple authentication.
@@ -91,6 +94,11 @@ Valid properties include:
(checklist :inline t
:greedy t
(list
+ :tag "Use auth-source"
+ :inline t
+ (const :tag "Use auth-source" auth-source)
+ boolean)
+ (list
:tag "Search Base"
:inline t
(const :tag "Search Base" base)
diff --git a/lisp/net/mailcap.el b/lisp/net/mailcap.el
index 469643dbca4..fd244a97b1a 100644
--- a/lisp/net/mailcap.el
+++ b/lisp/net/mailcap.el
@@ -716,27 +716,43 @@ to supply to the test."
result))))
(defun mailcap-add-mailcap-entry (major minor info &optional storage)
+ "Add handler INFO for mime type MAJOR/MINOR to STORAGE.
+
+MAJOR and MINOR should be strings. MINOR is treated as a regexp
+in later lookups, and, therefore, you may need to escape it
+appropriately.
+
+The format of INFO is described in `mailcap-mime-data'.
+
+STORAGE should be a symbol refering to a variable. The value of
+this variable should have the same format as `mailcap-mime-data'.
+STORAGE defaults to `mailcap--computed-mime-data'.
+
+None of this is enforced."
(let* ((storage (or storage 'mailcap--computed-mime-data))
- (old-major (assoc major (symbol-value storage))))
- (if (null old-major) ; New major area
- (set storage
- (cons (cons major (list (cons minor info)))
- (symbol-value storage)))
- (let ((cur-minor (assoc minor old-major)))
- (cond
- ((or (null cur-minor) ; New minor area, or
- (assq 'test info)) ; Has a test, insert at beginning
- (setcdr old-major
- (cons (cons minor info) (cdr old-major))))
- ((and (not (assq 'test info)) ; No test info, replace completely
- (not (assq 'test cur-minor))
- (equal (assq 'viewer info) ; Keep alternative viewer
- (assq 'viewer cur-minor)))
- (setcdr cur-minor info))
- (t
- (setcdr old-major
- (setcdr old-major
- (cons (cons minor info) (cdr old-major))))))))))
+ (major-entry (assoc major (symbol-value storage)))
+ (new-minor-entry (cons minor info))
+ minor-entry)
+ (cond
+ ((null major-entry)
+ ;; Add a new major entry containing the new minor entry.
+ (setf major-entry (list major new-minor-entry))
+ (push major-entry (symbol-value storage)))
+ ((and (setf minor-entry (assoc minor major-entry))
+ (not (assq 'test info))
+ (not (assq 'test minor-entry))
+ (equal (assq 'viewer info)
+ (assq 'viewer minor-entry)))
+ ;; Replace a previous MINOR entry if it and the entry to be
+ ;; added both do *not* have a ‘test’ associated in their info
+ ;; alist and both use the same ‘viewer’ command. This ignores
+ ;; other fields in the previous entryʼs info alist: they will be
+ ;; lost when the info alist in the cdr of the previous entry is
+ ;; replaced with the new INFO alist.
+ (setf (cdr minor-entry) info))
+ (t
+ ;; Add the new minor entry to the existing major entry.
+ (push new-minor-entry (cdr major-entry))))))
(defun mailcap-add (type viewer &optional test)
"Add VIEWER as a handler for TYPE.
diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el
index b38b908edb0..ab38ffa0cf9 100644
--- a/lisp/net/tramp-adb.el
+++ b/lisp/net/tramp-adb.el
@@ -278,10 +278,10 @@ arguments to pass to the OPERATION."
(name (match-string 6))
(symlink-target
(and is-symlink
- (cadr (split-string name (rx (group (| " -> " "\n"))))))))
+ (cadr (split-string name (rx (| " -> " "\n")))))))
(push (list
(if is-symlink
- (car (split-string name (rx (group (| " -> " "\n")))))
+ (car (split-string name (rx (| " -> " "\n"))))
name)
(or is-dir symlink-target)
1 ;link-count
@@ -560,10 +560,9 @@ Emacs dired can't find files."
;; (introduced in POSIX.1-2008) fails.
(tramp-adb-send-command-and-check
v (format
- (eval-when-compile
- (concat "touch -d %s %s %s 2>%s || "
- "touch -d %s %s %s 2>%s || "
- "touch -t %s %s %s"))
+ (concat "touch -d %s %s %s 2>%s || "
+ "touch -d %s %s %s 2>%s || "
+ "touch -t %s %s %s")
(format-time-string "%Y-%m-%dT%H:%M:%S.%NZ" time t)
nofollow quoted-name (tramp-get-remote-null-device v)
(format-time-string "%Y-%m-%dT%H:%M:%S" time t)
@@ -1284,11 +1283,10 @@ connection if a previous connection has died for some reason."
(tramp-message vec 5 "Checking system information")
(tramp-adb-send-command
vec
- (eval-when-compile
- (concat
- "echo \\\"`getprop ro.product.model` "
- "`getprop ro.product.version` "
- "`getprop ro.build.version.release`\\\"")))
+ (concat
+ "echo \\\"`getprop ro.product.model` "
+ "`getprop ro.product.version` "
+ "`getprop ro.build.version.release`\\\""))
(let ((old-getprop (tramp-get-connection-property vec "getprop"))
(new-getprop
(tramp-set-connection-property
diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el
index 0d931b42da4..c25d5096719 100644
--- a/lisp/net/tramp-archive.el
+++ b/lisp/net/tramp-archive.el
@@ -185,14 +185,14 @@ It must be supported by libarchive(3).")
(progn (defmacro tramp-archive-autoload-file-name-regexp ()
"Regular expression matching archive file names."
'(rx bos
- ;; \1
+ ;; This group is used in `tramp-archive-file-name-archive'.
(group
(+ nonl)
;; Default suffixes ...
"." (regexp (regexp-opt tramp-archive-suffixes))
;; ... with compression.
(? "." (regexp (regexp-opt tramp-archive-compression-suffixes))))
- ;; \2
+ ;; This group is used in `tramp-archive-file-name-localname'.
(group "/" (* nonl))
eos)))
diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el
index 6a3e60f7037..4c745092a3e 100644
--- a/lisp/net/tramp-cache.el
+++ b/lisp/net/tramp-cache.el
@@ -278,7 +278,7 @@ Remove also properties of all files in subdirectories."
This is suppressed for temporary buffers."
(save-match-data
(unless (or (null (buffer-name))
- (string-match-p (rx bos (| " " "*")) (buffer-name)))
+ (string-match-p (rx bos (| space "*")) (buffer-name)))
(let ((bfn (if (stringp (buffer-file-name))
(buffer-file-name)
default-directory))
diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el
index a7ac1352665..ad531b427a4 100644
--- a/lisp/net/tramp-cmds.el
+++ b/lisp/net/tramp-cmds.el
@@ -355,7 +355,7 @@ The remote connection identified by SOURCE is flushed by
(dir (tramp-rename-read-file-name-dir default))
(init (tramp-rename-read-file-name-init default))
(tramp-ignored-file-name-regexp
- (regexp-quote (file-remote-p source))))
+ (rx (literal (file-remote-p source)))))
(read-file-name-default
"Enter new Tramp connection: "
dir default 'confirm init #'file-directory-p)))))
@@ -466,7 +466,7 @@ For details, see `tramp-rename-files'."
(dir (tramp-rename-read-file-name-dir default))
(init (tramp-rename-read-file-name-init default))
(tramp-ignored-file-name-regexp
- (regexp-quote (file-remote-p source))))
+ (rx (literal (file-remote-p source)))))
(read-file-name-default
(format "Change Tramp connection `%s': " source)
dir default 'confirm init #'file-directory-p)))))
diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el
index 9060f37ed57..9c81bccffc9 100644
--- a/lisp/net/tramp-gvfs.el
+++ b/lisp/net/tramp-gvfs.el
@@ -316,6 +316,10 @@ It has been changed in GVFS 1.14.")
(defconst tramp-gvfs-password-anonymous-supported 16
"Operation supports anonymous users.")
+;; Since: 2.58
+(defconst tramp-gvfs-password-tcrypt 32
+ "Operation takes TCRYPT parameters.")
+
;; For the time being, we just need org.goa.Account and org.goa.Files
;; interfaces. We document the other ones, just in case.
@@ -710,11 +714,10 @@ It has been changed in GVFS 1.14.")
"unix::device")
"GVFS file attributes."))
-(eval-and-compile
- (defconst tramp-gvfs-file-attributes-with-gvfs-ls-regexp
- (rx blank (group (regexp (regexp-opt tramp-gvfs-file-attributes)))
- "=" (group (+? nonl)))
- "Regexp to parse GVFS file attributes with `gvfs-ls'."))
+(defconst tramp-gvfs-file-attributes-with-gvfs-ls-regexp
+ (rx blank (group (regexp (regexp-opt tramp-gvfs-file-attributes)))
+ "=" (group (+? nonl)))
+ "Regexp to parse GVFS file attributes with `gvfs-ls'.")
(defconst tramp-gvfs-file-attributes-with-gvfs-info-regexp
(rx bol (* blank) (group (regexp (regexp-opt tramp-gvfs-file-attributes)))
@@ -1317,7 +1320,7 @@ If FILE-SYSTEM is non-nil, return file system attributes."
(if (eq id-format 'integer)
(string-to-number
(or (cdr (assoc "unix::uid" attributes))
- (eval-when-compile (format "%s" tramp-unknown-id-integer))))
+ (number-to-string tramp-unknown-id-integer)))
(or (cdr (assoc "owner::user" attributes))
(cdr (assoc "unix::uid" attributes))
tramp-unknown-id-string)))
@@ -1325,7 +1328,7 @@ If FILE-SYSTEM is non-nil, return file system attributes."
(if (eq id-format 'integer)
(string-to-number
(or (cdr (assoc "unix::gid" attributes))
- (eval-when-compile (format "%s" tramp-unknown-id-integer))))
+ (number-to-string tramp-unknown-id-integer)))
(or (cdr (assoc "owner::group" attributes))
(cdr (assoc "unix::gid" attributes))
tramp-unknown-id-string)))
@@ -1726,7 +1729,7 @@ ID-FORMAT valid values are `string' and `integer'."
"Retrieve file name from D-Bus OBJECT-PATH."
(dbus-unescape-from-identifier
(replace-regexp-in-string
- (rx bol (* nonl) "/" (+ (not (any "/"))) eol) "\\1" object-path)))
+ (rx bol (* nonl) "/" (group (+ (not (any "/")))) eol) "\\1" object-path)))
(defun tramp-gvfs-url-host (url)
"Return the host name part of URL, a string.
diff --git a/lisp/net/tramp-integration.el b/lisp/net/tramp-integration.el
index 946f9725022..afc3e945802 100644
--- a/lisp/net/tramp-integration.el
+++ b/lisp/net/tramp-integration.el
@@ -86,7 +86,7 @@ special handling of `substitute-in-file-name'."
(defun tramp-rfn-eshadow-update-overlay-regexp ()
"An overlay covering the shadowed part of the filename."
(rx-to-string
- `(: (* (not (any ,tramp-postfix-host-format "/~"))) (or "/" "~"))))
+ `(: (* (not (any ,tramp-postfix-host-format "/~"))) (| "/" "~"))))
(defun tramp-rfn-eshadow-update-overlay ()
"Update `rfn-eshadow-overlay' to cover shadowed part of minibuffer input.
@@ -218,11 +218,11 @@ NAME must be equal to `tramp-current-connection'."
:mode 'tramp-info-lookup-mode :topic 'symbol
:regexp (rx (+ (not (any "\t\n \"'(),[]`‘’"))))
:doc-spec '(("(tramp)Function Index" nil
- (rx bol " " (+ "-") " " (* nonl) ": ")
- (rx (group (| " " eol))))
+ (rx bol space (+ "-") space (* nonl) ": ")
+ (rx (| space eol)))
("(tramp)Variable Index" nil
- (rx bol " " (+ "-") " " (* nonl) ": ")
- (rx (group (| " " eol))))))
+ (rx bol space (+ "-") space (* nonl) ": ")
+ (rx (| space eol)))))
(add-hook
'tramp-integration-unload-hook
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index 2489ac9aec9..dfb87059bdf 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -414,15 +414,13 @@ The string is used in `tramp-methods'.")
,(rx bos (literal tramp-root-id-string) eos) "su"))
(add-to-list 'tramp-default-user-alist
- `(,(rx bos (regexp (regexp-opt '("su" "sudo" "doas" "ksu"))) eos)
+ `(,(rx bos (| "su" "sudo" "doas" "ksu") eos)
nil ,tramp-root-id-string))
;; Do not add "ssh" based methods, otherwise ~/.ssh/config would be ignored.
;; Do not add "plink" based methods, they ask interactively for the user.
(add-to-list 'tramp-default-user-alist
`(,(rx bos
- (regexp
- (regexp-opt
- '("rcp" "remcp" "rsh" "telnet" "nc" "krlogin" "fcp")))
+ (| "rcp" "remcp" "rsh" "telnet" "nc" "krlogin" "fcp")
eos)
nil ,(user-login-name))))
@@ -1250,7 +1248,7 @@ component is used as the target of the symlink."
(tramp-do-file-attributes-with-perl v localname))
(t (tramp-do-file-attributes-with-ls v localname)))))))
-(defconst tramp-sunos-unames (regexp-opt '("SunOS 5.10" "SunOS 5.11"))
+(defconst tramp-sunos-unames (rx (| "SunOS 5.10" "SunOS 5.11"))
"Regexp to determine remote SunOS.")
(defun tramp-sh--quoting-style-options (vec)
@@ -4237,10 +4235,9 @@ file exists and nonzero exit status otherwise."
;; first.
(tramp-send-command
vec (format
- (eval-when-compile
- (concat
- "exec env TERM='%s' INSIDE_EMACS='%s' "
- "ENV=%s %s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s -i"))
+ (concat
+ "exec env TERM='%s' INSIDE_EMACS='%s' "
+ "ENV=%s %s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s -i")
tramp-terminal-type (tramp-inside-emacs)
(or (getenv-internal "ENV" tramp-remote-process-environment) "")
(if (stringp tramp-histfile-override)
@@ -4316,10 +4313,9 @@ file exists and nonzero exit status otherwise."
default-shell
(tramp-message
vec 2
- (eval-when-compile
- (concat
- "Couldn't find a remote shell which groks tilde "
- "expansion, using `%s'"))
+ (concat
+ "Couldn't find a remote shell which groks tilde "
+ "expansion, using `%s'")
default-shell)))
default-shell)))
@@ -4980,7 +4976,8 @@ Goes through the list `tramp-inline-compress-commands'."
string
(and
(string-match
- (rx bol (+ (not (any " #"))) " " (+ (not space)) " "
+ (rx bol (+ (not (any space "#"))) space
+ (+ (not space)) space
(group (+ (not space))) eol)
string)
(match-string 1 string))
@@ -5554,7 +5551,7 @@ Nonexistent directories are removed from spec."
(while candidates
(goto-char (point-min))
(if (string-match-p
- (rx bol (literal (car candidates))"%s" (? "\r") eol)
+ (rx bol (literal (car candidates)) (? "\r") eol)
(buffer-string))
(setq locale (car candidates)
candidates nil)
diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el
index 9e63d532626..3d65520282b 100644
--- a/lisp/net/tramp-smb.el
+++ b/lisp/net/tramp-smb.el
@@ -98,15 +98,14 @@ this variable \"client min protocol=NT1\"."
"Regexp of SMB server identification.")
(defconst tramp-smb-prompt
- (rx bol (| (: (| "smb:" "PS") " " (+ nonl) "> ")
+ (rx bol (| (: (| "smb:" "PS") space (+ nonl) "> ")
(: (+ space) "Server"
(+ space) "Comment" eol)))
"Regexp used as prompt in smbclient or powershell.")
(defconst tramp-smb-wrong-passwd-regexp
- (regexp-opt
- '("NT_STATUS_LOGON_FAILURE"
- "NT_STATUS_WRONG_PASSWORD"))
+ (rx (| "NT_STATUS_LOGON_FAILURE"
+ "NT_STATUS_WRONG_PASSWORD"))
"Regexp for login error strings of SMB servers.")
(defconst tramp-smb-errors
@@ -116,57 +115,56 @@ this variable \"client min protocol=NT1\"."
"Call timed out: server did not respond"
(: (+ (not space)) ": command not found")
"Server doesn't support UNIX CIFS calls"
- (regexp (regexp-opt
- '(;; Samba.
- "ERRDOS"
- "ERRHRD"
- "ERRSRV"
- "ERRbadfile"
- "ERRbadpw"
- "ERRfilexists"
- "ERRnoaccess"
- "ERRnomem"
- "ERRnosuchshare"
- ;; See /usr/include/samba-4.0/core/ntstatus.h.
- ;; Windows 4.0 (Windows NT), Windows 5.0 (Windows 2000),
- ;; Windows 5.1 (Windows XP), Windows 5.2 (Windows Server 2003),
- ;; Windows 6.0 (Windows Vista), Windows 6.1 (Windows 7),
- ;; Windows 6.3 (Windows Server 2012, Windows 10).
- "NT_STATUS_ACCESS_DENIED"
- "NT_STATUS_ACCOUNT_LOCKED_OUT"
- "NT_STATUS_BAD_NETWORK_NAME"
- "NT_STATUS_CANNOT_DELETE"
- "NT_STATUS_CONNECTION_DISCONNECTED"
- "NT_STATUS_CONNECTION_REFUSED"
- "NT_STATUS_CONNECTION_RESET"
- "NT_STATUS_DIRECTORY_NOT_EMPTY"
- "NT_STATUS_DUPLICATE_NAME"
- "NT_STATUS_FILE_IS_A_DIRECTORY"
- "NT_STATUS_HOST_UNREACHABLE"
- "NT_STATUS_IMAGE_ALREADY_LOADED"
- "NT_STATUS_INVALID_LEVEL"
- "NT_STATUS_INVALID_PARAMETER"
- "NT_STATUS_INVALID_PARAMETER_MIX"
- "NT_STATUS_IO_TIMEOUT"
- "NT_STATUS_LOGON_FAILURE"
- "NT_STATUS_NETWORK_ACCESS_DENIED"
- "NT_STATUS_NOT_IMPLEMENTED"
- "NT_STATUS_NO_LOGON_SERVERS"
- "NT_STATUS_NO_SUCH_FILE"
- "NT_STATUS_NO_SUCH_USER"
- "NT_STATUS_NOT_A_DIRECTORY"
- "NT_STATUS_NOT_SUPPORTED"
- "NT_STATUS_OBJECT_NAME_COLLISION"
- "NT_STATUS_OBJECT_NAME_INVALID"
- "NT_STATUS_OBJECT_NAME_NOT_FOUND"
- "NT_STATUS_OBJECT_PATH_SYNTAX_BAD"
- "NT_STATUS_PASSWORD_MUST_CHANGE"
- "NT_STATUS_RESOURCE_NAME_NOT_FOUND"
- "NT_STATUS_REVISION_MISMATCH"
- "NT_STATUS_SHARING_VIOLATION"
- "NT_STATUS_TRUSTED_RELATIONSHIP_FAILURE"
- "NT_STATUS_UNSUCCESSFUL"
- "NT_STATUS_WRONG_PASSWORD")))))
+ (| ;; Samba.
+ "ERRDOS"
+ "ERRHRD"
+ "ERRSRV"
+ "ERRbadfile"
+ "ERRbadpw"
+ "ERRfilexists"
+ "ERRnoaccess"
+ "ERRnomem"
+ "ERRnosuchshare"
+ ;; See /usr/include/samba-4.0/core/ntstatus.h.
+ ;; Windows 4.0 (Windows NT), Windows 5.0 (Windows 2000),
+ ;; Windows 5.1 (Windows XP), Windows 5.2 (Windows Server 2003),
+ ;; Windows 6.0 (Windows Vista), Windows 6.1 (Windows 7),
+ ;; Windows 6.3 (Windows Server 2012, Windows 10).
+ "NT_STATUS_ACCESS_DENIED"
+ "NT_STATUS_ACCOUNT_LOCKED_OUT"
+ "NT_STATUS_BAD_NETWORK_NAME"
+ "NT_STATUS_CANNOT_DELETE"
+ "NT_STATUS_CONNECTION_DISCONNECTED"
+ "NT_STATUS_CONNECTION_REFUSED"
+ "NT_STATUS_CONNECTION_RESET"
+ "NT_STATUS_DIRECTORY_NOT_EMPTY"
+ "NT_STATUS_DUPLICATE_NAME"
+ "NT_STATUS_FILE_IS_A_DIRECTORY"
+ "NT_STATUS_HOST_UNREACHABLE"
+ "NT_STATUS_IMAGE_ALREADY_LOADED"
+ "NT_STATUS_INVALID_LEVEL"
+ "NT_STATUS_INVALID_PARAMETER"
+ "NT_STATUS_INVALID_PARAMETER_MIX"
+ "NT_STATUS_IO_TIMEOUT"
+ "NT_STATUS_LOGON_FAILURE"
+ "NT_STATUS_NETWORK_ACCESS_DENIED"
+ "NT_STATUS_NOT_IMPLEMENTED"
+ "NT_STATUS_NO_LOGON_SERVERS"
+ "NT_STATUS_NO_SUCH_FILE"
+ "NT_STATUS_NO_SUCH_USER"
+ "NT_STATUS_NOT_A_DIRECTORY"
+ "NT_STATUS_NOT_SUPPORTED"
+ "NT_STATUS_OBJECT_NAME_COLLISION"
+ "NT_STATUS_OBJECT_NAME_INVALID"
+ "NT_STATUS_OBJECT_NAME_NOT_FOUND"
+ "NT_STATUS_OBJECT_PATH_SYNTAX_BAD"
+ "NT_STATUS_PASSWORD_MUST_CHANGE"
+ "NT_STATUS_RESOURCE_NAME_NOT_FOUND"
+ "NT_STATUS_REVISION_MISMATCH"
+ "NT_STATUS_SHARING_VIOLATION"
+ "NT_STATUS_TRUSTED_RELATIONSHIP_FAILURE"
+ "NT_STATUS_UNSUCCESSFUL"
+ "NT_STATUS_WRONG_PASSWORD")))
"Regexp for possible error strings of SMB servers.
Used instead of analyzing error codes of commands.")
@@ -1658,11 +1656,11 @@ If VEC has no cifs capabilities, exchange \"/\" by \"\\\\\"."
"")))
;; Sometimes we have discarded `substitute-in-file-name'.
- (when (string-match (rx (group "$$") (group (| "/" eol))) localname)
+ (when (string-match (rx (group "$$") (| "/" eol)) localname)
(setq localname (replace-match "$" nil nil localname 1)))
;; A trailing space is not supported.
- (when (string-match-p (rx " " eol) localname)
+ (when (string-match-p (rx space eol) localname)
(tramp-error
vec 'file-error
"Invalid file name %s" (tramp-make-tramp-file-name vec localname)))
@@ -1821,7 +1819,7 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)."
(cl-return))
;; weekday.
- (if (string-match-p (rx (group (+ wordchar)) eol) line)
+ (if (string-match-p (rx (+ wordchar) eol) line)
(setq line (substring line 0 -5))
(cl-return))
@@ -1856,7 +1854,7 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)."
;; localname.
(if (string-match
(rx bol (+ space)
- (group (not space) (? (group (* nonl) (not space))))
+ (group (not space) (? (* nonl) (not space)))
(* space) eol)
line)
(setq localname (match-string 1 line))
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index bb6eeaa7417..b24525de3a5 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -516,8 +516,8 @@ interpreted as a regular expression which always matches."
(defcustom tramp-restricted-shell-hosts-alist
(when (and (eq system-type 'windows-nt)
(not (string-match-p (rx "sh" eol) tramp-encoding-shell)))
- (list (rx bos (group (| (literal (downcase tramp-system-name))
- (literal (upcase tramp-system-name))))
+ (list (rx bos (| (literal (downcase tramp-system-name))
+ (literal (upcase tramp-system-name)))
eos)))
"List of hosts, which run a restricted shell.
This is a list of regular expressions, which denote hosts running
@@ -530,9 +530,8 @@ host runs a restricted shell, it shall be added to this list, too."
;;;###tramp-autoload
(defcustom tramp-local-host-regexp
(rx bos
- (regexp (regexp-opt
- `("localhost" "localhost4" "localhost6"
- ,tramp-system-name "127.0.0.1" "::1")))
+ (| (literal tramp-system-name)
+ (| "localhost" "localhost4" "localhost6" "127.0.0.1" "::1"))
eos)
"Host names which are regarded as local host.
If the local host runs a chrooted environment, set this to nil."
@@ -582,7 +581,7 @@ usually suffice.")
(defconst tramp-echoed-echo-mark-regexp
(rx-to-string
`(: ,tramp-echo-mark-marker
- (= ,tramp-echo-mark-marker-length (group "\b" (? " \b")))))
+ (= ,tramp-echo-mark-marker-length "\b" (? " \b"))))
"Regexp which matches `tramp-echo-mark' as it gets echoed by \
the remote shell.")
@@ -599,7 +598,7 @@ if you need to change this."
:type 'string)
(defcustom tramp-login-prompt-regexp
- (rx (* nonl) (group (| "user" "login")) (? (group " " (* nonl))) ":" (* " "))
+ (rx (* nonl) (| "user" "login") (? space (* nonl)) ":" (* space))
"Regexp matching login-like prompts.
The regexp should match at end of buffer.
@@ -692,9 +691,8 @@ files conditionalize this setup based on the TERM environment variable."
:type 'string)
(defcustom tramp-terminal-prompt-regexp
- (rx (group
- (| (: "TERM = (" (* nonl) ")")
- (: "Terminal type? [" (* nonl) "]")))
+ (rx (| (: "TERM = (" (* nonl) ")")
+ (: "Terminal type? [" (* nonl) "]"))
(* space))
"Regular expression matching all terminal setting prompts.
The regexp should match at end of buffer.
@@ -706,7 +704,7 @@ The answer will be provided by `tramp-action-terminal', which see."
;; "-no-antispoof". However, since we don't know which PuTTY
;; version is installed, we must react interactively.
(defcustom tramp-antispoof-regexp
- (rx (literal "Access granted. Press Return to begin session. "))
+ (rx "Access granted. Press Return to begin session. ")
"Regular expression matching plink's anti-spoofing message.
The regexp should match at end of buffer."
:version "27.1"
@@ -1177,7 +1175,7 @@ The `ftp' syntax does not support methods.")
"Return `tramp-completion-file-name-regexp' according to `tramp-syntax'."
(if (eq tramp-syntax 'separate)
;; FIXME: This shouldn't be necessary.
- (rx bos "/" (? (group "[" (* (not (any "]"))))) eos)
+ (rx bos "/" (? "[" (* (not (any "]")))) eos)
(rx bos
;; `file-name-completion' uses absolute paths for matching.
;; This means that on W32 systems, something like
@@ -1433,9 +1431,14 @@ calling HANDLER.")
;; internal data structure. Convenience functions for internal
;; data structure.
-;; The basic structure for remote file names. We must autoload it in
-;; tramp-loaddefs.el, because some functions, which need it, wouldn't
-;; work otherwise when unloading / reloading Tramp. (Bug#50869)
+;; The basic structure for remote file names.
+
+;; Note: We started autoloading it in tramp-loaddefs.el, because some
+;; functions, which needed it, wouldn't work otherwise when unloading
+;; / reloading Tramp (Bug#50869).
+;; This bug is fixed in Emacs 29, but other parts of Tramp have grown
+;; dependencies on having this in tramp-loaddefs.el in the mean time,
+;; so .... here we are.
;;;###tramp-autoload(require 'cl-lib)
;;;###tramp-autoload
(progn
@@ -1942,11 +1945,11 @@ of `current-buffer'."
(defconst tramp-debug-outline-regexp
(rx ;; Timestamp.
- (+ digit) ":" (+ digit) ":" (+ digit) "." (+ digit) " "
+ (+ digit) ":" (+ digit) ":" (+ digit) "." (+ digit) space
;; Thread.
- (? (group "#<thread " (+ nonl) ">") " ")
+ (? (group "#<thread " (+ nonl) ">") space)
;; Function name, verbosity.
- (+ (any "-" alnum)) " (" (group (group (+ digit))) ") #")
+ (+ (any "-" alnum)) " (" (group (+ digit)) ") #")
"Used for highlighting Tramp debug buffers in `outline-mode'.")
(defconst tramp-debug-font-lock-keywords
@@ -2804,7 +2807,7 @@ remote file names."
#'file-name-sans-extension
(directory-files
dir nil (rx bos "tramp" (+ nonl) ".el" (? "c") eos)))))
- (files-regexp (rx bol (: (regexp (regexp-opt files))) eol)))
+ (files-regexp (rx bol (regexp (regexp-opt files)) eol)))
(mapatoms
(lambda (atom)
(when (and (functionp atom)
@@ -3038,58 +3041,58 @@ not in completion mode."
(defun tramp-completion-dissect-file-name (name)
"Return a list of `tramp-file-name' structures for NAME.
They are collected by `tramp-completion-dissect-file-name1'."
- (let* (;; "/method" "/[method"
- (tramp-completion-file-name-structure1
- (list
- (rx (regexp tramp-prefix-regexp)
- (group (? (regexp tramp-completion-method-regexp))) eol)
- 1 nil nil nil))
- ;; "/method:user" "/[method/user"
- (tramp-completion-file-name-structure2
- (list
- (rx (regexp tramp-prefix-regexp)
- (group (regexp tramp-method-regexp))
- (regexp tramp-postfix-method-regexp)
- (group (? (regexp tramp-user-regexp))) eol)
- 1 2 nil nil))
- ;; "/method:host" "/[method/host"
- (tramp-completion-file-name-structure3
- (list
- (rx (regexp tramp-prefix-regexp)
- (group (regexp tramp-method-regexp))
- (regexp tramp-postfix-method-regexp)
- (group (? (regexp tramp-host-regexp))) eol)
- 1 nil 2 nil))
- ;; "/method:[ipv6" "/[method/ipv6"
- (tramp-completion-file-name-structure4
- (list
- (rx (regexp tramp-prefix-regexp)
- (group (regexp tramp-method-regexp))
- (regexp tramp-postfix-method-regexp)
- (regexp tramp-prefix-ipv6-regexp)
- (group (? (regexp tramp-ipv6-regexp))) eol)
- 1 nil 2 nil))
- ;; "/method:user@host" "/[method/user@host"
- (tramp-completion-file-name-structure5
- (list
- (rx (regexp tramp-prefix-regexp)
- (group (regexp tramp-method-regexp))
- (regexp tramp-postfix-method-regexp)
- (group (regexp tramp-user-regexp))
- (regexp tramp-postfix-user-regexp)
- (group (? (regexp tramp-host-regexp))) eol)
- 1 2 3 nil))
- ;; "/method:user@[ipv6" "/[method/user@ipv6"
- (tramp-completion-file-name-structure6
- (list
- (rx (regexp tramp-prefix-regexp)
- (group (regexp tramp-method-regexp))
- (regexp tramp-postfix-method-regexp)
- (group (regexp tramp-user-regexp))
- (regexp tramp-postfix-user-regexp)
- (regexp tramp-prefix-ipv6-regexp)
- (group (? (regexp tramp-ipv6-regexp))) eol)
- 1 2 3 nil)))
+ (let (;; "/method" "/[method"
+ (tramp-completion-file-name-structure1
+ (list
+ (rx (regexp tramp-prefix-regexp)
+ (group (? (regexp tramp-completion-method-regexp))) eol)
+ 1 nil nil nil))
+ ;; "/method:user" "/[method/user"
+ (tramp-completion-file-name-structure2
+ (list
+ (rx (regexp tramp-prefix-regexp)
+ (group (regexp tramp-method-regexp))
+ (regexp tramp-postfix-method-regexp)
+ (group (? (regexp tramp-user-regexp))) eol)
+ 1 2 nil nil))
+ ;; "/method:host" "/[method/host"
+ (tramp-completion-file-name-structure3
+ (list
+ (rx (regexp tramp-prefix-regexp)
+ (group (regexp tramp-method-regexp))
+ (regexp tramp-postfix-method-regexp)
+ (group (? (regexp tramp-host-regexp))) eol)
+ 1 nil 2 nil))
+ ;; "/method:[ipv6" "/[method/ipv6"
+ (tramp-completion-file-name-structure4
+ (list
+ (rx (regexp tramp-prefix-regexp)
+ (group (regexp tramp-method-regexp))
+ (regexp tramp-postfix-method-regexp)
+ (regexp tramp-prefix-ipv6-regexp)
+ (group (? (regexp tramp-ipv6-regexp))) eol)
+ 1 nil 2 nil))
+ ;; "/method:user@host" "/[method/user@host"
+ (tramp-completion-file-name-structure5
+ (list
+ (rx (regexp tramp-prefix-regexp)
+ (group (regexp tramp-method-regexp))
+ (regexp tramp-postfix-method-regexp)
+ (group (regexp tramp-user-regexp))
+ (regexp tramp-postfix-user-regexp)
+ (group (? (regexp tramp-host-regexp))) eol)
+ 1 2 3 nil))
+ ;; "/method:user@[ipv6" "/[method/user@ipv6"
+ (tramp-completion-file-name-structure6
+ (list
+ (rx (regexp tramp-prefix-regexp)
+ (group (regexp tramp-method-regexp))
+ (regexp tramp-postfix-method-regexp)
+ (group (regexp tramp-user-regexp))
+ (regexp tramp-postfix-user-regexp)
+ (regexp tramp-prefix-ipv6-regexp)
+ (group (? (regexp tramp-ipv6-regexp))) eol)
+ 1 2 3 nil)))
(delq
nil
(mapcar
@@ -3356,14 +3359,14 @@ User is always nil."
registry-or-dirname (rx bol (group (regexp tramp-host-regexp)) eol))))
(defun tramp-parse-putty-group (registry)
- "Return a (user host) tuple allowed to access.
+ "Return a (user host) tuple allowed to access.
User is always nil."
- (let (result
- (regexp (rx (literal registry) "\\" (group (+ nonl)))))
- (when (re-search-forward regexp (line-end-position) t)
- (setq result (list nil (match-string 1))))
- (forward-line 1)
- result))
+ (let (result
+ (regexp (rx (literal registry) "\\" (group (+ nonl)))))
+ (when (re-search-forward regexp (line-end-position) t)
+ (setq result (list nil (match-string 1))))
+ (forward-line 1)
+ result))
;;; Skeleton macros for file name handler functions.
@@ -4104,10 +4107,9 @@ Let-bind it when necessary.")
(not (with-tramp-connection-property
(tramp-get-process v) "unsafe-temporary-file"
(yes-or-no-p
- (eval-when-compile
- (concat
- "Backup file on local temporary directory, "
- "do you want to continue?"))))))
+ (concat
+ "Backup file on local temporary directory, "
+ "do you want to continue?")))))
(tramp-error v 'file-error "Unsafe backup file name"))))))
(defun tramp-handle-insert-directory
@@ -4439,7 +4441,7 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.")
(rx bos (group (+ nonl))
"@" (group (+ nonl))
"." (group (+ digit))
- (? ":" (group (+ digit))) eos)
+ (? ":" (+ digit)) eos)
"The format of a lock file.")
(defun tramp-handle-file-locked-p (file)
@@ -4494,10 +4496,9 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.")
(not (with-tramp-connection-property
(tramp-get-process v) "unsafe-temporary-file"
(yes-or-no-p
- (eval-when-compile
- (concat
- "Lock file on local temporary directory, "
- "do you want to continue?"))))))
+ (concat
+ "Lock file on local temporary directory, "
+ "do you want to continue?")))))
(tramp-error v 'file-error "Unsafe lock file name")))
;; Do the lock.
@@ -6112,10 +6113,9 @@ this file, if that variable is non-nil."
(not (with-tramp-connection-property
(tramp-get-process v) "unsafe-temporary-file"
(yes-or-no-p
- (eval-when-compile
- (concat
- "Autosave file on local temporary directory, "
- "do you want to continue?"))))))
+ (concat
+ "Autosave file on local temporary directory, "
+ "do you want to continue?")))))
(tramp-error v 'file-error "Unsafe autosave file name"))))))
(defun tramp-subst-strs-in-string (alist string)
@@ -6389,15 +6389,13 @@ would use a wrong quoting for local file names. See `w32-shell-name'."
Only works for Bourne-like shells."
(let ((system-type 'not-windows))
(save-match-data
- (let ((result (tramp-unquote-shell-quote-argument s))
- (nl (regexp-quote (format "\\%s" tramp-rsh-end-of-line))))
+ (let ((result (tramp-unquote-shell-quote-argument s)))
(when (and (>= (length result) 2)
(string= (substring result 0 2) "\\~"))
(setq result (substring result 1)))
- (while (string-match nl result)
- (setq result (replace-match (format "'%s'" tramp-rsh-end-of-line)
- t t result)))
- result))))
+ (replace-regexp-in-string
+ (rx "\\" (literal tramp-rsh-end-of-line))
+ (format "'%s'" tramp-rsh-end-of-line) result)))))
;;; Signal handling. This works for remote processes, which have set
;;; the process property `remote-pid'.
diff --git a/lisp/obsolete/url-about.el b/lisp/obsolete/url-about.el
index 608df3f2a5d..b9f8732b28c 100644
--- a/lisp/obsolete/url-about.el
+++ b/lisp/obsolete/url-about.el
@@ -32,7 +32,7 @@
(or (get 'url-extension-protocols 'probed)
(mapc (lambda (s) (url-scheme-get-property s 'name))
(or (get 'url-extension-protocols 'schemes)
- (let ((schemes '("info" "man" "rlogin" "telnet"
+ (let ((schemes '("info" "man" "telnet"
"tn3270" "data" "snews")))
(mapc (lambda (d)
(mapc (lambda (f)
diff --git a/lisp/org/org-version.el b/lisp/org/org-version.el
index 353d533c06c..3273d8707d6 100644
--- a/lisp/org/org-version.el
+++ b/lisp/org/org-version.el
@@ -5,13 +5,13 @@
(defun org-release ()
"The release version of Org.
Inserted by installing Org mode or when a release is made."
- (let ((org-release "9.5.4"))
+ (let ((org-release "9.5.5"))
org-release))
;;;###autoload
(defun org-git-version ()
"The Git version of Org mode.
Inserted by installing Org or when a release is made."
- (let ((org-git-version "release_9.5.4-19-g4dff42"))
+ (let ((org-git-version "release_9.5.5"))
org-git-version))
(provide 'org-version)
diff --git a/lisp/org/org.el b/lisp/org/org.el
index 9facbed04de..6f92cdeab5b 100644
--- a/lisp/org/org.el
+++ b/lisp/org/org.el
@@ -9,7 +9,7 @@
;; Homepage: https://orgmode.org
;; Package-Requires: ((emacs "25.1"))
-;; Version: 9.5.4
+;; Version: 9.5.5
;; This file is part of GNU Emacs.
;;
diff --git a/lisp/outline.el b/lisp/outline.el
index 3250b62f1e7..9a94cad6385 100644
--- a/lisp/outline.el
+++ b/lisp/outline.el
@@ -288,8 +288,7 @@ The value should be a `buffer-match-p' condition.
These buttons can be used to hide and show the body under the heading.
Note that this feature is not meant to be used in editing
buffers (yet) -- that will be amended in a future version."
- ;; FIXME -- is there a `buffer-match-p' defcustom type somewhere?
- :type 'sexp
+ :type 'buffer-predicate
:safe #'booleanp
:version "29.1")
@@ -427,15 +426,14 @@ outline font-lock faces to those of major mode."
(goto-char (point-min))
(let ((regexp (concat "^\\(?:" outline-regexp "\\).*$")))
(while (re-search-forward regexp nil t)
- (let ((overlay (make-overlay (match-beginning 0)
- (match-end 0))))
+ (let ((overlay (make-overlay (match-beginning 0) (match-end 0))))
(overlay-put overlay 'outline-overlay t)
- (when (or (eq outline-minor-mode-highlight 'override)
+ ;; FIXME: Is it possible to override all underlying face attributes?
+ (when (or (memq outline-minor-mode-highlight '(append override))
(and (eq outline-minor-mode-highlight t)
- (goto-char (match-beginning 0))
- (not (get-text-property (point) 'face))))
+ (not (get-text-property (match-beginning 0) 'face))))
(overlay-put overlay 'face (outline-font-lock-face)))
- (when (and (outline--use-buttons-p) (outline-on-heading-p))
+ (when (outline--use-buttons-p)
(outline--insert-open-button)))
(goto-char (match-end 0))))))
@@ -445,17 +443,19 @@ outline font-lock faces to those of major mode."
See the command `outline-mode' for more information on this mode."
:lighter " Outl"
- :keymap (easy-mmode-define-keymap
- `(([menu-bar] . ,outline-minor-mode-menu-bar-map)
- (,outline-minor-mode-prefix . ,outline-mode-prefix-map))
- :inherit outline-minor-mode-cycle-map)
+ :keymap (define-keymap
+ :parent outline-minor-mode-cycle-map
+ "<menu-bar>" outline-minor-mode-menu-bar-map
+ (key-description outline-minor-mode-prefix) outline-mode-prefix-map)
(if outline-minor-mode
(progn
(when outline-minor-mode-highlight
- (when (and global-font-lock-mode (font-lock-specified-p major-mode))
- (font-lock-add-keywords nil outline-font-lock-keywords t)
- (font-lock-flush))
- (outline-minor-mode-highlight-buffer))
+ (if (and global-font-lock-mode (font-lock-specified-p major-mode))
+ (progn
+ (font-lock-add-keywords nil outline-font-lock-keywords t)
+ (font-lock-flush)
+ (outline--fix-up-all-buttons))
+ (outline-minor-mode-highlight-buffer)))
;; Turn off this mode if we change major modes.
(add-hook 'change-major-mode-hook
(lambda () (outline-minor-mode -1))
@@ -1005,7 +1005,8 @@ If non-nil, EVENT should be a mouse event."
(put-text-property (point) (1+ (point)) 'face (plist-get icon 'face)))
(when-let ((image (plist-get icon 'image)))
(overlay-put o 'display image))
- (overlay-put o 'display (plist-get icon 'string))
+ (overlay-put o 'display (concat (plist-get icon 'string)
+ (string (char-after (point)))))
(overlay-put o 'face (plist-get icon 'face)))
o))
diff --git a/lisp/paren.el b/lisp/paren.el
index d7580de9a9d..e2c060ceb96 100644
--- a/lisp/paren.el
+++ b/lisp/paren.el
@@ -118,6 +118,14 @@ On non-graphical frames, the context is shown in the echo area."
(let ((ol (make-overlay (point) (point) nil t))) (delete-overlay ol) ol)
"Overlay used to highlight the paren at point.")
+(defcustom show-paren-predicate '(not (derived-mode . special-mode))
+ "Whether to use `show-paren-mode' in a buffer.
+The default is to enable the mode in all buffers that have don't
+derive from `special-mode', which means that it's on (by default)
+in all editing buffers."
+ :type 'buffer-predicate
+ :safe #'booleanp
+ :version "29.1")
;;;###autoload
(define-minor-mode show-paren-mode
@@ -126,6 +134,9 @@ On non-graphical frames, the context is shown in the echo area."
When enabled, any matching parenthesis is highlighted in `show-paren-style'
after `show-paren-delay' seconds of Emacs idle time.
+Also see `show-paren-predicate', which controls which buffers
+this mode is enabled in.
+
This is a global minor mode. To toggle the mode in a single buffer,
use `show-paren-local-mode'."
:global t :group 'paren-showing
@@ -414,7 +425,13 @@ It is the default value of `show-paren-data-function'."
(defun show-paren-function ()
"Highlight the parentheses until the next input arrives."
- (let ((data (and show-paren-mode (funcall show-paren-data-function))))
+ (let ((data (and show-paren-mode
+ ;; If we're using `show-paren-local-mode', then
+ ;; always heed the value.
+ (or (local-variable-p 'show-paren-mode)
+ ;; If not, check that the predicate matches.
+ (buffer-match-p show-paren-predicate (current-buffer)))
+ (funcall show-paren-data-function))))
(if (not data)
(progn
;; If show-paren-mode is nil in this buffer or if not at a paren that
diff --git a/lisp/play/gamegrid.el b/lisp/play/gamegrid.el
index 8cff67c5bcc..4e4982e7b0d 100644
--- a/lisp/play/gamegrid.el
+++ b/lisp/play/gamegrid.el
@@ -80,12 +80,8 @@ directory will be used.")
(defun gamegrid-calculate-glyph-size ()
"Calculate appropriate glyph size in pixels based on display resolution.
Return a multiple of 8 no less than 16."
- (let (atts
+ (let ((atts (frame-monitor-attributes))
y-pitch)
- (dolist (mon (display-monitor-attributes-list))
- (when-let ((frames (alist-get 'frames mon))
- (match (memq (selected-frame) frames)))
- (setq atts mon)))
(setq y-pitch (cond
(atts
(/ (nth 4 (assq 'geometry atts))
diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el
index b2d1f15d398..94225d6e3e9 100644
--- a/lisp/progmodes/cc-engine.el
+++ b/lisp/progmodes/cc-engine.el
@@ -142,6 +142,11 @@
;; Put on the brace which introduces a brace list and on the commas
;; which separate the elements within it.
;;
+;; 'c-<>-c-types-set
+;; This property is set on an opening angle bracket, and indicates that
+;; any "," separators within the template/generic expression have been
+;; marked with a 'c-type property value 'c-<>-arg-sep (see above).
+;;
;; 'c-awk-NL-prop
;; Used in AWK mode to mark the various kinds of newlines. See
;; cc-awk.el.
@@ -6137,7 +6142,7 @@ comment at the start of cc-engine.el for more info."
(forward-char))))
(backward-char)
(if (let ((c-parse-and-markup-<>-arglists t)
- (c-restricted-<>-arglists t))
+ c-restricted-<>-arglists)
(c-forward-<>-arglist nil)) ; Should always work.
(when (> (point) to)
(setq bound-<> (point)))
@@ -8505,9 +8510,9 @@ multi-line strings (but not C++, for example)."
arg-start-pos)
;; If the '<' has paren open syntax then we've marked it as an angle
;; bracket arglist before, so skip to the end.
- (if (and (not c-parse-and-markup-<>-arglists)
- syntax-table-prop-on-<)
-
+ (if (and syntax-table-prop-on-<
+ (or (not c-parse-and-markup-<>-arglists)
+ (c-get-char-property (point) 'c-<>-c-types-set)))
(progn
(forward-char)
(if (and (c-go-up-list-forward)
@@ -8604,6 +8609,7 @@ multi-line strings (but not C++, for example)."
(c-unmark-<->-as-paren (point)))))
(c-mark-<-as-paren start)
(c-mark->-as-paren (1- (point)))
+ (c-put-char-property start 'c-<>-c-types-set t)
(c-truncate-lit-pos-cache start))
(setq res t)
nil)) ; Exit the loop.
diff --git a/lisp/progmodes/cc-fonts.el b/lisp/progmodes/cc-fonts.el
index 12bb3d37513..f34f7f177db 100644
--- a/lisp/progmodes/cc-fonts.el
+++ b/lisp/progmodes/cc-fonts.el
@@ -934,17 +934,16 @@ casts and declarations are fontified. Used on level 2 and higher."
(save-excursion
(let ((pos (point)))
(c-backward-syntactic-ws (max (- (point) 500) (point-min)))
- (c-clear-char-properties
- (if (and (not (bobp))
- (memq (c-get-char-property (1- (point)) 'c-type)
- '(c-decl-arg-start
- c-decl-end
- c-decl-id-start
- c-decl-type-start
- c-not-decl)))
- (1- (point))
- pos)
- limit 'c-type)))
+ (when (and (not (bobp))
+ (memq (c-get-char-property (1- (point)) 'c-type)
+ '(c-decl-arg-start
+ c-decl-end
+ c-decl-id-start
+ c-decl-type-start
+ c-not-decl)))
+ (setq pos (1- (point))))
+ (c-clear-char-properties pos limit 'c-type)
+ (c-clear-char-properties pos limit 'c-<>-c-types-set)))
;; Update `c-state-cache' to the beginning of the region. This will
;; make `c-beginning-of-syntax' go faster when it's used later on,
diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el
index bab80719dbd..6e8032b7eae 100644
--- a/lisp/progmodes/gdb-mi.el
+++ b/lisp/progmodes/gdb-mi.el
@@ -4033,11 +4033,12 @@ DOC is an optional documentation string."
(file (gdb-mi--field frame 'fullname))
(line (gdb-mi--field frame 'line)))
(if file
- (format "-data-disassemble -f %s -l %s -n -1 -- 0" file line)
- ;; If we're unable to get a file name / line for $PC, simply
- ;; follow $PC, disassembling the next 10 (x ~15 (on IA) ==
- ;; 150 bytes) instructions.
- "-data-disassemble -s $pc -e \"$pc + 150\" -- 0"))
+ (format "-data-disassemble -f %s -l %s -n -1 -- 0"
+ (file-local-name file) line)
+ ;; If we're unable to get a file name / line for $PC, simply
+ ;; follow $PC, disassembling the next 10 (x ~15 (on IA) ==
+ ;; 150 bytes) instructions.
+ "-data-disassemble -s $pc -e \"$pc + 150\" -- 0"))
gdb-disassembly-handler
;; We update disassembly only after we have actual frame information
;; about all threads, so no there's `update' signal in this list
diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el
index ccc57205757..281762fb0a5 100644
--- a/lisp/progmodes/gud.el
+++ b/lisp/progmodes/gud.el
@@ -159,143 +159,96 @@ Used to gray out relevant toolbar icons.")
(t
(comint-interrupt-subjob)))))
-(easy-mmode-defmap gud-menu-map
- '(([help] "Info (debugger)" . gud-goto-info)
- ([tooltips] menu-item "Show GUD tooltips" gud-tooltip-mode
- :enable (and (not emacs-basic-display)
- (display-graphic-p)
- (fboundp 'x-show-tip))
- :visible (memq gud-minor-mode
- '(gdbmi guiler dbx sdb xdb pdb))
- :button (:toggle . gud-tooltip-mode))
- ([refresh] "Refresh" . gud-refresh)
- ([run] menu-item "Run" gud-run
- :enable (not gud-running)
- :visible (or (memq gud-minor-mode '(gdb dbx jdb))
- (and (eq gud-minor-mode 'gdbmi)
- (or (not (gdb-show-run-p))
- (bound-and-true-p
- gdb-active-process)))))
- ([go] . (menu-item (if (bound-and-true-p gdb-active-process)
- "Continue" "Run")
- gud-go
- :visible (and (eq gud-minor-mode 'gdbmi)
- (gdb-show-run-p))))
- ([stop] menu-item "Stop" gud-stop-subjob
- :visible (or (not (memq gud-minor-mode '(gdbmi pdb)))
- (and (eq gud-minor-mode 'gdbmi)
- (gdb-show-stop-p))))
- ([until] menu-item "Continue to selection" gud-until
- :enable (not gud-running)
- :visible (and (memq gud-minor-mode '(gdbmi gdb perldb))
- (gud-tool-bar-item-visible-no-fringe)))
- ([remove] menu-item "Remove Breakpoint" gud-remove
- :enable (not gud-running)
- :visible (gud-tool-bar-item-visible-no-fringe))
- ([tbreak] menu-item "Temporary Breakpoint" gud-tbreak
- :enable (not gud-running)
- :visible (memq gud-minor-mode
- '(gdbmi gdb sdb xdb)))
- ([break] menu-item "Set Breakpoint" gud-break
- :enable (not gud-running)
- :visible (gud-tool-bar-item-visible-no-fringe))
- ([up] menu-item "Up Stack" gud-up
- :enable (not gud-running)
- :visible (memq gud-minor-mode
- '(gdbmi gdb guiler dbx xdb jdb pdb)))
- ([down] menu-item "Down Stack" gud-down
- :enable (not gud-running)
- :visible (memq gud-minor-mode
- '(gdbmi gdb guiler dbx xdb jdb pdb)))
- ([pp] menu-item "Print S-expression" gud-pp
- :enable (and (not gud-running)
- (bound-and-true-p gdb-active-process))
- :visible (and (string-equal
- (buffer-local-value
- 'gud-target-name gud-comint-buffer)
- "emacs")
- (eq gud-minor-mode 'gdbmi)))
- ([print*] . (menu-item (if (eq gud-minor-mode 'jdb)
- "Dump object"
- "Print Dereference")
- gud-pstar
- :enable (not gud-running)
- :visible (memq gud-minor-mode '(gdbmi gdb jdb))))
- ([print] menu-item "Print Expression" gud-print
- :enable (not gud-running))
- ([watch] menu-item "Watch Expression" gud-watch
- :enable (not gud-running)
- :visible (eq gud-minor-mode 'gdbmi))
- ([finish] menu-item "Finish Function" gud-finish
- :enable (not gud-running)
- :visible (memq gud-minor-mode
- '(gdbmi gdb guiler xdb jdb pdb)))
- ([stepi] menu-item "Step Instruction" gud-stepi
- :enable (not gud-running)
- :visible (memq gud-minor-mode '(gdbmi gdb dbx)))
- ([nexti] menu-item "Next Instruction" gud-nexti
- :enable (not gud-running)
- :visible (memq gud-minor-mode '(gdbmi gdb dbx)))
- ([step] menu-item "Step Line" gud-step
- :enable (not gud-running))
- ([next] menu-item "Next Line" gud-next
- :enable (not gud-running))
- ([cont] menu-item "Continue" gud-cont
- :enable (not gud-running)
- :visible (not (eq gud-minor-mode 'gdbmi))))
- "Menu for `gud-mode'."
- :name "Gud")
-
-(easy-mmode-defmap gud-minor-mode-map
- (append
- `(([menu-bar debug] . ("Gud" . ,gud-menu-map)))
- ;; Get tool bar like functionality from the menu bar on a text only
- ;; terminal.
- (unless window-system
- `(([menu-bar down]
- . (,(propertize "down" 'face 'font-lock-doc-face) . gud-down))
- ([menu-bar up]
- . (,(propertize "up" 'face 'font-lock-doc-face) . gud-up))
- ([menu-bar finish]
- . (,(propertize "finish" 'face 'font-lock-doc-face) . gud-finish))
- ([menu-bar step]
- . (,(propertize "step" 'face 'font-lock-doc-face) . gud-step))
- ([menu-bar next]
- . (,(propertize "next" 'face 'font-lock-doc-face) . gud-next))
- ([menu-bar until] menu-item
- ,(propertize "until" 'face 'font-lock-doc-face) gud-until
- :visible (memq gud-minor-mode '(gdbmi gdb perldb)))
- ([menu-bar cont] menu-item
- ,(propertize "cont" 'face 'font-lock-doc-face) gud-cont
- :visible (not (eq gud-minor-mode 'gdbmi)))
- ([menu-bar run] menu-item
- ,(propertize "run" 'face 'font-lock-doc-face) gud-run
- :visible (memq gud-minor-mode '(gdbmi gdb dbx jdb)))
- ([menu-bar go] menu-item
- ,(propertize " go " 'face 'font-lock-doc-face) gud-go
- :visible (and (eq gud-minor-mode 'gdbmi)
- (gdb-show-run-p)))
- ([menu-bar stop] menu-item
- ,(propertize "stop" 'face 'font-lock-doc-face) gud-stop-subjob
- :visible (or (and (eq gud-minor-mode 'gdbmi)
- (gdb-show-stop-p))
- (not (eq gud-minor-mode 'gdbmi))))
- ([menu-bar print]
- . (,(propertize "print" 'face 'font-lock-doc-face) . gud-print))
- ([menu-bar tools] . undefined)
- ([menu-bar buffer] . undefined)
- ([menu-bar options] . undefined)
- ([menu-bar edit] . undefined)
- ([menu-bar file] . undefined))))
- "Map used in visited files.")
-
-(setf (alist-get 'gud-minor-mode minor-mode-map-alist)
- gud-minor-mode-map)
-
-(defvar gud-mode-map
+(defvar-keymap gud-mode-map
;; Will inherit from comint-mode via define-derived-mode.
- (make-sparse-keymap)
- "`gud-mode' keymap.")
+ :doc "`gud-mode' keymap.")
+
+(defvar-keymap gud-minor-mode-map
+ :parent gud-mode-map)
+
+(easy-menu-define gud-menu-map gud-mode-map
+ "Menu for `gud-mode'."
+ '("Gud"
+ ["Continue" gud-cont
+ :enable (not gud-running)
+ :visible (not (eq gud-minor-mode 'gdbmi))]
+ ["Next Line" gud-next
+ :enable (not gud-running)]
+ ["Step Line" gud-step
+ :enable (not gud-running)]
+ ["Next Instruction" gud-nexti
+ :enable (not gud-running)
+ :visible (memq gud-minor-mode '(gdbmi gdb dbx))]
+ ["Step Instruction" gud-stepi
+ :enable (not gud-running)
+ :visible (memq gud-minor-mode '(gdbmi gdb dbx))]
+ ["Finish Function" gud-finish
+ :enable (not gud-running)
+ :visible (memq gud-minor-mode '(gdbmi gdb guiler xdb jdb pdb))]
+ ["Watch Expression" gud-watch
+ :enable (not gud-running)
+ :visible (eq gud-minor-mode 'gdbmi)]
+ ["Print Expression" gud-print
+ :enable (not gud-running)]
+ ["Dump object-Derefenrece" gud-pstar
+ :label (if (eq gud-minor-mode 'jdb)
+ "Dump object"
+ "Print Dereference")
+ :enable (not gud-running)
+ :visible (memq gud-minor-mode '(gdbmi gdb jdb))]
+ ["Print S-expression" gud-pp
+ :enable (and (not gud-running)
+ (bound-and-true-p gdb-active-process))
+ :visible (and (string-equal
+ (buffer-local-value
+ 'gud-target-name gud-comint-buffer)
+ "emacs")
+ (eq gud-minor-mode 'gdbmi))]
+ ["Down Stack" gud-down
+ :enable (not gud-running)
+ :visible (memq gud-minor-mode '(gdbmi gdb guiler dbx xdb jdb pdb))]
+ ["Up Stack" gud-up
+ :enable (not gud-running)
+ :visible (memq gud-minor-mode
+ '(gdbmi gdb guiler dbx xdb jdb pdb))]
+ ["Set Breakpoint" gud-break
+ :enable (not gud-running)
+ :visible (gud-tool-bar-item-visible-no-fringe)]
+ ["Temporary Breakpoint" gud-tbreak
+ :enable (not gud-running)
+ :visible (memq gud-minor-mode '(gdbmi gdb sdb xdb))]
+ ["Remove Breakpoint" gud-remove
+ :enable (not gud-running)
+ :visible (gud-tool-bar-item-visible-no-fringe)]
+ ["Continue to selection" gud-until
+ :enable (not gud-running)
+ :visible (and (memq gud-minor-mode '(gdbmi gdb perldb))
+ (gud-tool-bar-item-visible-no-fringe))]
+ ["Stop" gud-stop-subjob
+ :visible (or (not (memq gud-minor-mode '(gdbmi pdb)))
+ (and (eq gud-minor-mode 'gdbmi)
+ (gdb-show-stop-p)))]
+ ["Continue-Run" gud-go
+ :label (if (bound-and-true-p gdb-active-process)
+ "Continue" "Run")
+ :visible (and (eq gud-minor-mode 'gdbmi)
+ (gdb-show-run-p))]
+ ["Run" gud-run
+ :enable (not gud-running)
+ :visible (or (memq gud-minor-mode '(gdb dbx jdb))
+ (and (eq gud-minor-mode 'gdbmi)
+ (or (not (gdb-show-run-p))
+ (bound-and-true-p
+ gdb-active-process))))]
+ ["Refresh" gud-refresh]
+ ["Show GUD tooltips" gud-tooltip-mode
+ :enable (and (not emacs-basic-display)
+ (display-graphic-p)
+ (fboundp 'x-show-tip))
+ :visible (memq gud-minor-mode
+ '(gdbmi guiler dbx sdb xdb pdb))
+ :button (:toggle . gud-tooltip-mode)]
+ ["Info (debugger)" gud-goto-info]))
(defvar gud-tool-bar-map
(let ((map (make-sparse-keymap)))
diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el
index d3ffc2db2c9..147c5f248d2 100644
--- a/lisp/progmodes/python.el
+++ b/lisp/progmodes/python.el
@@ -5,7 +5,7 @@
;; Author: Fabián E. Gallina <fgallina@gnu.org>
;; URL: https://github.com/fgallina/python.el
;; Version: 0.28
-;; Package-Requires: ((emacs "24.4") (cl-lib "1.0"))
+;; Package-Requires: ((emacs "24.4") (compat "28.1.2.1") (seq "2.23"))
;; Maintainer: emacs-devel@gnu.org
;; Created: Jul 2010
;; Keywords: languages
@@ -34,7 +34,8 @@
;; Implements Syntax highlighting, Indentation, Movement, Shell
;; interaction, Shell completion, Shell virtualenv support, Shell
;; package support, Shell syntax highlighting, Pdb tracking, Symbol
-;; completion, Skeletons, FFAP, Code Check, ElDoc, Imenu.
+;; completion, Skeletons, FFAP, Code Check, ElDoc, Imenu, Flymake,
+;; Import management.
;; Syntax highlighting: Fontification of code is provided and supports
;; python's triple quoted strings properly.
@@ -69,7 +70,7 @@
;; variables. This example enables IPython globally:
;; (setq python-shell-interpreter "ipython"
-;; python-shell-interpreter-args "-i")
+;; python-shell-interpreter-args "--simple-prompt")
;; Using the "console" subcommand to start IPython in server-client
;; mode is known to fail intermittently due a bug on IPython itself
@@ -240,11 +241,29 @@
;; I'd recommend the first one since you'll get the same behavior for
;; all modes out-of-the-box.
+;; Flymake: A Flymake backend, using the pyflakes program by default,
+;; is provided. You can also use flake8 or pylint by customizing
+;; `python-flymake-command'.
+
+;; Import management: The commands `python-sort-imports',
+;; `python-add-import', `python-remove-import', and
+;; `python-fix-imports' automate the editing of import statements at
+;; the top of the buffer, which tend to be a tedious task in larger
+;; projects. These commands require that the isort library is
+;; available to the interpreter pointed at by `python-interpreter'.
+;; The last command also requires pyflakes. These dependencies can be
+;; installed, among other methods, with the following command:
+;;
+;; pip install isort pyflakes
+
;;; Code:
(require 'ansi-color)
(require 'cl-lib)
(require 'comint)
+(require 'compat nil 'noerror)
+(require 'project nil 'noerror)
+(require 'seq)
(eval-when-compile (require 'subr-x)) ;For `string-empty-p'.
;; Avoid compiler warnings
@@ -265,6 +284,12 @@
:version "24.3"
:link '(emacs-commentary-link "python"))
+(defcustom python-interpreter "python"
+ "Python interpreter for noninteractive use.
+To customize the Python shell, modify `python-shell-interpreter'
+instead."
+ :version "29.1"
+ :type 'string)
;;; Bindings
@@ -303,6 +328,11 @@
(define-key map "\C-c\C-v" #'python-check)
(define-key map "\C-c\C-f" #'python-eldoc-at-point)
(define-key map "\C-c\C-d" #'python-describe-at-point)
+ ;; Import management
+ (define-key map "\C-c\C-ia" #'python-add-import)
+ (define-key map "\C-c\C-if" #'python-fix-imports)
+ (define-key map "\C-c\C-ir" #'python-remove-import)
+ (define-key map "\C-c\C-is" #'python-sort-imports)
;; Utilities
(substitute-key-definition #'complete-symbol #'completion-at-point
map global-map)
@@ -348,7 +378,17 @@
["Help on symbol" python-eldoc-at-point
:help "Get help on symbol at point"]
["Complete symbol" completion-at-point
- :help "Complete symbol before point"]))
+ :help "Complete symbol before point"]
+ "-----"
+ ["Add import" python-add-import
+ :help "Add an import statement to the top of this buffer"]
+ ["Remove import" python-remove-import
+ :help "Remove an import statement from the top of this buffer"]
+ ["Sort imports" python-sort-imports
+ :help "Sort the import statements at the top of this buffer"]
+ ["Fix imports" python-fix-imports
+ :help "Add missing imports and remove unused ones from the current buffer"]
+ ))
map)
"Keymap for `python-mode'.")
@@ -2304,6 +2344,16 @@ virtualenv."
"`compilation-error-regexp-alist' for inferior Python."
:type '(alist regexp))
+(defcustom python-shell-dedicated nil
+ "Whether to make Python shells dedicated by default.
+This option influences `run-python' when called without a prefix
+argument. If `buffer' or `project', create a Python shell
+dedicated to the current buffer or its project (if one is found)."
+ :version "29.1"
+ :type '(choice (const :tag "To buffer" buffer)
+ (const :tag "To project" project)
+ (const :tag "Not dedicated" nil)))
+
(defvar python-shell-output-filter-in-progress nil)
(defvar python-shell-output-filter-buffer nil)
@@ -2666,12 +2716,19 @@ from `python-shell-prompt-regexp',
(defun python-shell-get-process-name (dedicated)
"Calculate the appropriate process name for inferior Python process.
-If DEDICATED is t returns a string with the form
-`python-shell-buffer-name'[`buffer-name'] else returns the value
-of `python-shell-buffer-name'."
- (if dedicated
- (format "%s[%s]" python-shell-buffer-name (buffer-name))
- python-shell-buffer-name))
+If DEDICATED is nil, this is simply `python-shell-buffer-name'.
+If DEDICATED is `buffer' or `project', append the current buffer
+name respectively the current project name."
+ (pcase dedicated
+ ('nil python-shell-buffer-name)
+ ('project
+ (if-let ((proj (and (featurep 'project)
+ (project-current))))
+ (format "%s[%s]" python-shell-buffer-name (file-name-nondirectory
+ (directory-file-name
+ (project-root proj))))
+ python-shell-buffer-name))
+ (_ (format "%s[%s]" python-shell-buffer-name (buffer-name)))))
(defun python-shell-internal-get-process-name ()
"Calculate the appropriate process name for Internal Python process.
@@ -3129,8 +3186,8 @@ killed."
Argument CMD defaults to `python-shell-calculate-command' return
value. When called interactively with `prefix-arg', it allows
the user to edit such value and choose whether the interpreter
-should be DEDICATED for the current buffer. When numeric prefix
-arg is other than 0 or 4 do not SHOW.
+should be DEDICATED to the current buffer or project. When
+numeric prefix arg is other than 0 or 4 do not SHOW.
For a given buffer and same values of DEDICATED, if a process is
already running for it, it will do nothing. This means that if
@@ -3144,13 +3201,25 @@ process buffer for a list of commands.)"
(if current-prefix-arg
(list
(read-shell-command "Run Python: " (python-shell-calculate-command))
- (y-or-n-p "Make dedicated process? ")
+ (alist-get (car (read-multiple-choice "Make dedicated process?"
+ '((?b "to buffer")
+ (?p "to project")
+ (?n "no"))))
+ '((?b . buffer) (?p . project)))
(= (prefix-numeric-value current-prefix-arg) 4))
- (list (python-shell-calculate-command) nil t)))
- (let ((buffer
- (python-shell-make-comint
- (or cmd (python-shell-calculate-command))
- (python-shell-get-process-name dedicated) show)))
+ (list (python-shell-calculate-command)
+ python-shell-dedicated
+ t)))
+ (let* ((project (and (eq 'project dedicated)
+ (featurep 'project)
+ (project-current t)))
+ (default-directory (if project
+ (project-root project)
+ default-directory))
+ (buffer (python-shell-make-comint
+ (or cmd (python-shell-calculate-command))
+ (python-shell-get-process-name dedicated)
+ show)))
(get-buffer-process buffer)))
(defun run-python-internal ()
@@ -3180,15 +3249,13 @@ startup."
If current buffer is in `inferior-python-mode', return it."
(if (derived-mode-p 'inferior-python-mode)
(current-buffer)
- (let* ((dedicated-proc-name (python-shell-get-process-name t))
- (dedicated-proc-buffer-name (format "*%s*" dedicated-proc-name))
- (global-proc-name (python-shell-get-process-name nil))
- (global-proc-buffer-name (format "*%s*" global-proc-name))
- (dedicated-running (comint-check-proc dedicated-proc-buffer-name))
- (global-running (comint-check-proc global-proc-buffer-name)))
- ;; Always prefer dedicated
- (or (and dedicated-running dedicated-proc-buffer-name)
- (and global-running global-proc-buffer-name)))))
+ (seq-some
+ (lambda (dedicated)
+ (let* ((proc-name (python-shell-get-process-name dedicated))
+ (buffer-name (format "*%s*" proc-name)))
+ (when (comint-check-proc buffer-name)
+ buffer-name)))
+ '(buffer project nil))))
(defun python-shell-get-process ()
"Return inferior Python process for current buffer."
@@ -5822,6 +5889,225 @@ REPORT-FN is Flymake's callback function."
(process-send-eof python--flymake-proc))))
+;;; Import management
+(defconst python--list-imports "\
+from isort import find_imports_in_stream, find_imports_in_paths
+from sys import argv, stdin
+
+query, files, result = argv[1] or None, argv[2:], {}
+
+if files:
+ imports = find_imports_in_paths(files, top_only=True)
+else:
+ imports = find_imports_in_stream(stdin, top_only=True)
+
+for imp in imports:
+ if query is None or query == (imp.alias or imp.attribute or imp.module):
+ key = (imp.module, imp.attribute or '', imp.alias or '')
+ if key not in result:
+ result[key] = imp.statement()
+
+for key in sorted(result):
+ print(result[key])
+"
+ "Script to list import statements in Python code.")
+
+(defvar python-import-history nil
+ "History variable for `python-import' commands.")
+
+(defun python--import-sources ()
+ "List files containing Python imports that may be useful in the current buffer."
+ (if-let (((featurep 'project)) ;For compatibility with Emacs < 26
+ (proj (project-current)))
+ (seq-filter (lambda (s) (string-match-p "\\.py[ciw]?\\'" s))
+ (project-files proj))
+ (list default-directory)))
+
+(defun python--list-imports (name source)
+ "List all Python imports matching NAME in SOURCE.
+If NAME is nil, list all imports. SOURCE can be a buffer or a
+list of file names or directories; the latter are searched
+recursively."
+ (let ((buffer (current-buffer)))
+ (with-temp-buffer
+ (let* ((temp (current-buffer))
+ (status (if (bufferp source)
+ (with-current-buffer source
+ (call-process-region (point-min) (point-max)
+ python-interpreter
+ nil (list temp nil) nil
+ "-c" python--list-imports
+ (or name "")))
+ (with-current-buffer buffer
+ (apply #'call-process
+ python-interpreter
+ nil (list temp nil) nil
+ "-c" python--list-imports
+ (or name "")
+ (mapcar #'file-local-name source)))))
+ lines)
+ (unless (eq 0 status)
+ (error "%s exited with status %s (maybe isort is missing?)"
+ python-interpreter status))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (push (buffer-substring-no-properties (point) (pos-eol))
+ lines)
+ (forward-line 1))
+ (nreverse lines)))))
+
+(defun python--query-import (name source prompt)
+ "Read a Python import statement defining NAME.
+A list of candidates is produced by `python--list-imports' using
+the NAME and SOURCE arguments. An interactive query, using the
+PROMPT string, is made unless there is a single candidate."
+ (let* ((cands (python--list-imports name source))
+ ;; Don't use DEF argument of `completing-read', so it is able
+ ;; to return the empty string.
+ (minibuffer-default-add-function
+ (lambda ()
+ (setq minibuffer-default (with-minibuffer-selected-window
+ (thing-at-point 'symbol)))))
+ (statement (cond ((and name (length= cands 1))
+ (car cands))
+ (prompt
+ (completing-read prompt
+ (or cands python-import-history)
+ nil nil nil
+ 'python-import-history)))))
+ (unless (string-empty-p statement)
+ statement)))
+
+(defun python--do-isort (&rest args)
+ "Edit the current buffer using isort called with ARGS.
+Return non-nil if the buffer was actually modified."
+ (let ((buffer (current-buffer)))
+ (with-temp-buffer
+ (let ((temp (current-buffer)))
+ (with-current-buffer buffer
+ (let ((status (apply #'call-process-region
+ (point-min) (point-max)
+ python-interpreter
+ nil (list temp nil) nil
+ "-m" "isort" "-" args))
+ (tick (buffer-chars-modified-tick)))
+ (unless (eq 0 status)
+ (error "%s exited with status %s (maybe isort is missing?)"
+ python-interpreter status))
+ (replace-buffer-contents temp)
+ (not (eq tick (buffer-chars-modified-tick)))))))))
+
+;;;###autoload
+(defun python-add-import (name)
+ "Add an import statement to the current buffer.
+
+Interactively, ask for an import statement using all imports
+found in the current project as suggestions. With a prefix
+argument, restrict the suggestions to imports defining the symbol
+at point. If there is only one such suggestion, act without
+asking.
+
+When calling from Lisp, use a non-nil NAME to restrict the
+suggestions to imports defining NAME."
+ (interactive (list (when current-prefix-arg (thing-at-point 'symbol))))
+ (when-let ((statement (python--query-import name
+ (python--import-sources)
+ "Add import: ")))
+ (if (python--do-isort "--add" statement)
+ (message "Added `%s'" statement)
+ (message "(No changes in Python imports needed)"))))
+
+;;;###autoload
+(defun python-import-symbol-at-point ()
+ "Add an import statement for the symbol at point to the current buffer.
+This works like `python-add-import', but with the opposite
+behavior regarding the prefix argument."
+ (interactive nil)
+ (python-add-import (unless current-prefix-arg (thing-at-point 'symbol))))
+
+;;;###autoload
+(defun python-remove-import (name)
+ "Remove an import statement from the current buffer.
+
+Interactively, ask for an import statement to remove, displaying
+the imports of the current buffer as suggestions. With a prefix
+argument, restrict the suggestions to imports defining the symbol
+at point. If there is only one such suggestion, act without
+asking."
+ (interactive (list (when current-prefix-arg (thing-at-point 'symbol))))
+ (when-let ((statement (python--query-import name (current-buffer)
+ "Remove import: ")))
+ (if (python--do-isort "--rm" statement)
+ (message "Removed `%s'" statement)
+ (message "(No changes in Python imports needed)"))))
+
+;;;###autoload
+(defun python-sort-imports ()
+ "Sort Python imports in the current buffer."
+ (interactive)
+ (if (python--do-isort)
+ (message "Sorted imports")
+ (message "(No changes in Python imports needed)")))
+
+;;;###autoload
+(defun python-fix-imports ()
+ "Add missing imports and remove unused ones from the current buffer."
+ (interactive)
+ (let ((buffer (current-buffer))
+ undefined unused add remove)
+ ;; Compute list of undefined and unused names
+ (with-temp-buffer
+ (let ((temp (current-buffer)))
+ (with-current-buffer buffer
+ (call-process-region (point-min) (point-max)
+ python-interpreter
+ nil temp nil
+ "-m" "pyflakes"))
+ (goto-char (point-min))
+ (when (looking-at-p ".* No module named pyflakes$")
+ (error "%s couldn't find pyflakes" python-interpreter))
+ (while (not (eobp))
+ (cond ((looking-at ".* undefined name '\\([^']+\\)'$")
+ (push (match-string 1) undefined))
+ ((looking-at ".*'\\([^']+\\)' imported but unused$")
+ (push (match-string 1) unused)))
+ (forward-line 1))))
+ ;; Compute imports to be added
+ (dolist (name (seq-uniq undefined))
+ (when-let ((statement (python--query-import name
+ (python--import-sources)
+ (format "\
+Add import for undefined name `%s' (empty to skip): "
+ name))))
+ (push statement add)))
+ ;; Compute imports to be removed
+ (dolist (name (seq-uniq unused))
+ ;; The unused imported names, as provided by pyflakes, are of
+ ;; the form "module.var" or "module.var as alias", independently
+ ;; of style of import statement used.
+ (let* ((filter
+ (lambda (statement)
+ (string= name
+ (thread-last
+ statement
+ (replace-regexp-in-string "^\\(from\\|import\\) " "")
+ (replace-regexp-in-string " import " ".")))))
+ (statements (seq-filter filter (python--list-imports nil buffer))))
+ (when (length= statements 1)
+ (push (car statements) remove))))
+ ;; Edit buffer and say goodbye
+ (if (not (or add remove))
+ (message "(No changes in Python imports needed)")
+ (apply #'python--do-isort
+ (append (mapcan (lambda (x) (list "--add" x)) add)
+ (mapcan (lambda (x) (list "--rm" x)) remove)))
+ (message "%s" (concat (when add "Added ")
+ (when add (string-join add ", "))
+ (when remove (if add " and removed " "Removed "))
+ (when remove (string-join remove ", " )))))))
+
+
+;;; Major mode
(defun python-electric-pair-string-delimiter ()
(when (and electric-pair-mode
(memq last-command-event '(?\" ?\'))
@@ -5943,8 +6229,10 @@ REPORT-FN is Flymake's callback function."
;;; Completion predicates for M-x
;; Commands that only make sense when editing Python code
-(dolist (sym '(python-check
+(dolist (sym '(python-add-import
+ python-check
python-fill-paragraph
+ python-fix-imports
python-indent-dedent-line
python-indent-dedent-line-backspace
python-indent-guess-indent-offset
@@ -5969,9 +6257,11 @@ REPORT-FN is Flymake's callback function."
python-nav-forward-statement
python-nav-if-name-main
python-nav-up-list
+ python-remove-import
python-shell-send-buffer
python-shell-send-defun
- python-shell-send-statement))
+ python-shell-send-statement
+ python-sort-imports))
(put sym 'completion-predicate #'python--completion-predicate))
(defun python-shell--completion-predicate (_ buffer)
diff --git a/lisp/recentf.el b/lisp/recentf.el
index b80ee3dd7d8..32badb1a370 100644
--- a/lisp/recentf.el
+++ b/lisp/recentf.el
@@ -411,7 +411,8 @@ returned nil."
"Convert file NAME to absolute, and canonicalize it.
NAME is first passed to the function `expand-file-name', then to
`recentf-filename-handlers' to post process it."
- (recentf-apply-filename-handlers (expand-file-name name)))
+ (let ((non-essential t))
+ (recentf-apply-filename-handlers (expand-file-name name))))
(defun recentf-include-p (filename)
"Return non-nil if FILENAME should be included in the recent list.
diff --git a/lisp/replace.el b/lisp/replace.el
index 2bb9c1b90dc..06cde771b9e 100644
--- a/lisp/replace.el
+++ b/lisp/replace.el
@@ -448,6 +448,10 @@ Arguments FROM-STRING, TO-STRING, DELIMITED, START, END, BACKWARD, and
REGION-NONCONTIGUOUS-P are passed to `perform-replace' (which see).
To customize possible responses, change the bindings in `query-replace-map'."
+ (declare (interactive-args
+ (start (use-region-beginning))
+ (end (use-region-end))
+ (region-noncontiguous-p (use-region-noncontiguous-p))))
(interactive
(let ((common
(query-replace-read-args
@@ -461,10 +465,9 @@ To customize possible responses, change the bindings in `query-replace-map'."
;; These are done separately here
;; so that command-history will record these expressions
;; rather than the values they had this time.
- (if (use-region-p) (region-beginning))
- (if (use-region-p) (region-end))
+ (use-region-beginning) (use-region-end)
(nth 3 common)
- (if (use-region-p) (region-noncontiguous-p)))))
+ (use-region-noncontiguous-p))))
(perform-replace from-string to-string t nil delimited nil nil start end backward region-noncontiguous-p))
(define-key esc-map "%" 'query-replace)
@@ -541,6 +544,10 @@ Use \\[repeat-complex-command] after this command for details.
Arguments REGEXP, TO-STRING, DELIMITED, START, END, BACKWARD, and
REGION-NONCONTIGUOUS-P are passed to `perform-replace' (which see)."
+ (declare (interactive-args
+ (start (use-region-beginning))
+ (end (use-region-end))
+ (region-noncontiguous-p (use-region-noncontiguous-p))))
(interactive
(let ((common
(query-replace-read-args
@@ -555,10 +562,9 @@ REGION-NONCONTIGUOUS-P are passed to `perform-replace' (which see)."
;; These are done separately here
;; so that command-history will record these expressions
;; rather than the values they had this time.
- (if (use-region-p) (region-beginning))
- (if (use-region-p) (region-end))
+ (use-region-beginning) (use-region-end)
(nth 3 common)
- (if (use-region-p) (region-noncontiguous-p)))))
+ (use-region-noncontiguous-p))))
(perform-replace regexp to-string t t delimited nil nil start end backward region-noncontiguous-p))
(define-key esc-map [?\C-%] 'query-replace-regexp)
@@ -592,6 +598,10 @@ Fourth and fifth arg START and END specify the region to operate on.
Arguments REGEXP, START, END, and REGION-NONCONTIGUOUS-P are passed to
`perform-replace' (which see)."
+ (declare (interactive-args
+ (start (use-region-beginning))
+ (end (use-region-end))
+ (region-noncontiguous-p (use-region-noncontiguous-p))))
(interactive
(let* ((from (read-regexp "Map query replace (regexp): " nil
query-replace-from-history-variable))
@@ -603,9 +613,8 @@ Arguments REGEXP, START, END, and REGION-NONCONTIGUOUS-P are passed to
(list from to
(and current-prefix-arg
(prefix-numeric-value current-prefix-arg))
- (if (use-region-p) (region-beginning))
- (if (use-region-p) (region-end))
- (if (use-region-p) (region-noncontiguous-p)))))
+ (use-region-beginning) (use-region-end)
+ (use-region-noncontiguous-p))))
(let (replacements)
(if (listp to-strings)
(setq replacements to-strings)
@@ -665,9 +674,10 @@ which will run faster and will not set the mark or print anything.
and TO-STRING is also null.)"
(declare (interactive-only
"use `search-forward' and `replace-match' instead.")
- (interactive-args
+ (interactive-args
(start (use-region-beginning))
- (end (use-region-end))))
+ (end (use-region-end))
+ (region-noncontiguous-p (use-region-noncontiguous-p))))
(interactive
(let ((common
(query-replace-read-args
@@ -681,7 +691,7 @@ and TO-STRING is also null.)"
(list (nth 0 common) (nth 1 common) (nth 2 common)
(use-region-beginning) (use-region-end)
(nth 3 common)
- (if (use-region-p) (region-noncontiguous-p)))))
+ (use-region-noncontiguous-p))))
(perform-replace from-string to-string nil nil delimited nil nil start end backward region-noncontiguous-p))
(defun replace-regexp (regexp to-string &optional delimited start end backward region-noncontiguous-p)
@@ -746,7 +756,11 @@ What you probably want is a loop like this:
(replace-match TO-STRING nil nil))
which will run faster and will not set the mark or print anything."
(declare (interactive-only
- "use `re-search-forward' and `replace-match' instead."))
+ "use `re-search-forward' and `replace-match' instead.")
+ (interactive-args
+ (start (use-region-beginning))
+ (end (use-region-end))
+ (region-noncontiguous-p (use-region-noncontiguous-p))))
(interactive
(let ((common
(query-replace-read-args
@@ -758,10 +772,9 @@ which will run faster and will not set the mark or print anything."
(if (use-region-p) " in region" ""))
t)))
(list (nth 0 common) (nth 1 common) (nth 2 common)
- (if (use-region-p) (region-beginning))
- (if (use-region-p) (region-end))
+ (use-region-beginning) (use-region-end)
(nth 3 common)
- (if (use-region-p) (region-noncontiguous-p)))))
+ (use-region-noncontiguous-p))))
(perform-replace regexp to-string nil t delimited nil nil start end backward region-noncontiguous-p))
diff --git a/lisp/simple.el b/lisp/simple.el
index daacf697ff3..60f2ad34528 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -6878,6 +6878,10 @@ point otherwise."
"Return the end of the region if `use-region-p'."
(and (use-region-p) (region-end)))
+(defun use-region-noncontiguous-p ()
+ "Return non-nil for a non-contiguous region if `use-region-p'."
+ (and (use-region-p) (region-noncontiguous-p)))
+
(defun use-region-p ()
"Return t if the region is active and it is appropriate to act on it.
This is used by commands that act specially on the region under
@@ -6922,7 +6926,7 @@ see `region-noncontiguous-p' and `extract-rectangle-bounds'."
"Return non-nil if the region contains several pieces.
An example is a rectangular region handled as a list of
separate contiguous regions for each line."
- (cdr (region-bounds)))
+ (let ((bounds (region-bounds))) (and (cdr bounds) bounds)))
(defun redisplay--unhighlight-overlay-function (rol)
"If ROL is an overlay, call `delete-overlay'."
@@ -10431,7 +10435,9 @@ and setting it to nil."
map))
(define-derived-mode messages-buffer-mode special-mode "Messages"
- "Major mode used in the \"*Messages*\" buffer.")
+ "Major mode used in the \"*Messages*\" buffer."
+ ;; Make it easy to do like "tail -f".
+ (setq-local window-point-insertion-type t))
(defun messages-buffer ()
"Return the \"*Messages*\" buffer.
diff --git a/lisp/startup.el b/lisp/startup.el
index fe68c0f8a6f..a88cdd0d74d 100644
--- a/lisp/startup.el
+++ b/lisp/startup.el
@@ -718,8 +718,6 @@ It is the default value of the variable `top-level'."
(let ((dir default-directory))
(with-current-buffer "*Messages*"
(messages-buffer-mode)
- ;; Make it easy to do like "tail -f".
- (setq-local window-point-insertion-type t)
;; Give *Messages* the same default-directory as *scratch*,
;; just to keep things predictable.
(setq default-directory (or dir (expand-file-name "~/")))))
diff --git a/lisp/subr.el b/lisp/subr.el
index 36f5e2fee49..e4d32455371 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -1913,8 +1913,10 @@ be a list of the form returned by `event-start' and `event-end'."
(defalias 'mkdir #'make-directory)
;; These were the XEmacs names, now obsolete:
-(define-obsolete-function-alias 'point-at-eol #'line-end-position "29.1")
-(define-obsolete-function-alias 'point-at-bol #'line-beginning-position "29.1")
+(defalias 'point-at-eol #'line-end-position)
+(make-obsolete 'point-at-eol "use `line-end-position' or `pos-eol' instead." "29.1")
+(defalias 'point-at-bol #'line-beginning-position)
+(make-obsolete 'point-at-bol "use `line-beginning-position' or `pos-bol' instead." "29.1")
(define-obsolete-function-alias 'user-original-login-name #'user-login-name "28.1")
;; These are in obsolete/autoload.el, but are commonly used by
@@ -6990,32 +6992,32 @@ CONDITION is either:
(lambda (conditions)
(catch 'match
(dolist (condition conditions)
- (when (cond
- ((eq condition t))
- ((stringp condition)
- (string-match-p condition (buffer-name buffer)))
- ((functionp condition)
- (if (eq 1 (cdr (func-arity condition)))
- (funcall condition buffer)
- (funcall condition buffer arg)))
- ((eq (car-safe condition) 'major-mode)
- (eq
- (buffer-local-value 'major-mode buffer)
- (cdr condition)))
- ((eq (car-safe condition) 'derived-mode)
- (provided-mode-derived-p
- (buffer-local-value 'major-mode buffer)
- (cdr condition)))
- ((eq (car-safe condition) 'not)
- (not (funcall match (cdr condition))))
- ((eq (car-safe condition) 'or)
- (funcall match (cdr condition)))
- ((eq (car-safe condition) 'and)
- (catch 'fail
- (dolist (c (cdr conditions))
- (unless (funcall match c)
- (throw 'fail nil)))
- t)))
+ (when (pcase condition
+ ('t t)
+ ((pred stringp)
+ (string-match-p condition (buffer-name buffer)))
+ ((pred functionp)
+ (if (eq 1 (cdr (func-arity condition)))
+ (funcall condition buffer)
+ (funcall condition buffer arg)))
+ (`(major-mode . ,mode)
+ (eq
+ (buffer-local-value 'major-mode buffer)
+ mode))
+ (`(derived-mode . ,mode)
+ (provided-mode-derived-p
+ (buffer-local-value 'major-mode buffer)
+ mode))
+ (`(not . ,cond)
+ (not (funcall match cond)))
+ (`(or . ,args)
+ (funcall match args))
+ (`(and . ,args)
+ (catch 'fail
+ (dolist (c args)
+ (unless (funcall match (list c))
+ (throw 'fail nil)))
+ t)))
(throw 'match t)))))))
(funcall match (list condition))))
diff --git a/lisp/t-mouse.el b/lisp/t-mouse.el
index cdfc30c8793..7a4e7f330ea 100644
--- a/lisp/t-mouse.el
+++ b/lisp/t-mouse.el
@@ -62,6 +62,9 @@
(gpm-mouse-stop))
(set-terminal-parameter nil 'gpm-mouse-active nil))
+(defun gpm-mouse-tty-setup ()
+ (if gpm-mouse-mode (gpm-mouse-enable) (gpm-mouse-disable)))
+
;;;###autoload
(define-minor-mode gpm-mouse-mode
"Toggle mouse support in GNU/Linux consoles (GPM Mouse mode).
@@ -80,7 +83,9 @@ GPM. This is due to limitations in GPM and the Linux kernel."
(terminal-parameter terminal 'gpm-mouse-active))))
;; Simulate selecting a terminal by selecting one of its frames ;-(
(with-selected-frame (car (frames-on-display-list terminal))
- (if gpm-mouse-mode (gpm-mouse-enable) (gpm-mouse-disable))))))
+ (gpm-mouse-tty-setup))))
+ (when gpm-mouse-mode
+ (add-hook 'tty-setup-hook #'gpm-mouse-tty-setup)))
(provide 't-mouse)
diff --git a/lisp/term/fbterm.el b/lisp/term/fbterm.el
new file mode 100644
index 00000000000..ad7150c1a1f
--- /dev/null
+++ b/lisp/term/fbterm.el
@@ -0,0 +1,27 @@
+;;; fbterm.el -*- lexical-binding:t -*-
+
+;; Copyright (C) 2022 Free Software Foundation, Inc.
+
+;; Note that, in some versions of fbterm, the TERM environment
+;; variable is set to "linux". When that's the case, the code below
+;; will not be executed, and only 8 colors will be available. It is
+;; therefore necessary, with these versions of fbterm, to set that
+;; environment variable to "fbterm" to enable its 256 color mode
+;; extension. See also the node "Emacs in a Linux console" of the
+;; Emacs FAQ.
+
+(require 'term/xterm)
+
+(defun terminal-init-fbterm ()
+ "Terminal initialization function for fbterm."
+
+ ;; fbterm can't display underlines, even though its terminfo data
+ ;; says it can.
+ (tty-no-underline)
+
+ ;; fbterm supports xterm's 256 color mode extension.
+ (xterm-register-default-colors xterm-standard-colors))
+
+(provide 'term/fbterm)
+
+;;; fbterm.el ends here
diff --git a/lisp/term/linux.el b/lisp/term/linux.el
index ab5a6d8698f..f24af3f1344 100644
--- a/lisp/term/linux.el
+++ b/lisp/term/linux.el
@@ -2,8 +2,6 @@
;; The Linux console handles Latin-1 by default.
-(declare-function gpm-mouse-enable "t-mouse" ())
-
(defun terminal-init-linux ()
"Terminal initialization function for linux."
(unless (terminal-coding-system)
@@ -15,15 +13,11 @@
;; Compositions confuse cursor movement.
(setq-default auto-composition-mode "linux")
- (ignore-errors (when gpm-mouse-mode (require 't-mouse) (gpm-mouse-enable)))
-
- ;; Don't translate ESC TAB to backtab as directed
- ;; by ncurses-6.3.
+ ;; Don't translate ESC TAB to backtab as directed by ncurses-6.3.
(define-key input-decode-map "\e\t" nil)
;; Make Latin-1 input characters work, too.
- ;; Meta will continue to work, because the kernel
- ;; turns that into Escape.
+ ;; Meta will continue to work, because the kernel turns that into Escape.
;; The arg only matters in that it is not t or nil.
(set-input-meta-mode 'iso-latin-1))
diff --git a/lisp/textmodes/emacs-news-mode.el b/lisp/textmodes/emacs-news-mode.el
index 022e17c9343..6bf96deaccb 100644
--- a/lisp/textmodes/emacs-news-mode.el
+++ b/lisp/textmodes/emacs-news-mode.el
@@ -73,9 +73,11 @@
(defun emacs-news--mode-common ()
(setq-local font-lock-defaults '(emacs-news-mode-font-lock-keywords t))
- (setq-local outline-regexp "\\(:? +\\)?\\(\\*+\\) "
+ ;; This `outline-regexp' matches leading spaces inserted
+ ;; by the current implementation of `outline-minor-mode-use-buttons'.
+ (setq-local outline-regexp "\\(?: +\\)?\\(\\*+\\) "
+ outline-level (lambda () (length (match-string 1)))
outline-minor-mode-cycle t
- outline-level (lambda () (length (match-string 2)))
outline-minor-mode-highlight 'append)
(outline-minor-mode)
(emacs-etc--hide-local-variables))
diff --git a/lisp/textmodes/ispell.el b/lisp/textmodes/ispell.el
index 8e633688091..4b5ed98ecc9 100644
--- a/lisp/textmodes/ispell.el
+++ b/lisp/textmodes/ispell.el
@@ -262,12 +262,14 @@ This must be an absolute file name."
"Non-nil means use `look' rather than `grep'.
Default is based on whether `look' seems to be available."
:type 'boolean)
+(make-obsolete-variable 'ispell-look-p nil "29.1")
(defcustom ispell-have-new-look nil
"Non-nil means use the `-r' option (regexp) when running `look'."
:type 'boolean)
+(make-obsolete-variable 'ispell-have-new-look nil "29.1")
-(defcustom ispell-look-options (if ispell-have-new-look "-dfr" "-df")
+(defcustom ispell-look-options "-df"
"String of command options for `ispell-look-command'."
:type 'string)
@@ -2519,8 +2521,10 @@ if defined."
(let* ((process-connection-type ispell-use-ptys-p)
(wild-p (string-search "*" word))
- (look-p (and ispell-look-p ; Only use look for an exact match.
- (or ispell-have-new-look (not wild-p))))
+ (look-p (and ispell-look-command
+ (file-exists-p ispell-look-command)
+ ;; Only use look for an exact match.
+ (not wild-p)))
(prog (if look-p ispell-look-command ispell-grep-command))
(args (if look-p ispell-look-options ispell-grep-options))
status results loc)
diff --git a/lisp/textmodes/paragraphs.el b/lisp/textmodes/paragraphs.el
index cd726ad4776..c500dc014fb 100644
--- a/lisp/textmodes/paragraphs.el
+++ b/lisp/textmodes/paragraphs.el
@@ -514,9 +514,9 @@ Second and third arg START and END specify the region to operate on.
If optional argument NO-QUERY is non-nil, make changes without asking
for confirmation. You can use `repunctuate-sentences-filter' to add
filters to skip occurrences of spaces that don't need to be replaced."
- (interactive (list nil
- (if (use-region-p) (region-beginning))
- (if (use-region-p) (region-end))))
+ (declare (interactive-args (start (use-region-beginning))
+ (end (use-region-end))))
+ (interactive (list nil (use-region-beginning) (use-region-end)))
(let ((regexp "\\([]\"')]?\\)\\([.?!]\\)\\([]\"')]?\\) +")
(to-string "\\1\\2\\3 "))
(if no-query
diff --git a/lisp/url/url-gw.el b/lisp/url/url-gw.el
index c4a41f56b3e..e4d1ca72a0d 100644
--- a/lisp/url/url-gw.el
+++ b/lisp/url/url-gw.el
@@ -28,8 +28,6 @@
(require 'url-vars)
(require 'url-parse)
-;; Fixme: support SSH explicitly or via a url-gateway-rlogin-program?
-
(autoload 'socks-open-network-stream "socks")
(defgroup url-gateway nil
@@ -51,17 +49,20 @@
"What hostname to actually rlog into before doing a telnet."
:type '(choice (const nil) string)
:group 'url-gateway)
+(make-obsolete-variable 'url-gateway-rlogin-host nil "29.1")
(defcustom url-gateway-rlogin-user-name nil
"Username to log into the remote machine with when using rlogin."
:type '(choice (const nil) string)
:group 'url-gateway)
+(make-obsolete-variable 'url-gateway-rlogin-user-name nil "29.1")
(defcustom url-gateway-rlogin-parameters '("telnet" "-8")
"Parameters to `url-open-rlogin'.
This list will be used as the parameter list given to rsh."
:type '(repeat string)
:group 'url-gateway)
+(make-obsolete-variable 'url-gateway-rlogin-parameters nil "29.1")
(defcustom url-gateway-telnet-host nil
"What hostname to actually login to before doing a telnet."
@@ -141,6 +142,7 @@ linked Emacs under SunOS 4.x."
;; Stolen from red gnus nntp.el
(defun url-open-rlogin (name buffer host service)
"Open a connection using rsh."
+ (declare (obsolete nil "29.1"))
(if (not (stringp service))
(setq service (int-to-string service)))
(let ((proc (if url-gateway-rlogin-user-name
@@ -205,6 +207,9 @@ linked Emacs under SunOS 4.x."
(delete-region (point) (point-max)))
proc)))
+(defvar url-gw-rlogin-obsolete-warned-once nil)
+(make-obsolete-variable url-gw-rlogin-obsolete-warned-once nil "29.1")
+
;;;###autoload
(defun url-open-stream (name buffer host service &optional gateway-method)
"Open a stream to HOST, possibly via a gateway.
@@ -255,7 +260,11 @@ overriding the value of `url-gateway-method'."
('telnet
(url-open-telnet name buffer host service))
('rlogin
- (url-open-rlogin name buffer host service))
+ (unless url-gw-rlogin-obsolete-warned-once
+ (lwarn 'url :error "Setting `url-gateway-method' to `rlogin' is obsolete")
+ (setq url-gw-rlogin-obsolete-warned-once t))
+ (with-suppressed-warnings ((obsolete url-open-rlogin))
+ (url-open-rlogin name buffer host service)))
(_
(error "Bad setting of url-gateway-method: %s"
url-gateway-method))))))
diff --git a/lisp/url/url-misc.el b/lisp/url/url-misc.el
index 479f64c3e07..0c1f79a0c59 100644
--- a/lisp/url/url-misc.el
+++ b/lisp/url/url-misc.el
@@ -47,6 +47,9 @@
(error "Malformed url: %s" (url-recreate-url url)))
nil))
+(defvar url-misc-rlogin-obsolete-warned-once nil)
+(make-obsolete-variable url-misc-rlogin-obsolete-warned-once nil "29.1")
+
(defun url-do-terminal-emulator (type server port user)
(switch-to-buffer
(apply
@@ -58,6 +61,9 @@
(t (error "Unknown terminal emulator required: %s" type)))
nil
(cond ((eq type 'rlogin)
+ (unless url-misc-rlogin-obsolete-warned-once
+ (lwarn 'url :error "Method `rlogin' is obsolete")
+ (setq url-misc-rlogin-obsolete-warned-once t))
(if user (list server "-l" user) (list server)))
((eq type 'telnet)
(if port (list server port) (list server)))
@@ -74,7 +80,7 @@
nil)
;;;###autoload
-(defalias 'url-rlogin 'url-generic-emulator-loader)
+(define-obsolete-function-alias 'url-rlogin #'url-generic-emulator-loader "29.1")
;;;###autoload
(defalias 'url-telnet 'url-generic-emulator-loader)
;;;###autoload
diff --git a/lisp/url/url-vars.el b/lisp/url/url-vars.el
index 859a5c75ed3..4cdca055543 100644
--- a/lisp/url/url-vars.el
+++ b/lisp/url/url-vars.el
@@ -350,13 +350,11 @@ Should be a symbol specifying how to get a connection from the local machine.
Currently supported methods:
`telnet': Run telnet in a subprocess to connect;
-`rlogin': Rlogin to another machine to connect;
`socks': Connect through a socks server;
`tls': Connect with TLS;
`ssl': Connect with SSL (deprecated, use `tls' instead);
`native': Connect directly."
:type '(radio (const :tag "Telnet to gateway host" :value telnet)
- (const :tag "Rlogin to gateway host" :value rlogin)
(const :tag "Use SOCKS proxy" :value socks)
(const :tag "Use SSL/TLS for all connections" :value tls)
(const :tag "Use SSL for all connections (obsolete)" :value ssl)
diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el
index 7395253745e..9dfdd9e7b13 100644
--- a/lisp/vc/vc-git.el
+++ b/lisp/vc/vc-git.el
@@ -858,6 +858,47 @@ The car of the list is the current branch."
;;; STATE-CHANGING FUNCTIONS
+(defcustom vc-git-log-edit-summary-target-len nil
+ "Target length for Git commit summary lines.
+If a number, characters in Summary: lines beyond this length are
+displayed in the `vc-git-log-edit-summary-target-warning' face.
+A value of any other type means no highlighting.
+
+By setting this to an integer around 50, you can improve the
+compatibility of your commit messages with Git commands that
+print the summary line in width-constrained contexts. However,
+many commit summaries will need to exceed this length.
+
+See also `vc-git-log-edit-summary-max-len'."
+ :type '(choice (const :tag "No target" nil)
+ (natnum :tag "Target length"))
+ :safe (lambda (x) (or (not x) (natnump x))))
+
+(defface vc-git-log-edit-summary-target-warning
+ '((t :inherit warning))
+ "Face for Git commit summary lines beyond the target length.
+See `vc-git-log-edit-summary-target-len'.")
+
+(defcustom vc-git-log-edit-summary-max-len 68
+ "Maximum length for Git commit summary lines.
+If a number, characters in summary lines beyond this length are
+displayed in the `vc-git-log-edit-summary-max-warning' face.
+A value of any other type means no highlighting.
+
+It is good practice to avoid writing summary lines longer than
+this because otherwise the summary line will be truncated in many
+contexts in which Git commands display summary lines.
+
+See also `vc-git-log-edit-summary-target-len'."
+ :type '(choice (const :tag "No target" nil)
+ (natnum :tag "Target length"))
+ :safe (lambda (x) (or (not x) (natnump x))))
+
+(defface vc-git-log-edit-summary-max-warning
+ '((t :inherit error))
+ "Face for Git commit summary lines beyond the maximum length.
+See `vc-git-log-edit-summary-max-len'.")
+
(defun vc-git-create-repo ()
"Create a new Git repository."
(vc-git-command nil 0 nil "init"))
@@ -911,9 +952,32 @@ If toggling on, also insert its message into the buffer."
"C-c C-n" #'vc-git-log-edit-toggle-no-verify
"C-c C-e" #'vc-git-log-edit-toggle-amend)
+(defun vc-git--log-edit-summary-check (limit)
+ (and (re-search-forward "^Summary: " limit t)
+ (when-let ((regex
+ (cond ((and (natnump vc-git-log-edit-summary-max-len)
+ (natnump vc-git-log-edit-summary-target-len))
+ (format ".\\{,%d\\}\\(.\\{,%d\\}\\)\\(.*\\)"
+ vc-git-log-edit-summary-target-len
+ (- vc-git-log-edit-summary-max-len
+ vc-git-log-edit-summary-target-len)))
+ ((natnump vc-git-log-edit-summary-max-len)
+ (format ".\\{,%d\\}\\(?2:.*\\)"
+ vc-git-log-edit-summary-max-len))
+ ((natnump vc-git-log-edit-summary-target-len)
+ (format ".\\{,%d\\}\\(.*\\)"
+ vc-git-log-edit-summary-target-len)))))
+ (re-search-forward regex limit t))))
+
(define-derived-mode vc-git-log-edit-mode log-edit-mode "Log-Edit/git"
"Major mode for editing Git log messages.
-It is based on `log-edit-mode', and has Git-specific extensions.")
+It is based on `log-edit-mode', and has Git-specific extensions."
+ (setq-local
+ log-edit-font-lock-keywords
+ (append log-edit-font-lock-keywords
+ '((vc-git--log-edit-summary-check
+ (1 'vc-git-log-edit-summary-target-warning prepend t)
+ (2 'vc-git-log-edit-summary-max-warning prepend t))))))
(defvar vc-git-patch-string nil)
diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el
index ec2eb146e90..9aec6b02441 100644
--- a/lisp/wid-edit.el
+++ b/lisp/wid-edit.el
@@ -4145,6 +4145,15 @@ is inline."
(define-obsolete-function-alias 'widget-visibility-value-create
#'widget-toggle-value-create "29.1")
+;;; Buffer predicates.
+(define-widget 'buffer-predicate 'lazy
+ "A buffer predicate."
+ :tag "Buffer predicate"
+ :type '(choice (const :tag "All buffers" t)
+ (const :tag "No buffers" nil)
+ ;; FIXME: This should be expanded somehow.
+ sexp))
+
(provide 'wid-edit)
;;; wid-edit.el ends here
diff --git a/lisp/window.el b/lisp/window.el
index ec2b0a69302..9ff55dc9807 100644
--- a/lisp/window.el
+++ b/lisp/window.el
@@ -5672,9 +5672,9 @@ the original point in both windows."
:type 'boolean
:group 'windows)
-(defun split-window-below (&optional size)
- "Split the selected window into two windows, one above the other.
-The selected window is above. The newly split-off window is
+(defun split-window-below (&optional size window-to-split)
+ "Split WINDOW-TO-SPLIT into two windows, one above the other.
+WINDOW-TO-SPLIT is above. The newly split-off window is
below and displays the same buffer. Return the new window.
If optional argument SIZE is omitted or nil, both windows get the
@@ -5683,22 +5683,22 @@ same height, or close to it. If SIZE is positive, the upper
lower (new) window gets -SIZE lines.
If the variable `split-window-keep-point' is non-nil, both
-windows get the same value of point as the selected window.
+windows get the same value of point as the WINDOW-TO-SPLIT.
Otherwise, the window starts are chosen so as to minimize the
amount of redisplay; this is convenient on slow terminals."
- (interactive "P")
- (let ((old-window (selected-window))
- (old-point (window-point))
- (size (and size (prefix-numeric-value size)))
+ (interactive `(,(when current-prefix-arg
+ (prefix-numeric-value current-prefix-arg))
+ ,(selected-window)))
+ (let ((old-point (window-point))
moved-by-window-height moved new-window bottom)
(when (and size (< size 0) (< (- size) window-min-height))
;; `split-window' would not signal an error here.
(error "Size of new window too small"))
- (setq new-window (split-window nil size))
+ (setq new-window (split-window window-to-split size))
(unless split-window-keep-point
- (with-current-buffer (window-buffer)
+ (with-current-buffer (window-buffer window-to-split)
;; Use `save-excursion' around vertical movements below
- ;; (Bug#10971). Note: When the selected window's buffer has a
+ ;; (Bug#10971). Note: When WINDOW-TO-SPLIT's buffer has a
;; header line, up to two lines of the buffer may not show up
;; in the resulting configuration.
(save-excursion
@@ -5713,24 +5713,31 @@ amount of redisplay; this is convenient on slow terminals."
(setq bottom (point)))
(and moved-by-window-height
(<= bottom (point))
- (set-window-point old-window (1- bottom)))
+ (set-window-point window-to-split (1- bottom)))
(and moved-by-window-height
(<= (window-start new-window) old-point)
(set-window-point new-window old-point)
(select-window new-window))))
;; Always copy quit-restore parameter in interactive use.
- (let ((quit-restore (window-parameter old-window 'quit-restore)))
+ (let ((quit-restore (window-parameter window-to-split 'quit-restore)))
(when quit-restore
(set-window-parameter new-window 'quit-restore quit-restore)))
new-window))
(defalias 'split-window-vertically 'split-window-below)
-(defun split-window-right (&optional size)
- "Split the selected window into two side-by-side windows.
-The selected window is on the left. The newly split-off window
-is on the right and displays the same buffer. Return the new
-window.
+(defun split-root-window-below (&optional size)
+ "Split root window of current frame in two.
+The current window configuration is retained in the top window,
+the lower window takes up the whole width of the frame. SIZE is
+handled as in `split-window-below'."
+ (interactive "P")
+ (split-window-below size (frame-root-window)))
+
+(defun split-window-right (&optional size window-to-split)
+ "Split WINDOW-TO-SPLIT into two side-by-side windows.
+WINDOW-TO-SPLIT is on the left. The newly split-off window is on
+the right and displays the same buffer. Return the new window.
If optional argument SIZE is omitted or nil, both windows get the
same width, or close to it. If SIZE is positive, the left-hand
@@ -5739,21 +5746,30 @@ right-hand (new) window gets -SIZE columns. Here, SIZE includes
the width of the window's scroll bar; if there are no scroll
bars, it includes the width of the divider column to the window's
right, if any."
- (interactive "P")
- (let ((old-window (selected-window))
- (size (and size (prefix-numeric-value size)))
- new-window)
+ (interactive `(,(when current-prefix-arg
+ (prefix-numeric-value current-prefix-arg))
+ ,(selected-window)))
+ (let (new-window)
(when (and size (< size 0) (< (- size) window-min-width))
;; `split-window' would not signal an error here.
(error "Size of new window too small"))
- (setq new-window (split-window nil size t))
+ (setq new-window (split-window window-to-split size t))
;; Always copy quit-restore parameter in interactive use.
- (let ((quit-restore (window-parameter old-window 'quit-restore)))
+ (let ((quit-restore (window-parameter window-to-split 'quit-restore)))
(when quit-restore
(set-window-parameter new-window 'quit-restore quit-restore)))
new-window))
(defalias 'split-window-horizontally 'split-window-right)
+
+(defun split-root-window-right (&optional size)
+ "Split root window of current frame into two side-by-side windows.
+The current window configuration is retained within the left
+window, and a new window is created on the right, taking up the
+whole height of the frame. SIZE is treated as by
+`split-window-right'."
+ (interactive "P")
+ (split-window-right size (frame-root-window)))
;;; Balancing windows.
@@ -10564,6 +10580,8 @@ displaying that processes's buffer."
(define-key ctl-x-map "{" 'shrink-window-horizontally)
(define-key ctl-x-map "-" 'shrink-window-if-larger-than-buffer)
(define-key ctl-x-map "+" 'balance-windows)
+(define-key ctl-x-map "7" 'split-root-window-below)
+(define-key ctl-x-map "9" 'split-root-window-right)
(define-key ctl-x-4-map "0" 'kill-buffer-and-window)
(define-key ctl-x-4-map "1" 'same-window-prefix)
(define-key ctl-x-4-map "4" 'other-window-prefix)
diff --git a/src/character.c b/src/character.c
index 968daccafa7..5df49adade9 100644
--- a/src/character.c
+++ b/src/character.c
@@ -178,12 +178,16 @@ usage: (characterp OBJECT) */
return (CHARACTERP (object) ? Qt : Qnil);
}
-DEFUN ("max-char", Fmax_char, Smax_char, 0, 0, 0,
- doc: /* Return the character of the maximum code. */
+DEFUN ("max-char", Fmax_char, Smax_char, 0, 1, 0,
+ doc: /* Return the maximum character code.
+If UNICODE is non-nil, return the maximum character code defined
+by the Unicode Standard. */
attributes: const)
- (void)
+ (Lisp_Object unicode)
{
- return make_fixnum (MAX_CHAR);
+ return (!NILP (unicode)
+ ? make_fixnum (MAX_UNICODE_CHAR)
+ : make_fixnum (MAX_CHAR));
}
DEFUN ("unibyte-char-to-multibyte", Funibyte_char_to_multibyte,
diff --git a/src/comp.c b/src/comp.c
index 70e7d5a8bbf..4813ca04a90 100644
--- a/src/comp.c
+++ b/src/comp.c
@@ -4467,7 +4467,7 @@ the latter is supposed to be used by the Emacs build procedure. */)
}
if (NILP (base_dir))
error ("Cannot find suitable directory for output in "
- "`comp-native-load-path'.");
+ "`native-comp-eln-load-path'.");
}
if (!file_name_absolute_p (SSDATA (base_dir)))
diff --git a/src/fns.c b/src/fns.c
index 7e78bba3a04..2f4808be3d0 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -1563,10 +1563,21 @@ If N is zero or negative, return nil.
If N is greater or equal to the length of LIST, return LIST (or a copy). */)
(Lisp_Object n, Lisp_Object list)
{
- CHECK_FIXNUM (n);
- EMACS_INT m = XFIXNUM (n);
- if (m <= 0)
- return Qnil;
+ EMACS_INT m;
+ if (FIXNUMP (n))
+ {
+ m = XFIXNUM (n);
+ if (m <= 0)
+ return Qnil;
+ }
+ else if (BIGNUMP (n))
+ {
+ if (mpz_sgn (*xbignum_val (n)) < 0)
+ return Qnil;
+ m = MOST_POSITIVE_FIXNUM;
+ }
+ else
+ wrong_type_argument (Qintegerp, n);
CHECK_LIST (list);
if (NILP (list))
return Qnil;
@@ -1594,10 +1605,21 @@ If N is greater or equal to the length of LIST, return LIST unmodified.
Otherwise, return LIST after truncating it. */)
(Lisp_Object n, Lisp_Object list)
{
- CHECK_FIXNUM (n);
- EMACS_INT m = XFIXNUM (n);
- if (m <= 0)
- return Qnil;
+ EMACS_INT m;
+ if (FIXNUMP (n))
+ {
+ m = XFIXNUM (n);
+ if (m <= 0)
+ return Qnil;
+ }
+ else if (BIGNUMP (n))
+ {
+ if (mpz_sgn (*xbignum_val (n)) < 0)
+ return Qnil;
+ m = MOST_POSITIVE_FIXNUM;
+ }
+ else
+ wrong_type_argument (Qintegerp, n);
CHECK_LIST (list);
Lisp_Object tail = list;
--m;
diff --git a/src/keyboard.c b/src/keyboard.c
index 1d7125a0a3e..77280d08c5b 100644
--- a/src/keyboard.c
+++ b/src/keyboard.c
@@ -1827,21 +1827,15 @@ adjust_point_for_property (ptrdiff_t last_pt, bool modified)
}
}
-/* Subroutine for safe_run_hooks: run the hook, which is ARGS[1]. */
+/* Subroutine for safe_run_hooks: run the hook's function.
+ ARGS[0] holds the name of the hook, which we don't need here (we only use
+ it in the failure case of the internal_condition_case_n). */
static Lisp_Object
safe_run_hooks_1 (ptrdiff_t nargs, Lisp_Object *args)
{
- eassert (nargs >= 2 && nargs <= 4);
- switch (nargs)
- {
- case 2:
- return call0 (args[1]);
- case 3:
- return call1 (args[1], args[2]);
- default:
- return call2 (args[1], args[2], args[3]);
- }
+ eassert (nargs >= 2);
+ return Ffuncall (nargs - 1, args + 1);
}
/* Subroutine for safe_run_hooks: handle an error by clearing out the function
@@ -1850,7 +1844,7 @@ safe_run_hooks_1 (ptrdiff_t nargs, Lisp_Object *args)
static Lisp_Object
safe_run_hooks_error (Lisp_Object error, ptrdiff_t nargs, Lisp_Object *args)
{
- eassert (nargs >= 2 && nargs <= 4);
+ eassert (nargs >= 2);
AUTO_STRING (format, "Error in %s (%S): %S");
Lisp_Object hook = args[0];
Lisp_Object fun = args[1];
@@ -1886,27 +1880,13 @@ safe_run_hooks_error (Lisp_Object error, ptrdiff_t nargs, Lisp_Object *args)
static Lisp_Object
safe_run_hook_funcall (ptrdiff_t nargs, Lisp_Object *args)
{
- eassert (nargs >= 2 && nargs <= 4);
- /* Yes, run_hook_with_args works with args in the other order. */
- switch (nargs)
- {
- case 2:
- internal_condition_case_n (safe_run_hooks_1,
- 2, ((Lisp_Object []) {args[1], args[0]}),
- Qt, safe_run_hooks_error);
- break;
- case 3:
- internal_condition_case_n (safe_run_hooks_1,
- 3, ((Lisp_Object []) {args[1], args[0], args[2]}),
- Qt, safe_run_hooks_error);
- break;
- default:
- internal_condition_case_n (safe_run_hooks_1,
- 4, ((Lisp_Object [])
- {args[1], args[0], args[2], args[3]}),
- Qt, safe_run_hooks_error);
- break;
- }
+ eassert (nargs >= 2);
+ /* We need to swap args[0] and args[1] here or in `safe_run_hooks_1`.
+ It's more convenient to do it here. */
+ Lisp_Object fun = args[0], hook = args[1];
+ args[0] = hook, args[1] = fun;
+ internal_condition_case_n (safe_run_hooks_1, nargs, args,
+ Qt, safe_run_hooks_error);
return Qnil;
}
@@ -1920,7 +1900,8 @@ safe_run_hooks (Lisp_Object hook)
specpdl_ref count = SPECPDL_INDEX ();
specbind (Qinhibit_quit, Qt);
- run_hook_with_args (2, ((Lisp_Object []) {hook, hook}), safe_run_hook_funcall);
+ run_hook_with_args (2, ((Lisp_Object []) {hook, hook}),
+ safe_run_hook_funcall);
unbind_to (count, Qnil);
}
@@ -1936,7 +1917,8 @@ safe_run_hooks_maybe_narrowed (Lisp_Object hook, struct window *w)
make_fixnum (get_narrowed_zv (w, PT)),
true);
- run_hook_with_args (2, ((Lisp_Object []) {hook, hook}), safe_run_hook_funcall);
+ run_hook_with_args (2, ((Lisp_Object []) {hook, hook}),
+ safe_run_hook_funcall);
unbind_to (count, Qnil);
}
diff --git a/src/lread.c b/src/lread.c
index ccccd79cd7c..d64a4fad3af 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -2905,20 +2905,18 @@ digit_to_number (int character, int base)
return digit < base ? digit : -1;
}
-/* Size of the fixed-size buffer used during reading.
- It should be at least big enough for `invalid_radix_integer' but
- can usefully be much bigger than that. */
-enum { stackbufsize = 1024 };
-
static void
-invalid_radix_integer (EMACS_INT radix, char stackbuf[VLA_ELEMS (stackbufsize)],
- Lisp_Object readcharfun)
+invalid_radix_integer (EMACS_INT radix, Lisp_Object readcharfun)
{
- int n = snprintf (stackbuf, stackbufsize, "integer, radix %"pI"d", radix);
- eassert (n < stackbufsize);
- invalid_syntax (stackbuf, readcharfun);
+ char buf[64];
+ int n = snprintf (buf, sizeof buf, "integer, radix %"pI"d", radix);
+ eassert (n < sizeof buf);
+ invalid_syntax (buf, readcharfun);
}
+/* Size of the fixed-size buffer used during reading. */
+enum { stackbufsize = 1024 };
+
/* Read an integer in radix RADIX using READCHARFUN to read
characters. RADIX must be in the interval [2..36]. Use STACKBUF
for temporary storage as needed. Value is the integer read.
@@ -2976,7 +2974,7 @@ read_integer (Lisp_Object readcharfun, int radix,
UNREAD (c);
if (valid != 1)
- invalid_radix_integer (radix, stackbuf, readcharfun);
+ invalid_radix_integer (radix, readcharfun);
*p = '\0';
return unbind_to (count, string_to_number (read_buffer, radix, NULL));
@@ -3686,6 +3684,12 @@ read_stack_push (struct read_stack_entry e)
rdstack.stack[rdstack.sp++] = e;
}
+static void
+read_stack_reset (intmax_t sp)
+{
+ eassert (sp <= rdstack.sp);
+ rdstack.sp = sp;
+}
/* Read a Lisp object.
If LOCATE_SYMS is true, symbols are read with position. */
@@ -3696,9 +3700,12 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
char *read_buffer = stackbuf;
ptrdiff_t read_buffer_size = sizeof stackbuf;
char *heapbuf = NULL;
- specpdl_ref count = SPECPDL_INDEX ();
+ specpdl_ref base_pdl = SPECPDL_INDEX ();
ptrdiff_t base_sp = rdstack.sp;
+ record_unwind_protect_intmax (read_stack_reset, base_sp);
+
+ specpdl_ref count = SPECPDL_INDEX ();
bool uninterned_symbol;
bool skip_shorthand;
@@ -3980,7 +3987,7 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
{
/* #NrDIGITS -- radix-N number */
if (n < 0 || n > 36)
- invalid_radix_integer (n, stackbuf, readcharfun);
+ invalid_radix_integer (n, readcharfun);
obj = read_integer (readcharfun, n, stackbuf);
break;
}
@@ -4347,7 +4354,7 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
}
}
- return unbind_to (count, obj);
+ return unbind_to (base_pdl, obj);
}
diff --git a/src/widget.c b/src/widget.c
index b125b4caeed..5a75cdaca8e 100644
--- a/src/widget.c
+++ b/src/widget.c
@@ -292,18 +292,20 @@ update_wm_hints (Widget wmshell, EmacsFrame ew)
base_height = (wmshell->core.height - ew->core.height
+ (rounded_height - (char_height * ch)));
- /* This is kind of sleazy, but I can't see how else to tell it to
- make it mark the WM_SIZE_HINTS size as user specified.
- */
-/* ((WMShellWidget) wmshell)->wm.size_hints.flags |= USSize;*/
+ /* Ensure that Xt actually sets window manager hint flags specified
+ by the caller by making sure XtNminWidth (a relatively harmless
+ resource) always changes each time this function is invoked. */
+ ew->emacs_frame.size_switch = !ew->emacs_frame.size_switch;
XtVaSetValues (wmshell,
XtNbaseWidth, (XtArgVal) base_width,
XtNbaseHeight, (XtArgVal) base_height,
XtNwidthInc, (XtArgVal) (frame_resize_pixelwise ? 1 : cw),
XtNheightInc, (XtArgVal) (frame_resize_pixelwise ? 1 : ch),
- XtNminWidth, (XtArgVal) base_width,
- XtNminHeight, (XtArgVal) base_height,
+ XtNminWidth, (XtArgVal) (base_width
+ + ew->emacs_frame.size_switch),
+ XtNminHeight, (XtArgVal) (base_height
+ + ew->emacs_frame.size_switch),
NULL);
}
@@ -355,6 +357,8 @@ EmacsFrameInitialize (Widget request, Widget new,
exit (1);
}
+ ew->emacs_frame.size_switch = 1;
+
update_from_various_frame_slots (ew);
set_frame_size (ew);
}
diff --git a/src/widgetprv.h b/src/widgetprv.h
index 960f814e16f..fe960326b03 100644
--- a/src/widgetprv.h
+++ b/src/widgetprv.h
@@ -49,6 +49,8 @@ typedef struct {
Boolean visual_bell; /* flash instead of beep */
int bell_volume; /* how loud is beep */
+ int size_switch; /* hack to make setting size
+ hints work correctly */
/* private state */
diff --git a/src/window.c b/src/window.c
index 2bce4c9723d..12a212a85ac 100644
--- a/src/window.c
+++ b/src/window.c
@@ -8363,7 +8363,8 @@ on their symbols to be controlled by this variable. */);
Vscroll_preserve_screen_position = Qnil;
DEFVAR_LISP ("window-point-insertion-type", Vwindow_point_insertion_type,
- doc: /* Type of marker to use for `window-point'. */);
+ doc: /* Insertion type of marker to use for `window-point'.
+See `marker-insertion-type' for the meaning of the possible values. */);
Vwindow_point_insertion_type = Qnil;
DEFSYM (Qwindow_point_insertion_type, "window-point-insertion-type");
diff --git a/src/xdisp.c b/src/xdisp.c
index 70f6936dd0b..80a07636951 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -31773,9 +31773,9 @@ gui_produce_glyphs (struct it *it)
/* When no suitable font is found, display this character by
the method specified in the first extra slot of
Vglyphless_char_display. */
- Lisp_Object acronym = lookup_glyphless_char_display (-1, it);
+ Lisp_Object acronym = lookup_glyphless_char_display (-1, it);
- eassert (it->what == IT_GLYPHLESS);
+ eassert (it->what == IT_GLYPHLESS);
produce_glyphless_glyph (it, true,
STRINGP (acronym) ? acronym : Qnil);
goto done;
@@ -37109,16 +37109,20 @@ Each element, if non-nil, should be one of the following:
`empty-box': display as an empty box
`thin-space': display as 1-pixel width space
`zero-width': don't display
+Any other value is interpreted as `empty-box'.
An element may also be a cons cell (GRAPHICAL . TEXT), which specifies the
display method for graphical terminals and text terminals respectively.
GRAPHICAL and TEXT should each have one of the values listed above.
-The char-table has one extra slot to control the display of a character for
-which no font is found. This slot only takes effect on graphical terminals.
-Its value should be an ASCII acronym string, `hex-code', `empty-box', or
-`thin-space'. It could also be a cons cell of any two of these, to specify
-separate values for graphical and text terminals.
-The default is `empty-box'.
+The char-table has one extra slot to control the display of characters
+for which no font is found on graphical terminals, and characters that
+cannot be displayed by text-mode terminals. Its value should be an
+ASCII acronym string, `hex-code', `empty-box', or `thin-space'. It
+could also be a cons cell of any two of these, to specify separate
+values for graphical and text terminals. The default is `empty-box'.
+
+With the obvious exception of `zero-width', all the other representations
+are displayed using the face `glyphless-char'.
If a character has a non-nil entry in an active display table, the
display table takes effect; in this case, Emacs does not consult
diff --git a/src/xfaces.c b/src/xfaces.c
index 70d5cbeb4c7..5e3a47d7f8b 100644
--- a/src/xfaces.c
+++ b/src/xfaces.c
@@ -3052,6 +3052,15 @@ The value is TO. */)
}
+#define HANDLE_INVALID_NIL_VALUE(A,F) \
+ if (NILP (value)) \
+ { \
+ add_to_log ("Warning: setting attribute `%s' of face `%s': nil " \
+ "value is invalid, use `unspecified' instead.", A, F); \
+ /* Compatibility with 20.x. */ \
+ value = Qunspecified; \
+ }
+
DEFUN ("internal-set-lisp-face-attribute", Finternal_set_lisp_face_attribute,
Sinternal_set_lisp_face_attribute, 3, 4, 0,
doc: /* Set attribute ATTR of FACE to VALUE.
@@ -3390,9 +3399,7 @@ FRAME 0 means change the face on all frames, and change the default
}
else if (EQ (attr, QCforeground))
{
- /* Compatibility with 20.x. */
- if (NILP (value))
- value = Qunspecified;
+ HANDLE_INVALID_NIL_VALUE (QCforeground, face);
if (!UNSPECIFIEDP (value)
&& !IGNORE_DEFFACE_P (value)
&& !RESET_P (value))
@@ -3409,9 +3416,7 @@ FRAME 0 means change the face on all frames, and change the default
}
else if (EQ (attr, QCdistant_foreground))
{
- /* Compatibility with 20.x. */
- if (NILP (value))
- value = Qunspecified;
+ HANDLE_INVALID_NIL_VALUE (QCdistant_foreground, face);
if (!UNSPECIFIEDP (value)
&& !IGNORE_DEFFACE_P (value)
&& !RESET_P (value))
@@ -3428,9 +3433,7 @@ FRAME 0 means change the face on all frames, and change the default
}
else if (EQ (attr, QCbackground))
{
- /* Compatibility with 20.x. */
- if (NILP (value))
- value = Qunspecified;
+ HANDLE_INVALID_NIL_VALUE (QCbackground, face);
if (!UNSPECIFIEDP (value)
&& !IGNORE_DEFFACE_P (value)
&& !RESET_P (value))
diff --git a/src/xfns.c b/src/xfns.c
index 0b1f707e9fc..2da1e7bcf80 100644
--- a/src/xfns.c
+++ b/src/xfns.c
@@ -3955,10 +3955,6 @@ x_window (struct frame *f, long window_prompting)
XtManageChild (pane_widget);
XtRealizeWidget (shell_widget);
- if (FRAME_X_EMBEDDED_P (f))
- XReparentWindow (FRAME_X_DISPLAY (f), XtWindow (shell_widget),
- f->output_data.x->parent_desc, 0, 0);
-
FRAME_X_WINDOW (f) = XtWindow (frame_widget);
initial_set_up_x_back_buffer (f);
validate_x_resource_name ();
@@ -4132,7 +4128,7 @@ x_window (struct frame *f)
block_input ();
FRAME_X_WINDOW (f)
= XCreateWindow (FRAME_X_DISPLAY (f),
- f->output_data.x->parent_desc,
+ FRAME_DISPLAY_INFO (f)->root_window,
f->left_pos,
f->top_pos,
FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f),
@@ -4958,6 +4954,12 @@ This function is an internal primitive--use `make-frame' instead. */)
x_window (f);
#endif
+#ifndef USE_GTK
+ if (FRAME_X_EMBEDDED_P (f)
+ && !x_embed_frame (dpyinfo, f))
+ error ("The frame could not be embedded; does the embedder exist?");
+#endif
+
x_icon (f, parms);
x_make_gc (f);
diff --git a/src/xselect.c b/src/xselect.c
index bab0400540e..66782d41723 100644
--- a/src/xselect.c
+++ b/src/xselect.c
@@ -1567,7 +1567,8 @@ receive_incremental_selection (struct x_display_info *dpyinfo,
unsigned char **data_ret,
ptrdiff_t *size_bytes_ret,
Atom *type_ret, int *format_ret,
- unsigned long *size_ret)
+ unsigned long *size_ret,
+ ptrdiff_t *real_bytes_ret)
{
ptrdiff_t offset = 0;
struct prop_location *wait_object;
@@ -1622,7 +1623,8 @@ receive_incremental_selection (struct x_display_info *dpyinfo,
if (tmp_size_bytes == 0) /* we're done */
{
- TRACE0 ("Done reading incrementally");
+ TRACE1 ("Done reading incrementally; total bytes: %"pD"d",
+ *size_bytes_ret);
if (! waiting_for_other_props_on_window (display, window))
XSelectInput (display, window, STANDARD_EVENT_SET);
@@ -1652,6 +1654,19 @@ receive_incremental_selection (struct x_display_info *dpyinfo,
memcpy ((*data_ret) + offset, tmp_data, tmp_size_bytes);
offset += tmp_size_bytes;
+ /* *size_bytes_ret is not really the size of the data inside the
+ buffer; it is the size of the buffer allocated by xpalloc.
+
+ This matters when the cardinal specified in the INCR property
+ (a _lower bound_ on the size of the selection data) is
+ smaller than the actual selection contents, which can happen
+ when programs are streaming selection data from a file
+ descriptor. In that case, we used to return junk if xpalloc
+ decided to grow the buffer by more than the provided
+ increment; to avoid that, store the actual size of the
+ selection data in *real_bytes_ret. */
+ *real_bytes_ret += tmp_size_bytes;
+
/* Use xfree, not XFree, because x_get_window_property
calls xmalloc itself. */
xfree (tmp_data);
@@ -1674,10 +1689,14 @@ x_get_window_property_as_lisp_data (struct x_display_info *dpyinfo,
int actual_format;
unsigned long actual_size;
unsigned char *data = 0;
- ptrdiff_t bytes = 0;
+ ptrdiff_t bytes = 0, array_bytes;
Lisp_Object val;
Display *display = dpyinfo->display;
+ /* array_bytes is only used as an argument to xpalloc. The actual
+ size of the data inside the buffer is inside bytes. */
+ array_bytes = 0;
+
TRACE0 ("Reading selection data");
x_get_window_property (display, window, property, &data, &bytes,
@@ -1718,10 +1737,15 @@ x_get_window_property_as_lisp_data (struct x_display_info *dpyinfo,
calls xmalloc itself. */
xfree (data);
unblock_input ();
+
+ /* Clear bytes again. Previously, receive_incremental_selection
+ would set this to min_size_bytes, but that is now done to
+ array_bytes instead. */
+ bytes = 0;
receive_incremental_selection (dpyinfo, window, property, target_type,
- min_size_bytes, &data, &bytes,
+ min_size_bytes, &data, &array_bytes,
&actual_type, &actual_format,
- &actual_size);
+ &actual_size, &bytes);
}
if (!for_multiple)
@@ -1993,7 +2017,17 @@ lisp_data_to_selection_data (struct x_display_info *dpyinfo,
ptrdiff_t i;
ptrdiff_t size = ASIZE (obj);
- if (SYMBOLP (AREF (obj, 0)))
+ if (!size)
+ {
+ /* This vector is empty and of unknown type. Assume that it
+ is a vector of integers. */
+
+ cs->data = NULL;
+ cs->format = 32;
+ cs->size = 0;
+ type = QINTEGER;
+ }
+ else if (SYMBOLP (AREF (obj, 0)))
/* This vector is an ATOM set */
{
void *data;
diff --git a/src/xterm.c b/src/xterm.c
index 7a0a21b1369..c58f2d15da2 100644
--- a/src/xterm.c
+++ b/src/xterm.c
@@ -12740,6 +12740,25 @@ xi_focus_handle_for_device (struct x_display_info *dpyinfo,
case XI_FocusOut:
device->focus_frame = NULL;
+
+ /* So, unfortunately, the X Input Extension is implemented such
+ that means XI_Leave events will not have their focus field
+ set if the core focus is transferred to another window after
+ an entry event that pretends to (or really does) set the
+ implicit focus. In addition, if the core focus is set, but
+ the extension focus on the client pointer is not, all
+ XI_Enter events will have their focus fields set, despite not
+ actually changing the effective focus window. Combined with
+ almost all window managers not setting the focus on input
+ extension devices, this means that Emacs will continue to
+ think the implicit focus is set on one of its frames if the
+ actual (core) focus is transferred to another window while
+ the pointer remains inside a frame. The only workaround in
+ this case is to clear the implicit focus along with
+ XI_FocusOut events, which is not correct at all, but better
+ than leaving frames in an incorrectly-focused state.
+ (bug#57468) */
+ device->focus_implicit_frame = NULL;
break;
case XI_Enter:
@@ -13155,7 +13174,12 @@ x_detect_focus_change (struct x_display_info *dpyinfo, struct frame *frame,
void
x_mouse_leave (struct x_display_info *dpyinfo)
{
- Mouse_HLInfo *hlinfo = &dpyinfo->mouse_highlight;
+#if defined HAVE_XINPUT2 && !defined USE_X_TOOLKIT
+ struct xi_device_t *device;
+#endif
+ Mouse_HLInfo *hlinfo;
+
+ hlinfo = &dpyinfo->mouse_highlight;
if (hlinfo->mouse_face_mouse_frame)
{
@@ -13163,7 +13187,30 @@ x_mouse_leave (struct x_display_info *dpyinfo)
hlinfo->mouse_face_mouse_frame = NULL;
}
- x_new_focus_frame (dpyinfo, dpyinfo->x_focus_event_frame);
+#if defined HAVE_XINPUT2 && !defined USE_X_TOOLKIT
+ if (!dpyinfo->supports_xi2)
+ /* The call below is supposed to reset the implicit focus and
+ revert the focus back to the last explicitly focused frame. It
+ doesn't work on input extension builds because focus tracking
+ does not set x_focus_event_frame, and proceeds on a per-device
+ basis. On such builds, clear the implicit focus of the client
+ pointer instead. */
+#endif
+ x_new_focus_frame (dpyinfo, dpyinfo->x_focus_event_frame);
+#if defined HAVE_XINPUT2 && !defined USE_X_TOOLKIT
+ else
+ {
+ if (dpyinfo->client_pointer_device == -1)
+ /* If there's no client pointer device, then no implicit focus
+ is currently set. */
+ return;
+
+ device = xi_device_from_id (dpyinfo, dpyinfo->client_pointer_device);
+
+ if (device)
+ device->focus_implicit_frame = NULL;
+ }
+#endif
}
#endif
@@ -18416,6 +18463,20 @@ handle_one_xevent (struct x_display_info *dpyinfo,
f = x_top_window_to_frame (dpyinfo, event->xreparent.window);
if (f)
{
+#ifndef USE_GTK
+ if (FRAME_OUTPUT_DATA (f)->parent_desc
+ && FRAME_X_EMBEDDED_P (f))
+ {
+ /* The frame's embedder was destroyed; mark the frame as
+ no longer embedded, and map the frame. An
+ UnmapNotify event must have previously been received
+ during the start of save-set processing. */
+
+ FRAME_X_OUTPUT (f)->explicit_parent = false;
+ x_make_frame_visible (f);
+ }
+#endif
+
/* Maybe we shouldn't set this for child frames ?? */
f->output_data.x->parent_desc = event->xreparent.parent;
@@ -19262,6 +19323,18 @@ handle_one_xevent (struct x_display_info *dpyinfo,
x_display_set_last_user_time (dpyinfo, event->xcrossing.time,
event->xcrossing.send_event);
+#ifdef HAVE_XINPUT2
+ /* For whatever reason, the X server continues to deliver
+ EnterNotify and LeaveNotify events despite us selecting for
+ related XI_Enter and XI_Leave events. It's not just our
+ problem, since windows created by "xinput test-xi2" suffer
+ from the same defect. Simply ignore all such events while
+ the input extension is enabled. (bug#57468) */
+
+ if (dpyinfo->supports_xi2)
+ goto OTHER;
+#endif
+
if (x_top_window_to_frame (dpyinfo, event->xcrossing.window))
x_detect_focus_change (dpyinfo, any, event, &inev.ie);
@@ -19363,6 +19436,18 @@ handle_one_xevent (struct x_display_info *dpyinfo,
x_display_set_last_user_time (dpyinfo, event->xcrossing.time,
event->xcrossing.send_event);
+#ifdef HAVE_XINPUT2
+ /* For whatever reason, the X server continues to deliver
+ EnterNotify and LeaveNotify events despite us selecting for
+ related XI_Enter and XI_Leave events. It's not just our
+ problem, since windows created by "xinput test-xi2" suffer
+ from the same defect. Simply ignore all such events while
+ the input extension is enabled. (bug#57468) */
+
+ if (dpyinfo->supports_xi2)
+ goto OTHER;
+#endif
+
#ifdef HAVE_XWIDGETS
{
struct xwidget_view *xvw = xwidget_view_from_window (event->xcrossing.window);
@@ -19388,14 +19473,7 @@ handle_one_xevent (struct x_display_info *dpyinfo,
#else
f = x_top_window_to_frame (dpyinfo, event->xcrossing.window);
#endif
-#if defined USE_X_TOOLKIT && defined HAVE_XINPUT2 && !defined USE_MOTIF
- /* The XI2 event mask is set on the frame widget, so this event
- likely originates from the shell widget, which we aren't
- interested in. (But don't ignore this on Motif, since we
- want to clear the mouse face when a popup is active.) */
- if (dpyinfo->supports_xi2)
- f = NULL;
-#endif
+
if (f)
{
/* Now clear dpyinfo->last_mouse_motion_frame, or
@@ -20771,8 +20849,20 @@ handle_one_xevent (struct x_display_info *dpyinfo,
any = x_any_window_to_frame (dpyinfo, enter->event);
#ifdef HAVE_XINPUT2_1
- xi_reset_scroll_valuators_for_device_id (dpyinfo, enter->deviceid,
- true);
+ /* xfwm4 selects for button events on the frame window,
+ resulting in passive grabs being generated along with
+ the delivery of emulated button events; this then
+ interferes with scrolling, since device valuators
+ will constantly be reset as the crossing events
+ related to those grabs arrive. The only way to
+ remedy this is to never reset scroll valuators on a
+ grab-related crossing event. (bug#57476) */
+ if (enter->mode != XINotifyUngrab
+ && enter->mode != XINotifyGrab
+ && enter->mode != XINotifyPassiveGrab
+ && enter->mode != XINotifyPassiveUngrab)
+ xi_reset_scroll_valuators_for_device_id (dpyinfo, enter->deviceid,
+ true);
#endif
{
@@ -20888,7 +20978,20 @@ handle_one_xevent (struct x_display_info *dpyinfo,
moves out of a frame (and not into one of its
children, which we know about). */
#ifdef HAVE_XINPUT2_1
- if (leave->detail != XINotifyInferior && any)
+ if (leave->detail != XINotifyInferior && any
+ /* xfwm4 selects for button events on the frame
+ window, resulting in passive grabs being
+ generated along with the delivery of emulated
+ button events; this then interferes with
+ scrolling, since device valuators will constantly
+ be reset as the crossing events related to those
+ grabs arrive. The only way to remedy this is to
+ never reset scroll valuators on a grab-related
+ crossing event. (bug#57476) */
+ && leave->mode != XINotifyUngrab
+ && leave->mode != XINotifyGrab
+ && leave->mode != XINotifyPassiveUngrab
+ && leave->mode != XINotifyPassiveGrab)
xi_reset_scroll_valuators_for_device_id (dpyinfo,
leave->deviceid, false);
#endif
@@ -20926,7 +21029,11 @@ handle_one_xevent (struct x_display_info *dpyinfo,
just looks up a top window on Xt builds. */
#ifdef HAVE_XINPUT2_1
- if (leave->detail != XINotifyInferior && f)
+ if (leave->detail != XINotifyInferior && f
+ && leave->mode != XINotifyUngrab
+ && leave->mode != XINotifyGrab
+ && leave->mode != XINotifyPassiveUngrab
+ && leave->mode != XINotifyPassiveGrab)
xi_reset_scroll_valuators_for_device_id (dpyinfo,
leave->deviceid, false);
#endif
@@ -21333,26 +21440,26 @@ handle_one_xevent (struct x_display_info *dpyinfo,
/* Also remember the mouse glyph and set
mouse_moved. */
if (f != dpyinfo->last_mouse_glyph_frame
- || xev->event_x < r->x
- || xev->event_x >= r->x + r->width
- || xev->event_y < r->y
- || xev->event_y >= r->y + r->height)
+ || lrint (xev->event_x) < r->x
+ || lrint (xev->event_x) >= r->x + r->width
+ || lrint (xev->event_y) < r->y
+ || lrint (xev->event_y) >= r->y + r->height)
{
f->mouse_moved = true;
f->last_mouse_device = (source ? source->name
: Qnil);
dpyinfo->last_mouse_scroll_bar = NULL;
- remember_mouse_glyph (f, xev->event_x,
- xev->event_y, r);
+ remember_mouse_glyph (f, lrint (xev->event_x),
+ lrint (xev->event_y), r);
dpyinfo->last_mouse_glyph_frame = f;
}
}
if (xev->root == dpyinfo->root_window)
target = x_dnd_get_target_window (dpyinfo,
- xev->root_x,
- xev->root_y,
+ lrint (xev->root_x),
+ lrint (xev->root_y),
&target_proto,
&motif_style,
&toplevel,
@@ -21490,14 +21597,16 @@ handle_one_xevent (struct x_display_info *dpyinfo,
if (x_dnd_last_window_is_frame && target != None)
x_dnd_note_self_position (dpyinfo, target,
- xev->root_x, xev->root_y);
+ lrint (xev->root_x),
+ lrint (xev->root_y));
else if (x_dnd_last_protocol_version != -1 && target != None)
{
dnd_state = xi_convert_event_state (xev);
x_dnd_send_position (x_dnd_frame, target,
x_dnd_last_protocol_version,
- xev->root_x, xev->root_y,
+ lrint (xev->root_x),
+ lrint (xev->root_y),
x_dnd_selection_timestamp,
x_dnd_wanted_action, 0,
dnd_state);
@@ -21705,7 +21814,8 @@ handle_one_xevent (struct x_display_info *dpyinfo,
#endif
x_dnd_note_self_wheel (dpyinfo,
x_dnd_last_seen_window,
- xev->root_x, xev->root_y,
+ lrint (xev->root_x),
+ lrint (xev->root_y),
xev->detail, dnd_state,
xev->time);
}
@@ -21713,7 +21823,8 @@ handle_one_xevent (struct x_display_info *dpyinfo,
x_dnd_send_position (x_dnd_frame,
x_dnd_last_seen_window,
x_dnd_last_protocol_version,
- xev->root_x, xev->root_y,
+ lrint (xev->root_x),
+ lrint (xev->root_y),
xev->time, x_dnd_wanted_action,
xev->detail, dnd_state);
@@ -21756,7 +21867,8 @@ handle_one_xevent (struct x_display_info *dpyinfo,
{
x_dnd_waiting_for_finish = false;
x_dnd_note_self_drop (dpyinfo, x_dnd_last_seen_window,
- xev->root_x, xev->root_y, xev->time);
+ lrint (xev->root_x),
+ lrint (xev->root_y), xev->time);
}
else if (x_dnd_last_seen_window != None
&& x_dnd_last_protocol_version != -1)
@@ -21831,12 +21943,14 @@ handle_one_xevent (struct x_display_info *dpyinfo,
x_dnd_send_unsupported_drop (dpyinfo, (x_dnd_last_seen_toplevel != None
? x_dnd_last_seen_toplevel
: x_dnd_last_seen_window),
- xev->root_x, xev->root_y, xev->time);
+ lrint (xev->root_x),
+ lrint (xev->root_y), xev->time);
}
else if (x_dnd_last_seen_toplevel != None)
x_dnd_send_unsupported_drop (dpyinfo,
x_dnd_last_seen_toplevel,
- xev->root_x, xev->root_y,
+ lrint (xev->root_x),
+ lrint (xev->root_y),
xev->time);
x_dnd_last_protocol_version = -1;
@@ -27420,6 +27534,31 @@ x_get_atom_name (struct x_display_info *dpyinfo, Atom atom,
return value;
}
+#ifndef USE_GTK
+
+/* Set up XEmbed for F, and change its save set to handle the parent
+ being destroyed. */
+
+bool
+x_embed_frame (struct x_display_info *dpyinfo, struct frame *f)
+{
+ bool rc;
+
+ x_catch_errors (dpyinfo->display);
+ /* Catch errors; the target window might no longer exist. */
+ XReparentWindow (dpyinfo->display, FRAME_OUTER_WINDOW (f),
+ FRAME_OUTPUT_DATA (f)->parent_desc, 0, 0);
+ rc = x_had_errors_p (dpyinfo->display);
+ x_uncatch_errors_after_check ();
+
+ if (rc)
+ return false;
+
+ return true;
+}
+
+#endif
+
/* Setting window manager hints. */
@@ -27452,8 +27591,11 @@ x_wm_set_size_hint (struct frame *f, long flags, bool user_position)
eassert (XtIsWMShell (f->output_data.x->widget));
shell = (WMShellWidget) f->output_data.x->widget;
- shell->wm.size_hints.flags &= ~(PPosition | USPosition);
- shell->wm.size_hints.flags |= flags & (PPosition | USPosition);
+ if (flags)
+ {
+ shell->wm.size_hints.flags &= ~(PPosition | USPosition);
+ shell->wm.size_hints.flags |= flags & (PPosition | USPosition);
+ }
if (user_position)
{
diff --git a/src/xterm.h b/src/xterm.h
index a0ae3a330a9..7c5a889af30 100644
--- a/src/xterm.h
+++ b/src/xterm.h
@@ -1209,7 +1209,6 @@ enum
FOCUS_EXPLICIT = 2
};
-
/* Return the X output data for frame F. */
#define FRAME_X_OUTPUT(f) ((f)->output_data.x)
#define FRAME_OUTPUT_DATA(f) FRAME_X_OUTPUT (f)
@@ -1588,6 +1587,7 @@ extern void x_wm_set_size_hint (struct frame *, long, bool);
&& defined HAVE_CLOCK_GETTIME
extern void x_sync_init_fences (struct frame *);
#endif
+extern bool x_embed_frame (struct x_display_info *, struct frame *);
extern void x_delete_terminal (struct terminal *);
extern Cursor x_create_font_cursor (struct x_display_info *, int);
@@ -1827,7 +1827,7 @@ extern void mark_xterm (void);
/* Is the frame embedded into another application? */
-#define FRAME_X_EMBEDDED_P(f) (FRAME_X_OUTPUT(f)->explicit_parent != 0)
+#define FRAME_X_EMBEDDED_P(f) (FRAME_X_OUTPUT (f)->explicit_parent != 0)
#define STORE_NATIVE_RECT(nr,rx,ry,rwidth,rheight) \
((nr).x = (rx), \
diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el
index b19494af746..8d2b187e33a 100644
--- a/test/lisp/emacs-lisp/cl-lib-tests.el
+++ b/test/lisp/emacs-lisp/cl-lib-tests.el
@@ -511,6 +511,9 @@
(ert-deftest cl-lib-symbol-macrolet-hide ()
+ :expected-result :failed
+ ;; FIXME -- it's unclear what the semantics here should be, but
+ ;; 2dd1c2ab19f7fb99ecee flipped them.
;; bug#26325, bug#26073
(should (equal (let ((y 5))
(cl-symbol-macrolet ((x y))
diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el
index 19ede627a13..2a647e08305 100644
--- a/test/lisp/emacs-lisp/cl-macs-tests.el
+++ b/test/lisp/emacs-lisp/cl-macs-tests.el
@@ -539,7 +539,20 @@ collection clause."
((p (gv-synthetic-place cl (lambda (v) `(setcar l ,v)))))
(cl-incf p)))
l)
- '(1))))
+ '(1)))
+ ;; Make sure `gv-synthetic-place' isn't macro-expanded before
+ ;; `cl-letf' gets to see its `gv-expander'.
+ (should (equal
+ (condition-case err
+ (let ((x 1))
+ (list x
+ (cl-letf (((gv-synthetic-place (+ 1 2)
+ (lambda (v) `(setq x ,v)))
+ 7))
+ x)
+ x))
+ (error err))
+ '(1 7 3))))
(ert-deftest cl-macs-loop-conditional-step-clauses ()
"These tests failed under the initial fixes in #bug#29799."
diff --git a/test/lisp/emacs-lisp/seq-tests.el b/test/lisp/emacs-lisp/seq-tests.el
index 1a27467d292..d95b35c45eb 100644
--- a/test/lisp/emacs-lisp/seq-tests.el
+++ b/test/lisp/emacs-lisp/seq-tests.el
@@ -137,6 +137,14 @@ Evaluate BODY for each created sequence.
(with-test-sequences (seq '())
(should (equal (seq-remove #'test-sequences-evenp seq) '()))))
+(ert-deftest test-seq-remove-at-position ()
+ (with-test-sequences (seq '(1 2 3 4))
+ (should (same-contents-p (seq-remove-at-position seq 2) '(1 2 4)))
+ (should (same-contents-p (seq-remove-at-position seq 0) '(2 3 4)))
+ (should (same-contents-p (seq-remove-at-position seq 3) '(1 2 3)))
+ (should (eq (type-of (seq-remove-at-position seq 2))
+ (type-of seq)))))
+
(ert-deftest test-seq-count ()
(with-test-sequences (seq '(6 7 8 9 10))
(should (equal (seq-count #'test-sequences-evenp seq) 3))
@@ -482,6 +490,13 @@ Evaluate BODY for each created sequence.
(should (= (seq-position seq 'a #'eq) 0))
(should (null (seq-position seq (make-symbol "a") #'eq)))))
+(ert-deftest test-seq-positions ()
+ (with-test-sequences (seq '(1 2 3 1 4))
+ (should (equal '(0 3) (seq-positions seq 1)))
+ (should (seq-empty-p (seq-positions seq 9))))
+ (with-test-sequences (seq '(11 5 7 12 9 15))
+ (should (equal '(0 3 5) (seq-positions seq 10 #'>=)))))
+
(ert-deftest test-seq-sort-by ()
(let ((seq ["x" "xx" "xxx"]))
(should (equal (seq-sort-by #'seq-length #'> seq)
diff --git a/test/lisp/eshell/esh-cmd-tests.el b/test/lisp/eshell/esh-cmd-tests.el
index 3a582965d62..92d785d7fdf 100644
--- a/test/lisp/eshell/esh-cmd-tests.el
+++ b/test/lisp/eshell/esh-cmd-tests.el
@@ -74,6 +74,25 @@ e.g. \"{(+ 1 2)} 3\" => 3"
(eshell-command-result-equal "{(+ 1 2)} 3" 3))
+;; Lisp forms
+
+(ert-deftest esh-cmd-test/quoted-lisp-form ()
+ "Test parsing of a quoted Lisp form."
+ (eshell-command-result-equal "echo #'(1 2)" '(1 2)))
+
+(ert-deftest esh-cmd-test/backquoted-lisp-form ()
+ "Test parsing of a backquoted Lisp form."
+ (let ((eshell-test-value 42))
+ (eshell-command-result-equal "echo `(answer ,eshell-test-value)"
+ '(answer 42))))
+
+(ert-deftest esh-cmd-test/backquoted-lisp-form/splice ()
+ "Test parsing of a backquoted Lisp form using splicing."
+ (let ((eshell-test-value '(2 3)))
+ (eshell-command-result-equal "echo `(1 ,@eshell-test-value)"
+ '(1 2 3))))
+
+
;; Logical operators
(ert-deftest esh-cmd-test/and-operator ()
diff --git a/test/lisp/eshell/esh-io-tests.el b/test/lisp/eshell/esh-io-tests.el
new file mode 100644
index 00000000000..37b234eaf06
--- /dev/null
+++ b/test/lisp/eshell/esh-io-tests.el
@@ -0,0 +1,292 @@
+;;; esh-io-tests.el --- esh-io test suite -*- lexical-binding:t -*-
+
+;; Copyright (C) 2022 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert)
+(require 'ert-x)
+(require 'esh-mode)
+(require 'eshell)
+
+(require 'eshell-tests-helpers
+ (expand-file-name "eshell-tests-helpers"
+ (file-name-directory (or load-file-name
+ default-directory))))
+
+(defvar eshell-test-value nil)
+
+(defun eshell-test-file-string (file)
+ "Return the contents of FILE as a string."
+ (with-temp-buffer
+ (insert-file-contents file)
+ (buffer-string)))
+
+(defun eshell/test-output ()
+ "Write some test output separately to stdout and stderr."
+ (eshell-printn "stdout")
+ (eshell-errorn "stderr"))
+
+;;; Tests:
+
+
+;; Basic redirection
+
+(ert-deftest esh-io-test/redirect-file/overwrite ()
+ "Check that redirecting to a file in overwrite mode works."
+ (ert-with-temp-file temp-file
+ :text "old"
+ (with-temp-eshell
+ (eshell-insert-command (format "echo new > %s" temp-file)))
+ (should (equal (eshell-test-file-string temp-file) "new"))))
+
+(ert-deftest esh-io-test/redirect-file/append ()
+ "Check that redirecting to a file in append mode works."
+ (ert-with-temp-file temp-file
+ :text "old"
+ (with-temp-eshell
+ (eshell-insert-command (format "echo new >> %s" temp-file)))
+ (should (equal (eshell-test-file-string temp-file) "oldnew"))))
+
+(ert-deftest esh-io-test/redirect-file/insert ()
+ "Check that redirecting to a file in insert works."
+ (ert-with-temp-file temp-file
+ :text "old"
+ (with-temp-eshell
+ (eshell-insert-command (format "echo new >>> %s" temp-file)))
+ (should (equal (eshell-test-file-string temp-file) "newold"))))
+
+(ert-deftest esh-io-test/redirect-buffer/overwrite ()
+ "Check that redirecting to a buffer in overwrite mode works."
+ (eshell-with-temp-buffer bufname "old"
+ (with-temp-eshell
+ (eshell-insert-command (format "echo new > #<%s>" bufname)))
+ (should (equal (buffer-string) "new"))))
+
+(ert-deftest esh-io-test/redirect-buffer/append ()
+ "Check that redirecting to a buffer in append mode works."
+ (eshell-with-temp-buffer bufname "old"
+ (with-temp-eshell
+ (eshell-insert-command (format "echo new >> #<%s>" bufname)))
+ (should (equal (buffer-string) "oldnew"))))
+
+(ert-deftest esh-io-test/redirect-buffer/insert ()
+ "Check that redirecting to a buffer in insert mode works."
+ (eshell-with-temp-buffer bufname "old"
+ (goto-char (point-min))
+ (with-temp-eshell
+ (eshell-insert-command (format "echo new >>> #<%s>" bufname)))
+ (should (equal (buffer-string) "newold"))))
+
+(ert-deftest esh-io-test/redirect-buffer/escaped ()
+ "Check that redirecting to a buffer with escaped characters works."
+ (with-temp-buffer
+ (rename-buffer "eshell\\temp\\buffer" t)
+ (let ((bufname (buffer-name)))
+ (with-temp-eshell
+ (eshell-insert-command (format "echo hi > #<%s>"
+ (string-replace "\\" "\\\\" bufname))))
+ (should (equal (buffer-string) "hi")))))
+
+(ert-deftest esh-io-test/redirect-symbol/overwrite ()
+ "Check that redirecting to a symbol in overwrite mode works."
+ (let ((eshell-test-value "old"))
+ (with-temp-eshell
+ (eshell-insert-command "echo new > #'eshell-test-value"))
+ (should (equal eshell-test-value "new"))))
+
+(ert-deftest esh-io-test/redirect-symbol/append ()
+ "Check that redirecting to a symbol in append mode works."
+ (let ((eshell-test-value "old"))
+ (with-temp-eshell
+ (eshell-insert-command "echo new >> #'eshell-test-value"))
+ (should (equal eshell-test-value "oldnew"))))
+
+(ert-deftest esh-io-test/redirect-marker ()
+ "Check that redirecting to a marker works."
+ (with-temp-buffer
+ (let ((eshell-test-value (point-marker)))
+ (with-temp-eshell
+ (eshell-insert-command "echo hi > $eshell-test-value"))
+ (should (equal (buffer-string) "hi")))))
+
+(ert-deftest esh-io-test/redirect-multiple ()
+ "Check that redirecting to multiple targets works."
+ (let ((eshell-test-value "old"))
+ (eshell-with-temp-buffer bufname "old"
+ (with-temp-eshell
+ (eshell-insert-command (format "echo new > #<%s> > #'eshell-test-value"
+ bufname)))
+ (should (equal (buffer-string) "new"))
+ (should (equal eshell-test-value "new")))))
+
+(ert-deftest esh-io-test/redirect-multiple/repeat ()
+ "Check that redirecting to multiple targets works when repeating a target."
+ (let ((eshell-test-value "old"))
+ (eshell-with-temp-buffer bufname "old"
+ (with-temp-eshell
+ (eshell-insert-command
+ (format "echo new > #<%s> > #'eshell-test-value > #<%s>"
+ bufname bufname)))
+ (should (equal (buffer-string) "new"))
+ (should (equal eshell-test-value "new")))))
+
+
+;; Redirecting specific handles
+
+(ert-deftest esh-io-test/redirect-stdout ()
+ "Check that redirecting to stdout doesn't redirect stderr."
+ (eshell-with-temp-buffer bufname "old"
+ (with-temp-eshell
+ (eshell-match-command-output (format "test-output > #<%s>" bufname)
+ "stderr\n"))
+ (should (equal (buffer-string) "stdout\n")))
+ ;; Also check explicitly specifying the stdout fd.
+ (eshell-with-temp-buffer bufname "old"
+ (with-temp-eshell
+ (eshell-match-command-output (format "test-output 1> #<%s>" bufname)
+ "stderr\n"))
+ (should (equal (buffer-string) "stdout\n"))))
+
+(ert-deftest esh-io-test/redirect-stderr/overwrite ()
+ "Check that redirecting to stderr doesn't redirect stdout."
+ (eshell-with-temp-buffer bufname "old"
+ (with-temp-eshell
+ (eshell-match-command-output (format "test-output 2> #<%s>" bufname)
+ "stdout\n"))
+ (should (equal (buffer-string) "stderr\n"))))
+
+(ert-deftest esh-io-test/redirect-stderr/append ()
+ "Check that redirecting to stderr doesn't redirect stdout."
+ (eshell-with-temp-buffer bufname "old"
+ (with-temp-eshell
+ (eshell-match-command-output (format "test-output 2>> #<%s>" bufname)
+ "stdout\n"))
+ (should (equal (buffer-string) "oldstderr\n"))))
+
+(ert-deftest esh-io-test/redirect-stderr/insert ()
+ "Check that redirecting to stderr doesn't redirect stdout."
+ (eshell-with-temp-buffer bufname "old"
+ (goto-char (point-min))
+ (with-temp-eshell
+ (eshell-match-command-output (format "test-output 2>>> #<%s>" bufname)
+ "stdout\n"))
+ (should (equal (buffer-string) "stderr\nold"))))
+
+(ert-deftest esh-io-test/redirect-stdout-and-stderr ()
+ "Check that redirecting to both stdout and stderr works."
+ (eshell-with-temp-buffer bufname-1 "old"
+ (eshell-with-temp-buffer bufname-2 "old"
+ (with-temp-eshell
+ (eshell-match-command-output (format "test-output > #<%s> 2> #<%s>"
+ bufname-1 bufname-2)
+ "\\`\\'"))
+ (should (equal (buffer-string) "stderr\n")))
+ (should (equal (buffer-string) "stdout\n"))))
+
+(ert-deftest esh-io-test/redirect-all/overwrite ()
+ "Check that redirecting to stdout and stderr via shorthand works."
+ (eshell-with-temp-buffer bufname "old"
+ (with-temp-eshell
+ (eshell-match-command-output (format "test-output &> #<%s>" bufname)
+ "\\`\\'"))
+ (should (equal (buffer-string) "stdout\nstderr\n")))
+ ;; Also check the alternate (and less-preferred in Bash) `>&' syntax.
+ (eshell-with-temp-buffer bufname "old"
+ (with-temp-eshell
+ (eshell-match-command-output (format "test-output >& #<%s>" bufname)
+ "\\`\\'"))
+ (should (equal (buffer-string) "stdout\nstderr\n"))))
+
+(ert-deftest esh-io-test/redirect-all/append ()
+ "Check that redirecting to stdout and stderr via shorthand works."
+ (eshell-with-temp-buffer bufname "old"
+ (with-temp-eshell
+ (eshell-match-command-output (format "test-output &>> #<%s>" bufname)
+ "\\`\\'"))
+ (should (equal (buffer-string) "oldstdout\nstderr\n")))
+ ;; Also check the alternate (and less-preferred in Bash) `>>&' syntax.
+ (eshell-with-temp-buffer bufname "old"
+ (with-temp-eshell
+ (eshell-match-command-output (format "test-output >>& #<%s>" bufname)
+ "\\`\\'"))
+ (should (equal (buffer-string) "oldstdout\nstderr\n"))))
+
+(ert-deftest esh-io-test/redirect-all/insert ()
+ "Check that redirecting to stdout and stderr via shorthand works."
+ (eshell-with-temp-buffer bufname "old"
+ (goto-char (point-min))
+ (with-temp-eshell
+ (eshell-match-command-output (format "test-output &>>> #<%s>" bufname)
+ "\\`\\'"))
+ (should (equal (buffer-string) "stdout\nstderr\nold")))
+ ;; Also check the alternate `>>>&' syntax.
+ (eshell-with-temp-buffer bufname "old"
+ (goto-char (point-min))
+ (with-temp-eshell
+ (eshell-match-command-output (format "test-output >>>& #<%s>" bufname)
+ "\\`\\'"))
+ (should (equal (buffer-string) "stdout\nstderr\nold"))))
+
+(ert-deftest esh-io-test/redirect-copy ()
+ "Check that redirecting stdout and then copying stdout to stderr works.
+This should redirect both stdout and stderr to the same place."
+ (eshell-with-temp-buffer bufname "old"
+ (with-temp-eshell
+ (eshell-match-command-output (format "test-output > #<%s> 2>&1" bufname)
+ "\\`\\'"))
+ (should (equal (buffer-string) "stdout\nstderr\n"))))
+
+(ert-deftest esh-io-test/redirect-copy-first ()
+ "Check that copying stdout to stderr and then redirecting stdout works.
+This should redirect stdout to a buffer, and stderr to where
+stdout originally pointed (the terminal)."
+ (eshell-with-temp-buffer bufname "old"
+ (with-temp-eshell
+ (eshell-match-command-output (format "test-output 2>&1 > #<%s>" bufname)
+ "stderr\n"))
+ (should (equal (buffer-string) "stdout\n"))))
+
+(ert-deftest esh-io-test/redirect-pipe ()
+ "Check that \"redirecting\" to a pipe works."
+ ;; `|' should only redirect stdout.
+ (eshell-command-result-equal "test-output | rev"
+ "stderr\ntuodts\n")
+ ;; `|&' should redirect stdout and stderr.
+ (eshell-command-result-equal "test-output |& rev"
+ "tuodts\nrredts\n"))
+
+
+;; Virtual targets
+
+(ert-deftest esh-io-test/virtual-dev-eshell ()
+ "Check that redirecting to /dev/eshell works."
+ (with-temp-eshell
+ (eshell-match-command-output "echo hi > /dev/eshell" "hi")))
+
+(ert-deftest esh-io-test/virtual-dev-kill ()
+ "Check that redirecting to /dev/kill works."
+ (with-temp-eshell
+ (eshell-insert-command "echo one > /dev/kill")
+ (should (equal (car kill-ring) "one"))
+ (eshell-insert-command "echo two > /dev/kill")
+ (should (equal (car kill-ring) "two"))
+ (eshell-insert-command "echo three >> /dev/kill")
+ (should (equal (car kill-ring) "twothree"))))
+
+;;; esh-io-tests.el ends here
diff --git a/test/lisp/eshell/esh-proc-tests.el b/test/lisp/eshell/esh-proc-tests.el
index 62e784e8f62..52a0d1eeeb8 100644
--- a/test/lisp/eshell/esh-proc-tests.el
+++ b/test/lisp/eshell/esh-proc-tests.el
@@ -28,15 +28,97 @@
(file-name-directory (or load-file-name
default-directory))))
+(defvar esh-proc-test--output-cmd
+ (concat "sh -c '"
+ "echo stdout; "
+ "echo stderr >&2"
+ "'")
+ "A shell command that prints to both stdout and stderr.")
+
(defvar esh-proc-test--detect-pty-cmd
(concat "sh -c '"
"if [ -t 0 ]; then echo stdin; fi; "
"if [ -t 1 ]; then echo stdout; fi; "
"if [ -t 2 ]; then echo stderr; fi"
- "'"))
+ "'")
+ "A shell command that prints the standard streams connected as TTYs.")
;;; Tests:
+
+;; Output and redirection
+
+(ert-deftest esh-proc-test/output/to-screen ()
+ "Check that outputting stdout and stderr to the screen works."
+ (skip-unless (executable-find "sh"))
+ (with-temp-eshell
+ (eshell-match-command-output esh-proc-test--output-cmd
+ "stdout\nstderr\n")))
+
+(ert-deftest esh-proc-test/output/stdout-to-buffer ()
+ "Check that redirecting only stdout works."
+ (skip-unless (executable-find "sh"))
+ (eshell-with-temp-buffer bufname "old"
+ (with-temp-eshell
+ (eshell-match-command-output
+ (format "%s > #<%s>" esh-proc-test--output-cmd bufname)
+ "stderr\n"))
+ (should (equal (buffer-string) "stdout\n"))))
+
+(ert-deftest esh-proc-test/output/stderr-to-buffer ()
+ "Check that redirecting only stderr works."
+ (skip-unless (executable-find "sh"))
+ (eshell-with-temp-buffer bufname "old"
+ (with-temp-eshell
+ (eshell-match-command-output
+ (format "%s 2> #<%s>" esh-proc-test--output-cmd bufname)
+ "stdout\n"))
+ (should (equal (buffer-string) "stderr\n"))))
+
+(ert-deftest esh-proc-test/output/stdout-and-stderr-to-buffer ()
+ "Check that redirecting stdout and stderr works."
+ (skip-unless (executable-find "sh"))
+ (eshell-with-temp-buffer bufname "old"
+ (with-temp-eshell
+ (eshell-match-command-output
+ (format "%s &> #<%s>" esh-proc-test--output-cmd bufname)
+ "\\`\\'"))
+ (should (equal (buffer-string) "stdout\nstderr\n"))))
+
+
+;; Exit status
+
+(ert-deftest esh-proc-test/exit-status/success ()
+ "Check that successful execution is properly recorded."
+ (skip-unless (executable-find "sh"))
+ (with-temp-eshell
+ (eshell-insert-command "sh -c 'exit 0'")
+ (eshell-wait-for-subprocess)
+ (should (= eshell-last-command-status 0))
+ (should (eq eshell-last-command-result t))))
+
+(ert-deftest esh-proc-test/exit-status/failure ()
+ "Check that failed execution is properly recorded."
+ (skip-unless (executable-find "sh"))
+ (with-temp-eshell
+ (eshell-insert-command "sh -c 'exit 1'")
+ (eshell-wait-for-subprocess)
+ (should (= eshell-last-command-status 1))
+ (should (eq eshell-last-command-result nil))))
+
+(ert-deftest esh-proc-test/exit-status/with-stderr-pipe ()
+ "Check that failed execution is properly recorded even with a pipe process."
+ (skip-unless (executable-find "sh"))
+ (eshell-with-temp-buffer bufname "old"
+ (with-temp-eshell
+ (eshell-insert-command (format "sh -c 'exit 1' > #<%s>" bufname))
+ (eshell-wait-for-subprocess)
+ (should (= eshell-last-command-status 1))
+ (should (eq eshell-last-command-result nil)))))
+
+
+;; Pipelines
+
(ert-deftest esh-proc-test/sigpipe-exits-process ()
"Test that a SIGPIPE is properly sent to a process if a pipe closes"
(skip-unless (and (executable-find "sh")
@@ -74,23 +156,54 @@
(ert-deftest esh-proc-test/pipeline-connection-type/middle ()
"Test that all streams are pipes when a command is in the middle of a
pipeline."
- ;; Repeated unreproducible errors.
- :tags '(:unstable)
(skip-unless (and (executable-find "sh")
(executable-find "cat")))
- (eshell-command-result-equal
- (concat "echo | " esh-proc-test--detect-pty-cmd " | cat")
- nil))
+ ;; An `eshell-pipe-broken' signal might occur internally; let Eshell
+ ;; handle it!
+ (let ((debug-on-error nil))
+ (eshell-command-result-equal
+ (concat "echo hi | " esh-proc-test--detect-pty-cmd " | cat")
+ nil)))
(ert-deftest esh-proc-test/pipeline-connection-type/last ()
"Test that only output streams are PTYs when a command ends a pipeline."
- ;; Repeated unreproducible errors.
- :tags '(:unstable)
(skip-unless (executable-find "sh"))
- (eshell-command-result-equal
- (concat "echo | " esh-proc-test--detect-pty-cmd)
- (unless (eq system-type 'windows-nt)
- "stdout\nstderr\n")))
+ ;; An `eshell-pipe-broken' signal might occur internally; let Eshell
+ ;; handle it!
+ (let ((debug-on-error nil))
+ (eshell-command-result-equal
+ (concat "echo hi | " esh-proc-test--detect-pty-cmd)
+ (unless (eq system-type 'windows-nt)
+ "stdout\nstderr\n"))))
+
+
+;; Killing processes
+
+(ert-deftest esh-proc-test/kill-process/foreground-only ()
+ "Test that `eshell-kill-process' only kills foreground processes."
+ (with-temp-eshell
+ (eshell-insert-command "sleep 100 &")
+ (eshell-insert-command "sleep 100")
+ (should (equal (length eshell-process-list) 2))
+ ;; This should kill only the foreground process.
+ (eshell-kill-process)
+ (eshell-wait-for-subprocess)
+ (should (equal (length eshell-process-list) 1))
+ ;; Now kill everything, including the background process.
+ (eshell-process-interact 'kill-process t)
+ (eshell-wait-for-subprocess t)
+ (should (equal (length eshell-process-list) 0))))
+
+(ert-deftest esh-proc-test/kill-process/background-prompt ()
+ "Test that killing a background process doesn't emit a new
+prompt. See bug#54136."
+ (skip-unless (and (executable-find "sh")
+ (executable-find "sleep")))
+ (with-temp-eshell
+ (eshell-insert-command "sh -c 'while true; do sleep 1; done' &")
+ (kill-process (caar eshell-process-list))
+ (eshell-wait-for-subprocess)
+ (should (eshell-match-output "\\[sh\\(\\.exe\\)?\\] [[:digit:]]+\n"))))
(ert-deftest esh-proc-test/kill-pipeline ()
"Test that killing a pipeline of processes only emits a single
@@ -131,14 +244,4 @@ write the exit status to the pipe. See bug#54136."
output-start (eshell-end-of-output))
"")))))
-(ert-deftest esh-proc-test/kill-background-process ()
- "Test that killing a background process doesn't emit a new
-prompt. See bug#54136."
- (skip-unless (and (executable-find "sh")
- (executable-find "sleep")))
- (with-temp-eshell
- (eshell-insert-command "sh -c 'while true; do sleep 1; done' &")
- (kill-process (caar eshell-process-list))
- ;; Give `eshell-sentinel' a chance to run.
- (sit-for 0.1)
- (should (eshell-match-output "\\[sh\\(\\.exe\\)?\\] [[:digit:]]+\n"))))
+;;; esh-proc-tests.el ends here
diff --git a/test/lisp/eshell/eshell-tests-helpers.el b/test/lisp/eshell/eshell-tests-helpers.el
index 8f0f993447f..73abfcbb557 100644
--- a/test/lisp/eshell/eshell-tests-helpers.el
+++ b/test/lisp/eshell/eshell-tests-helpers.el
@@ -51,6 +51,16 @@ See `eshell-wait-for-subprocess'.")
(let (kill-buffer-query-functions)
(kill-buffer eshell-buffer)))))))
+(defmacro eshell-with-temp-buffer (bufname text &rest body)
+ "Create a temporary buffer containing TEXT and evaluate BODY there.
+BUFNAME will be set to the name of the temporary buffer."
+ (declare (indent 2))
+ `(with-temp-buffer
+ (insert ,text)
+ (rename-buffer "eshell-temp-buffer" t)
+ (let ((,bufname (buffer-name)))
+ ,@body)))
+
(defun eshell-wait-for-subprocess (&optional all)
"Wait until there is no interactive subprocess running in Eshell.
If ALL is non-nil, wait until there are no Eshell subprocesses at
diff --git a/test/lisp/eshell/eshell-tests.el b/test/lisp/eshell/eshell-tests.el
index 1845dba2809..d5112146c2d 100644
--- a/test/lisp/eshell/eshell-tests.el
+++ b/test/lisp/eshell/eshell-tests.el
@@ -105,25 +105,6 @@
(format template "format \"%s\" eshell-in-pipeline-p")
"nil")))
-(ert-deftest eshell-test/redirect-buffer ()
- "Check that piping to a buffer works"
- (with-temp-buffer
- (rename-buffer "eshell-temp-buffer" t)
- (let ((bufname (buffer-name)))
- (with-temp-eshell
- (eshell-insert-command (format "echo hi > #<%s>" bufname)))
- (should (equal (buffer-string) "hi")))))
-
-(ert-deftest eshell-test/redirect-buffer-escaped ()
- "Check that piping to a buffer with escaped characters works"
- (with-temp-buffer
- (rename-buffer "eshell\\temp\\buffer" t)
- (let ((bufname (buffer-name)))
- (with-temp-eshell
- (eshell-insert-command (format "echo hi > #<%s>"
- (string-replace "\\" "\\\\" bufname))))
- (should (equal (buffer-string) "hi")))))
-
(ert-deftest eshell-test/escape-nonspecial ()
"Test that \"\\c\" and \"c\" are equivalent when \"c\" is not a
special character."
diff --git a/test/lisp/filenotify-tests.el b/test/lisp/filenotify-tests.el
index 4ed1786a8ef..2d147e900d7 100644
--- a/test/lisp/filenotify-tests.el
+++ b/test/lisp/filenotify-tests.el
@@ -639,7 +639,9 @@ delivered."
(ert-deftest file-notify-test03-events ()
"Check file creation/change/removal notifications."
- :tags '(:expensive-test)
+ :tags (if (getenv "EMACS_EMBA_CI")
+ '(:expensive-test :unstable)
+ '(:expensive-test))
(skip-unless (file-notify--test-local-enabled))
(unwind-protect
@@ -1382,7 +1384,9 @@ descriptors that were issued when registering the watches. This
test caters for the situation in bug#22736 where the callback for
the directory received events for the file with the descriptor of
the file watch."
- :tags '(:expensive-test)
+ :tags (if (getenv "EMACS_EMBA_CI")
+ '(:expensive-test :unstable)
+ '(:expensive-test))
(skip-unless (file-notify--test-local-enabled))
;; A directory to be watched.
diff --git a/test/lisp/image-dired-tests.el b/test/lisp/image/image-dired-tests.el
index 00df72487fd..00df72487fd 100644
--- a/test/lisp/image-dired-tests.el
+++ b/test/lisp/image/image-dired-tests.el
diff --git a/test/lisp/net/mailcap-tests.el b/test/lisp/net/mailcap-tests.el
index 188706fc86a..c4f011dd1a7 100644
--- a/test/lisp/net/mailcap-tests.el
+++ b/test/lisp/net/mailcap-tests.el
@@ -133,4 +133,409 @@
(mailcap-view-file (ert-resource-file "test.test")))
(should mailcap--test-result))))
+
+
+(ert-deftest mailcap-add-mailcap-entry-new-major ()
+ "Add a major entry not yet in ‘mailcap-mime-data’."
+ (let ((mailcap-mime-data))
+
+ ;; Add a new major entry to a empty ‘mailcap-mime-data’.
+ (mailcap-add-mailcap-entry "major1" "minor1"
+ (list (cons 'viewer "viewer1"))
+ 'mailcap-mime-data)
+ (should (equal mailcap-mime-data
+ '(("major1"
+ ("minor1" . ((viewer . "viewer1")))))))
+
+ ;; Add a new major entry to a non-empty ‘mailcap-mime-data’.
+ (mailcap-add-mailcap-entry "major2" "minor2"
+ (list (cons 'viewer "viewer2"))
+ 'mailcap-mime-data)
+ (should (equal mailcap-mime-data
+ '(("major2"
+ ("minor2" . ((viewer . "viewer2"))))
+ ("major1"
+ ("minor1" . ((viewer . "viewer1"))))))))
+
+ ;; Same spiel but with extra entries in INFO.
+ (let ((mailcap-mime-data))
+ ;; Add a new major entry to an empty ‘mailcap-mime-data’.
+ (mailcap-add-mailcap-entry "major1" "minor1"
+ (list (cons 'viewer "viewer1")
+ (cons 'print "print1"))
+ 'mailcap-mime-data)
+ (should (equal mailcap-mime-data
+ '(("major1"
+ ("minor1" . ((viewer . "viewer1")
+ (print . "print1")))))))
+
+ ;; Add a new major entry to a non-empty ‘mailcap-mime-data’.
+ (mailcap-add-mailcap-entry "major2" "minor2"
+ (list (cons 'viewer "viewer2")
+ (cons 'print "print2")
+ (cons 'compose "compose2"))
+ 'mailcap-mime-data)
+ (should (equal mailcap-mime-data
+ '(("major2"
+ ("minor2" . ((viewer . "viewer2")
+ (print . "print2")
+ (compose . "compose2"))))
+ ("major1"
+ ("minor1" . ((viewer . "viewer1")
+ (print . "print1")))))))))
+
+
+(ert-deftest mailcap-add-mailcap-entry-new-minor-to-empty-major ()
+ "Add a minor entry to a an empty major entry."
+ (let ((mailcap-mime-data (list (list "major"))))
+ (mailcap-add-mailcap-entry "major" "minor1"
+ (list (cons 'viewer "viewer1")
+ (cons 'print "print1"))
+ 'mailcap-mime-data)
+ (should (equal mailcap-mime-data
+ '(("major"
+ ("minor1" . ((viewer . "viewer1")
+ (print . "print1")))))))))
+
+(ert-deftest mailcap-add-mailcap-entry-new-minor-to-non-empty-major ()
+ "Add a minor to a major entry containing already minor entries."
+ (let ((mailcap-mime-data
+ (list
+ (list "major"
+ (list "minor1"
+ (cons 'viewer "viewer1")
+ (cons 'test "test1")
+ (cons 'print "print1"))))))
+
+ (mailcap-add-mailcap-entry "major" "minor2"
+ (list (cons 'viewer "viewer2")
+ (cons 'test "test2")
+ (cons 'print "print2"))
+ 'mailcap-mime-data)
+ (should (equal mailcap-mime-data
+ '(("major"
+ ("minor2" . ((viewer . "viewer2")
+ (test . "test2")
+ (print . "print2")))
+ ("minor1" . ((viewer . "viewer1")
+ (test . "test1")
+ (print . "print1")))))))
+
+ (mailcap-add-mailcap-entry "major" "minor3"
+ (list (cons 'viewer "viewer3")
+ (cons 'test "test3")
+ (cons 'compose "compose3"))
+ 'mailcap-mime-data)
+ (should (equal mailcap-mime-data
+ '(("major"
+ ("minor3" . ((viewer . "viewer3")
+ (test . "test3")
+ (compose . "compose3")))
+ ("minor2" . ((viewer . "viewer2")
+ (test . "test2")
+ (print . "print2")))
+ ("minor1" . ((viewer . "viewer1")
+ (test . "test1")
+ (print . "print1")))))))))
+
+(ert-deftest mailcap-add-mailcap-entry-new-minor-to-various-major-positions ()
+ "Add a new minor entry to major entries at various postions
+in ‘mailcap-mime-data’."
+ (let ((mailcap-mime-data
+ (list
+ (list "major1"
+ (list "minor1.1"
+ (cons 'viewer "viewer1.1")
+ (cons 'print "print1.1")))
+ (list "major2"
+ (list "minor2.1"
+ (cons 'viewer "viewer2.1")
+ (cons 'print "print2.1")
+ (cons 'compose "compose2.1")))
+ (list "major3"
+ (list "minor3.1"
+ (cons 'viewer "viewer3.1")
+ (cons 'compose "compose3.1")))
+ (list "major4"
+ (list "minor4.1"
+ (cons 'viewer "viewer4.1")
+ (cons 'edit "edit4.1"))))))
+
+ ;; Add a minor entry to a major mode at the front of
+ ;; ‘mailcap-mime-data’.
+ (mailcap-add-mailcap-entry "major1" "minor1.2"
+ (list (cons 'viewer "viewer1.2")
+ (cons 'test "test1.2"))
+ 'mailcap-mime-data)
+ (should (equal mailcap-mime-data
+ '(("major1"
+ ("minor1.2" . ((viewer . "viewer1.2")
+ (test . "test1.2")))
+ ("minor1.1" . ((viewer . "viewer1.1")
+ (print . "print1.1"))))
+ ("major2"
+ ("minor2.1" . ((viewer . "viewer2.1")
+ (print . "print2.1")
+ (compose . "compose2.1"))))
+ ("major3"
+ ("minor3.1" . ((viewer . "viewer3.1")
+ (compose . "compose3.1"))))
+ ("major4"
+ ("minor4.1" . ((viewer . "viewer4.1")
+ (edit . "edit4.1")))))))
+
+ ;; Add a minor entry to a major mode in the middle of
+ ;; ‘mailcap-mime-data’.
+ (mailcap-add-mailcap-entry "major3" "minor3.2"
+ (list (cons 'viewer "viewer3.2")
+ (cons 'test "test3.2")
+ (cons 'compose "compose3.2"))
+ 'mailcap-mime-data)
+ (should (equal mailcap-mime-data
+ '(("major1"
+ ("minor1.2" . ((viewer . "viewer1.2")
+ (test . "test1.2")))
+ ("minor1.1" . ((viewer . "viewer1.1")
+ (print . "print1.1"))))
+ ("major2"
+ ("minor2.1" . ((viewer . "viewer2.1")
+ (print . "print2.1")
+ (compose . "compose2.1"))))
+ ("major3"
+ ("minor3.2" . ((viewer . "viewer3.2")
+ (test . "test3.2")
+ (compose . "compose3.2")))
+ ("minor3.1" . ((viewer . "viewer3.1")
+ (compose . "compose3.1"))))
+ ("major4"
+ ("minor4.1" . ((viewer . "viewer4.1")
+ (edit . "edit4.1")))))))
+
+ ;; Add a minor entry to a major mode at the end of
+ ;; ‘mailcap-mime-data’.
+ (mailcap-add-mailcap-entry "major4" "minor4.2"
+ (list (cons 'viewer "viewer4.2")
+ (cons 'test "test4.2")
+ (cons 'print "print4.2")
+ (cons 'compose "compose4.2"))
+ 'mailcap-mime-data)
+ (should (equal mailcap-mime-data
+ '(("major1"
+ ("minor1.2" . ((viewer . "viewer1.2")
+ (test . "test1.2")))
+ ("minor1.1" . ((viewer . "viewer1.1")
+ (print . "print1.1"))))
+ ("major2"
+ ("minor2.1" . ((viewer . "viewer2.1")
+ (print . "print2.1")
+ (compose . "compose2.1"))))
+ ("major3"
+ ("minor3.2" . ((viewer . "viewer3.2")
+ (test . "test3.2")
+ (compose . "compose3.2")))
+ ("minor3.1" . ((viewer . "viewer3.1")
+ (compose . "compose3.1"))))
+ ("major4"
+ ("minor4.2" . ((viewer . "viewer4.2")
+ (test . "test4.2")
+ (print . "print4.2")
+ (compose . "compose4.2")))
+ ("minor4.1" . ((viewer . "viewer4.1")
+ (edit . "edit4.1")))))))))
+
+(ert-deftest mailcap-add-mailcap-entry-existing-with-test-differing-viewer ()
+ "Add a new entry for an already existing major/minor entry."
+
+ ;; The new and the existing entry have each a test info field.
+ (let ((mailcap-mime-data
+ (list
+ (list "major"
+ (list "minor"
+ (cons 'viewer "viewer1")
+ (cons 'test "test1")
+ (cons 'print "print1"))))))
+ (mailcap-add-mailcap-entry "major" "minor"
+ (list (cons 'viewer "viewer2")
+ (cons 'test "test2"))
+ 'mailcap-mime-data)
+ (should (equal mailcap-mime-data
+ '(("major"
+ ("minor" . ((viewer . "viewer2")
+ (test . "test2")))
+ ("minor" . ((viewer . "viewer1")
+ (test . "test1")
+ (print . "print1"))))))))
+
+ ;; Only the new entry has a test info field.
+ (let ((mailcap-mime-data
+ (list
+ (list "major"
+ (list "minor"
+ (cons 'viewer "viewer1")
+ (cons 'print "print1"))))))
+ (mailcap-add-mailcap-entry "major" "minor"
+ (list (cons 'viewer "viewer2")
+ (cons 'test "test2"))
+ 'mailcap-mime-data)
+ (should (equal mailcap-mime-data
+ '(("major"
+ ("minor" . ((viewer . "viewer2")
+ (test . "test2")))
+ ("minor" . ((viewer . "viewer1")
+ (print . "print1"))))))))
+
+ ;; Only the existing entry has a test info field.
+ (let ((mailcap-mime-data
+ (list
+ (list "major"
+ (list "minor"
+ (cons 'viewer "viewer1")
+ (cons 'test "test1")
+ (cons 'print "print1"))))))
+ (mailcap-add-mailcap-entry "major" "minor"
+ (list (cons 'viewer "viewer2"))
+ 'mailcap-mime-data)
+ (should (equal mailcap-mime-data
+ '(("major"
+ ("minor" . ((viewer . "viewer2")))
+ ("minor" . ((viewer . "viewer1")
+ (test . "test1")
+ (print . "print1")))))))))
+
+(ert-deftest mailcap-add-mailcap-entry-existing-with-test-same-viewer ()
+ "Add a new entry for an already existing major/minor entry."
+ ;; Both the new and the existing entry have each a test info field.
+ (let ((mailcap-mime-data
+ (list
+ (list "major"
+ (list "minor"
+ (cons 'viewer "viewer")
+ (cons 'test "test1")
+ (cons 'print "print1"))))))
+ (mailcap-add-mailcap-entry "major" "minor"
+ (list (cons 'viewer "viewer")
+ (cons 'test "test2"))
+ 'mailcap-mime-data)
+ (should (equal mailcap-mime-data
+ '(("major"
+ ("minor" . ((viewer . "viewer")
+ (test . "test2")))
+ ("minor" . ((viewer . "viewer")
+ (test . "test1")
+ (print . "print1"))))))))
+
+ ;; Only the new entry has a test field.
+ (let ((mailcap-mime-data
+ (list
+ (list "major"
+ (list "minor"
+ (cons 'viewer "viewer")
+ (cons 'print "print1"))))))
+ (mailcap-add-mailcap-entry "major" "minor"
+ (list (cons 'viewer "viewer")
+ (cons 'test "test2"))
+ 'mailcap-mime-data)
+ (should (equal mailcap-mime-data
+ '(("major"
+ ("minor" . ((viewer . "viewer")
+ (test . "test2")))
+ ("minor" . ((viewer . "viewer")
+ (print . "print1"))))))))
+
+ ;; Only the existing entry has a test info field.
+ (let ((mailcap-mime-data
+ (list
+ (list "major"
+ (list "minor"
+ (cons 'viewer "viewer")
+ (cons 'test "test1")
+ (cons 'print "print1"))))))
+ (mailcap-add-mailcap-entry "major" "minor"
+ (list (cons 'viewer "viewer"))
+ 'mailcap-mime-data)
+ (should (equal mailcap-mime-data
+ '(("major"
+ ("minor" . ((viewer . "viewer")))
+ ("minor" . ((viewer . "viewer")
+ (test . "test1")
+ (print . "print1")))))))))
+
+(ert-deftest mailcap-add-mailcap-entry-existing-without-test-differing-viewer ()
+ "Add a new entry for an already existing major/minor entry."
+ ;; Both entries do not have test fields.
+ (let ((mailcap-mime-data
+ (list
+ (list "major"
+ (list "minor"
+ (cons 'viewer "viewer1")
+ (cons 'print "print1"))))))
+ (mailcap-add-mailcap-entry "major" "minor"
+ (list (cons 'viewer "viewer2")
+ (cons 'compose "print2"))
+ 'mailcap-mime-data)
+ (should (equal mailcap-mime-data
+ '(("major"
+ ("minor" . ((viewer . "viewer2")
+ (compose . "print2")))
+ ("minor" . ((viewer . "viewer1")
+ (print . "print1")))))))))
+
+(ert-deftest mailcap-add-mailcap-entry-simple-merge ()
+ "Merge entries without tests (no extra info fields in the existing entry)."
+ (let ((mailcap-mime-data
+ (list
+ (list "major"
+ (list "minor"
+ (cons 'viewer "viewer"))))))
+ (mailcap-add-mailcap-entry "major" "minor"
+ (list (cons 'viewer "viewer"))
+ 'mailcap-mime-data)
+ (should (equal mailcap-mime-data
+ '(("major"
+ ("minor" . ((viewer . "viewer"))))))))
+
+ (let ((mailcap-mime-data
+ (list
+ (list "major"
+ (list "minor"
+ (cons 'viewer "viewer"))))))
+ (mailcap-add-mailcap-entry "major" "minor"
+ (list (cons 'viewer "viewer")
+ (cons 'print "print"))
+ 'mailcap-mime-data)
+
+ (should (equal mailcap-mime-data
+ '(("major"
+ ("minor" . ((viewer . "viewer")
+ (print . "print")))))))))
+
+(ert-deftest mailcap-add-mailcap-entry-erroneous-merge ()
+ "Merge entries without tests (extra info fields in existing entry).
+
+In its current implementation ‘mailcap-add-mailcap-entry’ loses
+extra fields of an entry already existing in ‘mailcap-mime-data’.
+This test does not actually verify a correct result; it merely
+checks whether ‘mailcap-add-mailcap-entry’ behaviour is still the
+incorrect one. As such, it can be satisfied by any other result
+than the expected and known wrong one, and its success does not
+help to verify the correct addition and merging of an entry."
+ :expected-result :failed
+
+ (let ((mailcap-mime-data
+ (list
+ (list "major"
+ (list "minor"
+ (cons 'viewer "viewer")
+ (cons 'print "print"))))))
+ (mailcap-add-mailcap-entry "major" "minor"
+ (list (cons 'viewer "viewer")
+ (cons 'edit "edit"))
+ 'mailcap-mime-data)
+ ;; Has the print field been lost?
+ (should-not (equal mailcap-mime-data
+ '(("major"
+ ("minor" . ((viewer . "viewer")
+ (edit . "edit")))))))))
+
+
;;; mailcap-tests.el ends here
diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el
index 964404b4bf7..aa5d1cc496c 100644
--- a/test/lisp/net/tramp-archive-tests.el
+++ b/test/lisp/net/tramp-archive-tests.el
@@ -622,7 +622,7 @@ This checks also `file-name-as-directory', `file-name-directory',
(goto-char (point-min))
(should
(looking-at-p
- (rx bol (+ nonl) " " (literal tramp-archive-test-archive) eol))))
+ (rx bol (+ nonl) space (literal tramp-archive-test-archive) eol))))
(with-temp-buffer
(insert-directory
(file-name-as-directory tramp-archive-test-archive)
@@ -633,14 +633,14 @@ This checks also `file-name-as-directory', `file-name-directory',
(rx-to-string
`(:
;; There might be a summary line.
- (? "total" (+ nonl) (+ digit) (? " ")
+ (? "total" (+ nonl) (+ digit) (? space)
(? (any "EGKMPTYZk")) (? "i") (? "B") "\n")
;; We don't know in which order the files appear.
(= ,(length (directory-files tramp-archive-test-archive))
- (+ nonl) " "
+ (+ nonl) space
(regexp
,(regexp-opt (directory-files tramp-archive-test-archive)))
- (? " ->" (one-or-more nonl)) "\n"))))))
+ (? " ->" (+ nonl)) "\n"))))))
;; Check error case.
(with-temp-buffer
(should-error
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index bc67ff2ace7..fed1d881c57 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -3222,13 +3222,13 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
(insert-directory tmp-name1 "-al")
(goto-char (point-min))
(should
- (looking-at-p (rx bol (+ nonl) " " (literal tmp-name1) eol))))
+ (looking-at-p (rx bol (+ nonl) space (literal tmp-name1) eol))))
(with-temp-buffer
(insert-directory (file-name-as-directory tmp-name1) "-al")
(goto-char (point-min))
(should
(looking-at-p
- (rx bol (+ nonl) " " (literal tmp-name1) "/" eol))))
+ (rx bol (+ nonl) space (literal tmp-name1) "/" eol))))
(with-temp-buffer
(insert-directory
(file-name-as-directory tmp-name1) "-al" nil 'full-directory-p)
@@ -3238,11 +3238,11 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
(rx-to-string
`(:
;; There might be a summary line.
- (? "total" (+ nonl) (+ digit) (? " ")
+ (? "total" (+ nonl) (+ digit) (? space)
(? (any "EGKMPTYZk")) (? "i") (? "B") "\n")
;; We don't know in which order ".", ".." and "foo" appear.
(= ,(length (directory-files tmp-name1))
- (+ nonl) " "
+ (+ nonl) space
(regexp ,(regexp-opt (directory-files tmp-name1)))
(? " ->" (+ nonl)) "\n"))))))
@@ -6703,7 +6703,7 @@ Additionally, ls does not support \"--dired\"."
"Check, whether the method needs a share."
(and (tramp--test-gvfs-p)
(string-match-p
- (rx bol (or "afp" (: "dav" (opt "s")) "smb") eol)
+ (rx bol (| "afp" (: "dav" (? "s")) "smb") eol)
(file-remote-p ert-remote-temporary-file-directory 'method))))
(defun tramp--test-sshfs-p ()
diff --git a/test/src/buffer-tests.el b/test/src/buffer-tests.el
index 3c6a9208ffa..558d05de14a 100644
--- a/test/src/buffer-tests.el
+++ b/test/src/buffer-tests.el
@@ -22,6 +22,199 @@
(require 'ert)
(require 'ert-x)
(require 'cl-lib)
+(require 'let-alist)
+
+(defun overlay-tests-start-recording-modification-hooks (overlay)
+ "Start recording modification hooks on OVERLAY.
+
+Always overwrites the `insert-in-front-hooks',
+`modification-hooks' and `insert-behind-hooks' properties. Any
+recorded history from a previous call is erased.
+
+The history is stored in a property on the overlay itself. Call
+`overlay-tests-get-recorded-modification-hooks' to retrieve the
+recorded calls conveniently."
+ (dolist (hooks-property '(insert-in-front-hooks
+ modification-hooks
+ insert-behind-hooks))
+ (overlay-put
+ overlay
+ hooks-property
+ (list (lambda (ov &rest args)
+ (message " %S called on %S with args %S" hooks-property ov args)
+ (should inhibit-modification-hooks)
+ (should (eq ov overlay))
+ (push (list hooks-property args)
+ (overlay-get overlay
+ 'recorded-modification-hook-calls)))))
+ (overlay-put overlay 'recorded-modification-hook-calls nil)))
+
+(defun overlay-tests-get-recorded-modification-hooks (overlay)
+ "Extract the recorded calls made to modification hooks on OVERLAY.
+
+Must be preceded by a call to
+`overlay-tests-start-recording-modification-hooks' on OVERLAY.
+
+Returns a list. Each element of the list represents a recorded
+call to a particular modification hook.
+
+Each call is itself a sub-list where the first element is a
+symbol matching the modification hook property (one of
+`insert-in-front-hooks', `modification-hooks' or
+`insert-behind-hooks') and the second element is the list of
+arguments passed to the hook. The first hook argument, the
+overlay itself, is omitted to make test result verification
+easier."
+ (reverse (overlay-get overlay
+ 'recorded-modification-hook-calls)))
+
+(ert-deftest overlay-modification-hooks ()
+ "Test the basic functionality of overlay modification hooks.
+
+This exercises hooks registered on the `insert-in-front-hooks',
+`modification-hooks' and `insert-behind-hooks' overlay
+properties."
+ ;; This is a data driven test loop. Each test case is described
+ ;; by an alist. The test loop initializes a new temporary buffer
+ ;; for each case, creates an overlay, registers modification hooks
+ ;; on the overlay, modifies the buffer, and then verifies which
+ ;; modification hooks (if any) were called for the overlay, as
+ ;; well as which arguments were passed to the hooks.
+ ;;
+ ;; The following keys are available in the alist:
+ ;;
+ ;; `buffer-text': the initial buffer text of the temporary buffer.
+ ;; Defaults to "1234".
+ ;;
+ ;; `overlay-beg' and `overlay-end': the begin and end positions of
+ ;; the overlay under test. Defaults to 2 and 4 respectively.
+ ;;
+ ;; `insert-at': move to the given position and insert the string
+ ;; "x" into the test case's buffer.
+ ;;
+ ;; `replace': replace the first occurrence of the given string in
+ ;; the test case's buffer with "x". The test will fail if the
+ ;; string is not found.
+ ;;
+ ;; `expected-calls': a description of the expected buffer
+ ;; modification hooks. See
+ ;; `overlay-tests-get-recorded-modification-hooks' for the format.
+ ;; May be omitted, in which case the test will insist that no
+ ;; modification hooks are called.
+ ;;
+ ;; The test will fail itself in the degenerate case where no
+ ;; buffer modifications are requested.
+ (dolist (test-case
+ '(
+ ;; Remember that the default buffer text is "1234" and
+ ;; the default overlay begins at position 2 and ends at
+ ;; position 4. Most of the test cases below assume
+ ;; this.
+
+ ;; TODO: (info "(elisp) Special Properties") says this
+ ;; about `modification-hooks': "Furthermore, insertion
+ ;; will not modify any existing character, so this hook
+ ;; will only be run when removing some characters,
+ ;; replacing them with others, or changing their
+ ;; text-properties." So, why are modification-hooks
+ ;; being called when inserting at position 3 below?
+ ((insert-at . 1))
+ ((insert-at . 2)
+ (expected-calls . ((insert-in-front-hooks (nil 2 2))
+ (insert-in-front-hooks (t 2 3 0)))))
+ ((insert-at . 3)
+ (expected-calls . ((modification-hooks (nil 3 3))
+ (modification-hooks (t 3 4 0)))))
+ ((insert-at . 4)
+ (expected-calls . ((insert-behind-hooks (nil 4 4))
+ (insert-behind-hooks (t 4 5 0)))))
+ ((insert-at . 5))
+
+ ;; Replacing text never calls `insert-in-front-hooks'
+ ;; or `insert-behind-hooks'. It calls
+ ;; `modification-hooks' if the overlay covers any text
+ ;; that has changed.
+ ((replace . "1"))
+ ((replace . "2")
+ (expected-calls . ((modification-hooks (nil 2 3))
+ (modification-hooks (t 2 3 1)))))
+ ((replace . "3")
+ (expected-calls . ((modification-hooks (nil 3 4))
+ (modification-hooks (t 3 4 1)))))
+ ((replace . "4"))
+ ((replace . "12")
+ (expected-calls . ((modification-hooks (nil 1 3))
+ (modification-hooks (t 1 2 2)))))
+ ((replace . "23")
+ (expected-calls . ((modification-hooks (nil 2 4))
+ (modification-hooks (t 2 3 2)))))
+ ((replace . "34")
+ (expected-calls . ((modification-hooks (nil 3 5))
+ (modification-hooks (t 3 4 2)))))
+ ((replace . "123")
+ (expected-calls . ((modification-hooks (nil 1 4))
+ (modification-hooks (t 1 2 3)))))
+ ((replace . "234")
+ (expected-calls . ((modification-hooks (nil 2 5))
+ (modification-hooks (t 2 3 3)))))
+ ((replace . "1234")
+ (expected-calls . ((modification-hooks (nil 1 5))
+ (modification-hooks (t 1 2 4)))))
+
+ ;; Inserting at the position of a zero-length overlay
+ ;; calls both `insert-in-front-hooks' and
+ ;; `insert-behind-hooks'.
+ ((buffer-text . "") (overlay-beg . 1) (overlay-end . 1)
+ (insert-at . 1)
+ (expected-calls . ((insert-in-front-hooks
+ (nil 1 1))
+ (insert-behind-hooks
+ (nil 1 1))
+ (insert-in-front-hooks
+ (t 1 2 0))
+ (insert-behind-hooks
+ (t 1 2 0)))))))
+ (message "BEGIN overlay-modification-hooks test-case %S" test-case)
+
+ ;; All three hooks ignore the overlay's `front-advance' and
+ ;; `rear-advance' option, so test both ways while expecting the same
+ ;; result.
+ (dolist (advance '(nil t))
+ (message " advance is %S" advance)
+ (let-alist test-case
+ (with-temp-buffer
+ ;; Set up the temporary buffer and overlay as specified by
+ ;; the test case.
+ (insert (or .buffer-text "1234"))
+ (let ((overlay (make-overlay
+ (or .overlay-beg 2)
+ (or .overlay-end 4)
+ nil
+ advance advance)))
+ (message " (buffer-string) is %S" (buffer-string))
+ (message " overlay is %S" overlay)
+ (overlay-tests-start-recording-modification-hooks overlay)
+
+ ;; Modify the buffer, possibly inducing calls to the
+ ;; overlay's modification hooks.
+ (should (or .insert-at .replace))
+ (when .insert-at
+ (goto-char .insert-at)
+ (insert "x")
+ (message " inserted \"x\" at %S, buffer-string now %S"
+ .insert-at (buffer-string)))
+ (when .replace
+ (goto-char (point-min))
+ (search-forward .replace)
+ (replace-match "x")
+ (message " replaced %S with \"x\"" .replace))
+
+ ;; Verify that the expected and actual modification hook
+ ;; calls match.
+ (should (equal
+ .expected-calls
+ (overlay-tests-get-recorded-modification-hooks
+ overlay)))))))))
(ert-deftest overlay-modification-hooks-message-other-buf ()
"Test for bug#21824.
diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el
index a84cce3ad4e..4ef428af03e 100644
--- a/test/src/fns-tests.el
+++ b/test/src/fns-tests.el
@@ -1412,6 +1412,14 @@
(should (equal (take 5 list) '(a b c b c)))
(should (equal (take 10 list) '(a b c b c b c b c b)))
- (should (equal (ntake 10 list) '(a b)))))
+ (should (equal (ntake 10 list) '(a b))))
+
+ ;; Bignum N argument.
+ (let ((list (list 'a 'b 'c)))
+ (should (equal (take (+ most-positive-fixnum 1) list) '(a b c)))
+ (should (equal (take (- most-negative-fixnum 1) list) nil))
+ (should (equal (ntake (+ most-positive-fixnum 1) list) '(a b c)))
+ (should (equal (ntake (- most-negative-fixnum 1) list) nil))
+ (should (equal list '(a b c)))))
;;; fns-tests.el ends here