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