diff options
| author | Sean Whitton <spwhitton@spwhitton.name> | 2022-09-12 17:06:42 -0700 |
|---|---|---|
| committer | Sean Whitton <spwhitton@spwhitton.name> | 2022-09-12 17:06:42 -0700 |
| commit | c7dd518b0517dfd829ff1d2887f7205268193aa4 (patch) | |
| tree | 1032f5b0507273c9d32962c447f1f559a1be8694 | |
| parent | 8580cc57e459c85d0447fa0e2c0237f5a768b69e (diff) | |
| parent | 5e6a7a210bbb92b7f4c94b5765297fd814362338 (diff) | |
| download | emacs-c7dd518b0517dfd829ff1d2887f7205268193aa4.tar.gz | |
Merge remote-tracking branch 'origin/master' into athena/unstable
187 files changed, 5162 insertions, 3456 deletions
diff --git a/.dir-locals.el b/.dir-locals.el index 1c90ddcf567..84617a79807 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -5,7 +5,9 @@ (sentence-end-double-space . t) (fill-column . 70) (emacs-lisp-docstring-fill-column . 65) - (bug-reference-url-format . "https://debbugs.gnu.org/%s"))) + (vc-git-annotate-switches . "-w") + (bug-reference-url-format . "https://debbugs.gnu.org/%s") + (diff-add-log-use-relative-names . t))) (c-mode . ((c-file-style . "GNU") (c-noise-macro-names . ("INLINE" "ATTRIBUTE_NO_SANITIZE_UNDEFINED" "UNINIT" "CALLBACK" "ALIGN_STACK")) (electric-quote-comment . nil) @@ -27,6 +29,7 @@ (electric-quote-comment . nil) (electric-quote-string . nil) (mode . bug-reference-prog))) + (lisp-data-mode . ((indent-tabs-mode . nil))) (texinfo-mode . ((electric-quote-comment . nil) (electric-quote-string . nil) (mode . bug-reference-prog))) diff --git a/ChangeLog.3 b/ChangeLog.3 index 700a210f35b..a09dc29cbec 100644 --- a/ChangeLog.3 +++ b/ChangeLog.3 @@ -1,3 +1,314 @@ +2022-09-06 Stefan Kangas <stefankangas@gmail.com> + + * doc/misc/idlwave.texi (Troubleshooting): Don't say "Emacsen". + +2022-09-06 Stefan Kangas <stefankangas@gmail.com> + + Don't mention very old Emacs versions in docs + + * doc/misc/mh-e.texi (Conventions): + * doc/misc/reftex.texi (Problems and Work-Arounds): + * doc/misc/viper.texi (Loading Viper): Delete references to + very old versions of Emacs. + +2022-09-05 Stefan Kangas <stefankangas@gmail.com> + + * lisp/server.el: Improve Commentary. + +2022-09-05 Gregory Heytings <gregory@heytings.org> + + Explain how the font appearance can be fine-tuned in fbterm. + + * doc/misc/efaq.texi (Emacs in a Linux console): Briefly document + Xft font specifications with which the font appearance can be + fine-tuned. + +2022-09-04 Kyle Meyer <kyle@kyleam.com> + + Update to Org 9.5.5 + +2022-09-03 Stefan Monnier <monnier@iro.umontreal.ca> + + * lisp/emacs-lisp/comp.el (comp-run-async-workers): Fail more gracefully + + Otherwise Emacs may fail to start if it can't find a writable + `~/.emacs.d/eln-cache` directory. + Fixes bug#57562. See also Debian's bug #1017739. + +2022-09-03 Stefan Kangas <stefankangas@gmail.com> + + Update acknowledgments + + * doc/emacs/ack.texi (Acknowledgments): Update. + * doc/emacs/emacs.texi (Acknowledgments): Add several names from + Author: headers. + +2022-09-01 Stefan Kangas <stefankangas@gmail.com> + + Make some versions in docs match package version + + * doc/emacs/misc.texi (Interactive Shell): Bump Emacs version. + * doc/misc/ediff.texi: + * doc/misc/flymake.texi: + * doc/misc/viper.texi: Fix version to match package. + * lisp/emulation/viper.el: Make version match variable. + +2022-09-01 Stefan Kangas <stefankangas@gmail.com> + + Minor doc fix; improve sorting of VC backends + + * doc/emacs/maintaining.texi (Version Control Systems): Minor doc fix; + rearrange list to put git, cvs and subversion at the top. + +2022-09-01 Eli Zaretskii <eliz@gnu.org> + + Clarify the doc string of 'set-face-attribute' + + * lisp/faces.el (set-face-attribute): Clarify the issue with + resetting attribute values to 'unspecified' for future frames. + (Bug#57499) + +2022-08-30 Gregory Heytings <gregory@heytings.org> + + Enable 256 colors in fbterm. + + * lisp/term/fbterm.el: New file. + + * doc/misc/efaq.texi (Emacs in a Linux console): Document the TERM + environment variable with which the new file is used. + +2022-08-30 Eli Zaretskii <eliz@gnu.org> + + One more fix for find-file.el + + * lisp/find-file.el (ff-get-file-name): Use 'expand-file-name' + instead of 'concat', which doesn't DTRT with absolute file names. + (ff-other-file-alist): Yet another doc fix. (Bug#57325) + +2022-08-29 Gregory Heytings <gregory@heytings.org> + + Recommend using fbterm in the Linux console. + + * doc/misc/efaq.texi (Emacs in a Linux console): New node. + (Common requests): Entry for the new node. + + * etc/PROBLEMS (Linux console problems...): Mention the new FAQ node. + +2022-08-29 Eli Zaretskii <eliz@gnu.org> + + * lisp/find-file.el (ff-other-file-alist): Doc fix. (Bug#57325) + +2022-08-28 Eli Zaretskii <eliz@gnu.org> + + * lisp/info.el (Info-mode): Support the Linux console better. + +2022-08-28 Eli Zaretskii <eliz@gnu.org> + + Improve the documentation of glyphless-character display + + * lisp/international/characters.el (glyphless-char-display-control): + * src/xdisp.c (syms_of_xdisp) <glyphless-char-display>: Mention + the 'glyphless-char' face in the doc string. + + * doc/lispref/display.texi (Glyphless Chars): Index + 'glyphless-char' face. + +2022-08-27 Eli Zaretskii <eliz@gnu.org> + + Fix documentation of 'glyphless-char-display' + + * src/xdisp.c (syms_of_xdisp)<glyphless-char-display>: Doc fix. + (gui_produce_glyphs, lookup_glyphless_char_display): Fix + indentation. + +2022-08-25 Robert Pluim <rpluim@gmail.com> + + Treat smtp-auth method from auth-info as a symbol + + The lookup of the SMTP auth method is done based on symbols, but + sometimes the requested value comes from `auth-info', in which case it + is a string, so call `intern-soft' to convert it to a symbol (which + does nothing if it's already a symbol). + + * lisp/mail/smtpmail.el (smtpmail-try-auth-methods): Call + `intern-soft' on the smtp-auth key's value. (Bug#57373) + + Do not merge to master + +2022-08-25 Stefan Kangas <stefankangas@gmail.com> + + * lisp/wdired.el: Improve "Commentary" section. + + * lisp/wdired.el: Doc fix; don't mention obsolete variable. + + * lisp/progmodes/etags.el (next-file): Minor doc fix. + +2022-08-25 Andreas Schwab <schwab@suse.de> + + * configure.ac: Move AC_LANG_PUSH/POP out of AC_CACHE_CHECK. (Bug#57380) + + (cherry picked from commit ce82300221f270241fdda1f5dfb567bdb1208543) + +2022-08-21 Kyle Meyer <kyle@kyleam.com> + + Update to Org 9.5.4-19-g4dff42 + +2022-08-21 Eli Zaretskii <eliz@gnu.org> + + * lisp/find-file.el (ff-other-file-alist): Doc fix. (Bug#57325) + +2022-08-19 Stefan Kangas <stefankangas@gmail.com> + + Resurrect obsoletion warning for two functions + + These were supposed to have been deleted, but never were. Resurrect + their obsoletion warning and let's delete them in Emacs 29 instead. + + * lisp/subr.el (process-filter-multibyte-p) + (set-process-filter-multibyte): Resurrect obsoletion warning. + * etc/NEWS: Don't announce their deletion. + +2022-08-19 Alan Mackenzie <acm@muc.de> + + * src/window.c (select_window): Fix assert for buffer = non-active minibuffer + +2022-08-19 Gerd Möllmann <gerd@gnu.org> + + Find libgccjit on macOS with Homebrew differently + + * configure.ac (MAC_LIBS): Find libgccjit's directory slightly + differently for brew installations. + +2022-08-18 Stefan Kangas <stefankangas@gmail.com> + + Improve image-mode-as-hex docstring + + * lisp/image-mode.el: Fix typos. + (image-mode-as-hex): Doc fix; say that it uses 'hexl-mode' and reflow. + +2022-08-18 Stefan Kangas <stefankangas@gmail.com> + + * lisp/image-mode.el (image-mode-as-hex): Fix toggle instructions. + + * lisp/image-mode.el: Improve commentary. + +2022-08-18 Colin Woodbury <colin@fosskers.ca> + + cl-reduce doc string improvement + + * lisp/emacs-lisp/cl-seq.el (cl-reduce): Explain what happens when + using :from-end (bug#57273). + +2022-08-18 Paul Eggert <eggert@cs.ucla.edu> + + Backport tempname changes from master (bug#57129) + + * lib/tempname.c: Backport from master, which uses current Gnulib. + +2022-08-16 Stefan Kangas <stefankangas@gmail.com> + + Revert "; * doc/lispintro/emacs-lisp-intro.texi: Fix typo." + + This reverts commit 9d0dba44da7ac83d018fff3c26d33dac12ebd806. + + This was not a typo, but incorrectly matching parens in Info-mode. + +2022-08-16 Stefan Kangas <stefankangas@gmail.com> + + * doc/misc/gnus.texi (Article Washing): Fix Links URL. + +2022-08-12 Stefan Kangas <stefan@marxist.se> + + Delete references to deleted library hilit19.el + + * doc/misc/gnus.texi (Compatibility): + * lisp/progmodes/f90.el: + * lisp/ps-print.el: + * lisp/vc/ediff.el: Delete references to hilit19.el. + +2022-08-12 Stefan Kangas <stefan@marxist.se> + + Delete stale comments from Lisp Intro manual + + * doc/lispintro/emacs-lisp-intro.texi (Args as Variable or List) + (print-elements-of-list, Miscellaneous): Delete some references to + Emacs 22. + +2022-08-11 Stefan Kangas <stefan@marxist.se> + + Don't list Emacs as requirement for built-in package + + * doc/misc/htmlfontify.texi (Requirements): Don't list Emacs as + requirement for built-in package. + +2022-08-11 YAMAMOTO Mitsuharu <mituharu@math.s.chiba-u.ac.jp> + + Fix wrong metrics for bitmap-only fonts with HarfBuzz 5 + + * src/ftcrfont.c (ftcrhbfont_begin_hb_font): Always use the standard + position unit value on HarfBuzz 5 and later regardless of whether the + font is bitmap-only or not. (Bug#57066) + +2022-08-09 Stefan Kangas <stefan@marxist.se> + + Improve wording when documenting other TRAMP syntaxes + + * doc/misc/tramp.texi (Change file name syntax): Improve wording. + (Bug#57061) + +2022-08-08 Stefan Kangas <stefan@marxist.se> + + * lisp/vc/diff-mode.el: Don't mention XEmacs. + +2022-08-08 Stefan Kangas <stefan@marxist.se> + + Don't mention XEmacs toolbar in ediff manual + + * doc/misc/ediff.texi (Other Session Commands): Don't mention XEmacs + specific toolbar support for now. This can be changed back once the + toolbar is ported to Emacs. + +2022-08-06 Eli Zaretskii <eliz@gnu.org> + + * etc/PROBLEMS: Problems with Alacritty and Emoji. (Bug#56952) + +2022-08-06 Yuga Ego <yet@ego.team> + + Link from (emacs)Init Syntax to (elisp)Introduction + + * doc/emacs/custom.texi (Init Syntax): Link to the ELisp manual (Bug#56870) + +2022-08-06 Stefan Kangas <stefan@marxist.se> + + Don't mention removed XEmacs support in reftex manual + + * doc/misc/reftex.texi (Installation, Imprint): Don't mention + removed XEmacs support. + +2022-08-06 Stefan Kangas <stefan@marxist.se> + + Don't mention removed XEmacs support in idlwave manual + + * doc/misc/idlwave.texi (Lesson I---Development Cycle) + (Syntax Highlighting, Windows and macOS, Troubleshooting): Delete + most references to XEmacs. Support for it was deleted in 28.1. + +2022-08-05 Stefan Kangas <stefan@marxist.se> + + * lisp/play/fortune.el: Doc fixes. + +2022-08-04 Stefan Kangas <stefan@marxist.se> + + * doc/lispref/loading.texi (Autoload by Prefix): Fix typo. + +2022-08-03 Philipp Stephani <phst@google.com> + + * lisp/uniquify.el (uniquify-buffer-name-style): Quote apostrophe. + +2022-08-02 Stefan Kangas <stefan@marxist.se> + + * lisp/term.el: Doc fix; don't mention rlogin. + 2022-07-31 Eli Zaretskii <eliz@gnu.org> * src/lisp.h (CHECK_INTEGER): Fix the predicate. (Bug#56856) @@ -236607,7 +236918,7 @@ This file records repository revisions from commit 9d56a21e6a696ad19ac65c4b405aeca44785884a (exclusive) to -commit 78759ddcb0fc7dd75a7a8edfb2c19dc2f1d86ee2 (inclusive). +commit ddabb03a0176beb4b7fc8d4f2267d459fd2ebded (inclusive). See ChangeLog.2 for earlier changes. ;; Local Variables: diff --git a/admin/admin.el b/admin/admin.el index c84287a7024..fececc86a4b 100644 --- a/admin/admin.el +++ b/admin/admin.el @@ -124,9 +124,6 @@ Root must be the root of an Emacs source tree." ;; Major version only. (when (string-match "\\([0-9]\\{2,\\}\\)" version) (let ((newmajor (match-string 1 version))) - (set-version-in-file root "src/msdos.c" newmajor - (rx (and "Vwindow_system_version" (1+ not-newline) - ?\( (submatch (1+ (in "0-9"))) ?\)))) (set-version-in-file root "etc/refcards/ru-refcard.tex" newmajor "\\\\newcommand{\\\\versionemacs}\\[0\\]\ {\\([0-9]\\{2,\\}\\)}.+%.+version of Emacs"))) diff --git a/admin/cus-test.el b/admin/cus-test.el index 5894abed3df..22d5a3a1516 100644 --- a/admin/cus-test.el +++ b/admin/cus-test.el @@ -272,7 +272,7 @@ currently defined groups." (if group (memq symbol groups) (or - ;; (user-variable-p symbol) + ;; (custom-variable-p symbol) (get symbol 'standard-value) ;; (get symbol 'saved-value) (get symbol 'custom-type))) diff --git a/doc/emacs/maintaining.texi b/doc/emacs/maintaining.texi index 343cc83ce5d..89e6b2215c9 100644 --- a/doc/emacs/maintaining.texi +++ b/doc/emacs/maintaining.texi @@ -690,11 +690,15 @@ started editing (@pxref{Old Revisions}), type @kbd{C-c C-d} @kindex C-c C-w @r{(Log Edit mode)} @findex log-edit-generate-changelog-from-diff +@vindex diff-add-log-use-relative-names To help generate ChangeLog entries, type @kbd{C-c C-w} (@code{log-edit-generate-changelog-from-diff}), to generate skeleton ChangeLog entries, listing all changed file and function names based on the diff of the VC fileset. Consecutive entries left empty will be -combined by @kbd{C-q} (@code{fill-paragraph}). +combined by @kbd{C-q} (@code{fill-paragraph}). By default the +skeleton will just include the file name, without any leading +directories. If you wish to prepend the leading directories up to the +VC root, customize @code{diff-add-log-use-relative-names}. @kindex C-c C-a @r{(Log Edit mode)} @findex log-edit-insert-changelog @@ -1394,18 +1398,19 @@ Apart from acting on multiple files, these commands behave much like their single-buffer counterparts (@pxref{Search}). The VC Directory buffer additionally defines some branch-related -commands starting with the prefix @kbd{B}: +commands starting with the prefix @kbd{b}: @table @kbd -@item B c -Create a new branch (@code{vc-create-tag}). +@item b c +Create a new branch (@code{vc-create-branch}). @xref{Creating +Branches}. -@item B l +@item b l Prompt for the name of a branch and display the change history of that branch (@code{vc-print-branch-log}). -@item B s -Switch to a branch (@code{vc-retrieve-tag}). @xref{Switching +@item b s +Switch to a branch (@code{vc-switch-branch}). @xref{Switching Branches}. @item d @@ -1469,7 +1474,7 @@ Mercurial, command @kbd{hg update} is used to switch to another branch. The VC command to switch to another branch in the current directory -is @kbd{C-x v r @var{branch-name} @key{RET}} (@code{vc-retrieve-tag}). +is @kbd{C-x v b s @var{branch-name} @key{RET}} (@code{vc-switch-branch}). On centralized version control systems, you can also switch between branches by typing @kbd{C-u C-x v v} in an up-to-date work file @@ -1619,8 +1624,8 @@ if the current revision is 2.5, the branch ID should be 2.5.1, 2.5.2, and so on, depending on the number of existing branches at that point. This procedure will not work for distributed version control systems -like git or Mercurial. For those systems you should use the prefix -argument to @code{vc-create-tag} (@kbd{C-u C-x v s}) instead. +like git or Mercurial. For those systems you should use the command +@code{vc-create-branch} (@kbd{C-x v b c}) instead. To create a new branch at an older revision (one that is no longer the head of a branch), first select that revision (@pxref{Switching diff --git a/doc/emacs/misc.texi b/doc/emacs/misc.texi index d8ad0bee34f..10b44028bb9 100644 --- a/doc/emacs/misc.texi +++ b/doc/emacs/misc.texi @@ -2096,7 +2096,7 @@ If there is no response within that time, @command{emacsclient} will display a warning and exit. The default is @samp{0}, which means to wait forever. -@item --parent-id @var{id} +@item --parent-id=@var{id} Open an @command{emacsclient} frame as a client frame in the parent X window with id @var{id}, via the XEmbed protocol. Currently, this option is mainly useful for developers. diff --git a/doc/lispref/help.texi b/doc/lispref/help.texi index 463039c5a0e..154a7abeb63 100644 --- a/doc/lispref/help.texi +++ b/doc/lispref/help.texi @@ -374,25 +374,6 @@ as link in the @file{*Help*} buffer. @strong{Please note:} Each @samp{\} must be doubled when written in a string in Emacs Lisp. -@defopt text-quoting-style -@cindex curved quotes -@cindex curly quotes -The value of this variable is a symbol that specifies the style Emacs -should use for single quotes in the wording of help and messages. If -the variable's value is @code{curve}, the style is @t{‘like this’} -with curved single quotes. If the value is @code{straight}, the style -is @t{'like this'} with straight apostrophes. If the value is -@code{grave}, quotes are not translated and the style is @t{`like -this'} with grave accent and apostrophe, the standard style before -Emacs version 25. The default value @code{nil} acts like @code{curve} -if curved single quotes seem to be displayable, and like @code{grave} -otherwise. - -This option is useful on platforms that have problems with curved -quotes. You can customize it freely according to your personal -preference. -@end defopt - @defun substitute-command-keys string &optional no-face include-menus @vindex help-key-binding@r{ (face)} This function scans @var{string} for the above special sequences and @@ -403,6 +384,11 @@ given a special face @code{help-key-binding}, but if the optional argument @var{no-face} is non-@code{nil}, the function doesn't add this face to the produced string. +@defun substitute-quotes string +This function works like @code{substitute-command-keys}, but only +replaces quote characters. +@end defun + @cindex advertised binding If a command has multiple bindings, this function normally uses the first one it finds. You can specify one particular key binding by @@ -505,6 +491,13 @@ quotes. You can customize it freely according to your personal preference. @end defopt +@defun text-quoting-style +You should not read the value of the variable +@code{text-quoting-style} directly. Instead, use this function with +the same name to dynamically compute the correct quoting style on the +current terminal in the @code{nil} case described above. +@end defun + @node Describing Characters @section Describing Characters for Help Messages @cindex describe characters and events diff --git a/doc/lispref/keymaps.texi b/doc/lispref/keymaps.texi index 2be31d63a62..1e4bf4eb861 100644 --- a/doc/lispref/keymaps.texi +++ b/doc/lispref/keymaps.texi @@ -2911,6 +2911,10 @@ The @code{:rtl} property specifies an alternative image to use for right-to-left languages. Only the GTK+ version of Emacs supports this at present. +Some toolkits display both an image and a text in the toolbar. If you +want to force using only the image, use a @code{:vert-only} +non-@code{nil} property. + Like the menu bar, the tool bar can display separators (@pxref{Menu Separators}). Tool bar separators are vertical rather than horizontal, though, and only a single style is supported. They are diff --git a/doc/lispref/minibuf.texi b/doc/lispref/minibuf.texi index f2adc01c8f7..089ae41f32e 100644 --- a/doc/lispref/minibuf.texi +++ b/doc/lispref/minibuf.texi @@ -490,6 +490,9 @@ If @var{default} is @code{nil}, there is no default value, and therefore no ``default value'' string is included in the result value. If @var{default} is a non-@code{nil} list, the first element of the list is used in the prompt. + +Both @var{prompt} and @code{minibuffer-default-prompt-format} are run +through @code{substitute-command-keys} (@pxref{Keys in Documentation}). @end defun @defvar read-minibuffer-restore-windows diff --git a/doc/misc/efaq.texi b/doc/misc/efaq.texi index 8ec23a529df..ccaca1d017c 100644 --- a/doc/misc/efaq.texi +++ b/doc/misc/efaq.texi @@ -3047,6 +3047,19 @@ command, separated by commas: $ fc-list :spacing=mono family | sed 's/ /\\ /g' @end example +@noindent +Note that you can fine-tune the appearance of the fonts by adding +attribute-value pairs, separated by colons, after each font name. For +example, + +@example +font-names=DejaVu\ Sans\ Mono:style=bold:antialias=false +@end example + +@noindent +selects the bold style of the DejaVu Sans Mono font, and disables +anti-aliasing. + You can now start Emacs inside @command{fbterm} with the command @example diff --git a/doc/misc/flymake.texi b/doc/misc/flymake.texi index b4e7f3a41f8..7406557623f 100644 --- a/doc/misc/flymake.texi +++ b/doc/misc/flymake.texi @@ -801,6 +801,7 @@ Binding,,, elisp, The Emacs Lisp Reference Manual}) to be active. for type = (if (string-match "^warning" msg) :warning :error) + when (and beg end) collect (flymake-make-diagnostic source beg end diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi index 738ff94b9fc..b1331e79bf4 100644 --- a/doc/misc/gnus.texi +++ b/doc/misc/gnus.texi @@ -30580,7 +30580,6 @@ Below is a slightly shortened version of the @code{nndir} back end. (defvoo nndir-get-new-mail nil nil nnml-get-new-mail nnmh-get-new-mail) (defvoo nndir-status-string "" nil nnmh-status-string) -(defconst nndir-version "nndir 1.0") ;;; @r{Interface functions.} diff --git a/doc/misc/idlwave.texi b/doc/misc/idlwave.texi index 0ba87b2e58b..4bdbd5c2196 100644 --- a/doc/misc/idlwave.texi +++ b/doc/misc/idlwave.texi @@ -4162,8 +4162,8 @@ tried to install the optional modules @file{idlw-roprompt.el} or load file}}. The problem is that your Emacs is not finding the version of IDLWAVE you -installed. Many Emacsen come with an older bundled copy of IDLWAVE -(e.g., v4.7 for Emacs 21.x), which is likely what's being used instead. +installed. Emacs might come with an older bundled copy of IDLWAVE +which is likely what's being used instead. You need to make sure your Emacs @emph{load-path} contains the directory where IDLWAVE is installed (@file{/usr/local/share/emacs/site-lisp}, by default), @emph{before} Emacs's default search directories. You can diff --git a/doc/misc/mh-e.texi b/doc/misc/mh-e.texi index 2106c674f37..6aa2cf290da 100644 --- a/doc/misc/mh-e.texi +++ b/doc/misc/mh-e.texi @@ -213,13 +213,12 @@ more niceties about GNU Emacs and MH@. Now I'm fully hooked on both of them. The MH-E package is distributed with Emacs@footnote{Version -@value{VERSION} of MH-E appeared in Emacs 24.4. -It is compatible with MH versions 6.8.4 and -higher, all versions of nmh, and GNU mailutils 1.0 and higher}, so you -shouldn't have to do anything special to use it. Gnus is also -required; version 5.10 or higher is recommended. This manual covers -MH-E version @value{VERSION}. To help you decide which version you -have, see @ref{Getting Started}. +@value{VERSION} of MH-E appeared in Emacs 24.4. It is compatible with +MH versions 6.8.4 and higher, all versions of nmh, and GNU mailutils +1.0 and higher}, so you shouldn't have to do anything special to use +it. Gnus is also required; it is bundled with Emacs. This manual +covers MH-E version @value{VERSION}. To help you decide which version +you have, see @ref{Getting Started}. @findex help-with-tutorial @kindex C-h t @@ -331,8 +330,7 @@ Press the @key{TAB} key. Press the @key{DELETE} key. @c ------------------------- @item @key{BS} -Press the @key{BACKSPACE} key@footnote{If you are using Version 20 or -earlier of Emacs, you will need to use the @key{DEL} key.}. +Press the @key{BACKSPACE} key. @end table @cindex Emacs, prefix argument @@ -1480,11 +1478,9 @@ and click on the @samp{INS} button. Enter a @samp{Spool File} of Binding} of @samp{m}. @cindex @command{emacsclient} -@cindex @command{gnuclient} @cindex @command{xbuffy} @cindex @samp{gnuserv} @cindex Unix commands, @command{emacsclient} -@cindex Unix commands, @command{gnuclient} @cindex Unix commands, @command{xbuffy} You can use @command{xbuffy} to automate the incorporation of this @@ -2712,8 +2708,7 @@ Drafts}). @cindex signed messages You can read encrypted or signed PGP or GPG messages with -MH-E@footnote{This feature depends on post-5.10 versions of Gnus. -@cite{MIME Security with OpenPGP} is documented in +MH-E@footnote{@cite{MIME Security with OpenPGP} is documented in @uref{https://www.rfc-editor.org/rfc/rfc3156.txt, RFC 3156}. However, MH-E can also decrypt old-style PGP messages that are not in MIME format.}. This section assumes that you already have a good @@ -8538,9 +8533,7 @@ If you're on a mailing list that is so voluminous that it is impossible to read every message, it usually better to read the mailing list like a newsgroup in a news reader. Emacs has a built-in newsreader called Gnus. The remainder of this appendix talks about how -to use Gnus with an MH message store. The version of Gnus that was -used to prepare this manual was 5.10. Versions 5.8 through 5.10 should -work but versions prior to 5.8 use different options. +to use Gnus with an MH message store. This table contains a list of Gnus options that you will have to modify. Note that for them to become accessible, you'll have to load @@ -8660,28 +8653,11 @@ question, file a ticket and your question will become a new FAQ! @cindex getting MH-E @cindex obtaining MH-E -Because MH-E is undergoing a phase of sustained growth, the version of -MH-E in your Emacs is likely to be out of date although it is most -likely to be more up to date than the copy that comes with the MH -distribution in @file{miscellany/mh-e}. - -@cindex change log -@cindex release notes - -New MH-E releases are always available for downloading at -@uref{https://sourceforge.net/projects/mh-e/files/, SourceForge} -before they appear in an Emacs release. You can read the release notes -on that page to determine if the given release of MH-E is already -installed in your version of Emacs. You can also read the change log -to see if you are interested in what the given release of MH-E has to -offer (although we have no doubt that you will be extremely interested -in all new releases). - -@cindex Debian - -If you use Debian, you can install the Debian -@uref{https://packages.debian.org/unstable/mail/mh-e, mh-e package} -instead. +Since MH-E 8.6 was released in 2016, its development migrated to the +Emacs repository. MH-E is now only supported in the version of Emacs +in which it appears. Old releases of MH-E are still available for +download at @uref{https://sourceforge.net/projects/mh-e/files/, +SourceForge}. @cindex files, @samp{MH-E-NEWS} @cindex files, @samp{README} diff --git a/doc/misc/reftex.texi b/doc/misc/reftex.texi index 0c95b388cb2..b30e5aeaa4d 100644 --- a/doc/misc/reftex.texi +++ b/doc/misc/reftex.texi @@ -3539,18 +3539,6 @@ as a label of type @code{?p}. Argument count for this macro starts only after the @samp{@{step+@}}, also when specifying how to get context. -@item -@b{Viper mode}@* -@cindex Viper mode -@cindex Key bindings, problems with Viper mode -@findex viper-harness-minor-mode -With @i{Viper} mode prior to Vipers version 3.01, you need to protect -@RefTeX{}'s keymaps with - -@lisp -(viper-harness-minor-mode "reftex") -@end lisp - @end itemize @page diff --git a/doc/misc/semantic.texi b/doc/misc/semantic.texi index eb5c7e0e677..25ba30d13c9 100644 --- a/doc/misc/semantic.texi +++ b/doc/misc/semantic.texi @@ -25,8 +25,7 @@ @copying This manual documents the Semantic library and utilities. -Copyright @copyright{} 1999--2005, 2007, 2009--2022 Free Software -Foundation, Inc. +Copyright @copyright{} 1999--2022 Free Software Foundation, Inc. @quotation Permission is granted to copy, distribute and/or modify this document @@ -65,13 +64,6 @@ modify this GNU manual.'' @b{\kw\} @end macro -@macro obsolete{old,new} -@sp 1 -@strong{Compatibility}: -@code{\new\} introduced in @semantic{} version 2.0 supersedes -@code{\old\} which is now obsolete. -@end macro - @c ************************************************************************* @c @ Document @c ************************************************************************* diff --git a/doc/misc/viper.texi b/doc/misc/viper.texi index 7b91f887bbf..d36019f06ac 100644 --- a/doc/misc/viper.texi +++ b/doc/misc/viper.texi @@ -325,9 +325,9 @@ lines (in the given order!): @noindent in your @file{~/.emacs} file. The @file{.emacs} file is placed in your home directory and it is be executed every time you invoke Emacs. This is -the place where all general Emacs customization takes place. Beginning with -version 20.0, Emacsen have an interactive interface, which simplifies the -job of customization significantly. +the place where all general Emacs customization takes place. Emacs +has an interactive interface (@kbd{M-x customize}), which simplifies +the job of customization significantly. Viper also uses the file @file{~/.emacs.d/viper} for Viper-specific customization. The location of Viper customization file can be changed by setting the diff --git a/etc/AUTHORS b/etc/AUTHORS index f6349df5bc2..26593958988 100644 --- a/etc/AUTHORS +++ b/etc/AUTHORS @@ -103,8 +103,8 @@ Alakazam Petrofsky: changed hanoi.el Alan Mackenzie: wrote cc-awk.el and co-wrote cc-align.el cc-cmds.el cc-defs.el cc-engine.el cc-fonts.el cc-langs.el cc-mode.el cc-styles.el cc-vars.el -and changed cc-mode.texi minibuf.c bytecomp.el edebug.el follow.el - window.c display.texi subr.el syntax.texi progmodes/compile.el +and changed cc-mode.texi minibuf.c bytecomp.el window.c edebug.el + follow.el display.texi subr.el syntax.texi progmodes/compile.el programs.texi eval.c keyboard.c lisp.h modes.texi window.el windows.texi cus-start.el font-lock.el frame.c isearch.el and 167 other files @@ -994,7 +994,8 @@ and changed calc.el replace.el update-game-score.c calc-ext.el Colin Williams: changed calc.texi -Colin Woodbury: changed files.el files.texi macros.texi shortdoc.el +Colin Woodbury: changed files.el cl-seq.el files.texi macros.texi + shortdoc.el Constantin Kulikov: changed server.el startup.el @@ -2056,10 +2057,10 @@ Gregor Schmid: changed intervals.c intervals.h tcl-mode.el textprop.c Gregory Chernov: changed nnslashdot.el -Gregory Heytings: changed isearch.el minibuffer.el mini.texi quail.el - search.texi simple.el HELLO buffers.texi diff-mode.el emake facemenu.el - files.el fringe.c help-macro.el icomplete.el keyboard.c misc-lang.el - modula2.el pcmpl-gnu.el print.c pulse.el and 4 other files +Gregory Heytings: changed isearch.el minibuffer.el efaq.texi mini.texi + quail.el search.texi simple.el HELLO buffers.texi diff-mode.el emake + facemenu.el fbterm.el files.el fringe.c help-macro.el icomplete.el + keyboard.c misc-lang.el modula2.el pcmpl-gnu.el and 6 other files Grégory Mounié: changed display.texi hi-lock.el man.el xfns.c @@ -4518,7 +4519,7 @@ Philipp Stephani: wrote callint-tests.el checkdoc-tests.el and changed emacs-module.c emacs-module-tests.el configure.ac json.c process.c eval.c internals.texi json-tests.el process-tests.el alloc.c emacs-module.h.in emacs.c lread.c nsterm.m lisp.h pdumper.c bytecomp.el - callproc.c seccomp-filter.c gtkutil.c files.el and 184 other files + callproc.c seccomp-filter.c gtkutil.c files.el and 185 other files Phillip Lord: wrote ps-print-tests.el w32-feature.el and changed build-zips.sh build-dep-zips.py lisp/Makefile.in undo.c @@ -4787,7 +4788,7 @@ Robert Pluim: wrote nsm-tests.el and changed configure.ac process.c blocks.awk network-stream-tests.el font.c processes.texi ftfont.c gtkutil.c vc-git.el process-tests.el emoji-zwj.awk gnutls.el network-stream.el nsm.el tramp.texi mml-sec.el - nsterm.m unicode xfns.c auth.texi composite.c and 138 other files + nsterm.m unicode xfns.c auth.texi composite.c and 139 other files Robert Thorpe: changed cus-start.el indent.el rmail.texi @@ -5180,8 +5181,8 @@ Stefan Kangas: wrote bookmark-tests.el cal-julian-tests.el and co-wrote help-tests.el keymap-tests.el and changed efaq.texi checkdoc.el package.el cperl-mode.el bookmark.el help.el keymap.c subr.el simple.el erc.el ediff-util.el idlwave.el - time.el bytecomp-tests.el comp.el speedbar.el bytecomp.el edebug.el - emacs-lisp-intro.texi flyspell.el ibuffer.el and 1344 other files + time.el bytecomp-tests.el comp.el emacs-lisp-intro.texi speedbar.el + bytecomp.el edebug.el flyspell.el ibuffer.el and 1348 other files Stefan Merten: co-wrote rst.el @@ -145,6 +145,11 @@ reaches the end of the script, Emacs will exit with an exit code from the value of the final form. +++ +** New function 'substitute-quotes'. +This function works like 'substitute-command-keys' but only +substitutes quote characters. + ++++ ** Emacs now supports setting 'user-emacs-directory' via '--init-directory'. +++ @@ -945,8 +950,9 @@ non-nil in 'special-mode' and its derivatives. +++ *** New commands 'split-root-window-below' and 'split-root-window-right'. -These commands split the root window in to, and are are bound to 'C-x -7' and 'C-x 9' respectively. +These commands split the root window in two, and are bound to 'C-x w 2' +and 'C-x w 3', respectively. A number of other useful window-related +commands are now available on the 'C-x w' prefix. +++ *** New user option 'display-buffer-avoid-small-windows'. @@ -1213,6 +1219,12 @@ change the input method's translation rules, customize the user option * Changes in Specialized Modes and Packages in Emacs 29.1 +** ecomplete + +--- +*** New user option 'ecomplete-auto-select'. +If non-nil and there's only one matching option, auto-select that. + ** Dired +++ @@ -1340,6 +1352,11 @@ Sets the value of the buffer-local variable 'whitespace-style' in 'diff-mode' buffers. By default, this variable is '(face trailing)', which preserves behavior from previous Emacs versions. ++++ +*** New user option 'diff-add-log-use-relative-names'. +If non-nil insert file names in ChangeLog skeletons relative to the +VC root directory. + ** Ispell --- @@ -1631,6 +1648,13 @@ info node. This command only works for the Emacs and Emacs Lisp manuals. ** VC +++ +*** 'C-x v b' prefix key is used now for branch commands. +'vc-print-branch-log' is bound to 'C-x v b l', and new commands are +'vc-create-branch' ('C-x v b c') and 'vc-switch-branch' ('C-x v b s'). +The VC Directory buffer now uses the prefix 'b' for these branch-related +commands. + ++++ *** New command '%' ('vc-dir-mark-by-regexp'). This command marks files based on a regexp. If given a prefix argument, unmark instead. @@ -2434,6 +2458,11 @@ when visiting JSON files. * Incompatible Lisp Changes in Emacs 29.1 ++++ +** 'format-prompt' now uses 'substitute-command-keys'. +This means that both the prompt and 'minibuffer-default-prompt-format' +will have key definitions and single quotes handled specially. + --- ** 'find-image' now uses 'create-image'. This means that images found through 'find-image' also have @@ -2610,55 +2639,102 @@ but switching to `ash` is generally much preferable. --- ** Some functions and variables obsolete since Emacs 24 have been removed: +'Buffer-menu-buffer+size-width', 'Electric-buffer-menu-mode', 'Info-edit-map', 'allout-abbreviate-flattened-numbering', -'allout-mode-deactivate-hook', 'ansi-color-unfontify-region', -'auth-source-forget-user-or-password', 'auth-source-hide-passwords', -'auth-source-user-or-password', 'bibtex-complete', -'bibtex-entry-field-alist', 'buffer-substring-filters', -'byte-compile-disable-print-circle', 'cfengine-mode-abbrevs', -'chart-map', 'comint-dynamic-complete', -'comint-dynamic-complete-as-filename', -'comint-dynamic-simple-complete', 'command-history-map', -'compilation-parse-errors-function', 'completion-annotate-function', -'condition-case-no-debug', 'count-lines-region', 'data-debug-map', -'deferred-action-list', 'deferred-action-function', -'dired-x-submit-report', 'eieio-defgeneric', 'eieio-defmethod', -'emacs-lock-from-exiting', 'erc-complete-word', -'eshell-cmpl-suffix-list', 'eshell-for', 'font-lock-maximum-size', +'allout-exposure-change-hook', 'allout-mode-deactivate-hook', +'allout-structure-added-hook', 'allout-structure-deleted-hook', +'allout-structure-shifted-hook', 'ansi-color-unfontify-region', +'archive-extract-hooks', 'auth-source-forget-user-or-password', +'auth-source-hide-passwords', 'auth-source-user-or-password', +'automatic-hscrolling', 'automount-dir-prefix', 'bibtex-complete', +'bibtex-entry-field-alist', 'buffer-has-markers-at', +'buffer-substring-filters', 'byte-compile-disable-print-circle', +'c-prepare-bug-report-hooks', 'cfengine-mode-abbrevs', +'change-log-acknowledgement', 'chart-map', +'checkdoc-comment-style-hooks', 'comint--unquote&expand-filename', +'comint-dynamic-complete', 'comint-dynamic-complete-as-filename', +'comint-dynamic-simple-complete', 'comint-unquote-filename', +'command-history-map', 'compilation-parse-errors-function', +'completion-annotate-function', 'condition-case-no-debug', +'count-lines-region', 'crisp-mode-modeline-string', +'custom-print-functions', 'custom-print-functions', +'cvs-string-prefix-p', 'data-debug-map', 'deferred-action-function', +'deferred-action-list', 'dired-pop-to-buffer', 'dired-shrink-to-fit', +'dired-sort-set-modeline', 'dired-x-submit-report', +'display-buffer-function', +'ediff-choose-window-setup-function-automatically', +'eieio-defgeneric', 'eieio-defmethod', 'emacs-lock-from-exiting', +'erc-complete-word', 'erc-dcc-chat-filter-hook', +'eshell-add-to-window-buffer-names', 'eshell-cmpl-suffix-list', +'eshell-for', 'eshell-remove-from-window-buffer-names', +'eshell-status-in-modeline', 'filesets-cache-fill-content-hooks', +'font-list-limit', 'font-lock-maximum-size', 'font-lock-reference-face', 'gnus-carpal', 'gnus-debug-exclude-variables', 'gnus-debug-files', 'gnus-local-domain', 'gnus-outgoing-message-group', -'gnus-secondary-servers', 'gnus-registry-user-format-function-M', +'gnus-registry-user-format-function-M', 'gnus-secondary-servers', +'gnus-subscribe-newsgroup-hooks', 'gud-inhibit-global-bindings', +'hangul-input-method-inactivate', 'hfy-post-html-hooks', 'image-extension-data', 'image-library-alist', +'inactivate-current-input-method-function', 'inactivate-input-method', 'inhibit-first-line-modes-regexps', -'inhibit-first-line-modes-suffixes', 'intdos', -'mail-complete-function', 'mail-completion-at-point-function', +'inhibit-first-line-modes-suffixes', 'input-method-inactivate-hook', +'intdos', 'javascript-generic-mode', 'javascript-generic-mode-hook', +'latex-string-prefix-p', 'macro-declaration-function' (function), +'macro-declaration-function' (variable), 'mail-complete-function', +'mail-completion-at-point-function', 'mail-mailer-swallows-blank-line', 'mail-sent-via', 'make-register', 'makefile-complete', 'menu-bar-kill-ring-save', 'meta-complete-symbol', 'meta-mode-map', +'mh-kill-folder-suppress-prompt-hooks', 'minibuffer-completing-symbol', 'minibuffer-local-filename-must-match-map', 'mode25', 'mode4350', -'msb-after-load-hooks', 'nnimap-split-rule', 'nntp-authinfo-file', -'ns-alternatives-map', 'ns-store-cut-buffer-internal', -'package-menu-view-commentary', 'pascal-last-completions', -'pascal-show-completions', 'pascal-toggle-completions', -'prolog-char-quote-workaround', 'read-filename-at-point', +'mpc-string-prefix-p', 'msb-after-load-hooks', +'nndiary-request-accept-article-hooks', +'nndiary-request-create-group-hooks', +'nndiary-request-update-info-hooks', 'nnimap-split-rule', +'nntp-authinfo-file', 'ns-alternatives-map', +'ns-store-cut-buffer-internal', 'package-menu-view-commentary', +'pascal-last-completions', 'pascal-show-completions', +'pascal-toggle-completions', 'pcomplete-arg-quote-list', +'pcomplete-quote-argument', 'prolog-char-quote-workaround', +'python-buffer, 'python-guess-indent', 'python-indent', +'python-info-ppss-comment-or-string-p', 'python-info-ppss-context', +'python-info-ppss-context-type', 'python-preoutput-result', +'python-proc', 'python-send-receive', 'python-send-string', +'python-use-skeletons', 'quail-inactivate', 'quail-inactivate-hook', +'query-replace-interactive', 'rcirc-activity-hooks', +'rcirc-print-hooks', 'rcirc-receive-message-hooks', +'rcirc-sentinel-hooks', 'read-filename-at-point', 'redraw-modeline', 'reftex-index-map', 'reftex-index-phrases-map', 'reftex-select-bib-map', 'reftex-select-label-map', 'reftex-toc-map', -'register-name-alist', 'register-value', +'register-name-alist', 'register-value', 'report-emacs-bug-info', 'report-emacs-bug-pretest-address', 'rmail-default-dont-reply-to-names', 'rmail-dont-reply-to', -'rmail-dont-reply-to-names', 'rst-block-face', 'rst-comment-face', +'rmail-dont-reply-to-names', 'robin-inactivate', +'robin-inactivate-hook', 'rst-block-face', 'rst-comment-face', 'rst-definition-face', 'rst-directive-face', 'rst-emphasis1-face', 'rst-emphasis2-face', 'rst-external-face', 'rst-literal-face', -'rst-reference-face', 'semantic-grammar-map', -'semantic-grammar-syntax-table', 'set-register-value', -'speedbar-key-map', 'speedbar-syntax-table', -'starttls-any-program-available', 'strokes-report-bug', +'rst-reference-face', 'semantic-change-hooks', +'semantic-edits-delete-change-hooks', +'semantic-edits-new-change-hooks', +'semantic-edits-reparse-change-hooks', 'semantic-grammar-map', +'semantic-grammar-syntax-table', 'semantic-lex-reset-hooks', +'semanticdb-elisp-sym-function-arglist', +'semanticdb-save-database-hooks', 'set-face-underline-p', +'set-register-value', 'sh-maybe-here-document', 'speedbar-key-map', +'speedbar-syntax-table', 'starttls-any-program-available', +'strokes-modeline-string', 'strokes-report-bug', +'term-default-bg-color', 'term-default-fg-color', +'tex-string-prefix-p', 'timeclock-modeline-display', +'timeclock-modeline-display', 'timeclock-update-modeline', 'toggle-emacs-lock', 'tooltip-use-echo-area', 'turn-on-cwarn-mode', -'turn-on-iimage-mode', 'vc-toggle-read-only', 'view-return-to-alist', +'turn-on-iimage-mode', 'ucs-input-inactivate', 'ucs-insert', +'url-recreate-url-attributes', 'user-variable-p', +'vc-string-prefix-p', 'vc-toggle-read-only', 'view-return-to-alist', 'view-return-to-alist-update', 'w32-default-color-map' (function), -'which-func-mode' (function), 'x-cut-buffer-or-selection-value'. +'which-func-mode' (function), 'window-system-version', +'winner-mode-leave-hook', 'x-cut-buffer-or-selection-value'. --- ** Some functions and variables obsolete since Emacs 23 have been removed: @@ -3621,6 +3697,8 @@ to preserve the old behavior, apply '(take N LIST)' returns the first N elements of LIST; 'ntake' does the same but works by modifying LIST destructively. +--- +** 'string-split' is now an alias for 'split-string'. * Changes in Emacs 29.1 on Non-Free Operating Systems diff --git a/etc/NEWS.28 b/etc/NEWS.28 index 01e8ac112f9..1e8bd499b68 100644 --- a/etc/NEWS.28 +++ b/etc/NEWS.28 @@ -37,17 +37,11 @@ preloaded Lisp packages, and the relative name of that directory needs therefore to be recorded in the executable as part of the build. -* Startup Changes in Emacs 28.2 - - * Changes in Emacs 28.2 This is a bug-fix release with no new features. -* Editing Changes in Emacs 28.2 - - * Changes in Specialized Modes and Packages in Emacs 28.2 ** The command 'kdb-macro-redisplay' was renamed to 'kmacro-redisplay'. @@ -66,18 +60,6 @@ terminate Emacs with 'save-buffers-kill-emacs', not with 'kill-emacs'. back then.) -* New Modes and Packages in Emacs 28.2 - - -* Incompatible Lisp Changes in Emacs 28.2 - - -* Lisp Changes in Emacs 28.2 - - -* Changes in Emacs 28.2 on Non-Free Operating Systems - - * Installation Changes in Emacs 28.1 ** Emacs now optionally supports native compilation of Lisp files. @@ -3605,6 +3587,13 @@ pairs. ** New function 'mail-header-parse-address-lax'. Parse a string as a mail address-like string. +** New function 'make-closure'. +This function is used internally by the byte-compiler: calls to it are +inserted into the generated bytecode to handle closures more +efficiently than the old code which relied on +'make-byte-code' instead. +It also makes the disassembly more readable. + ** New function 'make-separator-line'. Make a string appropriate for usage as a visual separator line. @@ -1481,8 +1481,8 @@ Markers are implemented as a non-sorted singly linked list of markers. This makes them scale badly when thousands of markers are created in a buffer for some purpose, because some low-level primitives in Emacs traverse the markers' list (e.g., when converting between character -and byte positions), and also because searching for a marker (e.g., -with 'buffer-has-markers-at') becomes very slow. +and byte positions), and also because searching for a marker becomes +very slow. **** Explore whether overlay-recenter can cure overlays performance problems @@ -1732,7 +1732,11 @@ https://lists.gnu.org/r/emacs-devel/2012-06/msg00354.html ** Maybe replace lib-src/rcs2log with a Lisp implementation It wouldn't have to be a complete replacement, just enough for vc-rcs-update-changelog. - +** Allow Emacs to use the bottom-right corner of a TTY +Emacs doesn't use the bottom-right corner of a TTY when terminfo +capability "am" (auto_right_margin) is defined. It could use the +bottom-right corner nonetheless when certain other capabilities are +defined. See bug#57607. * Other known bugs ** 'make-frame' forgets unhandled parameters, at least for X11 frames diff --git a/lib-src/emacsclient.c b/lib-src/emacsclient.c index 15acb4589a9..425db8cface 100644 --- a/lib-src/emacsclient.c +++ b/lib-src/emacsclient.c @@ -55,8 +55,6 @@ char *w32_getenv (const char *); # include <sys/socket.h> # include <sys/un.h> -# define DEFAULT_TIMEOUT (30) - # define SOCKETS_IN_FILE_SYSTEM # define INVALID_SOCKET (-1) @@ -68,6 +66,8 @@ char *w32_getenv (const char *); #endif /* !WINDOWSNT */ +#define DEFAULT_TIMEOUT (30) + #include <ctype.h> #include <errno.h> #include <getopt.h> @@ -1078,7 +1078,9 @@ set_tcp_socket (const char *local_server_file) /* The cast to 'const char *' is to avoid a compiler warning when compiling for MS-Windows sockets. */ - setsockopt (s, SOL_SOCKET, SO_LINGER, (const char *) &l_arg, sizeof l_arg); + int ret = setsockopt (s, SOL_SOCKET, SO_LINGER, (const char *) &l_arg, sizeof l_arg); + if (ret < 0) + sock_err_message ("setsockopt"); /* Send the authentication. */ auth_string[AUTH_KEY_LENGTH] = '\0'; @@ -1892,15 +1894,25 @@ start_daemon_and_retry_set_socket (void) static void set_socket_timeout (HSOCKET socket, int seconds) { + int ret; + #ifndef WINDOWSNT struct timeval timeout; timeout.tv_sec = seconds; timeout.tv_usec = 0; - setsockopt (socket, SOL_SOCKET, SO_RCVTIMEO, &timeout, sizeof timeout); + ret = setsockopt (socket, SOL_SOCKET, SO_RCVTIMEO, &timeout, sizeof timeout); #else - DWORD timeout = seconds * 1000; - setsockopt (socket, SOL_SOCKET, SO_RCVTIMEO, (char *) &timeout, sizeof timeout); + DWORD timeout; + + if (seconds > INT_MAX / 1000) + timeout = INT_MAX; + else + timeout = seconds * 1000; + ret = setsockopt (socket, SOL_SOCKET, SO_RCVTIMEO, (char *) &timeout, sizeof timeout); #endif + + if (ret < 0) + sock_err_message ("setsockopt"); } static bool @@ -2144,12 +2156,12 @@ main (int argc, char **argv) act_on_signals (emacs_socket); rl = recv (emacs_socket, string, BUFSIZ, 0); retry = check_socket_timeout (rl); - if (retry) + if (retry && !saw_response) { - if (timeout > 0 && !saw_response) + if (timeout > 0) { /* Don't retry if we were given a --timeout flag. */ - fprintf (stderr, "\nServer not responding; timed out after %lu seconds", + fprintf (stderr, "\nServer not responding; timed out after %ju seconds", timeout); retry = false; } @@ -2165,8 +2177,6 @@ main (int argc, char **argv) if (rl <= 0) break; - if (msg_showed) - fprintf (stderr, "\nGot response from server"); saw_response = true; string[rl] = '\0'; diff --git a/lisp/allout.el b/lisp/allout.el index fb922608b0d..5f7087829e2 100644 --- a/lisp/allout.el +++ b/lisp/allout.el @@ -1352,8 +1352,6 @@ their settings before `allout-mode' was started." "Symbol for use as allout invisible-text overlay category.") ;;;_ = allout-exposure-change-functions -(define-obsolete-variable-alias 'allout-exposure-change-hook - 'allout-exposure-change-functions "24.3") (defcustom allout-exposure-change-functions nil "Abnormal hook run after allout outline subtree exposure changes. It is run at the conclusion of `allout-flag-region'. @@ -1370,8 +1368,6 @@ This hook might be invoked multiple times by a single command." :version "24.3") ;;;_ = allout-structure-added-functions -(define-obsolete-variable-alias 'allout-structure-added-hook - 'allout-structure-added-functions "24.3") (defcustom allout-structure-added-functions nil "Abnormal hook run after adding items to an Allout outline. Functions on the hook should take two arguments: @@ -1385,8 +1381,6 @@ This hook might be invoked multiple times by a single command." :version "24.3") ;;;_ = allout-structure-deleted-functions -(define-obsolete-variable-alias 'allout-structure-deleted-hook - 'allout-structure-deleted-functions "24.3") (defcustom allout-structure-deleted-functions nil "Abnormal hook run after deleting subtrees from an Allout outline. Functions on the hook must take two arguments: @@ -1403,8 +1397,6 @@ This hook might be invoked multiple times by a single command." :version "24.3") ;;;_ = allout-structure-shifted-functions -(define-obsolete-variable-alias 'allout-structure-shifted-hook - 'allout-structure-shifted-functions "24.3") (defcustom allout-structure-shifted-functions nil "Abnormal hook run after shifting items in an Allout outline. Functions on the hook should take two arguments: diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el index 632ae578523..b6f7794e337 100644 --- a/lisp/arc-mode.el +++ b/lisp/arc-mode.el @@ -125,8 +125,6 @@ A non-local file is one whose file name is not proper outside Emacs. A local copy of the archive will be used when updating." :type 'regexp) -(define-obsolete-variable-alias 'archive-extract-hooks - 'archive-extract-hook "24.3") (defcustom archive-extract-hook nil "Hook run when an archive member has been extracted." :type 'hook) diff --git a/lisp/buff-menu.el b/lisp/buff-menu.el index 539ef673f0b..abf152f058c 100644 --- a/lisp/buff-menu.el +++ b/lisp/buff-menu.el @@ -54,21 +54,6 @@ :group 'Buffer-menu) (put 'Buffer-menu-buffer 'face-alias 'buffer-menu-buffer) -(defcustom Buffer-menu-buffer+size-width nil - "Combined width of buffer name and size columns in Buffer Menu. -If nil, use `Buffer-menu-name-width' and `Buffer-menu-size-width'. - -If non-nil, the value of `Buffer-menu-name-width' is overridden; -the name column is assigned width `Buffer-menu-buffer+size-width' -minus `Buffer-menu-size-width'. This use is deprecated." - :type '(choice (const nil) number) - :group 'Buffer-menu - :version "24.3") - -(make-obsolete-variable 'Buffer-menu-buffer+size-width - "use `Buffer-menu-name-width' and `Buffer-menu-size-width' instead." - "24.3") - (defun Buffer-menu--dynamic-name-width (buffers) "Return a name column width based on the current window width. The width will never exceed the actual width of the buffer names, @@ -679,9 +664,6 @@ means list those buffers and no others." (setq name-width (if (functionp Buffer-menu-name-width) (funcall Buffer-menu-name-width (mapcar #'car entries)) Buffer-menu-name-width)) - ;; Handle obsolete variable: - (if Buffer-menu-buffer+size-width - (setq name-width (- Buffer-menu-buffer+size-width size-width))) (setq tabulated-list-format (vector '("C" 1 t :pad-right 0) '("R" 1 t :pad-right 0) diff --git a/lisp/calendar/timeclock.el b/lisp/calendar/timeclock.el index 6b6cc517a20..e36119984be 100644 --- a/lisp/calendar/timeclock.el +++ b/lisp/calendar/timeclock.el @@ -137,9 +137,6 @@ This variable only has effect if set with \\[customize]." (defvar timeclock-update-timer nil "The timer used to update `timeclock-mode-string'.") -(define-obsolete-variable-alias 'timeclock-modeline-display - 'timeclock-mode-line-display "24.3") - ;; For byte-compiler. (defvar display-time-hook) (defvar timeclock-mode-line-display) @@ -259,9 +256,6 @@ The time is bracketed by <> if you are clocked in, otherwise by [].") ;;; User Functions: -(define-obsolete-function-alias 'timeclock-modeline-display - 'timeclock-mode-line-display "24.3") - ;;;###autoload (define-minor-mode timeclock-mode-line-display "Toggle display of the amount of time left today in the mode line. @@ -612,9 +606,6 @@ arguments of `completing-read'." "Ask the user for the reason they are clocking out." (completing-read "Reason for clocking out: " timeclock-reason-list)) -(define-obsolete-function-alias 'timeclock-update-modeline - 'timeclock-update-mode-line "24.3") - (defun timeclock-update-mode-line () "Update the `timeclock-mode-string' displayed in the mode line. The value of `timeclock-relative' affects the display as described in diff --git a/lisp/cedet/semantic/db-el.el b/lisp/cedet/semantic/db-el.el index 02ebde40785..f72e2069089 100644 --- a/lisp/cedet/semantic/db-el.el +++ b/lisp/cedet/semantic/db-el.el @@ -342,9 +342,6 @@ Return a list of tags." ) taglst)))) -(define-obsolete-function-alias 'semanticdb-elisp-sym-function-arglist - #'help-function-arglist "24.3") - (provide 'semantic/db-el) ;;; semantic/db-el.el ends here diff --git a/lisp/cedet/semantic/db-file.el b/lisp/cedet/semantic/db-file.el index e2c9d618ba2..0fc6806e403 100644 --- a/lisp/cedet/semantic/db-file.el +++ b/lisp/cedet/semantic/db-file.el @@ -70,8 +70,6 @@ passes a list of predicates in `semanticdb-project-predicate-functions'." :type '(repeat (choice (string :tag "Directory") (const never) (const always) (const project)))) -(define-obsolete-variable-alias 'semanticdb-save-database-hooks - 'semanticdb-save-database-functions "24.3") (defcustom semanticdb-save-database-functions nil "Abnormal hook run after a database is saved. Each function is called with one argument, the object representing diff --git a/lisp/cedet/semantic/edit.el b/lisp/cedet/semantic/edit.el index 4679500ed99..7cb6768f7e1 100644 --- a/lisp/cedet/semantic/edit.el +++ b/lisp/cedet/semantic/edit.el @@ -72,8 +72,6 @@ updated in the current buffer. For language specific hooks, make sure you define this as a local hook.") -(define-obsolete-variable-alias 'semantic-change-hooks - 'semantic-change-functions "24.3") (defvar semantic-change-functions '(semantic-edits-change-function-handle-changes) "Abnormal hook run when semantic detects a change in a buffer. @@ -91,14 +89,10 @@ If the hook returns non-nil, then declare that a reparse is needed. For language specific hooks, make sure you define this as a local hook. Not used yet; part of the next generation reparse mechanism.") -(define-obsolete-variable-alias 'semantic-edits-new-change-hooks - 'semantic-edits-new-change-functions "24.3") (defvar semantic-edits-new-change-functions nil "Abnormal hook run when a new change is found. Functions must take one argument representing an overlay on that change.") -(define-obsolete-variable-alias 'semantic-edits-delete-change-hooks - 'semantic-edits-delete-change-functions "24.3") (defvar semantic-edits-delete-change-functions nil "Abnormal hook run before a change overlay is deleted. Deleted changes occur when multiple changes are merged. @@ -110,8 +104,6 @@ Changes move when a new change overlaps an old change. The old change will be moved. Functions must take one argument representing an overlay being moved.") -(define-obsolete-variable-alias 'semantic-edits-reparse-change-hooks - 'semantic-edits-reparse-change-functions "24.3") (defvar semantic-edits-reparse-change-functions nil "Abnormal hook run after a change results in a reparse. Functions are called before the overlay is deleted, and after the diff --git a/lisp/cedet/semantic/lex.el b/lisp/cedet/semantic/lex.el index 75c4ee328d6..b3c9e96538c 100644 --- a/lisp/cedet/semantic/lex.el +++ b/lisp/cedet/semantic/lex.el @@ -718,8 +718,6 @@ This is an alist of (ANCHOR . STREAM) elements where ANCHOR is the start position of the block, and STREAM is the list of tokens in that block.") -(define-obsolete-variable-alias 'semantic-lex-reset-hooks - 'semantic-lex-reset-functions "24.3") (defvar semantic-lex-reset-functions nil "Abnormal hook used by major-modes to reset lexical analyzers. Hook functions are called with START and END values for the diff --git a/lisp/cedet/srecode/srt-mode.el b/lisp/cedet/srecode/srt-mode.el index 724a6e0a941..56b482e1001 100644 --- a/lisp/cedet/srecode/srt-mode.el +++ b/lisp/cedet/srecode/srt-mode.el @@ -260,9 +260,9 @@ we can tell font lock about them.") (when (class-abstract-p C) (throw 'skip nil)) - (princ (substitute-command-keys "`")) + (princ (substitute-quotes "`")) (princ name) - (princ (substitute-command-keys "'")) + (princ (substitute-quotes "'")) (when (slot-exists-p C 'key) (when key (princ " - Character Key: ") diff --git a/lisp/comint.el b/lisp/comint.el index 3ed04f098c7..696dac3d12b 100644 --- a/lisp/comint.el +++ b/lisp/comint.el @@ -1944,6 +1944,7 @@ Similarly for Soar, Scheme, etc." (when comint-highlight-input (add-text-properties beg end '( font-lock-face comint-highlight-input + comint--fl-inhibit-fontification t front-sticky t ))) (unless comint-use-prompt-regexp ;; Give old user input a field property of `input', to @@ -3268,8 +3269,6 @@ See `comint-word'." (defun comint--unquote-argument (str) (car (comint--unquote&requote-argument str))) -(define-obsolete-function-alias 'comint--unquote&expand-filename - #'comint--unquote-argument "24.3") (defun comint-match-partial-filename () "Return the unquoted&expanded filename at point, or nil if none is found. @@ -3290,14 +3289,6 @@ Magic characters are those in `comint-file-name-quote-list'." (setq i (1+ (match-end 0))))) filename)))) -(defun comint-unquote-filename (filename) - "Return FILENAME with quoted characters unquoted." - (declare (obsolete nil "24.3")) - (if (null comint-file-name-quote-list) - filename - (save-match-data - (replace-regexp-in-string "\\\\\\(.\\)" "\\1" filename t)))) - (defun comint--requote-argument (upos qstr) ;; See `completion-table-with-quoting'. (let ((res (comint--unquote&requote-argument qstr upos))) @@ -4021,6 +4012,315 @@ This function is intended to be included as an entry of (cons (point-marker) (match-string-no-properties 1 text))))) +;;; Input fontification and indentation through an indirect buffer +;;============================================================================ +;; +;; Modes derived from `comint-mode' can set up fontification and +;; indentation of input text with the help of an indirect buffer whose +;; major mode and font-lock settings are set accordingly. + +(defvar-local comint-indirect-setup-function nil + "Function to set up an indirect comint fontification buffer. +This function is called by `comint-indirect-buffer' with zero +arguments after making an indirect buffer. It is usually set to +a major-mode command whose font-locking and indentation are +desired for input text. In order to prevent possible mode hooks +from running, the variable `delay-mode-hooks' is set to t prior +to calling this function and `change-major-mode-hook' along with +`after-change-major-mode-hook' are bound to nil.") + +(defcustom comint-indirect-setup-hook nil + "Hook run in an indirect buffer for input fontification. +Input fontification and indentation, if enabled, is performed in +an indirect buffer, whose major mode and syntax highlighting are +set up according to `comint-indirect-setup-function'. After this +setup is done, run this hook with the indirect buffer as the +current buffer. This can be used to further customize +fontification and other behaviour of the indirect buffer." + :group 'comint + :type 'hook + :version "29.1") + +(defvar-local comint--indirect-buffer nil + "Indirect buffer used for input fontification.") + +(defvar-local comint--fl-saved-jit-lock-contextually nil) + +(define-minor-mode comint-fl-mode + "Enable input fontification in the current comint buffer. +This minor mode is useful if the current major mode derives from +`comint-mode' and if `comint-indirect-setup-function' is set. +Comint modes that support input fontification usually set this +variable buffer-locally to a major-mode command whose +font-locking is desired for input text. + +Input text is fontified through an indirect buffer created with +`comint-indirect-buffer', which see. + +This function signals an error if `comint-use-prompt-regexp' is +non-nil. Input fontification isn't compatible with this +setting." + :lighter nil + (if comint-fl-mode + (let ((success nil)) + (unwind-protect + (progn + (comint--fl-on) + (setq success t)) + (unless success + (setq comint-fl-mode nil) + (comint--fl-off)))) + (comint--fl-off))) + +(defun comint--fl-on () + "Enable input fontification in the current comint buffer." + (comint--fl-off) + + (when comint-use-prompt-regexp + (error + "Input fontification is incompatible with `comint-use-prompt-regexp'")) + + (add-function :around (local 'font-lock-fontify-region-function) + #'comint--fl-fontify-region) + ;; `before-change-functions' are only run in the current buffer and + ;; not in its indirect buffers, which means that we must manually + ;; flush ppss cache + (add-hook 'before-change-functions + #'comint--fl-ppss-flush-indirect 99 t) + + ;; Set up contextual fontification + (unless (booleanp jit-lock-contextually) + (setq comint--fl-saved-jit-lock-contextually + jit-lock-contextually) + (setq-local jit-lock-contextually t) + (when jit-lock-mode + (jit-lock-mode t)))) + +(defun comint--fl-off () + "Disable input fontification in the current comint buffer." + (remove-function (local 'font-lock-fontify-region-function) + #'comint--fl-fontify-region) + (remove-hook 'before-change-functions + #'comint--fl-ppss-flush-indirect t) + + ;; Reset contextual fontification + (when comint--fl-saved-jit-lock-contextually + (setq-local jit-lock-contextually + comint--fl-saved-jit-lock-contextually) + (setq comint--fl-saved-jit-lock-contextually nil) + (when jit-lock-mode + (jit-lock-mode t))) + + (font-lock-flush)) + +(defun comint--fl-ppss-flush-indirect (beg &rest rest) + (when-let ((buf (comint-indirect-buffer t))) + (with-current-buffer buf + (when (memq #'syntax-ppss-flush-cache before-change-functions) + (apply #'syntax-ppss-flush-cache beg rest))))) + +(defun comint--fl-fontify-region (fun beg end verbose) + "Fontify process output and user input in the current comint buffer. +First, fontify the region between BEG and END using FUN. Then +fontify only the input text in the region with the help of an +indirect buffer. VERBOSE is passed to the fontify-region +functions. Skip fontification of input regions with non-nil +`comint--fl-inhibit-fontification' text property." + (pcase (funcall fun beg end verbose) + (`(jit-lock-bounds ,beg1 . ,end1) + (setq beg beg1 end end1))) + (pcase + (let ((min (point-min)) + (max (point-max))) + (with-current-buffer (comint-indirect-buffer) + (narrow-to-region min max) + (comint--intersect-regions + nil (lambda (beg end) + (unless (get-text-property + beg 'comint--fl-inhibit-fontification) + (font-lock-fontify-region beg end verbose))) + beg end))) + (`((jit-lock-bounds ,beg1 . ,_) . (jit-lock-bounds ,_ . ,end1)) + (setq beg (min beg beg1)) + (setq end (max end end1)))) + + `(jit-lock-bounds ,beg . ,end)) + +(defun comint--intersect-regions (fun-output fun-input beg end) + "Iterate over comint output and input regions between BEG and END. +Divide the region specified by BEG and END into smaller regions +that cover either process output (its `field' property is `output') +or input (all remaining text). Interchangeably call FUN-OUTPUT +on each output region, and FUN-INPUT on each input region. + +FUN-OUTPUT and FUN-INPUT are passed two arguments, the beginning +and end of the smaller region. Before calling each function, +narrow the buffer to the surrounding process output or input. You +can also pass nil as either function to skip its corresponding +regions. + +Return a cons cell of return values of the first and last +function called, or nil, if no function was called (if BEG = END)." + (let ((beg1 beg) + (end1 (copy-marker nil t)) + (return-beg nil) (return-end nil) + (is-output (eq (get-text-property beg 'field) 'output))) + (setq end (copy-marker end t)) + + (while (< beg1 end) + (set-marker + end1 (or (if is-output + (text-property-not-all beg1 end 'field 'output) + (text-property-any beg1 end 'field 'output)) + end)) + (when-let ((fun (if is-output fun-output fun-input))) + (save-restriction + (let ((beg2 beg1) + (end2 end1)) + (when (= beg2 beg) + (setq beg2 (field-beginning beg2))) + (when (= end2 end) + (setq end2 (field-end end2))) + ;; Narrow to the whole field surrounding the region + (narrow-to-region beg2 end2)) + (setq return-end (list (funcall fun beg1 + (marker-position end1))))) + (unless return-beg + (setq return-beg return-end))) + (setq beg1 (marker-position end1)) + (setq is-output (not is-output))) + + (set-marker end nil) + (set-marker end1 nil) + (when return-beg + (cons (car return-beg) (car return-end))))) + +(defun comint-indent-input-line (fun) + "Indent current line from comint process output or input. +If point is on output, call FUN, otherwise indent the current +line in the indirect buffer created by `comint-indirect-buffer', +which see." + (if (or comint-use-prompt-regexp + (eq (get-text-property (point) 'field) 'output)) + (funcall fun) + (let ((point (point)) + (min (point-min)) + (max (point-max))) + (unwind-protect + (with-current-buffer (comint-indirect-buffer) + (narrow-to-region min max) + (goto-char point) + (narrow-to-region (field-beginning) (field-end)) + (unwind-protect (funcall indent-line-function) + (setq point (point)))) + (goto-char point))))) + +(defun comint-indent-input-region (fun start end) + "Indent comint process output and input between START and END. +Output text between START and END is indented with FUN and input +text is indented in the indirect buffer created by +`comint-indirect-buffer', which see." + (if comint-use-prompt-regexp + (funcall fun start end) + (let ((opoint (copy-marker (point))) + final-point) + (unwind-protect + (comint--intersect-regions + (lambda (start end) + (goto-char opoint) + (if (= opoint (point)) + (unwind-protect (funcall fun start end) + (setq final-point (copy-marker (point)))) + (funcall fun start end))) + (lambda (start end) + (let ((min (point-min)) + (max (point-max)) + (final-point1 nil)) + (unwind-protect + (with-current-buffer (comint-indirect-buffer) + (narrow-to-region min max) + (goto-char opoint) + (if (= opoint (point)) + (unwind-protect + (funcall indent-region-function start end) + (setq final-point1 (point))) + (funcall indent-region-function start end))) + (when final-point1 + (setq final-point (copy-marker final-point1)))))) + start end) + (if final-point + (progn + (goto-char final-point) + (set-marker final-point nil)) + (goto-char opoint)) + (set-marker opoint nil))))) + +(defun comint-indent-input-line-default () + "Indent current line from comint process output or input. +If point is on output, indent the current line according to the +default value of `indent-line-function', otherwise indent the +current line in the indirect buffer created by +`comint-indirect-buffer', which see." + (comint-indent-input-line (default-value 'indent-line-function))) + +(defun comint-indent-input-region-default (start end) + "Indent comint process output and input between START and END. +Output text between START and END is indented according to the +default value of `indent-region-function' and input text is +indented in the indirect buffer created by +`comint-indirect-buffer', which see." + (comint-indent-input-region (default-value 'indent-line-function) + start end)) + +(defun comint-indirect-buffer (&optional no-create) + "Return an indirect comint fontification buffer. +If an indirect buffer for the current buffer already exists, +return it, otherwise create it first and set it up by calling +`comint-indirect-setup-function' with zero arguments, turning on +font-lock, and running `comint-indirect-setup-hook'. This setup +happens with `delay-mode-hooks' set to t in order to prevent +possible SETUP-FUN's mode hooks from running. + +If an indirect buffer doesn't exist and NO-CREATE is non-nil, +return nil." + (or + comint--indirect-buffer + (unless no-create + (let ((setup-hook + (if (local-variable-p 'comint-indirect-setup-hook) + (list comint-indirect-setup-hook))) + (setup-fun comint-indirect-setup-function)) + + (add-hook 'change-major-mode-hook #'comint--indirect-cleanup + nil t) + + (with-current-buffer + (setq comint--indirect-buffer + (make-indirect-buffer + (current-buffer) + (generate-new-buffer-name + (concat " " (buffer-name) "-comint-indirect")))) + (setq-local delay-mode-hooks t) + (when setup-fun + (let ((change-major-mode-hook nil) + (after-change-major-mode-hook nil)) + (funcall setup-fun))) + (setq-local font-lock-dont-widen t) + (setq-local font-lock-support-mode nil) + (font-lock-mode) + (when setup-hook + (setq-local comint-indirect-setup-hook + (car setup-hook))) + (run-hooks 'comint-indirect-setup-hook)) + comint--indirect-buffer)))) + +(defun comint--indirect-cleanup () + (when comint--indirect-buffer + (kill-buffer comint--indirect-buffer) + (setq comint--indirect-buffer nil))) + + + ;;; Converting process modes to use comint mode ;;============================================================================ ;; The code in the Emacs 19 distribution has all been modified to use comint diff --git a/lisp/cus-theme.el b/lisp/cus-theme.el index 69ec837db88..90680ff68f8 100644 --- a/lisp/cus-theme.el +++ b/lisp/cus-theme.el @@ -496,7 +496,7 @@ It includes all faces in list FACES." (princ (substitute-command-keys " in `")) (help-insert-xref-button (file-name-nondirectory fn) 'help-theme-def fn) - (princ (substitute-command-keys "'"))) + (princ (substitute-quotes "'"))) (princ ".\n") (if (custom-theme-p theme) (progn diff --git a/lisp/custom.el b/lisp/custom.el index 96dfb37d862..352b5b0e160 100644 --- a/lisp/custom.el +++ b/lisp/custom.el @@ -674,8 +674,6 @@ property, or (ii) an alias for another customizable variable." "Return the standard value of VARIABLE." (eval (car (get variable 'standard-value)) t)) -(define-obsolete-function-alias 'user-variable-p 'custom-variable-p "24.3") - (defun custom-note-var-changed (variable) "Inform Custom that VARIABLE has been set (changed). VARIABLE is a symbol that names a user option. diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index 0e8062af528..f870494e93e 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -1169,6 +1169,10 @@ Return the result of `process-file' - zero for success." ;; Optional decompression. "unxz") + ;; zstandard archives + `(,(rx (or ".tar.zst" ".tzst") eos) "unzstd -c %i | tar -xf -") + `(,(rx ".zst" eos) "unzstd --rm") + '("\\.shar\\.Z\\'" "zcat * | unshar") '("\\.shar\\.g?z\\'" "gunzip -qc * | unshar") diff --git a/lisp/dired.el b/lisp/dired.el index facfb35ab45..b9e89292e25 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -508,15 +508,6 @@ This is what the do-commands look for, and what the mark-commands store.") (defvar dired-del-marker ?D "Character used to flag files for deletion.") -(defvar dired-shrink-to-fit t - ;; I see no reason ever to make this nil -- rms. - ;; (> baud-rate search-slow-speed) - "Non-nil means Dired shrinks the display buffer to fit the marked files.") -(make-obsolete-variable 'dired-shrink-to-fit - "use the Customization interface to add a new rule -to `display-buffer-alist' where condition regexp is \"^ \\*Marked Files\\*$\", -action argument symbol is `window-height' and its value is nil." "24.3") - (defvar dired-file-version-alist) ;;;###autoload @@ -2259,8 +2250,6 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST." "M-s f C-M-s" #'dired-isearch-filenames-regexp ;; misc "<remap> <read-only-mode>" #'dired-toggle-read-only - ;; `toggle-read-only' is an obsolete alias for `read-only-mode' - "<remap> <toggle-read-only>" #'dired-toggle-read-only "?" #'dired-summary "DEL" #'dired-unmark-backward "<remap> <undo>" #'dired-undo @@ -3879,28 +3868,6 @@ or \"* [3 files]\"." (format "[next %d files]" arg) (format "%c [%d files]" dired-marker-char count))))) -(defun dired-pop-to-buffer (buf) - "Pop up buffer BUF in a way suitable for Dired." - (declare (obsolete pop-to-buffer "24.3")) - (let ((split-window-preferred-function - (lambda (window) - (or (and (let ((split-height-threshold 0)) - (window-splittable-p (selected-window))) - ;; Try to split the selected window vertically if - ;; that's possible. (Bug#1806) - (split-window-below)) - ;; Otherwise, try to split WINDOW sensibly. - (split-window-sensibly window)))) - pop-up-frames) - (pop-to-buffer (get-buffer-create buf))) - ;; See Bug#12281. - (set-window-start nil (point-min)) - ;; If dired-shrink-to-fit is t, make its window fit its contents. - (when dired-shrink-to-fit - ;; Try to not delete window when we want to display less than - ;; `window-min-height' lines. - (fit-window-to-buffer (get-buffer-window buf) nil 1 nil nil t))) - (defcustom dired-no-confirm nil "A list of symbols for commands Dired should not confirm, or t. Command symbols are `byte-compile', `chgrp', `chmod', `chown', `compress', @@ -4590,9 +4557,6 @@ Possible values: (t (concat "Dired " dired-actual-switches)))))) (force-mode-line-update))) -(define-obsolete-function-alias 'dired-sort-set-modeline - #'dired-sort-set-mode-line "24.3") - (defun dired-sort-toggle-or-edit (&optional arg) "Toggle sorting by date, and refresh the Dired buffer. With a prefix argument, edit the current listing switches instead." diff --git a/lisp/disp-table.el b/lisp/disp-table.el index 53dff1e7097..f0ee3d1d780 100644 --- a/lisp/disp-table.el +++ b/lisp/disp-table.el @@ -336,7 +336,16 @@ which characters can be displayed and which cannot." first) (with-current-buffer buf (erase-buffer) - (insert "(let ((tbl standard-display-table))\n") + (insert "\ +;; This code was produced by `standard-display-by-replacement-char'. +;; Evaluate the Lisp code below to make Emacs show the standard +;; replacement character as a substitute for each undisplayable character. +;; One way to do that is with \"C-x h M-x eval-region RET\". +;; Normally you would put this code in your Emacs initialization file, +;; perhaps conditionally based on the type of terminal, so that +;; this setup happens automatically on each startup. +(let ((tbl (or standard-display-table + (setq standard-display-table (make-display-table)))))\n") (while (<= ch to) (cond ((or (char-displayable-p ch) diff --git a/lisp/ebuff-menu.el b/lisp/ebuff-menu.el index 2b1fc916d9f..809a31d4573 100644 --- a/lisp/ebuff-menu.el +++ b/lisp/ebuff-menu.el @@ -203,9 +203,6 @@ See the documentation of `electric-buffer-list' for details." (setq mode-line-buffer-identification "Electric Buffer List") (setq-local Helper-return-blurb "return to buffer editing")) -(define-obsolete-function-alias 'Electric-buffer-menu-mode - #'electric-buffer-menu-mode "24.3") - ;; generally the same as Buffer-menu-mode-map ;; (except we don't indirect to global-map) (put 'Electric-buffer-menu-undefined 'suppress-keymap t) diff --git a/lisp/ecomplete.el b/lisp/ecomplete.el index aa415a3e9e3..76438fd25a7 100644 --- a/lisp/ecomplete.el +++ b/lisp/ecomplete.el @@ -81,6 +81,11 @@ string that was matched." (function-item :tag "Sort by newness" ecomplete-newness) (function :tag "Other"))) +(defcustom ecomplete-auto-select nil + "Whether `ecomplete-display-matches' should automatically select a sole option." + :type 'boolean + :version "29.1") + ;;; Internal variables. (defvar ecomplete-database nil) @@ -159,10 +164,14 @@ string that was matched." (defun ecomplete-display-matches (type word &optional choose) "Display the top-rated elements TYPE that match WORD. If CHOOSE, allow the user to choose interactively between the -matches." +matches. + +Auto-select when `ecomplete-message-display-abbrev-auto-select' is +non-nil and there is only a single completion option available." (let* ((matches (ecomplete-get-matches type word)) + (match-list (and matches (split-string matches "\n"))) + (max-lines (and matches (- (length match-list) 2))) (line 0) - (max-lines (when matches (- (length (split-string matches "\n")) 2))) (message-log-max nil) command highlight) (if (not matches) @@ -173,25 +182,31 @@ matches." (progn (message "%s" matches) nil) - (setq highlight (ecomplete-highlight-match-line matches line)) - (let ((local-map (make-sparse-keymap)) - (prev-func (lambda () (setq line (max (1- line) 0)))) - (next-func (lambda () (setq line (min (1+ line) max-lines)))) - selected) - (define-key local-map (kbd "RET") - (lambda () (setq selected (nth line (split-string matches "\n"))))) - (define-key local-map (kbd "M-n") next-func) - (define-key local-map (kbd "<down>") next-func) - (define-key local-map (kbd "M-p") prev-func) - (define-key local-map (kbd "<up>") prev-func) - (let ((overriding-local-map local-map)) - (while (and (null selected) - (setq command (read-key-sequence highlight)) - (lookup-key local-map command)) - (apply (key-binding command) nil) - (setq highlight (ecomplete-highlight-match-line matches line)))) - (message (or selected "Abort")) - selected))))) + (if (and ecomplete-auto-select + max-lines + (zerop max-lines)) + ;; Auto-select when only one option is available. + (nth 0 match-list) + ;; Interactively choose from the filtered completions. + (let ((local-map (make-sparse-keymap)) + (prev-func (lambda () (setq line (max (1- line) 0)))) + (next-func (lambda () (setq line (min (1+ line) max-lines)))) + selected) + (define-key local-map (kbd "RET") + (lambda () (setq selected (nth line match-list)))) + (define-key local-map (kbd "M-n") next-func) + (define-key local-map (kbd "<down>") next-func) + (define-key local-map (kbd "M-p") prev-func) + (define-key local-map (kbd "<up>") prev-func) + (let ((overriding-local-map local-map)) + (setq highlight (ecomplete-highlight-match-line matches line)) + (while (and (null selected) + (setq command (read-key-sequence highlight)) + (lookup-key local-map command)) + (apply (key-binding command) nil) + (setq highlight (ecomplete-highlight-match-line matches line)))) + (message (or selected "Abort")) + selected)))))) (defun ecomplete-highlight-match-line (matches line) (with-temp-buffer diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el index 70473770d16..4ffe6f573c6 100644 --- a/lisp/emacs-lisp/backtrace.el +++ b/lisp/emacs-lisp/backtrace.el @@ -209,7 +209,6 @@ frames where the source code location is known.") "v" #'backtrace-toggle-locals "#" #'backtrace-toggle-print-circle ":" #'backtrace-toggle-print-gensym - "s" #'backtrace-goto-source "RET" #'backtrace-help-follow-symbol "+" #'backtrace-multi-line "-" #'backtrace-single-line diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 9a56ba0f7ad..9db84c31b88 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -112,44 +112,6 @@ So far, FUNCTION can only be a symbol, not a lambda expression." (function-put 'defmacro 'doc-string-elt 3) (function-put 'defmacro 'lisp-indent-function 2) -;; `macro-declaration-function' are both obsolete (as marked at the end of this -;; file) but used in many .elc files. - -;; We don't use #' here, because it's an obsolete function, and we -;; can't use `with-suppressed-warnings' here due to how this file is -;; used in the bootstrapping process. -(defvar macro-declaration-function 'macro-declaration-function - "Function to process declarations in a macro definition. -The function will be called with two args MACRO and DECL. -MACRO is the name of the macro being defined. -DECL is a list `(declare ...)' containing the declarations. -The value the function returns is not used.") - -(defalias 'macro-declaration-function - #'(lambda (macro decl) - "Process a declaration found in a macro definition. -This is set as the value of the variable `macro-declaration-function'. -MACRO is the name of the macro being defined. -DECL is a list `(declare ...)' containing the declarations. -The return value of this function is not used." - ;; We can't use `dolist' or `cadr' yet for bootstrapping reasons. - (let (d) - ;; Ignore the first element of `decl' (it's always `declare'). - (while (setq decl (cdr decl)) - (setq d (car decl)) - (if (and (consp d) - (listp (cdr d)) - (null (cdr (cdr d)))) - (cond ((eq (car d) 'indent) - (put macro 'lisp-indent-function (car (cdr d)))) - ((eq (car d) 'debug) - (put macro 'edebug-form-spec (car (cdr d)))) - ((eq (car d) 'doc-string) - (put macro 'doc-string-elt (car (cdr d)))) - (t - (message "Unknown declaration %s" d))) - (message "Invalid declaration %s" d)))))) - ;; We define macro-declaration-alist here because it is needed to ;; handle declarations in macro definitions and this is the first file ;; loaded by loadup.el that uses declarations in macros. We specify @@ -771,9 +733,4 @@ type is. This defaults to \"INFO\"." ;; (file-format emacs19))" ;; nil) -(make-obsolete-variable 'macro-declaration-function - 'macro-declarations-alist "24.3") -(make-obsolete 'macro-declaration-function - 'macro-declarations-alist "24.3") - ;;; byte-run.el ends here diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index a16486dc31c..48929e62bdf 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -3104,8 +3104,8 @@ lambda-expression." ;; Check that the bit after the `interactive' spec is ;; just a list of symbols (i.e., modes). (unless (seq-every-p #'symbolp (cdr (cdr int))) - (byte-compile-warn-x int "malformed interactive specc: %s" - int)) + (byte-compile-warn-x + int "malformed `interactive' specification: %s" int)) (setq command-modes (cdr (cdr int))) ;; If the interactive spec is a call to `list', don't ;; compile it, because `call-interactively' looks at the diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index a5ab3a50ff2..20d64b59158 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -281,8 +281,6 @@ Currently, all recognized keywords must be on `finder-known-keywords'." :version "25.1" :type 'boolean) -(define-obsolete-variable-alias 'checkdoc-style-hooks - 'checkdoc-style-functions "24.3") (defvar checkdoc-style-functions nil "Hook run after the standard style check is completed. All functions must return nil or a string representing the error found. @@ -292,8 +290,6 @@ Each hook is called with two parameters, (DEFUNINFO ENDPOINT). DEFUNINFO is the return value of `checkdoc-defun-info'. ENDPOINT is the location of end of the documentation string.") -(define-obsolete-variable-alias 'checkdoc-comment-style-hooks - 'checkdoc-comment-style-functions "24.3") (defvar checkdoc-comment-style-functions nil "Hook run after the standard comment style check is completed. Must return nil if no errors are found, or a string describing the diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 607810ee141..7c7f027d777 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -772,7 +772,7 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (help-insert-xref-button (help-fns-short-filename location) 'cl-type-definition type location 'define-type) - (insert (substitute-command-keys "'"))) + (insert (substitute-quotes "'"))) (insert ".\n") ;; Parents. @@ -782,7 +782,7 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (insert " Inherits from ") (while (setq cur (pop pl)) (setq cur (cl--class-name cur)) - (insert (substitute-command-keys "`")) + (insert (substitute-quotes "`")) (help-insert-xref-button (symbol-name cur) 'cl-help-type cur) (insert (substitute-command-keys (if pl "', " "'")))) @@ -796,7 +796,7 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (when ch (insert " Children ") (while (setq cur (pop ch)) - (insert (substitute-command-keys "`")) + (insert (substitute-quotes "`")) (help-insert-xref-button (symbol-name cur) 'cl-help-type cur) (insert (substitute-command-keys (if ch "', " "'")))) @@ -815,10 +815,10 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (when generics (insert (propertize "Specialized Methods:\n\n" 'face 'bold)) (dolist (generic generics) - (insert (substitute-command-keys "`")) + (insert (substitute-quotes "`")) (help-insert-xref-button (symbol-name generic) 'help-function generic) - (insert (substitute-command-keys "'")) + (insert (substitute-quotes "'")) (pcase-dolist (`(,qualifiers ,args ,doc) (cl--generic-method-documentation generic type)) (insert (format " %s%S\n" qualifiers args) diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index a54fa21fa96..b83b44974d3 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -90,12 +90,6 @@ (defvar cl--optimize-safety 1) ;;;###autoload -(define-obsolete-variable-alias - ;; This alias is needed for compatibility with .elc files that use defstruct - ;; and were compiled with Emacs<24.3. - 'custom-print-functions 'cl-custom-print-functions "24.3") - -;;;###autoload (defvar cl-custom-print-functions nil "This is a list of functions that format user objects for printing. Each function is called in turn with three arguments: the object, the diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 9755c2636de..f8fdc50251f 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2261,139 +2261,131 @@ This is like `cl-flet', but for macros instead of functions. (eval `(function (lambda ,@res)) t)) macroexpand-all-environment)))))) -(defun cl--sm-macroexpand (orig-fun exp &optional env) +(defun cl--sm-macroexpand (exp &optional env) + "Special macro expander used inside `cl-symbol-macrolet'." + ;; FIXME: Arguably, this should be the official definition of `macroexpand'. + (while (not (eq exp (setq exp (macroexpand-1 exp env))))) + exp) + +(defun cl--sm-macroexpand-1 (orig-fun exp &optional env) "Special macro expander advice used inside `cl-symbol-macrolet'. -This function extends `macroexpand' during macro expansion +This function extends `macroexpand-1' during macro expansion of `cl-symbol-macrolet' to additionally expand symbol macros." - (let ((macroexpand-all-environment env) + (let ((exp (funcall orig-fun exp env)) (venv (alist-get :cl-symbol-macros env))) - (while - (progn - (setq exp (funcall orig-fun exp env)) - (pcase exp - ((pred symbolp) - ;; Perform symbol-macro expansion. - (let ((symval (assq exp venv))) - (when symval - (setq exp (cadr symval))))) - (`(setq . ,args) - ;; Convert setq to setf if required by symbol-macro expansion. - (let ((convert nil) - (rargs nil)) - (while args - (let ((place (pop args))) - ;; Here, we know `place' should be a symbol. - (while - (let ((symval (assq place venv))) - (when symval - (setq place (cadr symval)) - (if (symbolp place) - t ;Repeat. - (setq convert t) - nil)))) - (push place rargs) - (push (pop args) rargs))) - (setq exp (cons (if convert 'setf 'setq) - (nreverse rargs))) - convert)) - ;; CL's symbol-macrolet used to treat re-bindings as candidates for - ;; expansion (turning the let into a letf if needed), contrary to - ;; Common-Lisp where such re-bindings hide the symbol-macro. - ;; Not sure if there actually is code out there which depends - ;; on this behavior (haven't found any yet). - ;; Such code should explicitly use `cl-letf' instead, I think. - ;; - ;; (`(,(or `let `let*) . ,(or `(,bindings . ,body) pcase--dontcare)) - ;; (let ((letf nil) (found nil) (nbs ())) - ;; (dolist (binding bindings) - ;; (let* ((var (if (symbolp binding) binding (car binding))) - ;; (sm (assq var venv))) - ;; (push (if (not (cdr sm)) - ;; binding - ;; (let ((nexp (cadr sm))) - ;; (setq found t) - ;; (unless (symbolp nexp) (setq letf t)) - ;; (cons nexp (cdr-safe binding)))) - ;; nbs))) - ;; (when found - ;; (setq exp `(,(if letf - ;; (if (eq (car exp) 'let) 'cl-letf 'cl-letf*) - ;; (car exp)) - ;; ,(nreverse nbs) - ;; ,@body))))) - ;; - ;; We implement the Common-Lisp behavior, instead (see bug#26073): - ;; The behavior of CL made sense in a dynamically scoped - ;; language, but nowadays, lexical scoping semantics is more often - ;; expected. - (`(,(or 'let 'let*) . ,(or `(,bindings . ,body) pcase--dontcare)) - (let ((nbs ()) (found nil)) - (dolist (binding bindings) - (let* ((var (if (symbolp binding) binding (car binding))) - (val (and found (consp binding) (eq 'let* (car exp)) - (list (macroexpand-all (cadr binding) - env))))) - (push (if (assq var venv) - ;; This binding should hide "its" surrounding - ;; symbol-macro, but given the way macroexpand-all - ;; works (i.e. the `env' we receive as input will - ;; be (re)applied to the code we return), we can't - ;; prevent application of `env' to the - ;; sub-expressions, so we need to α-rename this - ;; variable instead. - (let ((nvar (make-symbol (symbol-name var)))) - (setq found t) - (push (list var nvar) venv) - (push (cons :cl-symbol-macros venv) env) - (cons nvar (or val (cdr-safe binding)))) - (if val (cons var val) binding)) - nbs))) - (when found - (setq exp `(,(car exp) - ,(nreverse nbs) - ,@(macroexp-unprogn - (macroexpand-all (macroexp-progn body) - env))))) - nil)) - ;; Do the same as for `let' but for variables introduced - ;; via other means, such as `lambda' and `condition-case'. - (`(function (lambda ,args . ,body)) - (let ((nargs ()) (found nil)) - (dolist (var args) - (push (cond - ((memq var '(&optional &rest)) var) - ((assq var venv) - (let ((nvar (make-symbol (symbol-name var)))) - (setq found t) - (push (list var nvar) venv) - (push (cons :cl-symbol-macros venv) env) - nvar)) - (t var)) - nargs)) - (when found - (setq exp `(function - (lambda ,(nreverse nargs) - . ,(mapcar (lambda (exp) - (macroexpand-all exp env)) - body))))) - nil)) - ((and `(condition-case ,var ,exp . ,clauses) - (guard (assq var venv))) - (let ((nvar (make-symbol (symbol-name var)))) - (push (list var nvar) venv) - (push (cons :cl-symbol-macros venv) env) - (setq exp - `(condition-case ,nvar ,(macroexpand-all exp env) - . ,(mapcar - (lambda (clause) - `(,(car clause) - . ,(mapcar (lambda (exp) - (macroexpand-all exp env)) - (cdr clause)))) - clauses))) - nil)) - ))) - exp)) + (pcase exp + ((pred symbolp) + ;; Try symbol-macro expansion. + (let ((symval (assq exp venv))) + (if symval (cadr symval) exp))) + (`(setq . ,args) + ;; Convert setq to setf if required by symbol-macro expansion. + (let ((convert nil)) + (while args + (let* ((place (pop args)) + ;; Here, we know `place' should be a symbol. + (symval (assq place venv))) + (pop args) + (when symval + (setq convert t)))) + (if convert + (cons 'setf (cdr exp)) + exp))) + ;; CL's symbol-macrolet used to treat re-bindings as candidates for + ;; expansion (turning the let into a letf if needed), contrary to + ;; Common-Lisp where such re-bindings hide the symbol-macro. + ;; Not sure if there actually is code out there which depends + ;; on this behavior (haven't found any yet). + ;; Such code should explicitly use `cl-letf' instead, I think. + ;; + ;; (`(,(or `let `let*) . ,(or `(,bindings . ,body) pcase--dontcare)) + ;; (let ((letf nil) (found nil) (nbs ())) + ;; (dolist (binding bindings) + ;; (let* ((var (if (symbolp binding) binding (car binding))) + ;; (sm (assq var venv))) + ;; (push (if (not (cdr sm)) + ;; binding + ;; (let ((nexp (cadr sm))) + ;; (setq found t) + ;; (unless (symbolp nexp) (setq letf t)) + ;; (cons nexp (cdr-safe binding)))) + ;; nbs))) + ;; (when found + ;; (setq exp `(,(if letf + ;; (if (eq (car exp) 'let) 'cl-letf 'cl-letf*) + ;; (car exp)) + ;; ,(nreverse nbs) + ;; ,@body))))) + ;; + ;; We implement the Common-Lisp behavior, instead (see bug#26073): + ;; The behavior of CL made sense in a dynamically scoped + ;; language, but nowadays, lexical scoping semantics is more often + ;; expected. + (`(,(or 'let 'let*) . ,(or `(,bindings . ,body) pcase--dontcare)) + (let ((nbs ()) (found nil)) + (dolist (binding bindings) + (let* ((var (if (symbolp binding) binding (car binding))) + (val (and found (consp binding) (eq 'let* (car exp)) + (list (macroexpand-all (cadr binding) + env))))) + (push (if (assq var venv) + ;; This binding should hide "its" surrounding + ;; symbol-macro, but given the way macroexpand-all + ;; works (i.e. the `env' we receive as input will + ;; be (re)applied to the code we return), we can't + ;; prevent application of `env' to the + ;; sub-expressions, so we need to α-rename this + ;; variable instead. + (let ((nvar (make-symbol (symbol-name var)))) + (setq found t) + (push (list var nvar) venv) + (push (cons :cl-symbol-macros venv) env) + (cons nvar (or val (cdr-safe binding)))) + (if val (cons var val) binding)) + nbs))) + (if found + `(,(car exp) + ,(nreverse nbs) + ,@(macroexp-unprogn + (macroexpand-all (macroexp-progn body) + env))) + exp))) + ;; Do the same as for `let' but for variables introduced + ;; via other means, such as `lambda' and `condition-case'. + (`(function (lambda ,args . ,body)) + (let ((nargs ()) (found nil)) + (dolist (var args) + (push (cond + ((memq var '(&optional &rest)) var) + ((assq var venv) + (let ((nvar (make-symbol (symbol-name var)))) + (setq found t) + (push (list var nvar) venv) + (push (cons :cl-symbol-macros venv) env) + nvar)) + (t var)) + nargs)) + (if found + `(function + (lambda ,(nreverse nargs) + . ,(mapcar (lambda (exp) + (macroexpand-all exp env)) + body))) + exp))) + ((and `(condition-case ,var ,exp . ,clauses) + (guard (assq var venv))) + (let ((nvar (make-symbol (symbol-name var)))) + (push (list var nvar) venv) + (push (cons :cl-symbol-macros venv) env) + `(condition-case ,nvar ,(macroexpand-all exp env) + . ,(mapcar + (lambda (clause) + `(,(car clause) + . ,(mapcar (lambda (exp) + (macroexpand-all exp env)) + (cdr clause)))) + clauses)))) + (_ exp)))) ;;;###autoload (defmacro cl-symbol-macrolet (bindings &rest body) @@ -2412,7 +2404,8 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). (unwind-protect (progn (unless advised - (advice-add 'macroexpand :around #'cl--sm-macroexpand)) + (advice-add 'macroexpand :override #'cl--sm-macroexpand) + (advice-add 'macroexpand-1 :around #'cl--sm-macroexpand-1)) (let* ((venv (cdr (assq :cl-symbol-macros macroexpand-all-environment))) (expansion @@ -2428,7 +2421,8 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). expansion nil nil rev-malformed-bindings)) expansion))) (unless advised - (advice-remove 'macroexpand #'cl--sm-macroexpand))))) + (advice-remove 'macroexpand #'cl--sm-macroexpand) + (advice-remove 'macroexpand-1 #'cl--sm-macroexpand-1))))) ;;;###autoload (defmacro cl-with-gensyms (names &rest body) @@ -2765,8 +2759,14 @@ Each PLACE may be a symbol, or any generalized variable allowed by `setf'. (place (car binding))) (gv-letplace (getter setter) place (macroexp-let2 nil vnew (cadr binding) - (if (symbolp place) + (if (and (symbolp place) + ;; `place' could be some symbol-macro. + (eq place getter)) ;; Special-case for simple variables. + ;; FIXME: We currently only use this special case when `place' + ;; is a simple var. Should we also use it when the + ;; macroexpansion of `place' is a simple var (i.e. when + ;; getter+setter is the same as that of a simple var)? (cl--letf (cdr bindings) (cons `(,getter ,(if (cdr binding) vnew getter)) simplebinds) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 9de8999fdfd..31c05057bfa 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -3791,9 +3791,6 @@ limited by `edebug-print-length' or `edebug-print-level'." ;;; Edebug Minor Mode -(define-obsolete-variable-alias 'gud-inhibit-global-bindings - 'edebug-inhibit-emacs-lisp-mode-bindings "24.3") - (defvar edebug-inhibit-emacs-lisp-mode-bindings nil "If non-nil, inhibit Edebug bindings on the C-x C-a key. By default, loading the `edebug' library causes these bindings to @@ -4182,6 +4179,7 @@ from Edebug instrumentation found in the backtrace." (backtrace-mode) (add-hook 'backtrace-goto-source-functions #'edebug--backtrace-goto-source nil t)) + (edebug-backtrace-mode) (setq edebug-instrumented-backtrace-frames (backtrace-get-frames 'edebug-debugger :constructor #'edebug--make-frame) @@ -4258,6 +4256,14 @@ Save DEF-NAME, BEFORE-INDEX and AFTER-INDEX in FRAME." (setf (edebug--frame-before-index frame) before-index) (setf (edebug--frame-after-index frame) after-index)) +(defvar-keymap edebug-backtrace-mode-map + "s" #'backtrace-goto-source) + +(define-minor-mode edebug-backtrace-mode + "Minor mode for showing backtraces from edebug." + :lighter nil + :interactive nil) + (defun edebug--backtrace-goto-source () (let* ((index (backtrace-get-index)) (frame (nth index backtrace-frames))) @@ -4567,6 +4573,12 @@ With prefix argument, make it a temporary breakpoint." (was-macro `(macro . ,unwrapped)) (t unwrapped)))))) +(defun edebug--strip-plist (symbol) + "Remove edebug related properties from plist for SYMBOL." + (dolist (prop '( edebug edebug-behavior edebug-coverage + edebug-freq-count ghost-edebug)) + (cl-remprop symbol prop))) + (defun edebug-remove-instrumentation (functions) "Remove Edebug instrumentation from FUNCTIONS. Interactively, the user is prompted for the function to remove @@ -4598,6 +4610,7 @@ instrumentation for, defaulting to all functions." (dolist (symbol functions) (when-let ((unwrapped (edebug--unwrap*-symbol-function symbol))) + (edebug--strip-plist symbol) (defalias symbol unwrapped))) (message "Removed edebug instrumentation from %s" (mapconcat #'symbol-name functions ", "))) diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index 5f67263f177..b599aabb7f7 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -153,7 +153,7 @@ are not abstract." (help-insert-xref-button (help-fns-short-filename location) 'cl-type-definition ctr location 'define-type) - (insert (substitute-command-keys "'"))) + (insert (substitute-quotes "'"))) (insert ".\nCreates an object of class " (symbol-name ctr) ".") (goto-char (point-max)) (if (autoloadp def) diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index 4436d0a4b16..fe291290a28 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -102,6 +102,35 @@ the name of the test and the result of NAME-FORM." (indent 1)) `(ert--call-with-test-buffer ,name-form (lambda () ,@body))) +(cl-defmacro ert-with-test-buffer-selected ((&key name) + &body body) + "Create a test buffer, switch to it, and run BODY. + +This extends `ert-with-test-buffer' by displaying the test +buffer (whose name is derived from NAME) in a temporary window. +The temporary window becomes the `selected-window' before BODY is +evaluated. The modification hooks `before-change-functions' and +`after-change-functions' are not inhibited during the evaluation +of BODY, which makes it easier to use `execute-kbd-macro' to +simulate user interaction. The window configuration is restored +before returning, even if BODY exits nonlocally. The return +value is the last form in BODY." + (declare (debug ((":name" form) def-body)) + (indent 1)) + (let ((ret (make-symbol "ert--with-test-buffer-selected-ret"))) + `(save-window-excursion + (let (,ret) + (ert-with-test-buffer (:name ,name) + (with-current-buffer-window (current-buffer) + `(display-buffer-below-selected + (body-function + . ,(lambda (window) + (select-window window t) + (let ((inhibit-modification-hooks nil)) + (setq ,ret (progn ,@body)))))) + nil)) + ,ret)))) + ;;;###autoload (defun ert-kill-all-test-buffers () "Kill all test buffers that are still live." diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 24880a66a05..634178c7810 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2649,7 +2649,7 @@ Helper function for `describe-package'." "',\n shadowing a ") (propertize "built-in package" 'font-lock-face 'package-status-built-in)) - (insert (substitute-command-keys "'"))) + (insert (substitute-quotes "'"))) (if signed (insert ".") (insert " (unsigned).")) @@ -3701,30 +3701,34 @@ objects removed." `((delete . ,del) (install . ,ins) (upgrade . ,upg)))) (defun package-menu--perform-transaction (install-list delete-list) - "Install packages in INSTALL-LIST and delete DELETE-LIST." - (if install-list - (let ((status-format (format ":Installing %%d/%d" - (length install-list))) - (i 0) - (package-menu--transaction-status)) - (dolist (pkg install-list) - (setq package-menu--transaction-status - (format status-format (cl-incf i))) - (force-mode-line-update) - (redisplay 'force) - ;; Don't mark as selected, `package-menu-execute' already - ;; does that. - (package-install pkg 'dont-select)))) - (let ((package-menu--transaction-status ":Deleting")) - (force-mode-line-update) - (redisplay 'force) - (dolist (elt (package--sort-by-dependence delete-list)) - (condition-case-unless-debug err - (let ((inhibit-message (or inhibit-message package-menu-async))) - (package-delete elt nil 'nosave)) - (error (message "Error trying to delete `%s': %S" - (package-desc-full-name elt) - err)))))) + "Install packages in INSTALL-LIST and delete DELETE-LIST. +Return nil if there were no errors; non-nil otherwise." + (let ((errors nil)) + (if install-list + (let ((status-format (format ":Installing %%d/%d" + (length install-list))) + (i 0) + (package-menu--transaction-status)) + (dolist (pkg install-list) + (setq package-menu--transaction-status + (format status-format (cl-incf i))) + (force-mode-line-update) + (redisplay 'force) + ;; Don't mark as selected, `package-menu-execute' already + ;; does that. + (package-install pkg 'dont-select)))) + (let ((package-menu--transaction-status ":Deleting")) + (force-mode-line-update) + (redisplay 'force) + (dolist (elt (package--sort-by-dependence delete-list)) + (condition-case-unless-debug err + (let ((inhibit-message (or inhibit-message package-menu-async))) + (package-delete elt nil 'nosave)) + (error + (push (package-desc-full-name elt) errors) + (message "Error trying to delete `%s': %S" + (package-desc-full-name elt) err))))) + errors)) (defun package--update-selected-packages (add remove) "Update the `package-selected-packages' list according to ADD and REMOVE. @@ -3797,8 +3801,8 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." (message "Operation %s started" message-template) ;; Packages being upgraded are not marked as selected. (package--update-selected-packages .install .delete) - (package-menu--perform-transaction install-list delete-list) - (when package-selected-packages + (unless (package-menu--perform-transaction install-list delete-list) + ;; If there weren't errors, output data. (if-let* ((removable (package--removable-packages))) (message "Operation finished. Packages that are no longer needed: %d. Type `%s' to remove them" (length removable) diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el index dd70bfb7b70..90a10766c4c 100644 --- a/lisp/erc/erc-dcc.el +++ b/lisp/erc/erc-dcc.el @@ -1108,9 +1108,6 @@ Possible values are: ask, auto, ignore." (pcomplete-here '("auto" "ask" "ignore"))) (defalias 'pcomplete/erc-mode/SREQ #'pcomplete/erc-mode/CREQ) -(define-obsolete-variable-alias 'erc-dcc-chat-filter-hook - 'erc-dcc-chat-filter-functions "24.3") - (defvar erc-dcc-chat-filter-functions '(erc-dcc-chat-parse-output) "Abnormal hook run after parsing (and maybe inserting) a DCC message. Each function is called with two arguments: the ERC process and diff --git a/lisp/eshell/esh-mode.el b/lisp/eshell/esh-mode.el index ecbcf88b973..69069183a3f 100644 --- a/lisp/eshell/esh-mode.el +++ b/lisp/eshell/esh-mode.el @@ -175,9 +175,6 @@ This is used by `eshell-watch-for-password-prompt'." "A function called from beginning of line to skip the prompt." :type '(choice (const nil) function)) -(define-obsolete-variable-alias 'eshell-status-in-modeline - 'eshell-status-in-mode-line "24.3") - (defcustom eshell-status-in-mode-line t "If non-nil, let the user know a command is running in the mode line." :type 'boolean) diff --git a/lisp/eshell/eshell.el b/lisp/eshell/eshell.el index 2c472a2afad..e0c927cad41 100644 --- a/lisp/eshell/eshell.el +++ b/lisp/eshell/eshell.el @@ -194,17 +194,6 @@ shells such as bash, zsh, rc, 4dos." ;; The following user options modify the behavior of Eshell overall. (defvar eshell-buffer-name) -(defun eshell-add-to-window-buffer-names () - "Add `eshell-buffer-name' to `same-window-buffer-names'." - (declare (obsolete nil "24.3")) - (add-to-list 'same-window-buffer-names eshell-buffer-name)) - -(defun eshell-remove-from-window-buffer-names () - "Remove `eshell-buffer-name' from `same-window-buffer-names'." - (declare (obsolete nil "24.3")) - (setq same-window-buffer-names - (delete eshell-buffer-name same-window-buffer-names))) - (defcustom eshell-load-hook nil "A hook run once Eshell has been loaded." :type 'hook diff --git a/lisp/faces.el b/lisp/faces.el index f1d8f82fec5..e171b32e317 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -1001,9 +1001,6 @@ Use `set-face-attribute' to \"unspecify\" underlining." (interactive (read-face-and-attribute :underline)) (set-face-attribute face frame :underline underline)) -(define-obsolete-function-alias 'set-face-underline-p - 'set-face-underline "24.3") - (defun set-face-inverse-video (face inverse-video-p &optional frame) "Specify whether face FACE is in inverse video. @@ -3174,12 +3171,6 @@ also the same size as FACE on FRAME, or fail." (car fonts)) (frame-parameter nil 'font))) -(defcustom font-list-limit 100 - "This variable is obsolete and has no effect." - :type 'integer - :group 'display) -(make-obsolete-variable 'font-list-limit nil "24.3") - (define-obsolete-function-alias 'face-background-pixmap #'face-stipple "29.1") (define-obsolete-function-alias 'set-face-background-pixmap #'set-face-stipple "29.1") diff --git a/lisp/ffap.el b/lisp/ffap.el index 88b4bce9fd1..7ea05dccbdd 100644 --- a/lisp/ffap.el +++ b/lisp/ffap.el @@ -1623,9 +1623,9 @@ and `ffap-url-at-point'." ((or (not ffap-newfile-prompt) (file-exists-p filename) (y-or-n-p "File does not exist, create buffer? ")) - (find-file - ;; expand-file-name fixes "~/~/.emacs" bug - (expand-file-name filename))) + (funcall ffap-file-finder + ;; expand-file-name fixes "~/~/.emacs" bug + (expand-file-name filename))) ;; User does not want to find a non-existent file: ((signal 'file-missing (list "Opening file buffer" "No such file or directory" diff --git a/lisp/files.el b/lisp/files.el index b084dca8b7d..540bc2a6a85 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -2079,12 +2079,6 @@ this function prepends a \"|\" to the final result if necessary." (uniquify--create-file-buffer-advice buf filename) buf)) -(defcustom automount-dir-prefix (purecopy "^/tmp_mnt/") - "Regexp to match the automounter prefix in a directory name." - :group 'files - :type 'regexp) -(make-obsolete-variable 'automount-dir-prefix 'directory-abbrev-alist "24.3") - (defvar abbreviated-home-dir nil "Regexp matching the user's homedir at the beginning of file name. The value includes abbreviation according to `directory-abbrev-alist'.") @@ -2092,8 +2086,7 @@ The value includes abbreviation according to `directory-abbrev-alist'.") (defun abbreviate-file-name (filename) "Return a version of FILENAME shortened using `directory-abbrev-alist'. This also substitutes \"~\" for the user's home directory (unless the -home directory is a root directory) and removes automounter prefixes -\(see the variable `automount-dir-prefix'). +home directory is a root directory). When this function is first called, it caches the user's home directory as a regexp in `abbreviated-home-dir', and reuses it @@ -2104,11 +2097,6 @@ started Emacs, set `abbreviated-home-dir' to nil so it will be recalculated)." (save-match-data ;FIXME: Why? (if-let ((handler (find-file-name-handler filename 'abbreviate-file-name))) (funcall handler 'abbreviate-file-name filename) - (if (and automount-dir-prefix - (string-match automount-dir-prefix filename) - (file-exists-p (file-name-directory - (substring filename (1- (match-end 0)))))) - (setq filename (substring filename (1- (match-end 0))))) ;; Avoid treating /home/foo as /home/Foo during `~' substitution. (let ((case-fold-search (file-name-case-insensitive-p filename))) ;; If any elt of directory-abbrev-alist matches this name, @@ -6100,14 +6088,6 @@ prints a message in the minibuffer. Instead, use `set-buffer-modified-p'." "Modification-flag cleared")) (set-buffer-modified-p arg)) -(defun toggle-read-only (&optional arg interactive) - "Change whether this buffer is read-only." - (declare (obsolete read-only-mode "24.3")) - (interactive (list current-prefix-arg t)) - (if interactive - (call-interactively 'read-only-mode) - (read-only-mode (or arg 'toggle)))) - (defun insert-file (filename) "Insert contents of file FILENAME into buffer after point. Set mark after the inserted text. diff --git a/lisp/filesets.el b/lisp/filesets.el index 4831bf167dd..aeebd907c35 100644 --- a/lisp/filesets.el +++ b/lisp/filesets.el @@ -358,8 +358,6 @@ Don't forget to check out `filesets-menu-ensure-use-cached'." :value filesets-be-docile-flag) (sexp :tag "Other" :value nil)))) -(define-obsolete-variable-alias 'filesets-cache-fill-content-hooks - 'filesets-cache-fill-content-hook "24.3") (defcustom filesets-cache-fill-content-hook nil "Hook run when writing the contents of filesets' cache file. diff --git a/lisp/find-lisp.el b/lisp/find-lisp.el index e825d9cba04..62b4ef625db 100644 --- a/lisp/find-lisp.el +++ b/lisp/find-lisp.el @@ -166,7 +166,8 @@ It is a function which takes two arguments, the directory and its parent." ;;;###autoload (defun find-lisp-find-dired (dir regexp) - "Find files in DIR, matching REGEXP." + "Find the files within DIR whose names match REGEXP. +A Dired buffer with the results will be opened." (interactive "DFind files in directory: \nsMatching regexp: ") (let ((find-lisp-regexp regexp)) (find-lisp-find-dired-internal @@ -175,34 +176,54 @@ It is a function which takes two arguments, the directory and its parent." 'find-lisp-default-directory-predicate "*Find Lisp Dired*"))) +(defun find-lisp-find-dired-other-window (dir regexp) + "Same as `find-lisp-find-dired', but use another window." + (interactive "DFind files in directory: \nsMatching regexp: ") + (let ((find-lisp-regexp regexp)) + (find-lisp-find-dired-internal + dir + 'find-lisp-default-file-predicate + 'find-lisp-default-directory-predicate + "*Find Lisp Dired*" + 'OTHER-WINDOW))) + ;; Just the subdirectories ;;;###autoload (defun find-lisp-find-dired-subdirectories (dir) "Find all subdirectories of DIR." - (interactive "DFind subdirectories of directory: ") + (interactive "DFind dired subdirectories of directory: ") (find-lisp-find-dired-internal dir 'find-lisp-file-predicate-is-directory 'find-lisp-default-directory-predicate "*Find Lisp Dired Subdirectories*")) +;;;###autoload +(defun find-lisp-find-dired-subdirs-other-window (dir) + "Same as `find-lisp-find-dired-subdirectories', but use another window." + (interactive "DDired descendent dirs of directory: ") + (find-lisp-find-dired-internal dir + 'find-lisp-file-predicate-is-directory + 'find-lisp-default-directory-predicate + "*Find Lisp Dired Subdirectories*" + 'OTHER-WINDOW)) + ;; Most of this is lifted from find-dired.el ;; (defun find-lisp-find-dired-internal (dir file-predicate - directory-predicate buffer-name) + directory-predicate buffer-name + &optional other-window) "Run find (Lisp version) and go into Dired mode on a buffer of the output." - (let ((dired-buffers dired-buffers) - (regexp find-lisp-regexp)) - ;; Expand DIR ("" means default-directory), and make sure it has a - ;; trailing slash. + (let ((dired-buffers dired-buffers) + (regexp find-lisp-regexp)) + ;; Expand DIR ("" means `default-directory'), ensuring a trailing slash. (setq dir (file-name-as-directory (expand-file-name dir))) ;; Check that it's really a directory. (or (file-directory-p dir) (error "find-dired needs a directory: %s" dir)) - (or - (and (buffer-name) - (string= buffer-name (buffer-name))) - (switch-to-buffer (get-buffer-create buffer-name))) + (unless (and (buffer-name) (string= buffer-name (buffer-name))) + (let ((buf (get-buffer-create buffer-name))) + (if other-window (pop-to-buffer buf) (switch-to-buffer buf)))) (widen) (kill-all-local-variables) (setq buffer-read-only nil) @@ -278,10 +299,19 @@ It is a function which takes two arguments, the directory and its parent." (revert-buffer)) (defun find-lisp-find-dired-insert-file (file buffer) + "Insert line for FILE in BUFFER. +FILE is a file or a directory name. + +This function heeds `dired-actual-switches'." (set-buffer buffer) (insert find-lisp-line-indent - (find-lisp-format file (file-attributes file 'string) (list "") - nil))) + (find-lisp-format + (propertize file 'dired-filename t) + (file-attributes file 'string) + (or (and dired-actual-switches + (split-string-and-unquote dired-actual-switches)) + (list "")) + nil))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Lifted from ls-lisp. We don't want to require it, because that @@ -289,15 +319,14 @@ It is a function which takes two arguments, the directory and its parent." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun find-lisp-format (file-name file-attr switches now) - "Format one line of long ls output for file FILE-NAME. + "Format one line of long `ls' output for file or directory FILE-NAME. FILE-ATTR and FILE-SIZE give the file's attributes and size. SWITCHES and TIME-INDEX give the full switch list and time data." (let ((file-type (file-attribute-type file-attr))) - (concat (if (memq ?i switches) ; inode number - (format "%6d " (file-attribute-inode-number file-attr))) - ;; nil is treated like "" in concat - (if (memq ?s switches) ; size in K - (format "%4d " (1+ (/ (file-attribute-size file-attr) 1024)))) + (concat (and (memq ?i switches) ; inode number + (format "%6d " (file-attribute-inode-number file-attr))) + (and (memq ?s switches) ; size in K + (format "%4d " (1+ (/ (file-attribute-size file-attr) 1024)))) (file-attribute-modes file-attr) (format " %3d %-8s %-8s %8d " (file-attribute-link-number file-attr) @@ -309,14 +338,14 @@ SWITCHES and TIME-INDEX give the full switch list and time data." (if (numberp (file-attribute-group-id file-attr)) (int-to-string (file-attribute-group-id file-attr)) (file-attribute-group-id file-attr))) - (file-attribute-size file-attr) - ) + (file-attribute-size file-attr)) (find-lisp-format-time file-attr switches now) " " file-name - (if (stringp file-type) ; is a symbolic link - (concat " -> " file-type) - "") + (and (eq t file-type) (memq ?F switches) + "/") ; Add `/' for dir if `F' switch + (and (stringp file-type) + (concat " -> " file-type)) ; Add " -> " for symbolic link "\n"))) (defun find-lisp-time-index (switches) diff --git a/lisp/frame.el b/lisp/frame.el index 9476cb0ec46..ae8449d0ea8 100644 --- a/lisp/frame.el +++ b/lisp/frame.el @@ -3048,16 +3048,8 @@ See also `toggle-frame-maximized'." ;; Misc. -;; Only marked as obsolete in 24.3. -(define-obsolete-variable-alias 'automatic-hscrolling - 'auto-hscroll-mode "22.1") - (make-variable-buffer-local 'show-trailing-whitespace) -;; Defined in dispnew.c. -(make-obsolete-variable - 'window-system-version "it does not give useful information." "24.3") - (defun set-frame-property--interactive (prompt number) "Get a value for `set-frame-width' or `set-frame-height', prompting with PROMPT. Offer NUMBER as default value, if it is a natural number." diff --git a/lisp/generic-x.el b/lisp/generic-x.el index 2c9d1b316e1..bbc90493afe 100644 --- a/lisp/generic-x.el +++ b/lisp/generic-x.el @@ -193,7 +193,6 @@ This hook will be installed if the variable hosts-generic-mode java-manifest-generic-mode java-properties-generic-mode - javascript-generic-mode show-tabs-generic-mode vrml-generic-mode) "List of generic modes that are defined by default.") @@ -489,12 +488,6 @@ like an INI file. You can add this hook to `find-file-hook'." nil "Generic mode for Sys V pkginfo files.")) -;; Javascript mode -;; Obsolete; defer to js-mode from js.el. -(when (memq 'javascript-generic-mode generic-extras-enable-list) - (define-obsolete-function-alias 'javascript-generic-mode 'js-mode "24.3") - (define-obsolete-variable-alias 'javascript-generic-mode-hook 'js-mode-hook "24.3")) - ;; VRML files (when (memq 'vrml-generic-mode generic-extras-enable-list) diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el index 9bd9f2155f7..0e38fc0680f 100644 --- a/lisp/gnus/gnus-cloud.el +++ b/lisp/gnus/gnus-cloud.el @@ -84,6 +84,7 @@ easy interactive way to set this from the Server buffer." (defun gnus-cloud-make-chunk (elems) (with-temp-buffer + (set-buffer-multibyte nil) (insert (format "Gnus-Cloud-Version %s\n" gnus-cloud-version)) (insert (gnus-cloud-insert-data elems)) (buffer-string))) diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index 7700e6bd430..8d9e50059fd 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -294,8 +294,6 @@ claim them." function (repeat function))) -(define-obsolete-variable-alias 'gnus-subscribe-newsgroup-hooks - 'gnus-subscribe-newsgroup-functions "24.3") (defcustom gnus-subscribe-newsgroup-functions nil "Hooks run after you subscribe to a new group. The hooks will be called with new group's name as argument." diff --git a/lisp/gnus/nndiary.el b/lisp/gnus/nndiary.el index 27204b3618a..ab9c6dd74f9 100644 --- a/lisp/gnus/nndiary.el +++ b/lisp/gnus/nndiary.el @@ -165,22 +165,16 @@ In order to make this clear, here are some examples: :type 'boolean) -(define-obsolete-variable-alias 'nndiary-request-create-group-hooks - 'nndiary-request-create-group-functions "24.3") (defcustom nndiary-request-create-group-functions nil "Hook run after `nndiary-request-create-group' is executed. The hook functions will be called with the full group name as argument." :type 'hook) -(define-obsolete-variable-alias 'nndiary-request-update-info-hooks - 'nndiary-request-update-info-functions "24.3") (defcustom nndiary-request-update-info-functions nil "Hook run after `nndiary-request-update-info' is executed. The hook functions will be called with the full group name as argument." :type 'hook) -(define-obsolete-variable-alias 'nndiary-request-accept-article-hooks - 'nndiary-request-accept-article-functions "24.3") (defcustom nndiary-request-accept-article-functions nil "Hook run before accepting an article. Executed near the beginning of `nndiary-request-accept-article'. diff --git a/lisp/help-fns.el b/lisp/help-fns.el index dac4a03cd94..d5b576de285 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -712,13 +712,13 @@ the C sources, too." (get function 'derived-mode-parent)))) (when parent-mode - (insert (substitute-command-keys " Parent mode: `")) + (insert (substitute-quotes " Parent mode: `")) (let ((beg (point))) (insert (format "%s" parent-mode)) (make-text-button beg (point) 'type 'help-function 'help-args (list parent-mode))) - (insert (substitute-command-keys "'.\n"))))) + (insert (substitute-quotes "'.\n"))))) (defun help-fns--obsolete (function) ;; Ignore lambda constructs, keyboard macros, etc. @@ -1559,7 +1559,7 @@ This cancels value editing without updating the value." (princ " This variable may be risky if used as a \ file-local variable.\n") (when (assq variable safe-local-variable-values) - (princ (substitute-command-keys + (princ (substitute-quotes " However, you have added it to \ `safe-local-variable-values'.\n"))))) @@ -1609,8 +1609,8 @@ variable.\n"))) (insert-text-button file 'type 'help-dir-local-var-def 'help-args (list variable file))) - (princ (substitute-command-keys "'.\n")))) - (princ (substitute-command-keys + (princ (substitute-quotes "'.\n")))) + (princ (substitute-quotes " This variable's value is file-local.\n"))))))) (add-hook 'help-fns-describe-variable-functions #'help-fns--var-watchpoints) @@ -1690,10 +1690,10 @@ variable.\n"))) ((not permanent-local)) ((bufferp locus) (princ - (substitute-command-keys + (substitute-quotes " This variable's buffer-local value is permanent.\n"))) (t - (princ (substitute-command-keys + (princ (substitute-quotes " This variable's value is permanent \ if it is given a local binding.\n")))))) @@ -1770,9 +1770,9 @@ If FRAME is omitted or nil, use the selected frame." (setq help-mode--current-data (list :symbol f)) (setq help-mode--current-data (list :symbol f :file file-name)) - (princ (substitute-command-keys "Defined in `")) + (princ (substitute-quotes "Defined in `")) (princ (help-fns-short-filename file-name)) - (princ (substitute-command-keys "'")) + (princ (substitute-quotes "'")) ;; Make a hyperlink to the library. (save-excursion (re-search-backward diff --git a/lisp/help.el b/lisp/help.el index 15ab3192ad7..92b87cf7999 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -1260,9 +1260,9 @@ Otherwise, return a new string." (cond ((null this-keymap) (insert "\nUses keymap " - (substitute-command-keys "`") + (substitute-quotes "`") (symbol-name name) - (substitute-command-keys "'") + (substitute-quotes "'") ", which is not currently defined.\n") (unless generate-summary (setq keymap nil))) @@ -1291,6 +1291,18 @@ Otherwise, return a new string." (t (forward-char 1))))) (buffer-string))))) +(defun substitute-quotes (string) + "Substitute quote characters for display. +Each grave accent \\=` is replaced by left quote, and each +apostrophe \\=' is replaced by right quote. Left and right quote +characters are specified by `text-quoting-style'." + (cond ((eq (text-quoting-style) 'curve) + (string-replace "`" "‘" + (string-replace "'" "’" string))) + ((eq (text-quoting-style) 'straight) + (string-replace "`" "'" string)) + (t string))) + (defvar help--keymaps-seen nil) (defun describe-map-tree (startmap &optional partial shadow prefix title no-menu transl always-title mention-shadow diff --git a/lisp/htmlfontify.el b/lisp/htmlfontify.el index bf7446f151a..b1fdbd2c4a3 100644 --- a/lisp/htmlfontify.el +++ b/lisp/htmlfontify.el @@ -226,7 +226,6 @@ to make them safe." :tag "html-quote-regex" :type '(regexp)) -(define-obsolete-variable-alias 'hfy-post-html-hooks 'hfy-post-html-hook "24.3") (defcustom hfy-post-html-hook nil "List of functions to call after creating and filling the HTML buffer. These functions will be called with the HTML buffer as the current buffer." diff --git a/lisp/icomplete.el b/lisp/icomplete.el index b1fcf9ae712..19afdaa278e 100644 --- a/lisp/icomplete.el +++ b/lisp/icomplete.el @@ -1,7 +1,6 @@ ;;; icomplete.el --- minibuffer completion incremental feedback -*- lexical-binding: t -*- -;; Copyright (C) 1992-1994, 1997, 1999, 2001-2022 Free Software -;; Foundation, Inc. +;; Copyright (C) 1992-2022 Free Software Foundation, Inc. ;; Author: Ken Manheimer <ken dot manheimer at gmail...> ;; Created: Mar 1993 Ken Manheimer, klm@nist.gov - first release to usenet @@ -173,15 +172,13 @@ Used to implement the option `icomplete-show-matches-on-no-input'.") (let ((non-essential t)) ;E.g. don't prompt for password! (icomplete-exhibit))) -(defvar icomplete-minibuffer-map - (let ((map (make-sparse-keymap))) - (define-key map [?\M-\t] #'icomplete-force-complete) - (define-key map [remap minibuffer-complete-and-exit] #'icomplete-ret) - (define-key map [?\C-j] #'icomplete-force-complete-and-exit) - (define-key map [?\C-.] #'icomplete-forward-completions) - (define-key map [?\C-,] #'icomplete-backward-completions) - map) - "Keymap used by `icomplete-mode' in the minibuffer.") +(defvar-keymap icomplete-minibuffer-map + :doc "Keymap used by `icomplete-mode' in the minibuffer." + "C-M-i" #'icomplete-force-complete + "C-j" #'icomplete-force-complete-and-exit + "C-." #'icomplete-forward-completions + "C-," #'icomplete-backward-completions + "<remap> <minibuffer-complete-and-exit>" #'icomplete-ret) (defun icomplete-ret () "Exit minibuffer for icomplete." @@ -393,22 +390,20 @@ if that doesn't produce a completion match." (delete-region (1+ (point)) (point-max))))) (t (call-interactively 'backward-delete-char)))) -(defvar icomplete-fido-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-k") #'icomplete-fido-kill) - (define-key map (kbd "C-d") #'icomplete-fido-delete-char) - (define-key map (kbd "RET") #'icomplete-fido-ret) - (define-key map (kbd "C-m") #'icomplete-fido-ret) - (define-key map (kbd "DEL") #'icomplete-fido-backward-updir) - (define-key map (kbd "M-j") #'icomplete-fido-exit) - (define-key map (kbd "C-s") #'icomplete-forward-completions) - (define-key map (kbd "C-r") #'icomplete-backward-completions) - (define-key map (kbd "<right>") #'icomplete-forward-completions) - (define-key map (kbd "<left>") #'icomplete-backward-completions) - (define-key map (kbd "C-.") #'icomplete-forward-completions) - (define-key map (kbd "C-,") #'icomplete-backward-completions) - map) - "Keymap used by `fido-mode' in the minibuffer.") +(defvar-keymap icomplete-fido-mode-map + :doc "Keymap used by `fido-mode' in the minibuffer." + "C-k" #'icomplete-fido-kill + "C-d" #'icomplete-fido-delete-char + "RET" #'icomplete-fido-ret + "C-m" #'icomplete-fido-ret + "DEL" #'icomplete-fido-backward-updir + "M-j" #'icomplete-fido-exit + "C-s" #'icomplete-forward-completions + "C-r" #'icomplete-backward-completions + "<right>" #'icomplete-forward-completions + "<left>" #'icomplete-backward-completions + "C-." #'icomplete-forward-completions + "C-," #'icomplete-backward-completions) (defun icomplete--fido-mode-setup () "Setup `fido-mode''s minibuffer." @@ -634,16 +629,14 @@ Usually run by inclusion in `minibuffer-setup-hook'." (completion--cache-all-sorted-completions beg end (cons comp all)))) finally return all))) -(defvar icomplete-vertical-mode-minibuffer-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-n") #'icomplete-forward-completions) - (define-key map (kbd "C-p") #'icomplete-backward-completions) - (define-key map (kbd "<down>") #'icomplete-forward-completions) - (define-key map (kbd "<up>") #'icomplete-backward-completions) - (define-key map (kbd "M-<") #'icomplete-vertical-goto-first) - (define-key map (kbd "M->") #'icomplete-vertical-goto-last) - map) - "Keymap used by `icomplete-vertical-mode' in the minibuffer.") +(defvar-keymap icomplete-vertical-mode-minibuffer-map + :doc "Keymap used by `icomplete-vertical-mode' in the minibuffer." + "C-n" #'icomplete-forward-completions + "C-p" #'icomplete-backward-completions + "<down>" #'icomplete-forward-completions + "<up>" #'icomplete-backward-completions + "M-<" #'icomplete-vertical-goto-first + "M->" #'icomplete-vertical-goto-last) (defun icomplete--vertical-minibuffer-setup () "Setup the minibuffer for vertical display of completion candidates." diff --git a/lisp/ido.el b/lisp/ido.el index 520513b1d29..1d0082da97c 100644 --- a/lisp/ido.el +++ b/lisp/ido.el @@ -1507,15 +1507,18 @@ Removes badly formatted data and ignored directories." (add-hook 'minibuffer-setup-hook #'ido-minibuffer-setup) (add-hook 'choose-completion-string-functions #'ido-choose-completion-string)) +(defun ido--ffap-find-file (file) + (find-file file)) + (define-minor-mode ido-everywhere "Toggle use of Ido for all buffer/file reading." :global t (remove-function read-file-name-function #'ido-read-file-name) (remove-function read-buffer-function #'ido-read-buffer) (when (boundp 'ffap-file-finder) - (remove-function ffap-file-finder #'ido-find-file) + (remove-function ffap-file-finder #'ido--ffap-find-file) (when ido-mode - (add-function :override ffap-file-finder #'ido-find-file))) + (add-function :override ffap-file-finder #'ido--ffap-find-file))) (when ido-everywhere (if (not ido-mode) (ido-mode 'both) diff --git a/lisp/ielm.el b/lisp/ielm.el index 47c17921181..4a10c002976 100644 --- a/lisp/ielm.el +++ b/lisp/ielm.el @@ -472,6 +472,34 @@ nonempty, then flushes the buffer." ;; Set the process mark in the current buffer to POS. (set-marker (process-mark (get-buffer-process (current-buffer))) pos)) +;;; Input fontification + +(defcustom ielm-comint-fl-enable t + "Enable fontification of input in ielm buffers. +This variable only has effect when creating an ielm buffer. Use +the command `comint-fl-mode' to toggle fontification of input in +an already existing ielm buffer." + :type 'boolean + :safe 'booleanp + :version "29.1") + +(defcustom ielm-indirect-setup-hook nil + "Hook run in an indirect buffer for input fontification. +Input fontification and indentation of an IELM buffer, if +enabled, is performed in an indirect buffer, whose indentation +and syntax highlighting are set up with `emacs-lisp-mode'. In +addition to `comint-indirect-setup-hook', run this hook with the +indirect buffer as the current buffer after its setup is done. +This can be used to further customize fontification and other +behaviour of the indirect buffer." + :type 'boolean + :safe 'booleanp + :version "29.1") + +(defun ielm-indirect-setup-hook () + "Run `ielm-indirect-setup-hook'." + (run-hooks 'ielm-indirect-setup-hook)) + ;;; Major mode (define-derived-mode inferior-emacs-lisp-mode comint-mode "IELM" @@ -526,6 +554,10 @@ The behavior of IELM may be customized with the following variables: Customized bindings may be defined in `ielm-map', which currently contains: \\{ielm-map}" :syntax-table emacs-lisp-mode-syntax-table + :after-hook + (and (null comint-use-prompt-regexp) + ielm-comint-fl-enable + (comint-fl-mode)) (setq comint-prompt-regexp (concat "^" (regexp-quote ielm-prompt))) (setq-local paragraph-separate "\\'") @@ -564,6 +596,10 @@ Customized bindings may be defined in `ielm-map', which currently contains: (setq-local font-lock-defaults '(ielm-font-lock-keywords nil nil ((?: . "w") (?- . "w") (?* . "w")))) + (add-hook 'comint-indirect-setup-hook + #'ielm-indirect-setup-hook 'append t) + (setq comint-indirect-setup-function #'emacs-lisp-mode) + ;; A dummy process to keep comint happy. It will never get any input (unless (comint-check-proc (current-buffer)) ;; Was cat, but on non-Unix platforms that might not exist, so diff --git a/lisp/image/image-dired-external.el b/lisp/image/image-dired-external.el index c26cedc9f2c..223d881bcfa 100644 --- a/lisp/image/image-dired-external.el +++ b/lisp/image/image-dired-external.el @@ -30,6 +30,7 @@ (require 'image-dired-util) (declare-function image-dired-display-image "image-dired") +(declare-function clear-image-cache "image.c" (&optional filter)) (defvar image-dired-dir) (defvar image-dired-main-image-directory) diff --git a/lisp/image/image-dired.el b/lisp/image/image-dired.el index 88f4ceaffb4..a22edee2ec5 100644 --- a/lisp/image/image-dired.el +++ b/lisp/image/image-dired.el @@ -767,7 +767,7 @@ according to `image-dired-marking-shows-next'." ,(when maybe-next '(if image-dired-marking-shows-next (image-dired-display-next-thumbnail-original) - (image-dired-next-line))))) + (image-dired-forward-image))))) (defun image-dired-mark-thumb-original-file () "Mark original image file in associated Dired buffer." @@ -1126,7 +1126,8 @@ and a confirmation is needed before the original image files is overwritten. This confirmation can be turned off using `image-dired-rotate-original-ask-before-overwrite'." (interactive nil image-dired-thumbnail-mode) - (image-dired-rotate-original "270")) + (image-dired--with-marked + (image-dired-rotate-original "270"))) (defun image-dired-rotate-original-right () "Rotate original image right (clockwise) 90 degrees. @@ -1135,7 +1136,8 @@ and a confirmation is needed before the original image files is overwritten. This confirmation can be turned off using `image-dired-rotate-original-ask-before-overwrite'." (interactive nil image-dired-thumbnail-mode) - (image-dired-rotate-original "90")) + (image-dired--with-marked + (image-dired-rotate-original "90"))) (defun image-dired-display-next-thumbnail-original (&optional arg) "Move to the next image in the thumbnail buffer and display it. @@ -1446,6 +1448,8 @@ of the thumbnail file." :type '(repeat (string :tag "Argument"))) (make-obsolete-variable 'image-dired-cmd-rotate-thumbnail-options nil "29.1") +(declare-function clear-image-cache "image.c" (&optional filter)) + (defun image-dired-rotate-thumbnail (degrees) "Rotate thumbnail DEGREES degrees." (declare (obsolete image-dired-refresh-thumb "29.1")) diff --git a/lisp/info.el b/lisp/info.el index 1a58910c3af..292bf93a6f4 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -451,6 +451,7 @@ or `Info-virtual-nodes'." (".info.z" . "gunzip") (".info.bz2" . ("bzip2" "-dc")) (".info.xz" . "unxz") + (".info.zst" . ("zstd" "-dc")) (".info" . nil) ("-info.Z" . "uncompress") ("-info.Y" . "unyabba") @@ -458,6 +459,7 @@ or `Info-virtual-nodes'." ("-info.bz2" . ("bzip2" "-dc")) ("-info.z" . "gunzip") ("-info.xz" . "unxz") + ("-info.zst" . ("zstd" "-dc")) ("-info" . nil) ("/index.Z" . "uncompress") ("/index.Y" . "unyabba") @@ -465,6 +467,7 @@ or `Info-virtual-nodes'." ("/index.z" . "gunzip") ("/index.bz2" . ("bzip2" "-dc")) ("/index.xz" . "unxz") + ("/index.zst" . ("zstd" "-dc")) ("/index" . nil) (".Z" . "uncompress") (".Y" . "unyabba") @@ -472,6 +475,7 @@ or `Info-virtual-nodes'." (".z" . "gunzip") (".bz2" . ("bzip2" "-dc")) (".xz" . "unxz") + (".zst" . ("zstd" "-dc")) ("" . nil))) "List of file name suffixes and associated decoding commands. Each entry should be (SUFFIX . STRING); the file is given to diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index 41376425289..e1d0df6e3ed 100644 --- a/lisp/international/mule-cmds.el +++ b/lisp/international/mule-cmds.el @@ -1389,9 +1389,6 @@ Maximum length of the history list is determined by the value of `history-length', which see.") (put 'input-method-history 'permanent-local t) -(define-obsolete-variable-alias - 'inactivate-current-input-method-function - 'deactivate-current-input-method-function "24.3") (defvar-local deactivate-current-input-method-function nil "Function to call for deactivating the current input method. Every input method should set this to an appropriate value when activated. @@ -1524,10 +1521,6 @@ If INPUT-METHOD is nil, deactivate any current input method." (setq current-input-method nil) (force-mode-line-update))))) -(define-obsolete-function-alias - 'inactivate-input-method - 'deactivate-input-method "24.3") - (defun set-input-method (input-method &optional interactive) "Select and activate input method INPUT-METHOD for the current buffer. This also sets the default input method to the one you specify. @@ -1741,10 +1734,6 @@ just activated." :type 'hook :group 'mule) -(define-obsolete-variable-alias - 'input-method-inactivate-hook - 'input-method-deactivate-hook "24.3") - (defcustom input-method-deactivate-hook nil "Normal hook run just after an input method is deactivated. @@ -3254,7 +3243,6 @@ single characters to be treated as standing for themselves." (error "Invalid character")) char)) -(define-obsolete-function-alias 'ucs-insert 'insert-char "24.3") (define-key ctl-x-map "8\r" 'insert-char) (define-key ctl-x-map "8e" (define-keymap diff --git a/lisp/international/quail.el b/lisp/international/quail.el index 4bb6dbcc8e4..e2ba485bbea 100644 --- a/lisp/international/quail.el +++ b/lisp/international/quail.el @@ -540,8 +540,6 @@ This function runs the normal hook `quail-deactivate-hook'." (interactive) (quail-activate -1)) -(define-obsolete-function-alias 'quail-inactivate 'quail-deactivate "24.3") - (defun quail-activate (&optional arg) "Activate Quail input method. With ARG, activate Quail input method if and only if arg is positive. @@ -583,10 +581,6 @@ While this input method is active, the variable (run-hooks 'quail-activate-hook) (setq-local input-method-function #'quail-input-method))) -(define-obsolete-variable-alias - 'quail-inactivate-hook - 'quail-deactivate-hook "24.3") - (defun quail-exit-from-minibuffer () (deactivate-input-method) (if (<= (minibuffer-depth) 1) diff --git a/lisp/international/robin.el b/lisp/international/robin.el index 4c498d7f923..9f0ff80e62e 100644 --- a/lisp/international/robin.el +++ b/lisp/international/robin.el @@ -393,8 +393,6 @@ A nil value means no package is selected.") (interactive) (robin-activate -1)) -(define-obsolete-function-alias 'robin-inactivate 'robin-deactivate "24.3") - (defun robin-activate (&optional arg) "Activate robin input method. @@ -423,10 +421,6 @@ While this input method is active, the variable 'robin-activate-hook) (setq-local input-method-function 'robin-input-method))) -(define-obsolete-variable-alias - 'robin-inactivate-hook - 'robin-deactivate-hook "24.3") - (defun robin-exit-from-minibuffer () (deactivate-input-method) (if (<= (minibuffer-depth) 1) diff --git a/lisp/jit-lock.el b/lisp/jit-lock.el index 9543253cf24..6ef46ad60b7 100644 --- a/lisp/jit-lock.el +++ b/lisp/jit-lock.el @@ -382,7 +382,11 @@ is active." (or (not (eq jit-lock-defer-time 0)) (input-pending-p)))) ;; No deferral. - (jit-lock-fontify-now start (+ start jit-lock-chunk-size)) + (let* ((cend (min (point-max) (+ start jit-lock-chunk-size))) + (vend (next-single-property-change start 'invisible nil cend))) + ;; Presumably if we're called it means `start' is + ;; not at EOB (nor invisible) and hence (> vend start). + (jit-lock-fontify-now start vend)) ;; Record the buffer for later fontification. (unless (memq (current-buffer) jit-lock-defer-buffers) (push (current-buffer) jit-lock-defer-buffers)) diff --git a/lisp/leim/quail/hangul.el b/lisp/leim/quail/hangul.el index 83fee1e04c3..89b9abe137e 100644 --- a/lisp/leim/quail/hangul.el +++ b/lisp/leim/quail/hangul.el @@ -537,10 +537,6 @@ HELP-TEXT is a text set in `hangul-input-method-help-text'." (setq describe-current-input-method-function nil)) (kill-local-variable 'input-method-function))) -(define-obsolete-function-alias - 'hangul-input-method-inactivate - #'hangul-input-method-deactivate "24.3") - (defun hangul-input-method-help () "Describe the current Hangul input method." (interactive) diff --git a/lisp/leim/quail/uni-input.el b/lisp/leim/quail/uni-input.el index 36d8e6a8404..3f10b873a34 100644 --- a/lisp/leim/quail/uni-input.el +++ b/lisp/leim/quail/uni-input.el @@ -113,10 +113,6 @@ While this input method is active, the variable (interactive) (ucs-input-activate -1)) -(define-obsolete-function-alias - 'ucs-input-inactivate - #'ucs-input-deactivate "24.3") - (defun ucs-input-help () (interactive) (with-output-to-temp-buffer "*Help*" diff --git a/lisp/mail/emacsbug.el b/lisp/mail/emacsbug.el index d72809b186d..a85ceaf1a5a 100644 --- a/lisp/mail/emacsbug.el +++ b/lisp/mail/emacsbug.el @@ -414,8 +414,6 @@ copy text to your preferred mail program.\n" system-configuration-options "'\n\n") (fill-region (line-beginning-position -1) (point)))) -(define-obsolete-function-alias 'report-emacs-bug-info #'info-emacs-bug "24.3") - (defun report-emacs-bug-hook () "Do some checking before sending a bug report." (goto-char (point-max)) diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el index 4bfec22b3a9..fed0a2057bc 100644 --- a/lisp/mail/rmail.el +++ b/lisp/mail/rmail.el @@ -4614,6 +4614,9 @@ Argument MIME is non-nil if this is a mime message." "> ") (push (rmail-epa-decrypt-1 mime) decrypts)))) + ;; Decode any base64-encoded mime sections. + (rmail-epa-decode) + (when (and decrypts (rmail-buffers-swapped-p)) (when (y-or-n-p "Replace the original message? ") (when (eq major-mode 'rmail-mode) @@ -4678,6 +4681,23 @@ Argument MIME is non-nil if this is a mime message." (unless decrypts (error "Nothing to decrypt"))))) +;; Decode all base64-encoded mime sections, so that this change +;; is made in the Rmail file, not just in the viewing buffer. +(defun rmail-epa-decode () + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "--------------[0-9a-zA-Z]+\n" nil t) + (let ((delim (concat (substring (match-string 0) 0 -1) "--\n"))) + (when (looking-at "\ +Content-Type: text/[a-z]+; charset=UTF-8; format=flowed +Content-Transfer-Encoding: base64\n") + (goto-char (match-end 0)) + (let ((start (point)) + (inhibit-read-only t)) + (search-forward delim) + (forward-line -1) + (base64-decode-region start (point)) + (forward-line 1))))))) ;;;; Desktop support diff --git a/lisp/mh-e/mh-e.el b/lisp/mh-e/mh-e.el index f6031df9c24..0ad934107d3 100644 --- a/lisp/mh-e/mh-e.el +++ b/lisp/mh-e/mh-e.el @@ -3183,8 +3183,6 @@ function used to insert the signature with :group 'mh-letter :package-version '(MH-E . "8.0")) -(define-obsolete-variable-alias 'mh-kill-folder-suppress-prompt-hooks - 'mh-kill-folder-suppress-prompt-functions "24.3") (defcustom mh-kill-folder-suppress-prompt-functions '(mh-search-p) "Abnormal hook run at the beginning of \\<mh-folder-mode-map>\\[mh-kill-folder]. diff --git a/lisp/mh-e/mh-funcs.el b/lisp/mh-e/mh-funcs.el index ab89ef2a3d1..4956d9b59fd 100644 --- a/lisp/mh-e/mh-funcs.el +++ b/lisp/mh-e/mh-funcs.el @@ -101,7 +101,7 @@ a non-nil value to suppress the normal prompt when you remove a folder. This is useful for folders that are easily regenerated." (interactive) (if (or (run-hook-with-args-until-success - 'mh-kill-folder-suppress-prompt-hooks) + 'mh-kill-folder-suppress-prompt-functions) (yes-or-no-p (format "Remove folder %s (and all included messages)? " mh-current-folder))) (let ((folder mh-current-folder) diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 3daab8a1e8d..9f26e4f7f98 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -4461,6 +4461,11 @@ FORMAT-ARGS is non-nil, PROMPT is used as a format control string, and FORMAT-ARGS are the arguments to be substituted into it. See `format' for details. +Both PROMPT and `minibuffer-default-prompt-format' are run +through `substitute-command-keys' (which see). In particular, +this means that single quotes may be displayed by equivalent +characters, according to the capabilities of the terminal. + If DEFAULT is a list, the first element is used as the default. If not, the element is used as is. @@ -4468,12 +4473,12 @@ If DEFAULT is nil or an empty string, no \"default value\" string is included in the return value." (concat (if (null format-args) - prompt - (apply #'format prompt format-args)) + (substitute-command-keys prompt) + (apply #'format (substitute-command-keys prompt) format-args)) (and default (or (not (stringp default)) (length> default 0)) - (format minibuffer-default-prompt-format + (format (substitute-command-keys minibuffer-default-prompt-format) (if (consp default) (car default) default))) diff --git a/lisp/mpc.el b/lisp/mpc.el index ba95308bf67..1775e7d5e72 100644 --- a/lisp/mpc.el +++ b/lisp/mpc.el @@ -182,8 +182,6 @@ numerically rather than lexicographically." (abs res)) res)))))))) -(define-obsolete-function-alias 'mpc-string-prefix-p #'string-prefix-p "24.3") - ;; This can speed up mpc--song-search significantly. The table may grow ;; very large, tho. It's only bounded by the fact that it gets flushed ;; whenever the connection is established; which seems to work OK thanks diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index 71505dcaa39..abb67da95f0 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -116,7 +116,7 @@ VALUE must be a string that will be used instead of the server name for display purposes. If absent, the real server name will be displayed instead." :type '(alist :key-type string - :value-type (plist :options + :value-type (plist :options ((:nick string) (:port integer) (:user-name string) @@ -167,7 +167,7 @@ If a function (e.g., `frame-text-width' or `window-text-width'), call it to compute the number of columns." :risky t ; can get funcalled :type '(choice (const :tag "Value of `fill-column'" nil) - (integer :tag "Number of columns") + (integer :tag "Number of columns") (function :tag "Function returning the number of columns"))) (defcustom rcirc-fill-prefix nil @@ -175,7 +175,7 @@ call it to compute the number of columns." If nil, calculate the prefix dynamically to line up text underneath each nick." :type '(choice (const :tag "Dynamic" nil) - (string :tag "Prefix text"))) + (string :tag "Prefix text"))) (defcustom rcirc-url-max-length nil "Maximum number of characters in displayed URLs. @@ -273,19 +273,19 @@ Examples: (\"quakenet.org\" quakenet \"bobby\" \"sekrit\") (\"oftc\" sasl \"bob\" \"hunter2\"))" :type '(alist :key-type (regexp :tag "Server") - :value-type (choice (list :tag "NickServ" - (const nickserv) - (string :tag "Nick") - (string :tag "Password")) - (list :tag "ChanServ" - (const chanserv) - (string :tag "Nick") - (string :tag "Channel") - (string :tag "Password")) - (list :tag "BitlBee" - (const bitlbee) - (string :tag "Nick") - (string :tag "Password")) + :value-type (choice (list :tag "NickServ" + (const nickserv) + (string :tag "Nick") + (string :tag "Password")) + (list :tag "ChanServ" + (const chanserv) + (string :tag "Nick") + (string :tag "Channel") + (string :tag "Password")) + (list :tag "BitlBee" + (const bitlbee) + (string :tag "Nick") + (string :tag "Password")) (list :tag "QuakeNet" (const quakenet) (string :tag "Account") @@ -350,8 +350,6 @@ See `rcirc-bright-nick' face." See `rcirc-dim-nick' face." :type '(repeat string)) -(define-obsolete-variable-alias 'rcirc-print-hooks - 'rcirc-print-functions "24.3") (defcustom rcirc-print-functions nil "Hook run after text is printed. Called with 5 arguments, PROCESS, SENDER, RESPONSE, TARGET and TEXT." @@ -388,10 +386,10 @@ messages. If VAL is a cons of coding systems, the car part is used for decoding, and the cdr part is used for encoding." :type '(alist :key-type (choice (regexp :tag "Channel Regexp") - (cons (regexp :tag "Channel Regexp") - (regexp :tag "Server Regexp"))) - :value-type (choice coding-system - (cons (coding-system :tag "Decode") + (cons (regexp :tag "Channel Regexp") + (regexp :tag "Server Regexp"))) + :value-type (choice coding-system + (cons (coding-system :tag "Decode") (coding-system :tag "Encode"))))) (defcustom rcirc-multiline-major-mode 'fundamental-mode @@ -520,50 +518,50 @@ If ARG is non-nil, instead prompt for connection parameters." (interactive "P") (if arg (let* ((server (completing-read "IRC Server: " - rcirc-server-alist - nil nil - (caar rcirc-server-alist) - 'rcirc-server-name-history)) - (server-plist (cdr (assoc-string server rcirc-server-alist))) - (port (read-string "IRC Port: " - (number-to-string - (or (plist-get server-plist :port) - rcirc-default-port)) - 'rcirc-server-port-history)) - (nick (read-string "IRC Nick: " - (or (plist-get server-plist :nick) - rcirc-default-nick) - 'rcirc-nick-name-history)) - (user-name (read-string "IRC Username: " + rcirc-server-alist + nil nil + (caar rcirc-server-alist) + 'rcirc-server-name-history)) + (server-plist (cdr (assoc-string server rcirc-server-alist))) + (port (read-string "IRC Port: " + (number-to-string + (or (plist-get server-plist :port) + rcirc-default-port)) + 'rcirc-server-port-history)) + (nick (read-string "IRC Nick: " + (or (plist-get server-plist :nick) + rcirc-default-nick) + 'rcirc-nick-name-history)) + (user-name (read-string "IRC Username: " (or (plist-get server-plist :user-name) rcirc-default-user-name) 'rcirc-user-name-history)) - (password (read-passwd "IRC Password: " nil + (password (read-passwd "IRC Password: " nil (plist-get server-plist :password))) - (channels (split-string - (read-string "IRC Channels: " - (mapconcat 'identity - (plist-get server-plist - :channels) - " ")) - "[, ]+" t)) + (channels (split-string + (read-string "IRC Channels: " + (mapconcat 'identity + (plist-get server-plist + :channels) + " ")) + "[, ]+" t)) (encryption (rcirc-prompt-for-encryption server-plist)) (process (rcirc-connect server port nick user-name - rcirc-default-full-name - channels password encryption))) - (when rcirc-display-server-buffer + rcirc-default-full-name + channels password encryption))) + (when rcirc-display-server-buffer (pop-to-buffer-same-window (process-buffer process)))) ;; connect to servers in `rcirc-server-alist' (let (connected-servers) (dolist (c rcirc-server-alist) - (let ((server (car c)) - (nick (or (plist-get (cdr c) :nick) rcirc-default-nick)) - (port (or (plist-get (cdr c) :port) rcirc-default-port)) - (user-name (or (plist-get (cdr c) :user-name) - rcirc-default-user-name)) - (full-name (or (plist-get (cdr c) :full-name) - rcirc-default-full-name)) - (channels (plist-get (cdr c) :channels)) + (let ((server (car c)) + (nick (or (plist-get (cdr c) :nick) rcirc-default-nick)) + (port (or (plist-get (cdr c) :port) rcirc-default-port)) + (user-name (or (plist-get (cdr c) :user-name) + rcirc-default-user-name)) + (full-name (or (plist-get (cdr c) :full-name) + rcirc-default-full-name)) + (channels (plist-get (cdr c) :channels)) (password (plist-get (cdr c) :password)) (encryption (plist-get (cdr c) :encryption)) (server-alias (plist-get (cdr c) :server-alias)) @@ -577,21 +575,21 @@ If ARG is non-nil, instead prompt for connection parameters." :port port)) (pwd (auth-info-password (car auth)))) (setq password pwd)) - (when server - (let (connected) - (dolist (p (rcirc-process-list)) - (when (string= (or server-alias server) (process-name p)) - (setq connected p))) - (if (not connected) - (condition-case nil - (let ((process (rcirc-connect server port nick user-name + (when server + (let (connected) + (dolist (p (rcirc-process-list)) + (when (string= (or server-alias server) (process-name p)) + (setq connected p))) + (if (not connected) + (condition-case nil + (let ((process (rcirc-connect server port nick user-name full-name channels password encryption client-cert server-alias))) (when rcirc-display-server-buffer (pop-to-buffer-same-window (process-buffer process)))) - (quit (message "Quit connecting to %s" + (quit (message "Quit connecting to %s" (or server-alias server)))) - (with-current-buffer (process-buffer connected) + (with-current-buffer (process-buffer connected) (setq contact (process-contact (get-buffer-process (current-buffer)) :name)) (setq connected-servers @@ -599,12 +597,12 @@ If ARG is non-nil, instead prompt for connection parameters." contact (or server-alias server)) connected-servers)))))))) (when connected-servers - (message "Already connected to %s" - (if (cdr connected-servers) - (concat (mapconcat 'identity (butlast connected-servers) ", ") - ", and " - (car (last connected-servers))) - (car connected-servers))))))) + (message "Already connected to %s" + (if (cdr connected-servers) + (concat (mapconcat 'identity (butlast connected-servers) ", ") + ", and " + (car (last connected-servers))) + (car connected-servers))))))) ;;;###autoload (defalias 'irc 'rcirc) @@ -732,7 +730,7 @@ that are joined after authentication." (setq rcirc-nick nick) (setq rcirc-startup-channels startup-channels) (setq rcirc-last-connect-time (current-time)) - (setq rcirc-last-server-message-time rcirc-last-connect-time) + (setq rcirc-last-server-message-time rcirc-last-connect-time) ;; Check if the immediate process state (sit-for .1) @@ -804,8 +802,8 @@ MESSAGE should contain a timestamp, indicating when the KEEPALIVE message was generated." (with-rcirc-process-buffer process (setq header-line-format - (format "%f" (float-time - (time-since (string-to-number message))))))) + (format "%f" (float-time + (time-since (string-to-number message))))))) (defvar rcirc-debug-buffer "*rcirc debug*" "Buffer name for debugging messages.") @@ -832,8 +830,6 @@ is moved to after the text inserted. Otherwise the point is not moved." text)) (goto-char old))))) -(define-obsolete-variable-alias 'rcirc-sentinel-hooks - 'rcirc-sentinel-functions "24.3") (defvar rcirc-sentinel-functions nil "Hook functions called when the process sentinel is called. Functions are called with PROCESS and SENTINEL arguments.") @@ -864,19 +860,19 @@ If QUIET is non-nil, no not emit a message." (throw 'exit (or quiet (message "Server process is alive"))) (delete-process process)) (let ((conn-info rcirc-connection-info)) - (setf (nth 5 conn-info) - (cl-remove-if-not #'rcirc-channel-p - (mapcar #'car rcirc-buffer-alist))) + (setf (nth 5 conn-info) + (cl-remove-if-not #'rcirc-channel-p + (mapcar #'car rcirc-buffer-alist))) (dolist (buffer (mapcar #'cdr rcirc-buffer-alist)) - (when (buffer-live-p buffer) + (when (buffer-live-p buffer) (with-current-buffer buffer - (setq mode-line-process ":connecting")))) - (let ((nprocess (apply #'rcirc-connect conn-info))) + (setq mode-line-process ":connecting")))) + (let ((nprocess (apply #'rcirc-connect conn-info))) (when (and (< rcirc-failed-attempts rcirc-reconnect-attempts) (eq (process-status nprocess) 'failed)) (setq rcirc-failed-attempts (1+ rcirc-failed-attempts)) (rcirc-print nprocess "*rcirc*" "ERROR" nil - (format "Failed to reconnect (%d/%d)..." + (format "Failed to reconnect (%d/%d)..." rcirc-failed-attempts rcirc-reconnect-attempts)) (setq rcirc-reconnection-timer @@ -932,26 +928,26 @@ SENTINEL describes the change in form of a string." (message "Connecting to %s...done" (or server-alias server)) (dolist (buffer (cons nil (mapcar 'cdr rcirc-buffer-alist))) - (with-current-buffer (or buffer (current-buffer)) - (setq mode-line-process nil))))) + (with-current-buffer (or buffer (current-buffer)) + (setq mode-line-process nil))))) ((eq status 'closed) (let ((now (current-time))) (with-rcirc-process-buffer process (when (and (< 0 rcirc-reconnect-delay) (time-less-p rcirc-reconnect-delay - (time-subtract now rcirc-last-connect-time))) + (time-subtract now rcirc-last-connect-time))) (setq rcirc-last-connect-time now) (rcirc-reconnect process))))) ((eq status 'failed) (dolist (buffer (cons nil (mapcar 'cdr rcirc-buffer-alist))) - (with-current-buffer (or buffer (current-buffer)) - (rcirc-print process "*rcirc*" "ERROR" rcirc-target - (format "%s: %s (%S)" - (process-name process) - sentinel - (process-status process)) + (with-current-buffer (or buffer (current-buffer)) + (rcirc-print process "*rcirc*" "ERROR" rcirc-target + (format "%s: %s (%S)" + (process-name process) + sentinel + (process-status process)) (not rcirc-target)) - (rcirc-disconnect-buffer))))) + (rcirc-disconnect-buffer))))) (run-hook-with-args 'rcirc-sentinel-functions process sentinel)))) (defun rcirc-disconnect-buffer (&optional buffer) @@ -974,8 +970,6 @@ If BUFFER is nil, default to the current buffer." (process-list)) ps)) -(define-obsolete-variable-alias 'rcirc-receive-message-hooks - 'rcirc-receive-message-functions "24.3") (defvar rcirc-receive-message-functions nil "Hook functions run when a message is received from server. Function is called with PROCESS, COMMAND, SENDER, ARGS and LINE.") @@ -998,10 +992,10 @@ Function is called with PROCESS, COMMAND, SENDER, ARGS and LINE.") (with-rcirc-process-buffer process (when (not rcirc-connecting) (with-rcirc-process-buffer process - (when rcirc-timeout-timer (cancel-timer rcirc-timeout-timer)) - (setq rcirc-timeout-timer (run-at-time rcirc-timeout-seconds nil - 'delete-process - process)))))) + (when rcirc-timeout-timer (cancel-timer rcirc-timeout-timer)) + (setq rcirc-timeout-timer (run-at-time rcirc-timeout-seconds nil + 'delete-process + process)))))) (defvar rcirc-trap-errors-flag t "Non-nil means Lisp errors are degraded to error messages.") @@ -1017,7 +1011,7 @@ Function is called with PROCESS, COMMAND, SENDER, ARGS and LINE.") (defconst rcirc-process-regexp (rx-let ((message-tag ; message tags as specified in - ; https://ircv3.net/specs/extensions/message-tags + ; https://ircv3.net/specs/extensions/message-tags (: (? "+") (? (+ (or alnum "-")) (+ "." (+ (or alnum "-"))) "/") (+ (any alnum "-")) @@ -1098,7 +1092,7 @@ Note that the messages are stored in reverse order.") (split-string tag-data ";")))) rcirc-message-tags)) (user (match-string 3 text)) - (sender (rcirc-user-nick user)) + (sender (rcirc-user-nick user)) (cmd (match-string 4 text)) (cmd-end (match-end 4)) (args nil) @@ -1140,7 +1134,7 @@ found. PROCESS, SENDER and RESPONSE are passed on to used as the message body." (rcirc-print process sender response nil (mapconcat 'identity (cdr args) " ") - (not (member response rcirc-responses-no-activity)))) + (not (member response rcirc-responses-no-activity)))) (defun rcirc--connection-open-p (process) "Check if PROCESS is open or running." @@ -1186,7 +1180,7 @@ element in PARTS is a list, append it to PARTS." "Return the process associated with channel BUFFER. With no argument or nil as argument, use the current buffer." (let ((buffer (or buffer (and (buffer-live-p rcirc-server-buffer) - rcirc-server-buffer)))) + rcirc-server-buffer)))) (if buffer (buffer-local-value 'rcirc-process buffer) rcirc-process))) @@ -1195,7 +1189,7 @@ With no argument or nil as argument, use the current buffer." "Return PROCESS server name, given by the 001 response." (with-rcirc-process-buffer process (or rcirc-server-name - (warn "server name for process %S unknown" process)))) + (warn "server name for process %S unknown" process)))) (defun rcirc-nick (process) "Return PROCESS nick." @@ -1220,17 +1214,17 @@ With no argument or nil as argument, use the current buffer." (insert message) (goto-char (point-min)) (let (result) - (while (not (eobp)) - (goto-char (or (byte-to-position rcirc-max-message-length) - (point-max))) - ;; max message length is 512 including CRLF - (while (and (not (bobp)) - (> (length (encode-coding-region - (point-min) (point) encoding t)) - rcirc-max-message-length)) - (forward-char -1)) - (push (delete-and-extract-region (point-min) (point)) result)) - (nreverse result))))) + (while (not (eobp)) + (goto-char (or (byte-to-position rcirc-max-message-length) + (point-max))) + ;; max message length is 512 including CRLF + (while (and (not (bobp)) + (> (length (encode-coding-region + (point-min) (point) encoding t)) + rcirc-max-message-length)) + (forward-char -1)) + (push (delete-and-extract-region (point-min) (point)) result)) + (nreverse result))))) (defun rcirc-send-message (process target message &optional noticep silent) "Send TARGET associated with PROCESS a privmsg with text MESSAGE. @@ -1241,7 +1235,7 @@ If SILENT is non-nil, do not print the message in any irc buffer." (dolist (msg (rcirc-split-message message)) (rcirc-send-string process response target : msg) (unless silent - (rcirc-print process (rcirc-nick process) response target msg))))) + (rcirc-print process (rcirc-nick process) response target msg))))) (defvar-local rcirc-input-ring nil "Ring object for input.") @@ -1293,10 +1287,10 @@ The list is updated automatically by `defun-rcirc-command'.") ;; On some networks it is common to message or ;; mention someone using @nick instead of just ;; nick. - (if (re-search-backward "[[:space:]@]" rcirc-prompt-end-marker t) - (1+ (point)) - rcirc-prompt-end-marker))) - (table (cond + (if (re-search-backward "[[:space:]@]" rcirc-prompt-end-marker t) + (1+ (point)) + rcirc-prompt-end-marker))) + (table (cond ;; No completion before the prompt ((< beg rcirc-prompt-end-marker) nil) ;; Only complete nicks mid-message @@ -1304,23 +1298,23 @@ The list is updated automatically by `defun-rcirc-command'.") (mapcar rcirc-nick-filter (rcirc-channel-nicks (rcirc-buffer-process) - rcirc-target))) + rcirc-target))) ;; Complete commands at the beginning of the ;; message, when the first character is a dash ((eq (char-after beg) ?/) (mapcar (lambda (cmd) (concat cmd " ")) (nconc (sort (copy-sequence rcirc-client-commands) - 'string-lessp) - (sort (copy-sequence rcirc-server-commands) - 'string-lessp)))) + 'string-lessp) + (sort (copy-sequence rcirc-server-commands) + 'string-lessp)))) ;; Complete usernames right after the prompt by ;; appending a colon after the name ((mapcar (lambda (str) (concat (funcall rcirc-nick-filter str) ": ")) (rcirc-channel-nicks (rcirc-buffer-process) - rcirc-target)))))) - (list beg (point) + rcirc-target)))))) + (list beg (point) (lambda (str pred action) (if (eq action 'metadata) '(metadata (cycle-sort-function . identity)) @@ -1416,13 +1410,13 @@ PROCESS is the process object used for communication. (setq mode-line-process nil) (setq rcirc-input-ring - ;; If rcirc-input-ring is already a ring with desired - ;; size do not re-initialize. - (if (and (ring-p rcirc-input-ring) - (= (ring-size rcirc-input-ring) - rcirc-input-ring-size)) - rcirc-input-ring - (make-ring rcirc-input-ring-size))) + ;; If rcirc-input-ring is already a ring with desired + ;; size do not re-initialize. + (if (and (ring-p rcirc-input-ring) + (= (ring-size rcirc-input-ring) + rcirc-input-ring-size)) + rcirc-input-ring + (make-ring rcirc-input-ring-size))) (setq rcirc-server-buffer (process-buffer process)) (setq rcirc-target target) (setq rcirc-last-post-time (current-time)) @@ -1435,19 +1429,19 @@ PROCESS is the process object used for communication. (setq buffer-invisibility-spec '()) (setq buffer-display-table (make-display-table)) (set-display-table-slot buffer-display-table 4 - (let ((glyph (make-glyph-code - ?. 'font-lock-keyword-face))) - (make-vector 3 glyph))) + (let ((glyph (make-glyph-code + ?. 'font-lock-keyword-face))) + (make-vector 3 glyph))) (dolist (i rcirc-coding-system-alist) (let ((chan (if (consp (car i)) (caar i) (car i))) - (serv (if (consp (car i)) (cdar i) ""))) + (serv (if (consp (car i)) (cdar i) ""))) (when (and (string-match chan (or target "")) - (string-match serv (rcirc-server-name process))) - (setq-local rcirc-decode-coding-system - (if (consp (cdr i)) (cadr i) (cdr i))) + (string-match serv (rcirc-server-name process))) + (setq-local rcirc-decode-coding-system + (if (consp (cdr i)) (cadr i) (cdr i))) (setq-local rcirc-encode-coding-system - (if (consp (cdr i)) (cddr i) (cdr i)))))) + (if (consp (cdr i)) (cddr i) (cdr i)))))) ;; setup the prompt and markers (setq rcirc-prompt-start-marker (point-max-marker)) @@ -1463,7 +1457,7 @@ PROCESS is the process object used for communication. (add-hook 'kill-buffer-hook 'rcirc-kill-buffer-hook nil t) ;; add to buffer list, and update buffer abbrevs - (when target ; skip server buffer + (when target ; skip server buffer (let ((buffer (current-buffer))) (with-rcirc-process-buffer process (push (cons target buffer) rcirc-buffer-alist))) @@ -1485,41 +1479,41 @@ PROCESS is the process object used for communication. If ALL is non-nil, update prompts in all IRC buffers." (if all (mapc (lambda (process) - (mapc (lambda (buffer) - (with-current-buffer buffer - (rcirc-update-prompt))) - (with-rcirc-process-buffer process - (mapcar 'cdr rcirc-buffer-alist)))) - (rcirc-process-list)) + (mapc (lambda (buffer) + (with-current-buffer buffer + (rcirc-update-prompt))) + (with-rcirc-process-buffer process + (mapcar 'cdr rcirc-buffer-alist)))) + (rcirc-process-list)) (let ((inhibit-read-only t) - (prompt (or rcirc-prompt ""))) + (prompt (or rcirc-prompt ""))) (mapc (lambda (rep) - (setq prompt - (replace-regexp-in-string (car rep) (cdr rep) prompt))) - (list (cons "%n" (rcirc-buffer-nick)) - (cons "%s" (with-rcirc-server-buffer rcirc-server-name)) - (cons "%t" (or rcirc-target "")))) + (setq prompt + (replace-regexp-in-string (car rep) (cdr rep) prompt))) + (list (cons "%n" (rcirc-buffer-nick)) + (cons "%s" (with-rcirc-server-buffer rcirc-server-name)) + (cons "%t" (or rcirc-target "")))) (save-excursion - (delete-region rcirc-prompt-start-marker rcirc-prompt-end-marker) - (goto-char rcirc-prompt-start-marker) - (let ((start (point))) - (insert-before-markers prompt) - (set-marker rcirc-prompt-start-marker start) - (when (not (zerop (- rcirc-prompt-end-marker - rcirc-prompt-start-marker))) - (add-text-properties rcirc-prompt-start-marker - rcirc-prompt-end-marker - (list 'face 'rcirc-prompt - 'read-only t 'field t - 'front-sticky t 'rear-nonsticky t)))))))) + (delete-region rcirc-prompt-start-marker rcirc-prompt-end-marker) + (goto-char rcirc-prompt-start-marker) + (let ((start (point))) + (insert-before-markers prompt) + (set-marker rcirc-prompt-start-marker start) + (when (not (zerop (- rcirc-prompt-end-marker + rcirc-prompt-start-marker))) + (add-text-properties rcirc-prompt-start-marker + rcirc-prompt-end-marker + (list 'face 'rcirc-prompt + 'read-only t 'field t + 'front-sticky t 'rear-nonsticky t)))))))) (defun rcirc-set-changed (option value) "Set OPTION to VALUE and update after a customization change." (set-default option value) (cond ((eq option 'rcirc-prompt) - (rcirc-update-prompt 'all)) - (t - (error "Bad option %s" option)))) + (rcirc-update-prompt 'all)) + (t + (error "Bad option %s" option)))) (defun rcirc-channel-p (target) "Return t if TARGET is a channel name." @@ -1554,7 +1548,7 @@ with it." (when (and rcirc-buffer-alist ;; it's a server buffer rcirc-kill-channel-buffers) (dolist (channel rcirc-buffer-alist) - (kill-buffer (cdr channel)))))) + (kill-buffer (cdr channel)))))) (defun rcirc-change-major-mode-hook () "Part the channel when changing the major mode." @@ -1565,18 +1559,18 @@ with it." (let ((buffer (current-buffer))) (rcirc-clear-activity buffer) (when (and (rcirc-buffer-process) - (rcirc--connection-open-p (rcirc-buffer-process))) + (rcirc--connection-open-p (rcirc-buffer-process))) (with-rcirc-server-buffer - (setq rcirc-buffer-alist - (rassq-delete-all buffer rcirc-buffer-alist))) + (setq rcirc-buffer-alist + (rassq-delete-all buffer rcirc-buffer-alist))) (rcirc-update-short-buffer-names) (if (rcirc-channel-p rcirc-target) - (rcirc-send-string (rcirc-buffer-process) + (rcirc-send-string (rcirc-buffer-process) "PART" rcirc-target : reason) - (when rcirc-target - (rcirc-remove-nick-channel (rcirc-buffer-process) - (rcirc-buffer-nick) - rcirc-target)))) + (when rcirc-target + (rcirc-remove-nick-channel (rcirc-buffer-process) + (rcirc-buffer-nick) + rcirc-target)))) (setq rcirc-target nil))) (defun rcirc-generate-new-buffer-name (process target) @@ -1594,30 +1588,30 @@ If optional argument SERVER is non-nil, return the server buffer if there is no existing buffer for TARGET, otherwise return nil." (with-rcirc-process-buffer process (if (null target) - (current-buffer) + (current-buffer) (let ((buffer (cdr (assoc-string target rcirc-buffer-alist t)))) - (or buffer (when server (current-buffer))))))) + (or buffer (when server (current-buffer))))))) (defun rcirc-get-buffer-create (process target) "Return the buffer associated with the PROCESS and TARGET. Create the buffer if it doesn't exist." (let ((buffer (rcirc-get-buffer process target))) (if (and buffer (buffer-live-p buffer)) - (with-current-buffer buffer - (when (not rcirc-target) - (setq rcirc-target target)) - buffer) + (with-current-buffer buffer + (when (not rcirc-target) + (setq rcirc-target target)) + buffer) ;; create the buffer (with-rcirc-process-buffer process - (let ((new-buffer (get-buffer-create - (rcirc-generate-new-buffer-name process target)))) - (with-current-buffer new-buffer + (let ((new-buffer (get-buffer-create + (rcirc-generate-new-buffer-name process target)))) + (with-current-buffer new-buffer (unless (eq major-mode 'rcirc-mode) - (rcirc-mode process target)) + (rcirc-mode process target)) (setq mode-line-process nil)) - (rcirc-put-nick-channel process (rcirc-nick process) target - rcirc-current-line) - new-buffer))))) + (rcirc-put-nick-channel process (rcirc-nick process) target + rcirc-current-line) + new-buffer))))) (defun rcirc-send-input () "Send input to target associated with the current buffer." @@ -1625,31 +1619,31 @@ Create the buffer if it doesn't exist." (if (< (point) rcirc-prompt-end-marker) ;; copy the line down to the input area (progn - (forward-line 0) - (let ((start (if (eq (point) (point-min)) - (point) - (if (get-text-property (1- (point)) 'hard) - (point) - (previous-single-property-change (point) 'hard)))) - (end (next-single-property-change (1+ (point)) 'hard))) - (goto-char (point-max)) - (insert (replace-regexp-in-string - "\n\\s-+" " " - (buffer-substring-no-properties start end))))) + (forward-line 0) + (let ((start (if (eq (point) (point-min)) + (point) + (if (get-text-property (1- (point)) 'hard) + (point) + (previous-single-property-change (point) 'hard)))) + (end (next-single-property-change (1+ (point)) 'hard))) + (goto-char (point-max)) + (insert (replace-regexp-in-string + "\n\\s-+" " " + (buffer-substring-no-properties start end))))) ;; process input (goto-char (point-max)) (when (not (equal 0 (- (point) rcirc-prompt-end-marker))) ;; delete a trailing newline (when (eq (point) (line-beginning-position)) - (delete-char -1)) + (delete-char -1)) (let ((input (buffer-substring-no-properties - rcirc-prompt-end-marker (point)))) - (dolist (line (split-string input "\n")) - (rcirc-process-input-line line)) - ;; add to input-ring - (save-excursion - (ring-insert rcirc-input-ring input) - (setq rcirc-input-ring-index 0)))))) + rcirc-prompt-end-marker (point)))) + (dolist (line (split-string input "\n")) + (rcirc-process-input-line line)) + ;; add to input-ring + (save-excursion + (ring-insert rcirc-input-ring input) + (setq rcirc-input-ring-index 0)))))) (defun rcirc-fill-paragraph (&optional justify) "Implementation for `fill-paragraph-function'. @@ -1659,14 +1653,14 @@ The argument JUSTIFY is passed on to `fill-region'." (save-restriction (narrow-to-region rcirc-prompt-end-marker (point-max)) (let ((fill-column rcirc-max-message-length)) - (fill-region (point-min) (point-max) justify))))) + (fill-region (point-min) (point-max) justify))))) (defun rcirc-process-input-line (line) "Process LINE as a message or a command." (if (string-match "^/\\([^/ ][^ ]*\\) ?\\(.*\\)$" line) (rcirc-process-command (match-string 1 line) - (match-string 2 line) - line) + (match-string 2 line) + line) (rcirc-process-message line))) (defun rcirc-process-message (line) @@ -1687,19 +1681,19 @@ The argument JUSTIFY is passed on to `fill-region'." LINE is the raw input, from which COMMAND and ARGS was extracted." (let ((fun (intern-soft (concat "rcirc-cmd-" command))) - (process (rcirc-buffer-process))) + (process (rcirc-buffer-process))) (newline) (with-current-buffer (current-buffer) (delete-region rcirc-prompt-end-marker (point)) (if (string= command "me") - (rcirc-print process (rcirc-buffer-nick) - "ACTION" rcirc-target args) - (rcirc-print process (rcirc-buffer-nick) - "COMMAND" rcirc-target line)) + (rcirc-print process (rcirc-buffer-nick) + "ACTION" rcirc-target args) + (rcirc-print process (rcirc-buffer-nick) + "COMMAND" rcirc-target line)) (set-marker rcirc-prompt-end-marker (point)) (if (fboundp fun) - (funcall fun args process rcirc-target) - (rcirc-send-string process command : args))))) + (funcall fun args process rcirc-target) + (rcirc-send-string process command : args))))) (defvar-local rcirc-parent-buffer nil "Message buffer that requested a multiline buffer.") @@ -1714,7 +1708,7 @@ extracted." (let ((pos (1+ (- (point) rcirc-prompt-end-marker)))) (goto-char (point-max)) (let ((text (buffer-substring-no-properties rcirc-prompt-end-marker - (point))) + (point))) (parent (buffer-name))) (delete-region rcirc-prompt-end-marker (point)) (setq rcirc-window-configuration (current-window-configuration)) @@ -1768,11 +1762,11 @@ extracted." (process-buffer process) (let ((buffer (window-buffer))) (if (and buffer - (with-current-buffer buffer - (and (eq major-mode 'rcirc-mode) - (eq (rcirc-buffer-process) process)))) - buffer - (process-buffer process))))) + (with-current-buffer buffer + (and (eq major-mode 'rcirc-mode) + (eq (rcirc-buffer-process) process)))) + buffer + (process-buffer process))))) (defcustom rcirc-response-formats '(("PRIVMSG" . "<%N> %m") @@ -1803,7 +1797,7 @@ the of the following escape sequences replaced by the described values: %f- Following text uses the default face %% A literal `%' character" :type '(alist :key-type (choice (string :tag "Type") - (const :tag "Default" t)) + (const :tag "Default" t)) :value-type string)) (defun rcirc-format-response-string (process sender response target text) @@ -1813,55 +1807,55 @@ The specific formatting used is found by looking up RESPONSE in communication." (with-temp-buffer (insert (or (cdr (assoc response rcirc-response-formats)) - (cdr (assq t rcirc-response-formats)))) + (cdr (assq t rcirc-response-formats)))) (goto-char (point-min)) (let ((start (point-min)) - (sender (if (or (not sender) - (string= (rcirc-server-name process) sender)) - "" - (funcall rcirc-nick-filter sender))) - face) + (sender (if (or (not sender) + (string= (rcirc-server-name process) sender)) + "" + (funcall rcirc-nick-filter sender))) + face) (while (re-search-forward "%\\(\\(f\\(.\\)\\)\\|\\(.\\)\\)" nil t) - (rcirc-add-face start (match-beginning 0) face) - (setq start (match-beginning 0)) - (replace-match - (cl-case (aref (match-string 1) 0) - (?f (setq face - (cl-case (string-to-char (match-string 3)) - (?w 'font-lock-warning-face) - (?p 'rcirc-server-prefix) - (?s 'rcirc-server) - (t nil))) - "") - (?n sender) - (?N (let ((my-nick (rcirc-nick process))) - (save-match-data - (with-syntax-table rcirc-nick-syntax-table - (rcirc-facify sender - (cond ((string= sender my-nick) - 'rcirc-my-nick) - ((and rcirc-bright-nicks - (string-match - (regexp-opt rcirc-bright-nicks - 'words) - sender)) - 'rcirc-bright-nick) - ((and rcirc-dim-nicks - (string-match - (regexp-opt rcirc-dim-nicks - 'words) - sender)) - 'rcirc-dim-nick) - (t - 'rcirc-other-nick))))))) - (?m (propertize text 'rcirc-text text)) - (?r response) - (?t (or target "")) - (t (concat "UNKNOWN CODE:" (match-string 0)))) - t t nil 0) - (rcirc-add-face (match-beginning 0) (match-end 0) face)) + (rcirc-add-face start (match-beginning 0) face) + (setq start (match-beginning 0)) + (replace-match + (cl-case (aref (match-string 1) 0) + (?f (setq face + (cl-case (string-to-char (match-string 3)) + (?w 'font-lock-warning-face) + (?p 'rcirc-server-prefix) + (?s 'rcirc-server) + (t nil))) + "") + (?n sender) + (?N (let ((my-nick (rcirc-nick process))) + (save-match-data + (with-syntax-table rcirc-nick-syntax-table + (rcirc-facify sender + (cond ((string= sender my-nick) + 'rcirc-my-nick) + ((and rcirc-bright-nicks + (string-match + (regexp-opt rcirc-bright-nicks + 'words) + sender)) + 'rcirc-bright-nick) + ((and rcirc-dim-nicks + (string-match + (regexp-opt rcirc-dim-nicks + 'words) + sender)) + 'rcirc-dim-nick) + (t + 'rcirc-other-nick))))))) + (?m (propertize text 'rcirc-text text)) + (?r response) + (?t (or target "")) + (t (concat "UNKNOWN CODE:" (match-string 0)))) + t t nil 0) + (rcirc-add-face (match-beginning 0) (match-end 0) face)) (rcirc-add-face start (match-beginning 0) face)) - (buffer-substring (point-min) (point-max)))) + (buffer-substring (point-min) (point-max)))) (defun rcirc-target-buffer (process sender response target _text) "Return a buffer to print the server response from SENDER. @@ -1869,17 +1863,17 @@ PROCESS is the process object for the current connection." (cl-assert (not (bufferp target))) (with-rcirc-process-buffer process (cond ((not target) - (rcirc-any-buffer process)) - ((not (rcirc-channel-p target)) - ;; message from another user - (if (or (string= response "PRIVMSG") - (string= response "ACTION")) - (rcirc-get-buffer-create process (if (string= sender rcirc-nick) - target - sender)) - (rcirc-get-buffer process target t))) - ((or (rcirc-get-buffer process target) - (rcirc-any-buffer process)))))) + (rcirc-any-buffer process)) + ((not (rcirc-channel-p target)) + ;; message from another user + (if (or (string= response "PRIVMSG") + (string= response "ACTION")) + (rcirc-get-buffer-create process (if (string= sender rcirc-nick) + target + sender)) + (rcirc-get-buffer process target t))) + ((or (rcirc-get-buffer process target) + (rcirc-any-buffer process)))))) (defvar-local rcirc-last-sender nil) (defvar-local rcirc-activity-types nil @@ -1908,11 +1902,11 @@ PROCESS is the process object for the current connection." "Return the line from the last activity from NICK in TARGET. PROCESS is the process object for the current connection." (let ((line (or (cdr (assoc-string target - (gethash nick (with-rcirc-server-buffer - rcirc-nick-table)) t)) - (rcirc-last-quit-line process nick target)))) + (gethash nick (with-rcirc-server-buffer + rcirc-nick-table)) t)) + (rcirc-last-quit-line process nick target)))) (if line - line + line ;;(message "line is nil for %s in %s" nick target) nil))) @@ -1921,7 +1915,7 @@ PROCESS is the process object for the current connection." PROCESS is the process object for the current connection." (let ((last-activity-line (rcirc-last-line process nick target))) (when (and last-activity-line - (> last-activity-line 0)) + (> last-activity-line 0)) (- rcirc-current-line last-activity-line)))) (defvar rcirc-markup-text-functions @@ -1945,33 +1939,33 @@ record activity. PROCESS is the process object for the current connection." (or text (setq text "")) (unless (and (or (member sender rcirc-ignore-list) - (member (with-syntax-table rcirc-nick-syntax-table - (when (string-match "^\\([^/]\\w*\\)[:,]" text) - (match-string 1 text))) - rcirc-ignore-list)) - ;; do not ignore if we sent the message - (not (string= sender (rcirc-nick process)))) + (member (with-syntax-table rcirc-nick-syntax-table + (when (string-match "^\\([^/]\\w*\\)[:,]" text) + (match-string 1 text))) + rcirc-ignore-list)) + ;; do not ignore if we sent the message + (not (string= sender (rcirc-nick process)))) (let* ((buffer (rcirc-target-buffer process sender response target text)) (time (if-let ((time (rcirc-get-tag "time"))) (parse-iso8601-time-string time) (current-time))) - (inhibit-read-only t)) + (inhibit-read-only t)) (with-current-buffer buffer - (let ((moving (= (point) rcirc-prompt-end-marker)) - (old-point (point-marker))) - - (setq text (decode-coding-string text rcirc-decode-coding-system)) - (unless (string= sender (rcirc-nick process)) - ;; mark the line with overlay arrow - (unless (or (marker-position overlay-arrow-position) - (get-buffer-window (current-buffer)) - (member response rcirc-omit-responses)) - (set-marker overlay-arrow-position - (marker-position rcirc-prompt-start-marker)))) - - ;; temporarily set the marker insertion-type because - ;; insert-before-markers results in hidden text in new buffers - (goto-char rcirc-prompt-start-marker) + (let ((moving (= (point) rcirc-prompt-end-marker)) + (old-point (point-marker))) + + (setq text (decode-coding-string text rcirc-decode-coding-system)) + (unless (string= sender (rcirc-nick process)) + ;; mark the line with overlay arrow + (unless (or (marker-position overlay-arrow-position) + (get-buffer-window (current-buffer)) + (member response rcirc-omit-responses)) + (set-marker overlay-arrow-position + (marker-position rcirc-prompt-start-marker)))) + + ;; temporarily set the marker insertion-type because + ;; insert-before-markers results in hidden text in new buffers + (goto-char rcirc-prompt-start-marker) (catch 'exit (while (not (bobp)) (goto-char (or (previous-single-property-change (point) 'hard) @@ -1981,8 +1975,8 @@ connection." (next-single-property-change (point) 'hard) (forward-char 1) (throw 'exit nil)))) - (set-marker-insertion-type rcirc-prompt-start-marker t) - (set-marker-insertion-type rcirc-prompt-end-marker t) + (set-marker-insertion-type rcirc-prompt-start-marker t) + (set-marker-insertion-type rcirc-prompt-end-marker t) ;; run markup functions (cl-assert (bolp)) @@ -1990,32 +1984,32 @@ connection." (save-restriction (narrow-to-region (point) (point)) (insert (propertize (rcirc-format-response-string process sender response - nil text) - 'rcirc-msgid (rcirc-get-tag "msgid")) - (propertize "\n" 'hard t)) + nil text) + 'rcirc-msgid (rcirc-get-tag "msgid")) + (propertize "\n" 'hard t)) ;; squeeze spaces out of text before rcirc-text (fill-region (point-min) (point-max)) (goto-char (or (next-single-property-change (point-min) 'rcirc-text) - (point))) - (when (rcirc-buffer-process) - (save-excursion (rcirc-markup-timestamp sender response)) - (dolist (fn rcirc-markup-text-functions) - (save-excursion (funcall fn sender response))) - (when rcirc-fill-flag - (save-excursion (rcirc-markup-fill sender response)))) - - (when rcirc-read-only-flag - (add-text-properties (point-min) (point-max) + (point))) + (when (rcirc-buffer-process) + (save-excursion (rcirc-markup-timestamp sender response)) + (dolist (fn rcirc-markup-text-functions) + (save-excursion (funcall fn sender response))) + (when rcirc-fill-flag + (save-excursion (rcirc-markup-fill sender response)))) + + (when rcirc-read-only-flag + (add-text-properties (point-min) (point-max) '(read-only t front-sticky t))) (add-text-properties (point-min) (point-max) (list 'rcirc-time time)) ;; make text omittable - (let ((last-activity-lines (rcirc-elapsed-lines process sender target))) - (if (and (not (string= (rcirc-nick process) sender)) + (let ((last-activity-lines (rcirc-elapsed-lines process sender target))) + (if (and (not (string= (rcirc-nick process) sender)) (or (member response rcirc-omit-responses) (and (member response rcirc-omit-unless-requested) (if (member response rcirc-pending-requests) @@ -2025,50 +2019,50 @@ connection." (or (member response rcirc-omit-unless-requested) (not last-activity-lines) (< rcirc-omit-threshold last-activity-lines))) - (put-text-property (point-min) (point-max) - 'invisible 'rcirc-omit) - ;; otherwise increment the line count - (setq rcirc-current-line (1+ rcirc-current-line)))))) - - (set-marker-insertion-type rcirc-prompt-start-marker nil) - (set-marker-insertion-type rcirc-prompt-end-marker nil) - - ;; truncate buffer if it is very long - (save-excursion - (when (and rcirc-buffer-maximum-lines - (> rcirc-buffer-maximum-lines 0) - (= (forward-line (- rcirc-buffer-maximum-lines)) 0)) - (delete-region (point-min) (point)))) - - ;; set the window point for buffers show in windows - (walk-windows (lambda (w) - (when (and (not (eq (selected-window) w)) - (eq (current-buffer) - (window-buffer w)) - (>= (window-point w) - rcirc-prompt-end-marker)) - (set-window-point w (point-max)))) - nil t) - - ;; restore the point - (goto-char (if moving rcirc-prompt-end-marker old-point))) - - ;; keep window on bottom line if it was already there - (when rcirc-scroll-show-maximum-output - (let ((window (get-buffer-window))) - (when window - (with-selected-window window - (when (eq major-mode 'rcirc-mode) - (when (<= (- (window-height) - (count-screen-lines (window-point) - (window-start)) - 1) - 0) - (recenter -1))))))) - - ;; flush undo (can we do something smarter here?) - (buffer-disable-undo) - (buffer-enable-undo) + (put-text-property (point-min) (point-max) + 'invisible 'rcirc-omit) + ;; otherwise increment the line count + (setq rcirc-current-line (1+ rcirc-current-line)))))) + + (set-marker-insertion-type rcirc-prompt-start-marker nil) + (set-marker-insertion-type rcirc-prompt-end-marker nil) + + ;; truncate buffer if it is very long + (save-excursion + (when (and rcirc-buffer-maximum-lines + (> rcirc-buffer-maximum-lines 0) + (= (forward-line (- rcirc-buffer-maximum-lines)) 0)) + (delete-region (point-min) (point)))) + + ;; set the window point for buffers show in windows + (walk-windows (lambda (w) + (when (and (not (eq (selected-window) w)) + (eq (current-buffer) + (window-buffer w)) + (>= (window-point w) + rcirc-prompt-end-marker)) + (set-window-point w (point-max)))) + nil t) + + ;; restore the point + (goto-char (if moving rcirc-prompt-end-marker old-point))) + + ;; keep window on bottom line if it was already there + (when rcirc-scroll-show-maximum-output + (let ((window (get-buffer-window))) + (when window + (with-selected-window window + (when (eq major-mode 'rcirc-mode) + (when (<= (- (window-height) + (count-screen-lines (window-point) + (window-start)) + 1) + 0) + (recenter -1))))))) + + ;; flush undo (can we do something smarter here?) + (buffer-disable-undo) + (buffer-enable-undo) ;; record mode line activity (when (and activity @@ -2076,16 +2070,16 @@ connection." (not (and rcirc-dim-nicks sender (string-match (regexp-opt rcirc-dim-nicks) sender) (rcirc-channel-p target)))) - (rcirc-record-activity (current-buffer) - (when (not (rcirc-channel-p rcirc-target)) - 'nick))) + (rcirc-record-activity (current-buffer) + (when (not (rcirc-channel-p rcirc-target)) + 'nick))) (when (and rcirc-log-flag (or target rcirc-log-process-buffers)) (rcirc-log process sender response target text)) - (sit-for 0) ; displayed text before hook + (sit-for 0) ; displayed text before hook (run-hook-with-args 'rcirc-print-functions process sender response target text))))) @@ -2127,15 +2121,15 @@ disk. PROCESS is the process object for the current connection." (parse-iso8601-time-string time)))) (unless (null filename) (let ((cell (assoc-string filename rcirc-log-alist)) - (line (concat (format-time-string rcirc-time-format time) - (substring-no-properties - (rcirc-format-response-string process sender - response target text)) - "\n"))) - (if cell - (setcdr cell (concat (cdr cell) line)) - (setq rcirc-log-alist - (cons (cons filename line) rcirc-log-alist))))))) + (line (concat (format-time-string rcirc-time-format time) + (substring-no-properties + (rcirc-format-response-string process sender + response target text)) + "\n"))) + (if cell + (setcdr cell (concat (cdr cell) line)) + (setq rcirc-log-alist + (cons (cons filename line) rcirc-log-alist))))))) (defun rcirc-log-write () "Flush `rcirc-log-alist' data to disk. @@ -2146,11 +2140,11 @@ log-files with absolute names (see `rcirc-log-filename-function')." (let ((filename (convert-standard-filename (expand-file-name (car cell) rcirc-log-directory))) - (coding-system-for-write 'utf-8)) + (coding-system-for-write 'utf-8)) (make-directory (file-name-directory filename) t) (with-temp-buffer - (insert (cdr cell)) - (write-region (point-min) (point-max) filename t 'quiet)))) + (insert (cdr cell)) + (write-region (point-min) (point-max) filename t 'quiet)))) (setq rcirc-log-alist nil)) (defun rcirc-view-log-file () @@ -2158,8 +2152,8 @@ log-files with absolute names (see `rcirc-log-filename-function')." (interactive) (find-file-other-window (expand-file-name (funcall rcirc-log-filename-function - (rcirc-buffer-process) rcirc-target) - rcirc-log-directory))) + (rcirc-buffer-process) rcirc-target) + rcirc-log-directory))) (defun rcirc-join-channels (process channels) "Join CHANNELS. @@ -2167,7 +2161,7 @@ PROCESS is the process object for the current connection." (save-window-excursion (dolist (channel channels) (with-rcirc-process-buffer process - (rcirc-cmd-join channel process))))) + (rcirc-cmd-join channel process))))) ;;; nick management (defvar rcirc-nick-prefix-chars '(?~ ?& ?@ ?% ?+) @@ -2177,9 +2171,9 @@ PROCESS is the process object for the current connection." "Return the nick from USER. Remove any non-nick junk." (save-match-data (if (string-match (concat "^[" rcirc-nick-prefix-chars - "]*\\([^! ]+\\)!?") + "]*\\([^! ]+\\)!?") (or user "")) - (match-string 1 user) + (match-string 1 user) user))) (defun rcirc-nick-channels (process nick) @@ -2187,7 +2181,7 @@ PROCESS is the process object for the current connection." PROCESS is the process object for the current connection." (with-rcirc-process-buffer process (mapcar (lambda (x) (car x)) - (gethash nick rcirc-nick-table)))) + (gethash nick rcirc-nick-table)))) (defun rcirc-put-nick-channel (process nick channel &optional line) "Add CHANNEL to list associated with NICK. @@ -2198,12 +2192,12 @@ to zero. PROCESS is the process object for the current connection." (let ((nick (rcirc-user-nick nick))) (with-rcirc-process-buffer process (let* ((chans (gethash nick rcirc-nick-table)) - (record (assoc-string channel chans t))) - (if record - (when line (setcdr record line)) - (puthash nick (cons (cons channel (or line 0)) - chans) - rcirc-nick-table)))))) + (record (assoc-string channel chans t))) + (if record + (when line (setcdr record line)) + (puthash nick (cons (cons channel (or line 0)) + chans) + rcirc-nick-table)))))) (defun rcirc-nick-remove (process nick) "Remove NICK from table. @@ -2217,11 +2211,11 @@ PROCESS is the process object for the current connection." (with-rcirc-process-buffer process (let* ((chans (gethash nick rcirc-nick-table)) (newchans - ;; instead of assoc-string-delete-all: - (let ((record (assoc-string channel chans t))) - (when record - (setcar record 'delete) - (assq-delete-all 'delete chans))))) + ;; instead of assoc-string-delete-all: + (let ((record (assoc-string channel chans t))) + (when record + (setcar record 'delete) + (assq-delete-all 'delete chans))))) (if newchans (puthash nick newchans rcirc-nick-table) (remhash nick rcirc-nick-table))))) @@ -2231,19 +2225,19 @@ PROCESS is the process object for the current connection." PROCESS is the process object for the current connection." (when target (if (rcirc-channel-p target) - (with-rcirc-process-buffer process - (let (nicks) - (maphash - (lambda (k v) - (let ((record (assoc-string target v t))) - (if record - (setq nicks (cons (cons k (cdr record)) nicks))))) - rcirc-nick-table) - (mapcar (lambda (x) (car x)) - (sort nicks (lambda (x y) - (let ((lx (or (cdr x) 0)) - (ly (or (cdr y) 0))) - (< ly lx))))))) + (with-rcirc-process-buffer process + (let (nicks) + (maphash + (lambda (k v) + (let ((record (assoc-string target v t))) + (if record + (setq nicks (cons (cons k (cdr record)) nicks))))) + rcirc-nick-table) + (mapcar (lambda (x) (car x)) + (sort nicks (lambda (x y) + (let ((lx (or (cdr x) 0)) + (ly (or (cdr y) 0))) + (< ly lx))))))) (list target)))) (defun rcirc-ignore-update-automatic (nick) @@ -2251,10 +2245,10 @@ PROCESS is the process object for the current connection." If so, remove from `rcirc-ignore-list'. PROCESS is the process object for the current connection." (when (member nick rcirc-ignore-list-automatic) - (setq rcirc-ignore-list-automatic - (delete nick rcirc-ignore-list-automatic) - rcirc-ignore-list - (delete nick rcirc-ignore-list)))) + (setq rcirc-ignore-list-automatic + (delete nick rcirc-ignore-list-automatic) + rcirc-ignore-list + (delete nick rcirc-ignore-list)))) (defun rcirc-nickname< (s1 s2) "Return non-nil if IRC nickname S1 is less than S2, and nil otherwise. @@ -2300,15 +2294,15 @@ This function does not alter the INPUT string." ;; toggle the mode-line channel indicator (if rcirc-track-minor-mode (progn - (and (not (memq 'rcirc-activity-string global-mode-string)) - (setq global-mode-string - (append global-mode-string '(rcirc-activity-string)))) - (add-hook 'window-configuration-change-hook - 'rcirc-window-configuration-change)) + (and (not (memq 'rcirc-activity-string global-mode-string)) + (setq global-mode-string + (append global-mode-string '(rcirc-activity-string)))) + (add-hook 'window-configuration-change-hook + 'rcirc-window-configuration-change)) (setq global-mode-string - (delete 'rcirc-activity-string global-mode-string)) + (delete 'rcirc-activity-string global-mode-string)) (remove-hook 'window-configuration-change-hook - 'rcirc-window-configuration-change))) + 'rcirc-window-configuration-change))) (add-to-list 'minor-mode-alist '(rcirc-ignore-buffer-activity-flag " Ignore")) (add-to-list 'minor-mode-alist '(rcirc-low-priority-flag " LowPri")) @@ -2317,20 +2311,20 @@ This function does not alter the INPUT string." "Toggle the value of `rcirc-ignore-buffer-activity-flag'." (interactive) (setq rcirc-ignore-buffer-activity-flag - (not rcirc-ignore-buffer-activity-flag)) + (not rcirc-ignore-buffer-activity-flag)) (message (if rcirc-ignore-buffer-activity-flag - "Ignore activity in this buffer" - "Notice activity in this buffer")) + "Ignore activity in this buffer" + "Notice activity in this buffer")) (force-mode-line-update)) (defun rcirc-toggle-low-priority () "Toggle the value of `rcirc-low-priority-flag'." (interactive) (setq rcirc-low-priority-flag - (not rcirc-low-priority-flag)) + (not rcirc-low-priority-flag)) (message (if rcirc-low-priority-flag - "Activity in this buffer is low priority" - "Activity in this buffer is normal priority")) + "Activity in this buffer is low priority" + "Activity in this buffer is normal priority")) (force-mode-line-update)) (defun rcirc-switch-to-server-buffer () @@ -2358,14 +2352,14 @@ This function does not alter the INPUT string." With prefix ARG, go to the next low priority buffer with activity." (interactive "P") (let* ((pair (rcirc-split-activity rcirc-activity)) - (lopri (car pair)) - (hipri (cdr pair))) + (lopri (car pair)) + (hipri (cdr pair))) (if (or (and (not arg) hipri) - (and arg lopri)) - (progn - (switch-to-buffer (car (if arg lopri hipri))) - (when (> (point) rcirc-prompt-start-marker) - (recenter -1))) + (and arg lopri)) + (progn + (switch-to-buffer (car (if arg lopri hipri))) + (when (> (point) rcirc-prompt-start-marker) + (recenter -1))) (rcirc-bury-buffers) (message "No IRC activity.%s" (if lopri @@ -2375,8 +2369,6 @@ With prefix ARG, go to the next low priority buffer with activity." "")))) (rcirc-update-activity-string)) -(define-obsolete-variable-alias 'rcirc-activity-hooks - 'rcirc-activity-functions "24.3") (defvar rcirc-activity-functions nil "Hook to be run when there is channel activity. @@ -2388,21 +2380,21 @@ activity. Only run if the buffer is not visible and "Record BUFFER activity with TYPE." (with-current-buffer buffer (let ((old-activity rcirc-activity) - (old-types rcirc-activity-types)) + (old-types rcirc-activity-types)) (when (and (not (get-buffer-window (current-buffer) t)) (not (and rcirc-track-ignore-server-buffer-flag (eq rcirc-server-buffer (current-buffer))))) - (setq rcirc-activity - (sort (if (memq (current-buffer) rcirc-activity) rcirc-activity + (setq rcirc-activity + (sort (if (memq (current-buffer) rcirc-activity) rcirc-activity (cons (current-buffer) rcirc-activity)) - (lambda (b1 b2) - (let ((t1 (buffer-local-value 'rcirc-last-post-time b1)) - (t2 (buffer-local-value 'rcirc-last-post-time b2))) - (time-less-p t2 t1))))) - (cl-pushnew type rcirc-activity-types) - (unless (and (equal rcirc-activity old-activity) - (member type old-types)) - (rcirc-update-activity-string))))) + (lambda (b1 b2) + (let ((t1 (buffer-local-value 'rcirc-last-post-time b1)) + (t2 (buffer-local-value 'rcirc-last-post-time b2))) + (time-less-p t2 t1))))) + (cl-pushnew type rcirc-activity-types) + (unless (and (equal rcirc-activity old-activity) + (member type old-types)) + (rcirc-update-activity-string))))) (run-hook-with-args 'rcirc-activity-functions buffer)) (defun rcirc-clear-activity (buffer) @@ -2422,10 +2414,10 @@ activity. Only run if the buffer is not visible and (let (lopri hipri) (dolist (buf activity) (with-current-buffer buf - (if (and rcirc-low-priority-flag - (not (member 'nick rcirc-activity-types))) - (push buf lopri) - (push buf hipri)))) + (if (and rcirc-low-priority-flag + (not (member 'nick rcirc-activity-types))) + (push buf lopri) + (push buf hipri)))) (cons (nreverse lopri) (nreverse hipri)))) (defvar rcirc-update-activity-string-hook nil @@ -2434,33 +2426,33 @@ activity. Only run if the buffer is not visible and (defun rcirc-update-activity-string () "Update mode-line string." (let* ((pair (rcirc-split-activity rcirc-activity)) - (lopri (car pair)) - (hipri (cdr pair))) + (lopri (car pair)) + (hipri (cdr pair))) (setq rcirc-activity-string - (cond ((or hipri lopri) - (concat (and hipri "[") - (rcirc-activity-string hipri) - (and hipri lopri ",") - (and lopri - (concat "(" - (rcirc-activity-string lopri) - ")")) - (and hipri "]"))) - ((not (null (rcirc-process-list))) - "[]") - (t "[]"))) + (cond ((or hipri lopri) + (concat (and hipri "[") + (rcirc-activity-string hipri) + (and hipri lopri ",") + (and lopri + (concat "(" + (rcirc-activity-string lopri) + ")")) + (and hipri "]"))) + ((not (null (rcirc-process-list))) + "[]") + (t "[]"))) (run-hooks 'rcirc-update-activity-string-hook) (force-mode-line-update t))) (defun rcirc-activity-string (buffers) "Generate activity string for all BUFFERS." (mapconcat (lambda (b) - (let ((s (substring-no-properties (rcirc-short-buffer-name b)))) - (with-current-buffer b - (dolist (type rcirc-activity-types) + (let ((s (substring-no-properties (rcirc-short-buffer-name b)))) + (with-current-buffer b + (dolist (type rcirc-activity-types) (rcirc-facify s (cl-case type - (nick 'rcirc-track-nick) - (keyword 'rcirc-track-keyword))))) + (nick 'rcirc-track-nick) + (keyword 'rcirc-track-keyword))))) (let ((map (make-mode-line-mouse-map 'mouse-1 (lambda () @@ -2469,7 +2461,7 @@ activity. Only run if the buffer is not visible and (propertize s 'mouse-face 'mode-line-highlight 'local-map map)))) - buffers ",")) + buffers ",")) (defun rcirc-short-buffer-name (buffer) "Return a short name for BUFFER to use in the mode line indicator." @@ -2485,9 +2477,9 @@ activity. Only run if the buffer is not visible and "Return a list of the visible buffers that are in `rcirc-mode'." (let (acc) (walk-windows (lambda (w) - (with-current-buffer (window-buffer w) - (when (eq major-mode 'rcirc-mode) - (push (current-buffer) acc))))) + (with-current-buffer (window-buffer w) + (when (eq major-mode 'rcirc-mode) + (push (current-buffer) acc))))) acc)) (defvar rcirc-visible-buffers nil @@ -2501,7 +2493,7 @@ activity. Only run if the buffer is not visible and (defun rcirc-window-configuration-change-1 () "Clear activity and overlay arrows." (let* ((old-activity rcirc-activity) - (hidden-buffers rcirc-visible-buffers)) + (hidden-buffers rcirc-visible-buffers)) (setq rcirc-visible-buffers (rcirc-visible-buffers)) @@ -2516,8 +2508,8 @@ activity. Only run if the buffer is not visible and ;; remove any killed buffers from list (setq rcirc-activity - (delq nil (mapcar (lambda (buf) (when (buffer-live-p buf) buf)) - rcirc-activity))) + (delq nil (mapcar (lambda (buf) (when (buffer-live-p buf) buf)) + rcirc-activity))) ;; update the mode-line string (unless (equal old-activity rcirc-activity) (rcirc-update-activity-string)))) @@ -2527,14 +2519,14 @@ activity. Only run if the buffer is not visible and (defun rcirc-update-short-buffer-names () "Update variable `rcirc-short-buffer-name' for IRC buffers." (let ((bufalist - (apply 'append (mapcar (lambda (process) - (with-rcirc-process-buffer process - rcirc-buffer-alist)) - (rcirc-process-list))))) + (apply 'append (mapcar (lambda (process) + (with-rcirc-process-buffer process + rcirc-buffer-alist)) + (rcirc-process-list))))) (dolist (i (rcirc-abbreviate bufalist)) (when (buffer-live-p (cdr i)) - (with-current-buffer (cdr i) - (setq rcirc-short-buffer-name (car i))))))) + (with-current-buffer (cdr i) + (setq rcirc-short-buffer-name (car i))))))) (defun rcirc-abbreviate (pairs) "Generate alist of abbreviated buffer names to buffers. @@ -2548,12 +2540,12 @@ values, from each process." acc) (dolist (x (cdr tree)) (if (listp x) - (setq acc (append acc - (mapcar (lambda (y) - (cons (concat ch (car y)) - (cdr y))) - (rcirc-rebuild-tree x)))) - (setq acc (cons (cons ch x) acc)))) + (setq acc (append acc + (mapcar (lambda (y) + (cons (concat ch (car y)) + (cdr y))) + (rcirc-rebuild-tree x)))) + (setq acc (cons (cons ch x) acc)))) acc)) (defun rcirc-make-trees (pairs) @@ -2565,31 +2557,31 @@ prefix could be found or another tree if it shares the same prefix with another element in PAIRS." (let (alist) (mapc (lambda (pair) - (if (consp pair) - (let* ((str (car pair)) - (data (cdr pair)) - (char (unless (zerop (length str)) - (aref str 0))) - (rest (unless (zerop (length str)) - (substring str 1))) - (part (if char (assq char alist)))) - (if part - ;; existing partition - (setcdr part (cons (cons rest data) (cdr part))) - ;; new partition - (setq alist (cons (if char - (list char (cons rest data)) - data) - alist)))) - (setq alist (cons pair alist)))) - pairs) + (if (consp pair) + (let* ((str (car pair)) + (data (cdr pair)) + (char (unless (zerop (length str)) + (aref str 0))) + (rest (unless (zerop (length str)) + (substring str 1))) + (part (if char (assq char alist)))) + (if part + ;; existing partition + (setcdr part (cons (cons rest data) (cdr part))) + ;; new partition + (setq alist (cons (if char + (list char (cons rest data)) + data) + alist)))) + (setq alist (cons pair alist)))) + pairs) ;; recurse into cdrs of alist (mapc (lambda (x) - (when (and (listp x) (listp (cadr x))) - (setcdr x (if (> (length (cdr x)) 1) - (rcirc-make-trees (cdr x)) - (setcdr x (list (cdadr x))))))) - alist))) + (when (and (listp x) (listp (cadr x))) + (setcdr x (if (> (length (cdr x)) 1) + (rcirc-make-trees (cdr x)) + (setcdr x (list (cdadr x))))))) + alist))) ;;; /commands these are called with 3 args: PROCESS, TARGET, which is ;; the current buffer/channel/user, and ARGS, which is a string @@ -2666,7 +2658,7 @@ that, an interactive form can specified." "Send MESSAGE to CHAN-OR-NICK." (interactive (list (completing-read "Message nick: " (with-rcirc-server-buffer - rcirc-nick-table)) + rcirc-nick-table)) (read-string "Message: "))) (rcirc-send-message process chan-or-nick message)) @@ -2677,7 +2669,7 @@ that, an interactive form can specified." rcirc-nick-table)))) (let ((existing-buffer (rcirc-get-buffer process nick))) (switch-to-buffer (or existing-buffer - (rcirc-get-buffer-create process nick))) + (rcirc-get-buffer-create process nick))) (when (not existing-buffer) (rcirc-cmd-whois nick)))) @@ -2699,7 +2691,7 @@ CHANNELS is a comma- or space-separated string of channel names." "Invite NICK to CHANNEL." (interactive (list (completing-read "Invite nick: " - (with-rcirc-server-buffer rcirc-nick-table)) + (with-rcirc-server-buffer rcirc-nick-table)) (read-string "Channel: "))) (rcirc-send-string process "INVITE" nick channel)) @@ -2778,8 +2770,8 @@ With a prefix arg, prompt for new topic." (interactive (list (completing-read "Kick nick: " (rcirc-channel-nicks - (rcirc-buffer-process) - rcirc-target)) + (rcirc-buffer-process) + rcirc-target)) (read-from-minibuffer "Kick reason: "))) (rcirc-send-string process "KICK" target nick : reason)) @@ -2811,9 +2803,9 @@ PROCESS is the process object for the current connection." "Toggle membership of ELEMENTS in SET." (dolist (elt elements) (if (and elt (not (string= "" elt))) - (setq set (if (member-ignore-case elt set) - (delete elt set) - (cons elt set))))) + (setq set (if (member-ignore-case elt set) + (delete elt set) + (cons elt set))))) set) @@ -2824,33 +2816,33 @@ nicks when no NICK is given. When listing ignored nicks, the ones added to the list automatically are marked with an asterisk." (interactive "sToggle ignoring of nick: ") (setq rcirc-ignore-list - (apply #'rcirc-add-or-remove rcirc-ignore-list - (split-string nick nil t))) + (apply #'rcirc-add-or-remove rcirc-ignore-list + (split-string nick nil t))) (rcirc-print process nil "IGNORE" target - (mapconcat - (lambda (nick) - (concat nick - (if (member nick rcirc-ignore-list-automatic) - "*" ""))) - rcirc-ignore-list " "))) + (mapconcat + (lambda (nick) + (concat nick + (if (member nick rcirc-ignore-list-automatic) + "*" ""))) + rcirc-ignore-list " "))) (rcirc-define-command bright (nick) "Manage the bright nick list." (interactive "sToggle emphasis of nick: ") (setq rcirc-bright-nicks - (apply #'rcirc-add-or-remove rcirc-bright-nicks - (split-string nick nil t))) + (apply #'rcirc-add-or-remove rcirc-bright-nicks + (split-string nick nil t))) (rcirc-print process nil "BRIGHT" target - (mapconcat 'identity rcirc-bright-nicks " "))) + (mapconcat 'identity rcirc-bright-nicks " "))) (rcirc-define-command dim (nick) "Manage the dim nick list." (interactive "sToggle deemphasis of nick: ") (setq rcirc-dim-nicks - (apply #'rcirc-add-or-remove rcirc-dim-nicks - (split-string nick nil t))) + (apply #'rcirc-add-or-remove rcirc-dim-nicks + (split-string nick nil t))) (rcirc-print process nil "DIM" target - (mapconcat 'identity rcirc-dim-nicks " "))) + (mapconcat 'identity rcirc-dim-nicks " "))) (rcirc-define-command keyword (keyword) "Manage the keyword list. @@ -2858,24 +2850,24 @@ Mark KEYWORD, unmark KEYWORD if already marked, or list marked keywords when no KEYWORD is given." (interactive "sToggle highlighting of keyword: ") (setq rcirc-keywords - (apply #'rcirc-add-or-remove rcirc-keywords - (split-string keyword nil t))) + (apply #'rcirc-add-or-remove rcirc-keywords + (split-string keyword nil t))) (rcirc-print process nil "KEYWORD" target - (mapconcat 'identity rcirc-keywords " "))) + (mapconcat 'identity rcirc-keywords " "))) (defun rcirc-add-face (start end name &optional object) "Add face NAME to the face text property of the text from START to END." (when name (let ((pos start) - next prop) + next prop) (while (< pos end) - (setq prop (get-text-property pos 'font-lock-face object) - next (next-single-property-change pos 'font-lock-face object end)) - (unless (member name (get-text-property pos 'font-lock-face object)) - (add-text-properties pos next - (list 'font-lock-face (cons name prop)) object)) - (setq pos next))))) + (setq prop (get-text-property pos 'font-lock-face object) + next (next-single-property-change pos 'font-lock-face object end)) + (unless (member name (get-text-property pos 'font-lock-face object)) + (add-text-properties pos next + (list 'font-lock-face (cons name prop)) object)) + (setq pos next))))) (defun rcirc-facify (string face) "Return a copy of STRING with FACE property added." @@ -2917,7 +2909,7 @@ If ARG is given, opens the URL in a new browser window." (let ((time (and-let* ((time (rcirc-get-tag "time"))) (parse-iso8601-time-string time)))) (insert (rcirc-facify (format-time-string rcirc-time-format time) - 'rcirc-timestamp)))) + 'rcirc-timestamp)))) (defun rcirc-markup-attributes (_sender _response) "Highlight IRC markup, indicated by ASCII control codes." @@ -2974,10 +2966,10 @@ If ARG is given, opens the URL in a new browser window." ((<= 0 bg (1- (length rcirc-color-codes))))) (setq background (aref rcirc-color-codes bg))) (rcirc-add-face (match-beginning 0) (match-end 0) - `(face (:foreground - ,foreground - :background - ,background)))))) + `(face (:foreground + ,foreground + :background + ,background)))))) (defun rcirc-remove-markup-codes (_sender _response) "Remove ASCII control codes used to designate markup." @@ -2993,16 +2985,16 @@ If RESPONSE indicates that the nick was mentioned in a message, highlight the entire line and record the activity." (with-syntax-table rcirc-nick-syntax-table (while (re-search-forward (concat "\\b" - (regexp-quote (rcirc-nick - (rcirc-buffer-process))) - "\\b") - nil t) + (regexp-quote (rcirc-nick + (rcirc-buffer-process))) + "\\b") + nil t) (rcirc-add-face (match-beginning 0) (match-end 0) - 'rcirc-nick-in-message) + 'rcirc-nick-in-message) (when (string= response "PRIVMSG") - (rcirc-add-face (point-min) (point-max) - 'rcirc-nick-in-message-full-line) - (rcirc-record-activity (current-buffer) 'nick))))) + (rcirc-add-face (point-min) (point-max) + 'rcirc-nick-in-message-full-line) + (rcirc-record-activity (current-buffer) 'nick))))) (defun rcirc-markup-urls (_sender _response) "Highlight and activate URLs." @@ -3018,11 +3010,11 @@ highlight the entire line and record the activity." ;; rather than `make-button', as text-buttons are much faster in ;; large buffers. (make-text-button start (point) - 'face 'rcirc-url - 'follow-link t - 'rcirc-url url - 'action (lambda (button) - (browse-url-button-open-url + 'face 'rcirc-url + 'follow-link t + 'rcirc-url url + 'action (lambda (button) + (browse-url-button-open-url (button-get button 'rcirc-url)))) ;; Record the URL if it is not already the latest stored URL. (unless (string= url (caar rcirc-urls)) @@ -3034,42 +3026,42 @@ Keywords are only highlighted in messages (as indicated by RESPONSE) when they were not written by the user (as indicated by SENDER)." (when (and (string= response "PRIVMSG") - (not (string= sender (rcirc-nick (rcirc-buffer-process))))) + (not (string= sender (rcirc-nick (rcirc-buffer-process))))) (let* ((target (or rcirc-target "")) - (keywords (delq nil (mapcar (lambda (keyword) - (when (not (string-match keyword - target)) - keyword)) - rcirc-keywords)))) + (keywords (delq nil (mapcar (lambda (keyword) + (when (not (string-match keyword + target)) + keyword)) + rcirc-keywords)))) (when keywords - (while (re-search-forward (regexp-opt keywords 'words) nil t) - (rcirc-add-face (match-beginning 0) (match-end 0) 'rcirc-keyword) - (rcirc-record-activity (current-buffer) 'keyword)))))) + (while (re-search-forward (regexp-opt keywords 'words) nil t) + (rcirc-add-face (match-beginning 0) (match-end 0) 'rcirc-keyword) + (rcirc-record-activity (current-buffer) 'keyword)))))) (defun rcirc-markup-bright-nicks (_sender response) "Highlight nicks brightly as specified by `rcirc-bright-nicks'. This highlighting only takes place in name lists (as indicated by RESPONSE)." (when (and rcirc-bright-nicks - (string= response "NAMES")) + (string= response "NAMES")) (with-syntax-table rcirc-nick-syntax-table (while (re-search-forward (regexp-opt rcirc-bright-nicks 'words) nil t) - (rcirc-add-face (match-beginning 0) (match-end 0) - 'rcirc-bright-nick))))) + (rcirc-add-face (match-beginning 0) (match-end 0) + 'rcirc-bright-nick))))) (defun rcirc-markup-fill (_sender response) "Fill messages as configured by `rcirc-fill-column'. MOTD messages are not filled (as indicated by RESPONSE)." - (when (not (string= response "372")) ; /motd + (when (not (string= response "372")) ; /motd (let ((fill-prefix - (or rcirc-fill-prefix - (make-string (- (point) (line-beginning-position)) ?\s))) - (fill-column (- (cond ((null rcirc-fill-column) fill-column) + (or rcirc-fill-prefix + (make-string (- (point) (line-beginning-position)) ?\s))) + (fill-column (- (cond ((null rcirc-fill-column) fill-column) ((functionp rcirc-fill-column) - (funcall rcirc-fill-column)) - (t rcirc-fill-column)) - ;; make sure ... doesn't cause line wrapping - 3))) + (funcall rcirc-fill-column)) + (t rcirc-fill-column)) + ;; make sure ... doesn't cause line wrapping + 3))) (fill-region (point) (point-max) nil t)))) ;;; handlers @@ -3098,7 +3090,7 @@ PROCESS is the process object for the current connection." (setq auth-required t))))) (if rcirc-authenticate-before-join (progn - (add-hook 'rcirc-authenticated-hook 'rcirc-join-channels-post-auth t t) + (add-hook 'rcirc-authenticated-hook 'rcirc-join-channels-post-auth t t) (rcirc-authenticate)) (rcirc-authenticate) (rcirc-join-channels process rcirc-startup-channels)) @@ -3137,18 +3129,18 @@ PROCESS is the process object for the current connection." (message (cadr args))) (if (string-match "^\C-a\\(.*\\)\C-a$" message) (rcirc-handler-CTCP-response process target sender - (match-string 1 message)) + (match-string 1 message)) (rcirc-print process sender "NOTICE" - (cond ((rcirc-channel-p target) - target) + (cond ((rcirc-channel-p target) + target) ;; -ChanServ- [#gnu] Welcome... - ((string-match "\\[\\(#[^] ]+\\)\\]" message) - (match-string 1 message)) - (sender - (if (string= sender (rcirc-server-name process)) - nil ; server notice - sender))) - message t)))) + ((string-match "\\[\\(#[^] ]+\\)\\]" message) + (match-string 1 message)) + (sender + (if (string= sender (rcirc-server-name process)) + nil ; server notice + sender))) + message t)))) (defun rcirc-check-auth-status (process sender args _text) "Check if the user just authenticated. @@ -3200,10 +3192,10 @@ connection." (with-current-buffer (rcirc-get-buffer-create process channel) ;; when recently rejoining, restore the linestamp (rcirc-put-nick-channel process sender channel - (let ((last-activity-lines - (rcirc-elapsed-lines process sender channel))) - (when (and last-activity-lines - (< last-activity-lines rcirc-omit-threshold)) + (let ((last-activity-lines + (rcirc-elapsed-lines process sender channel))) + (when (and last-activity-lines + (< last-activity-lines rcirc-omit-threshold)) (rcirc-last-line process sender channel)))) ;; reset mode-line-process in case joining a channel with an ;; already open buffer (after getting kicked e.g.) @@ -3223,25 +3215,25 @@ PROCESS is the process object for the current connection." (if (not (string= nick (rcirc-nick process))) ;; this is someone else leaving (progn - (rcirc-maybe-remember-nick-quit process nick channel) - (rcirc-remove-nick-channel process nick channel)) + (rcirc-maybe-remember-nick-quit process nick channel) + (rcirc-remove-nick-channel process nick channel)) ;; this is us leaving (mapc (lambda (n) - (rcirc-remove-nick-channel process n channel)) - (rcirc-channel-nicks process channel)) + (rcirc-remove-nick-channel process n channel)) + (rcirc-channel-nicks process channel)) ;; if the buffer is still around, make it inactive (let ((buffer (rcirc-get-buffer process channel))) (when buffer - (rcirc-disconnect-buffer buffer))))) + (rcirc-disconnect-buffer buffer))))) (defun rcirc-handler-PART (process sender args _text) "Handle PART message from SENDER. ARGS should have the form (CHANNEL REASON). PROCESS is the process object for the current connection." (let* ((channel (car args)) - (reason (cadr args)) - (message (concat channel " " reason))) + (reason (cadr args)) + (message (concat channel " " reason))) (rcirc-print process sender "PART" (funcall rcirc-channel-filter channel) message) ;; print in private chat buffer if it exists (when (rcirc-get-buffer (rcirc-buffer-process) sender) @@ -3254,9 +3246,9 @@ PROCESS is the process object for the current connection." ARGS should have the form (CHANNEL NICK REASON). PROCESS is the process object for the current connection." (let* ((channel (car args)) - (nick (cadr args)) - (reason (nth 2 args)) - (message (concat nick " " channel " " reason))) + (nick (cadr args)) + (reason (nth 2 args)) + (message (concat nick " " channel " " reason))) (rcirc-print process sender "KICK" (funcall rcirc-channel-filter channel) message t) ;; print in private chat buffer if it exists (when (rcirc-get-buffer (rcirc-buffer-process) nick) @@ -3269,28 +3261,28 @@ PROCESS is the process object for the current connection." PROCESS is the process object for the current connection." (let ((elapsed-lines (rcirc-elapsed-lines process nick channel))) (when (and elapsed-lines - (< elapsed-lines rcirc-omit-threshold)) + (< elapsed-lines rcirc-omit-threshold)) (let ((buffer (rcirc-get-buffer process channel))) - (when buffer - (with-current-buffer buffer - (let ((record (assoc-string nick rcirc-recent-quit-alist t)) - (line (rcirc-last-line process nick channel))) - (if record - (setcdr record line) - (setq rcirc-recent-quit-alist - (cons (cons nick line) - rcirc-recent-quit-alist)))))))))) + (when buffer + (with-current-buffer buffer + (let ((record (assoc-string nick rcirc-recent-quit-alist t)) + (line (rcirc-last-line process nick channel))) + (if record + (setcdr record line) + (setq rcirc-recent-quit-alist + (cons (cons nick line) + rcirc-recent-quit-alist)))))))))) (defun rcirc-handler-QUIT (process sender args _text) "Handle QUIT message from SENDER. PROCESS is the process object for the current connection." (rcirc-ignore-update-automatic sender) (mapc (lambda (channel) - ;; broadcast quit message each channel - (rcirc-print process sender "QUIT" (funcall rcirc-channel-filter channel) (apply 'concat args)) - ;; record nick in quit table if they recently spoke - (rcirc-maybe-remember-nick-quit process sender channel)) - (rcirc-nick-channels process sender)) + ;; broadcast quit message each channel + (rcirc-print process sender "QUIT" (funcall rcirc-channel-filter channel) (apply 'concat args)) + ;; record nick in quit table if they recently spoke + (rcirc-maybe-remember-nick-quit process sender channel)) + (rcirc-nick-channels process sender)) (rcirc-nick-remove process sender)) (defun rcirc-handler-NICK (process sender args _text) @@ -3311,9 +3303,9 @@ PROCESS is the process object for the current connection." ;; update chat buffer, if it exists (when-let ((chat-buffer (rcirc-get-buffer process old-nick))) (with-current-buffer chat-buffer - (rcirc-print process sender "NICK" old-nick new-nick) - (setq rcirc-target new-nick) - (rename-buffer (rcirc-generate-new-buffer-name process new-nick) t)) + (rcirc-print process sender "NICK" old-nick new-nick) + (setq rcirc-target new-nick) + (rename-buffer (rcirc-generate-new-buffer-name process new-nick) t)) (setf rcirc-buffer-alist (cons (cons new-nick chat-buffer) (delq (assoc-string old-nick rcirc-buffer-alist t) @@ -3326,7 +3318,7 @@ PROCESS is the process object for the current connection." ;; if this is our nick... (when (string= old-nick rcirc-nick) (setq rcirc-nick new-nick) - (rcirc-update-prompt t) + (rcirc-update-prompt t) ;; reauthenticate (when rcirc-auto-authenticate-flag (rcirc-authenticate)))))) @@ -3356,16 +3348,16 @@ PROCESS is the process object for the current connection." ARGS should have the form (NICK AWAY-MESSAGE). PROCESS is the process object for the current connection." (let* ((nick (cadr args)) - (rec (assoc-string nick rcirc-nick-away-alist)) - (away-message (nth 2 args))) + (rec (assoc-string nick rcirc-nick-away-alist)) + (away-message (nth 2 args))) (when (or (not rec) - (not (string= (cdr rec) away-message))) + (not (string= (cdr rec) away-message))) ;; away message has changed (rcirc-handler-generic process "AWAY" nick (cdr args) text) (if rec - (setcdr rec away-message) - (setq rcirc-nick-away-alist (cons (cons nick away-message) - rcirc-nick-away-alist)))))) + (setcdr rec away-message) + (setq rcirc-nick-away-alist (cons (cons nick away-message) + rcirc-nick-away-alist)))))) (defun rcirc-handler-317 (process sender args _text) "Handle idle messages from SENDER (RPL_WHOISIDLE). @@ -3374,7 +3366,7 @@ PROCESS is the process object for the current connection." (let* ((nick (nth 1 args)) (idle-secs (string-to-number (nth 2 args))) (idle-string (format-seconds "%yy %dd %hh %mm %z%ss" idle-secs)) - (signon-time (string-to-number (nth 3 args))) + (signon-time (string-to-number (nth 3 args))) (signon-string (format-time-string "%c" signon-time)) (message (format "%s idle for %s, signed on %s" nick idle-string signon-string))) @@ -3385,7 +3377,7 @@ PROCESS is the process object for the current connection." ARGS should have the form (CHANNEL TOPIC). PROCESS is the process object for the current connection." (let ((buffer (or (rcirc-get-buffer process (cadr args)) - (rcirc-get-temp-buffer-create process (cadr args))))) + (rcirc-get-temp-buffer-create process (cadr args))))) (with-current-buffer buffer (setq rcirc-topic (nth 2 args))))) @@ -3396,13 +3388,13 @@ ARGS has the form (CHANNEL SETTER TIME). SENDER is passed on to connection. This is a non-standard extension, not specified in RFC1459." (let ((buffer (or (rcirc-get-buffer process (cadr args)) - (rcirc-get-temp-buffer-create process (cadr args))))) + (rcirc-get-temp-buffer-create process (cadr args))))) (with-current-buffer buffer (let ((setter (nth 2 args)) - (time (current-time-string - (string-to-number (cadddr args))))) - (rcirc-print process sender "TOPIC" (cadr args) - (format "%s (%s on %s)" rcirc-topic setter time)))))) + (time (current-time-string + (string-to-number (cadddr args))))) + (rcirc-print process sender "TOPIC" (cadr args) + (format "%s (%s on %s)" rcirc-topic setter time)))))) (defun rcirc-handler-477 (process sender args _text) "Notify user that CHANNEL does not support modes (ERR_NOCHANMODES). @@ -3426,9 +3418,9 @@ PROCESS is the process object for the current connection." ;; print in private chat buffers if they exist (mapc (lambda (nick) - (when (rcirc-get-buffer process nick) - (rcirc-print process sender "MODE" nick msg))) - (cddr args)))) + (when (rcirc-get-buffer process nick) + (rcirc-print process sender "MODE" nick msg))) + (cddr args)))) (defun rcirc-get-temp-buffer-create (process channel) "Return a buffer based on PROCESS and CHANNEL." @@ -3440,7 +3432,7 @@ PROCESS is the process object for the current connection." ARGS should have the form (TYPE CHANNEL . NICK-LIST). PROCESS is the process object for the current connection." (let ((channel (nth 2 args)) - (names (or (nth 3 args) ""))) + (names (or (nth 3 args) ""))) (mapc (lambda (nick) (rcirc-put-nick-channel process nick channel)) (split-string names " " t)) @@ -3459,7 +3451,7 @@ PROCESS is the process object for the current connection." (with-current-buffer buffer (rcirc-print process sender "NAMES" channel (let ((content (buffer-substring (point-min) (point-max)))) - (rcirc-sort-nicknames-join content " ")))) + (rcirc-sort-nicknames-join content " ")))) (kill-buffer buffer))) (defun rcirc-handler-433 (process sender args text) @@ -3507,11 +3499,11 @@ Passwords are stored in `rcirc-authinfo' (which see)." (with-rcirc-server-buffer (dolist (i rcirc-authinfo) (let ((process (rcirc-buffer-process)) - (server (car i)) - (nick (nth 2 i)) - (method (cadr i)) - (args (cdddr i))) - (when (and (string-match server rcirc-server)) + (server (car i)) + (nick (nth 2 i)) + (method (cadr i)) + (args (cdddr i))) + (when (and (string-match server rcirc-server)) (if (and (memq method '(nickserv chanserv bitlbee)) (string-match nick rcirc-nick)) ;; the following methods rely on the user's nickname. @@ -3581,12 +3573,12 @@ current connection." (if (not (fboundp handler)) (rcirc-print process sender "ERROR" target (format "%s sent unsupported ctcp: %s" sender text) - t) + t) (funcall handler process target sender args) (unless (or (string= request "ACTION") - (string= request "KEEPALIVE")) - (rcirc-print process sender "CTCP" target - (format "%s" text) t)))))) + (string= request "KEEPALIVE")) + (rcirc-print process sender "CTCP" target + (format "%s" text) t)))))) (defun rcirc-handler-ctcp-VERSION (process _target sender _message) "Handle a CTCP VERSION message from SENDER. @@ -3733,7 +3725,7 @@ PROCESS is the process object for the current connection." '((t :family "Monospace")) "Face used for monospace text in messages.") -(defface rcirc-my-nick ; font-lock-function-name-face +(defface rcirc-my-nick ; font-lock-function-name-face '((((class color) (min-colors 88) (background light)) :foreground "Blue1") (((class color) (min-colors 88) (background dark)) :foreground "LightSkyBlue") (((class color) (min-colors 16) (background light)) :foreground "Blue") @@ -3742,7 +3734,7 @@ PROCESS is the process object for the current connection." (t :inverse-video t :weight bold)) "Rcirc face for my messages.") -(defface rcirc-other-nick ; font-lock-variable-name-face +(defface rcirc-other-nick ; font-lock-variable-name-face '((((class grayscale) (background light)) :foreground "Gray90" :weight bold :slant italic) (((class grayscale) (background dark)) @@ -3772,7 +3764,7 @@ PROCESS is the process object for the current connection." '((t :inherit default)) "Rcirc face for nicks in `rcirc-dim-nicks'.") -(defface rcirc-server ; font-lock-comment-face +(defface rcirc-server ; font-lock-comment-face '((((class grayscale) (background light)) :foreground "DimGray" :weight bold :slant italic) (((class grayscale) (background dark)) @@ -3790,7 +3782,7 @@ PROCESS is the process object for the current connection." (t :weight bold :slant italic)) "Rcirc face for server messages.") -(defface rcirc-server-prefix ; font-lock-comment-delimiter-face +(defface rcirc-server-prefix ; font-lock-comment-delimiter-face '((default :inherit rcirc-server) (((class grayscale))) (((class color) (min-colors 16))) @@ -3804,7 +3796,7 @@ PROCESS is the process object for the current connection." '((t :inherit default)) "Rcirc face for timestamps.") -(defface rcirc-nick-in-message ; font-lock-keyword-face +(defface rcirc-nick-in-message ; font-lock-keyword-face '((((class grayscale) (background light)) :foreground "LightGray" :weight bold) (((class grayscale) (background dark)) :foreground "DimGray" :weight bold) (((class color) (min-colors 88) (background light)) :foreground "Purple") @@ -3818,7 +3810,7 @@ PROCESS is the process object for the current connection." (defface rcirc-nick-in-message-full-line '((t :weight bold)) "Rcirc face for emphasizing the entire message when your nick is mentioned.") -(defface rcirc-prompt ; comint-highlight-prompt +(defface rcirc-prompt ; comint-highlight-prompt '((((min-colors 88) (background dark)) :foreground "cyan1") (((background dark)) :foreground "cyan") (t :foreground "dark blue")) diff --git a/lisp/net/sieve-manage.el b/lisp/net/sieve-manage.el index a39e35a53a1..381e1fcd4f8 100644 --- a/lisp/net/sieve-manage.el +++ b/lisp/net/sieve-manage.el @@ -167,7 +167,52 @@ Valid states are `closed', `initial', `nonauth', and `auth'.") (defvar sieve-manage-capability nil) ;; Internal utility functions -(autoload 'mm-enable-multibyte "mm-util") +(defun sieve-manage--append-to-log (&rest args) + "Append ARGS to sieve-manage log buffer. + +ARGS can be a string or a list of strings. +The buffer to use for logging is specifified via +`sieve-manage-log'. If it is nil, logging is disabled." + (when sieve-manage-log + (with-current-buffer (or (get-buffer sieve-manage-log) + (with-current-buffer + (get-buffer-create sieve-manage-log) + (set-buffer-multibyte nil) + (buffer-disable-undo))) + (goto-char (point-max)) + (apply #'insert args)))) + +(defun sieve-manage--message (format-string &rest args) + "Wrapper around `message' which also logs to sieve manage log. + +See `sieve-manage--append-to-log'." + (let ((ret (apply #'message + (concat "sieve-manage: " format-string) + args))) + (sieve-manage--append-to-log ret "\n") + ret)) + +(defun sieve-manage--error (format-string &rest args) + "Wrapper around `error' which also logs to sieve manage log. + +See `sieve-manage--append-to-log'." + (let ((msg (apply #'format + (concat "sieve-manage/ERROR: " format-string) + args))) + (sieve-manage--append-to-log msg "\n") + (error msg))) + +(defun sieve-manage-encode (utf8-string) + "Convert UTF8-STRING to managesieve protocol octets." + (encode-coding-string utf8-string 'raw-text t)) + +(defun sieve-manage-decode (octets &optional buffer) + "Convert managesieve protocol OCTETS to utf-8 string. + +If optional BUFFER is non-nil, insert decoded string into BUFFER." + (when octets + ;; eol type unix is required to preserve "\r\n" + (decode-coding-string octets 'utf-8-unix t buffer))) (defun sieve-manage-make-process-buffer () (with-current-buffer @@ -175,22 +220,19 @@ Valid states are `closed', `initial', `nonauth', and `auth'.") sieve-manage-server sieve-manage-port)) (mapc #'make-local-variable sieve-manage-local-variables) - (mm-enable-multibyte) + (set-buffer-multibyte nil) + (setq-local after-change-functions nil) (buffer-disable-undo) (current-buffer))) (defun sieve-manage-erase (&optional p buffer) - (let ((buffer (or buffer (current-buffer)))) - (and sieve-manage-log - (with-current-buffer (get-buffer-create sieve-manage-log) - (mm-enable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert-buffer-substring buffer (with-current-buffer buffer - (point-min)) - (or p (with-current-buffer buffer - (point-max))))))) - (delete-region (point-min) (or p (point-max)))) + (with-current-buffer (or buffer (current-buffer)) + (let* ((start (point-min)) + (end (or p (point-max))) + (logdata (buffer-substring-no-properties start end))) + (sieve-manage--append-to-log logdata) + (delete-region start end) + logdata))) (defun sieve-manage-open-server (server port &optional stream buffer) "Open network connection to SERVER on PORT. @@ -202,6 +244,8 @@ Return the buffer associated with the connection." (open-network-stream "SIEVE" buffer server port :type stream + ;; eol type unix is required to preserve "\r\n" + :coding 'raw-text-unix :capability-command "CAPABILITY\r\n" :end-of-command "^\\(OK\\|NO\\).*\n" :success "^OK.*\n" @@ -224,7 +268,7 @@ Return the buffer associated with the connection." ;; Authenticators (defun sieve-sasl-auth (buffer mech) "Login to server using the SASL MECH method." - (message "sieve: Authenticating using %s..." mech) + (sieve-manage--message "Authenticating using %s..." mech) (with-current-buffer buffer (let* ((auth-info (auth-source-search :host sieve-manage-server :port "sieve" @@ -275,11 +319,15 @@ Return the buffer associated with the connection." (if (and (setq step (sasl-next-step client step)) (setq data (sasl-step-data step))) ;; We got data for server but it's finished - (error "Server not ready for SASL data: %s" data) + (sieve-manage--error + "Server not ready for SASL data: %s" data) ;; The authentication process is finished. + (sieve-manage--message "Logged in as %s using %s" + user-name mech) (throw 'done t))) (unless (stringp rsp) - (error "Server aborted SASL authentication: %s" (caddr rsp))) + (sieve-manage--error + "Server aborted SASL authentication: %s" (caddr rsp))) (sasl-step-set-data step (base64-decode-string rsp)) (setq step (sasl-next-step client step)) (sieve-manage-send @@ -288,8 +336,7 @@ Return the buffer associated with the connection." (base64-encode-string (sasl-step-data step) 'no-line-break) "\"") - "")))) - (message "sieve: Login using %s...done" mech)))) + ""))))))) (defun sieve-manage-cram-md5-p (buffer) (sieve-manage-capability "SASL" "CRAM-MD5" buffer)) @@ -353,7 +400,7 @@ to work in." sieve-manage-default-stream) sieve-manage-auth (or auth sieve-manage-auth)) - (message "sieve: Connecting to %s..." sieve-manage-server) + (sieve-manage--message "Connecting to %s..." sieve-manage-server) (sieve-manage-open-server sieve-manage-server sieve-manage-port sieve-manage-stream @@ -368,7 +415,8 @@ to work in." (setq sieve-manage-auth auth) (cl-return))) (unless sieve-manage-auth - (error "Couldn't figure out authenticator for server"))) + (sieve-manage--error + "Couldn't figure out authenticator for server"))) (sieve-manage-erase) (current-buffer)))) @@ -433,11 +481,7 @@ If NAME is nil, return the full server list of capabilities." (defun sieve-manage-putscript (name content &optional buffer) (with-current-buffer (or buffer (current-buffer)) (sieve-manage-send (format "PUTSCRIPT \"%s\" {%d+}%s%s" name - ;; Here we assume that the coding-system will - ;; replace each char with a single byte. - ;; This is always the case if `content' is - ;; a unibyte string. - (length content) + (length (sieve-manage-encode content)) sieve-manage-client-eol content)) (sieve-manage-parse-okno))) @@ -449,11 +493,10 @@ If NAME is nil, return the full server list of capabilities." (defun sieve-manage-getscript (name output-buffer &optional buffer) (with-current-buffer (or buffer (current-buffer)) (sieve-manage-send (format "GETSCRIPT \"%s\"" name)) - (let ((script (sieve-manage-parse-string))) - (sieve-manage-parse-crlf) - (with-current-buffer output-buffer - (insert script)) - (sieve-manage-parse-okno)))) + (sieve-manage-decode (sieve-manage-parse-string) + output-buffer) + (sieve-manage-parse-crlf) + (sieve-manage-parse-okno))) (defun sieve-manage-setactive (name &optional buffer) (with-current-buffer (or buffer (current-buffer)) @@ -478,6 +521,9 @@ If NAME is nil, return the full server list of capabilities." (defun sieve-manage-ok-p (rsp) (string= (downcase (or (car-safe rsp) "")) "ok")) +(defun sieve-manage-no-p (rsp) + (string= (downcase (or (car-safe rsp) "")) "no")) + (defun sieve-manage-is-okno () (when (looking-at (concat "^\\(OK\\|NO\\)\\( (\\([^)]+\\))\\)?\\( \\(.*\\)\\)?" @@ -528,7 +574,11 @@ to local variable `sieve-manage-capability'." (while (null rsp) (accept-process-output (get-buffer-process (current-buffer)) 1) (goto-char (point-min)) - (setq rsp (sieve-manage-is-string))) + (unless (setq rsp (sieve-manage-is-string)) + (when (sieve-manage-no-p (sieve-manage-is-okno)) + ;; simple `error' is enough since `sieve-manage-erase' + ;; already adds the server response to the log + (error (sieve-manage-erase))))) (sieve-manage-erase (point)) rsp)) @@ -540,7 +590,8 @@ to local variable `sieve-manage-capability'." (let (tmp rsp data) (while (null rsp) (while (null (or (setq rsp (sieve-manage-is-okno)) - (setq tmp (sieve-manage-is-string)))) + (setq tmp (sieve-manage-decode + (sieve-manage-is-string))))) (accept-process-output (get-buffer-process (current-buffer)) 1) (goto-char (point-min))) (when tmp @@ -559,13 +610,9 @@ to local variable `sieve-manage-capability'." rsp))) (defun sieve-manage-send (cmdstr) - (setq cmdstr (concat cmdstr sieve-manage-client-eol)) - (and sieve-manage-log - (with-current-buffer (get-buffer-create sieve-manage-log) - (mm-enable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert cmdstr))) + (setq cmdstr (sieve-manage-encode + (concat cmdstr sieve-manage-client-eol))) + (sieve-manage--append-to-log cmdstr) (process-send-string sieve-manage-process cmdstr)) (provide 'sieve-manage) diff --git a/lisp/net/sieve.el b/lisp/net/sieve.el index 3a6067ee10b..c2faeaef544 100644 --- a/lisp/net/sieve.el +++ b/lisp/net/sieve.el @@ -152,7 +152,8 @@ require \"fileinto\"; (interactive) (sieve-manage-close sieve-manage-buffer) (kill-buffer sieve-manage-buffer) - (kill-buffer (current-buffer))) + (when-let ((buffer (get-buffer sieve-buffer))) + (kill-buffer buffer))) (defun sieve-bury-buffer () "Bury the Manage Sieve buffer without closing the connection." diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index ab38ffa0cf9..49cbf526ec3 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -55,7 +55,7 @@ It is used for TCP/IP devices." (defconst tramp-adb-method "adb" "When this method name is used, forward all calls to Android Debug Bridge.") -(defcustom tramp-adb-prompt (rx bol (* (not (any "#$\n\r"))) (any "#$") space) +(defcustom tramp-adb-prompt (rx bol (* (not (any "#$\n\r"))) (any "#$") blank) "Regexp used as prompt in almquist shell." :type 'regexp :version "28.1" @@ -71,20 +71,22 @@ It is used for TCP/IP devices." "Regexp for date time format in ls output.")) (defconst tramp-adb-ls-date-regexp - (rx space (regexp tramp-adb-ls-date-year-regexp) - space (regexp tramp-adb-ls-date-time-regexp) - space) + (tramp-compat-rx + blank (regexp tramp-adb-ls-date-year-regexp) + blank (regexp tramp-adb-ls-date-time-regexp) + blank) "Regexp for date format in ls output.") (defconst tramp-adb-ls-toolbox-regexp - (rx bol (* space) (group (+ (any ".-" alpha))) ; \1 permissions - (? (+ space) (+ digit)) ; links (Android 7/toybox) - (* space) (group (+ (not space))) ; \2 username - (+ space) (group (+ (not space))) ; \3 group - (+ space) (group (+ digit)) ; \4 size - (+ space) (group (regexp tramp-adb-ls-date-year-regexp) - space (regexp tramp-adb-ls-date-time-regexp)) ; \5 date - space (group (* nonl)) eol) ; \6 filename + (tramp-compat-rx + bol (* blank) (group (+ (any ".-" alpha))) ; \1 permissions + (? (+ blank) (+ digit)) ; links (Android 7/toybox) + (* blank) (group (+ (not blank))) ; \2 username + (+ blank) (group (+ (not blank))) ; \3 group + (+ blank) (group (+ digit)) ; \4 size + (+ blank) (group (regexp tramp-adb-ls-date-year-regexp) + blank (regexp tramp-adb-ls-date-time-regexp)) ; \5 date + blank (group (* nonl)) eol) ; \6 filename "Regexp for ls output.") ;;;###tramp-autoload @@ -127,7 +129,7 @@ It is used for TCP/IP devices." (file-directory-p . tramp-handle-file-directory-p) (file-equal-p . tramp-handle-file-equal-p) (file-executable-p . tramp-adb-handle-file-executable-p) - (file-exists-p . tramp-handle-file-exists-p) + (file-exists-p . tramp-adb-handle-file-exists-p) (file-in-directory-p . tramp-handle-file-in-directory-p) (file-local-copy . tramp-adb-handle-file-local-copy) (file-locked-p . tramp-handle-file-locked-p) @@ -180,6 +182,7 @@ It is used for TCP/IP devices." (temporary-file-directory . tramp-handle-temporary-file-directory) (tramp-get-home-directory . ignore) (tramp-get-remote-gid . tramp-adb-handle-get-remote-gid) + (tramp-get-remote-groups . tramp-adb-handle-get-remote-groups) (tramp-get-remote-uid . tramp-adb-handle-get-remote-uid) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) @@ -218,7 +221,7 @@ arguments to pass to the OPERATION." (mapcar (lambda (line) (when (string-match - (rx bol (group (+ (not space))) (+ space) "device" eol) line) + (rx bol (group (+ (not blank))) (+ blank) "device" eol) line) ;; Replace ":" by "#". `(nil ,(tramp-compat-string-replace ":" tramp-prefix-port-format (match-string 1 line))))) @@ -235,10 +238,10 @@ arguments to pass to the OPERATION." (goto-char (point-min)) (forward-line) (when (looking-at - (rx (* space) (+ (not space)) - (+ space) (group (+ digit)) - (+ space) (group (+ digit)) - (+ space) (group (+ digit)))) + (rx (* blank) (+ (not blank)) + (+ blank) (group (+ digit)) + (+ blank) (group (+ digit)) + (+ blank) (group (+ digit)))) ;; The values are given as 1k numbers, so we must change ;; them to number of bytes. (list (* 1024 (string-to-number (match-string 1))) @@ -323,8 +326,8 @@ arguments to pass to the OPERATION." (tramp-shell-quote-argument (tramp-compat-file-name-concat localname "..")))) (tramp-compat-replace-regexp-in-region - (rx (literal (tramp-compat-file-name-unquote - (file-name-as-directory localname)))) + (tramp-compat-rx (literal (tramp-compat-file-name-unquote + (file-name-as-directory localname)))) "" (point-min)) (widen))) (tramp-adb-sh-fix-ls-output) @@ -362,12 +365,14 @@ Emacs dired can't find files." (goto-char (point-min)) (while (search-forward-regexp - (rx space (group space (regexp tramp-adb-ls-date-year-regexp) space)) + (tramp-compat-rx + blank (group blank (regexp tramp-adb-ls-date-year-regexp) blank)) nil t) (replace-match "0\\1" "\\1" nil) ;; Insert missing "/". (when (looking-at-p - (rx (regexp tramp-adb-ls-date-time-regexp) (+ space) eol)) + (tramp-compat-rx + (regexp tramp-adb-ls-date-time-regexp) (+ blank) eol)) (end-of-line) (insert "/"))) ;; Sort entries. @@ -466,7 +471,7 @@ Emacs dired can't find files." nil (mapcar (lambda (l) - (and (not (string-match-p (rx bol (* space) eol) l)) l)) + (and (not (string-match-p (rx bol (* blank) eol) l)) l)) (split-string (buffer-string) "\n"))))))))))) (defun tramp-adb-handle-file-local-copy (filename) @@ -486,26 +491,52 @@ Emacs dired can't find files." (defun tramp-adb-handle-file-executable-p (filename) "Like `file-executable-p' for Tramp files." - (with-parsed-tramp-file-name filename nil + (with-parsed-tramp-file-name (expand-file-name filename) nil (with-tramp-file-property v localname "file-executable-p" - (tramp-adb-send-command-and-check - v (format "test -x %s" (tramp-shell-quote-argument localname)))))) + ;; Examine `file-attributes' cache to see if request can be + ;; satisfied without remote operation. + (if (tramp-file-property-p v localname "file-attributes") + (or (tramp-check-cached-permissions v ?x) + (tramp-check-cached-permissions v ?s)) + (tramp-adb-send-command-and-check + v (format "test -x %s" (tramp-shell-quote-argument localname))))))) + +(defun tramp-adb-handle-file-exists-p (filename) + "Like `file-exists-p' for Tramp files." + ;; `file-exists-p' is used as predicate in file name completion. + ;; We don't want to run it when `non-essential' is t, or there is + ;; no connection process yet. + (when (tramp-connectable-p filename) + (with-parsed-tramp-file-name (expand-file-name filename) nil + (with-tramp-file-property v localname "file-exists-p" + (if (tramp-file-property-p v localname "file-attributes") + (not (null (tramp-get-file-property v localname "file-attributes"))) + (tramp-adb-send-command-and-check + v (format "test -e %s" (tramp-shell-quote-argument localname)))))))) (defun tramp-adb-handle-file-readable-p (filename) "Like `file-readable-p' for Tramp files." - (with-parsed-tramp-file-name filename nil + (with-parsed-tramp-file-name (expand-file-name filename) nil (with-tramp-file-property v localname "file-readable-p" - (or (tramp-handle-file-readable-p filename) - (tramp-adb-send-command-and-check - v (format "test -r %s" (tramp-shell-quote-argument localname))))))) + ;; Examine `file-attributes' cache to see if request can be + ;; satisfied without remote operation. + (if (tramp-file-property-p v localname "file-attributes") + (tramp-handle-file-readable-p filename) + (tramp-adb-send-command-and-check + v (format "test -r %s" (tramp-shell-quote-argument localname))))))) (defun tramp-adb-handle-file-writable-p (filename) "Like `file-writable-p' for Tramp files." - (with-parsed-tramp-file-name filename nil + (with-parsed-tramp-file-name (expand-file-name filename) nil (with-tramp-file-property v localname "file-writable-p" (if (file-exists-p filename) - (tramp-adb-send-command-and-check - v (format "test -w %s" (tramp-shell-quote-argument localname))) + (if (tramp-file-property-p v localname "file-attributes") + ;; Examine `file-attributes' cache to see if request can + ;; be satisfied without remote operation. + (tramp-check-cached-permissions v ?w) + (tramp-adb-send-command-and-check + v (format "test -w %s" (tramp-shell-quote-argument localname)))) + ;; If file doesn't exist, check if directory is writable. (and (file-directory-p (file-name-directory filename)) (file-writable-p (file-name-directory filename))))))) @@ -717,9 +748,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (setcar result 0) (dolist (line signals) (when (string-match - (rx bol (* space) (group (+ digit)) - (+ space) (+ (not space)) - (+ space) (group alpha (* nonl)) eol) + (rx bol (* blank) (group (+ digit)) + (+ blank) (+ (not blank)) + (+ blank) (group alpha (* nonl)) eol) line) (setcar (nthcdr (string-to-number (match-string 1 line)) result) @@ -917,7 +948,7 @@ implementation will be used." (i 0) p) - (when (string-match-p (rx multibyte) command) + (when (string-match-p (tramp-compat-rx multibyte) command) (tramp-error v 'file-error "Cannot apply multi-byte command `%s'" command)) @@ -1039,32 +1070,23 @@ implementation will be used." (defun tramp-adb-handle-get-remote-uid (vec id-format) "Like `tramp-get-remote-uid' for Tramp files. ID-FORMAT valid values are `string' and `integer'." - ;; The result is cached in `tramp-get-remote-uid'. - (tramp-adb-send-command - vec - (format "id -u%s %s" - (if (equal id-format 'integer) "" "n") - (if (equal id-format 'integer) - "" "| sed -e s/^/\\\"/ -e s/\\$/\\\"/"))) - (with-current-buffer (tramp-get-connection-buffer vec) - ;; Read the expression. - (goto-char (point-min)) - (read (current-buffer)))) + (tramp-adb-send-command vec "id") + (tramp-read-id-output vec) + (tramp-get-connection-property vec (format "uid-%s" id-format))) (defun tramp-adb-handle-get-remote-gid (vec id-format) "Like `tramp-get-remote-gid' for Tramp files. ID-FORMAT valid values are `string' and `integer'." - ;; The result is cached in `tramp-get-remote-gid'. - (tramp-adb-send-command - vec - (format "id -g%s %s" - (if (equal id-format 'integer) "" "n") - (if (equal id-format 'integer) - "" "| sed -e s/^/\\\"/ -e s/\\$/\\\"/"))) - (with-current-buffer (tramp-get-connection-buffer vec) - ;; Read the expression. - (goto-char (point-min)) - (read (current-buffer)))) + (tramp-adb-send-command vec "id") + (tramp-read-id-output vec) + (tramp-get-connection-property vec (format "gid-%s" id-format))) + +(defun tramp-adb-handle-get-remote-groups (vec id-format) + "Like `tramp-get-remote-groups' for Tramp files. +ID-FORMAT valid values are `string' and `integer'." + (tramp-adb-send-command vec "id") + (tramp-read-id-output vec) + (tramp-get-connection-property vec (format "groups-%s" id-format))) (defun tramp-adb-get-device (vec) "Return full host name from VEC to be used in shell execution. @@ -1118,7 +1140,7 @@ error and non-nil on success." (defun tramp-adb-send-command (vec command &optional neveropen nooutput) "Send the COMMAND to connection VEC." - (if (string-match-p (rx multibyte) command) + (if (string-match-p (tramp-compat-rx multibyte) command) ;; Multibyte codepoints with four bytes are not supported at ;; least by toybox. @@ -1142,7 +1164,7 @@ error and non-nil on success." ;; We can't use stty to disable echo of command. stty is said ;; to be added to toybox 0.7.6. busybox shall have it, but this ;; isn't used any longer for Android. - (delete-matching-lines (rx (literal command))) + (delete-matching-lines (tramp-compat-rx bol (literal command) eol)) ;; When the local machine is W32, there are still trailing ^M. ;; There must be a better solution by setting the correct coding ;; system, but this requires changes in core Tramp. @@ -1265,7 +1287,7 @@ connection if a previous connection has died for some reason." ;; Change prompt. (tramp-set-connection-property - p "prompt" (rx "///" (literal prompt) "#$")) + p "prompt" (tramp-compat-rx "///" (literal prompt) "#$")) (tramp-adb-send-command vec (format "PS1=\"///\"\"%s\"\"#$\"" prompt)) diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index c25d5096719..9ff5d6ac75d 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -184,17 +184,18 @@ It must be supported by libarchive(3).") ;;;###autoload (progn (defmacro tramp-archive-autoload-file-name-regexp () "Regular expression matching archive file names." - '(rx bos - ;; This group is used in `tramp-archive-file-name-archive'. - (group - (+ nonl) - ;; Default suffixes ... - "." (regexp (regexp-opt tramp-archive-suffixes)) - ;; ... with compression. - (? "." (regexp (regexp-opt tramp-archive-compression-suffixes)))) - ;; This group is used in `tramp-archive-file-name-localname'. - (group "/" (* nonl)) - eos))) + `(rx + bos + ;; This group is used in `tramp-archive-file-name-archive'. + (group + (+ nonl) + ;; Default suffixes ... + "." ,(cons '| tramp-archive-suffixes) + ;; ... with compression. + (? "." ,(cons '| tramp-archive-compression-suffixes))) + ;; This group is used in `tramp-archive-file-name-localname'. + (group "/" (* nonl)) + eos))) (put #'tramp-archive-autoload-file-name-regexp 'tramp-autoload t) @@ -297,6 +298,7 @@ It must be supported by libarchive(3).") (temporary-file-directory . tramp-archive-handle-temporary-file-directory) (tramp-get-home-directory . ignore) (tramp-get-remote-gid . ignore) + (tramp-get-remote-groups . ignore) (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index 4c745092a3e..58954c238e0 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -28,7 +28,7 @@ ;; An implementation of information caching for remote files. ;; Each connection, identified by a `tramp-file-name' structure or by -;; a process, has a unique cache. We distinguish 4 kind of caches, +;; a process, has a unique cache. We distinguish 5 kind of caches, ;; depending on the key: ;; ;; - localname is nil. These are reusable properties. Examples: @@ -37,13 +37,14 @@ ;; host when starting a Perl script. These properties are saved in ;; the file `tramp-persistency-file-name'. ;; -;; - localname is a string. These are temporary properties, which are -;; related to the file localname is referring to. Examples: -;; "file-exists-p" is t or nil, depending on the file existence, or -;; "file-attributes" caches the result of the function +;; - localname is an absolute file name. These are temporary +;; properties, which are related to the file localname is referring +;; to. Examples: "file-exists-p" is t or nil, depending on the file +;; existence, or "file-attributes" caches the result of the function ;; `file-attributes'. These entries have a timestamp, and they ;; expire after `remote-file-name-inhibit-cache' seconds if this -;; variable is set. +;; variable is set. These properties are taken into account only if +;; the connection is established, or `non-essential' is nil. ;; ;; - The key is a process. These are temporary properties related to ;; an open connection. Examples: "scripts" keeps shell script @@ -135,39 +136,41 @@ If KEY is `tramp-cache-undefined', don't create anything, and return nil." Return DEFAULT if not set." ;; Unify localname. Remove hop from `tramp-file-name' structure. (setq key (tramp-file-name-unify key file)) - (let* ((hash (tramp-get-hash-table key)) - (cached (and (hash-table-p hash) (gethash property hash))) - (cached-at (and (consp cached) (format-time-string "%T" (car cached)))) - (value default) - cache-used) - - (when ;; We take the value only if there is any, and - ;; `remote-file-name-inhibit-cache' indicates that it is - ;; still valid. Otherwise, DEFAULT is set. - (and (consp cached) - (or (null remote-file-name-inhibit-cache) - (and (integerp remote-file-name-inhibit-cache) - (time-less-p - nil - (time-add (car cached) remote-file-name-inhibit-cache))) - (and (consp remote-file-name-inhibit-cache) - (time-less-p - remote-file-name-inhibit-cache (car cached))))) - (setq value (cdr cached) - cache-used t)) - - (tramp-message - key 8 "%s %s %s; inhibit: %s; cache used: %s; cached at: %s" - (tramp-file-name-localname key) - property value remote-file-name-inhibit-cache cache-used cached-at) - ;; For analysis purposes, count the number of getting this file attribute. - (when (>= tramp-verbose 10) - (let* ((var (intern (concat "tramp-cache-get-count-" property))) - (val (or (and (boundp var) (numberp (symbol-value var)) - (symbol-value var)) - 0))) - (set var (1+ val)))) - value)) + (if (eq key tramp-cache-undefined) default + (let* ((hash (tramp-get-hash-table key)) + (cached (and (hash-table-p hash) (gethash property hash))) + (cached-at + (and (consp cached) (format-time-string "%T" (car cached)))) + (value default) + cache-used) + + (when ;; We take the value only if there is any, and + ;; `remote-file-name-inhibit-cache' indicates that it is + ;; still valid. Otherwise, DEFAULT is set. + (and (consp cached) + (or (null remote-file-name-inhibit-cache) + (and (integerp remote-file-name-inhibit-cache) + (time-less-p + nil + (time-add (car cached) remote-file-name-inhibit-cache))) + (and (consp remote-file-name-inhibit-cache) + (time-less-p + remote-file-name-inhibit-cache (car cached))))) + (setq value (cdr cached) + cache-used t)) + + (tramp-message + key 8 "%s %s %s; inhibit: %s; cache used: %s; cached at: %s" + (tramp-file-name-localname key) + property value remote-file-name-inhibit-cache cache-used cached-at) + ;; For analysis purposes, count the number of getting this file attribute. + (when (>= tramp-verbose 10) + (let* ((var (intern (concat "tramp-cache-get-count-" property))) + (val (or (and (boundp var) (numberp (symbol-value var)) + (symbol-value var)) + 0))) + (set var (1+ val)))) + value))) (add-hook 'tramp-cache-unload-hook (lambda () @@ -180,19 +183,20 @@ Return DEFAULT if not set." Return VALUE." ;; Unify localname. Remove hop from `tramp-file-name' structure. (setq key (tramp-file-name-unify key file)) - (let ((hash (tramp-get-hash-table key))) - ;; We put the timestamp there. - (puthash property (cons (current-time) value) hash) - (tramp-message - key 8 "%s %s %s" (tramp-file-name-localname key) property value) - ;; For analysis purposes, count the number of setting this file attribute. - (when (>= tramp-verbose 10) - (let* ((var (intern (concat "tramp-cache-set-count-" property))) - (val (or (and (boundp var) (numberp (symbol-value var)) - (symbol-value var)) - 0))) - (set var (1+ val)))) - value)) + (if (eq key tramp-cache-undefined) value + (let ((hash (tramp-get-hash-table key))) + ;; We put the timestamp there. + (puthash property (cons (current-time) value) hash) + (tramp-message + key 8 "%s %s %s" (tramp-file-name-localname key) property value) + ;; For analysis purposes, count the number of setting this file attribute. + (when (>= tramp-verbose 10) + (let* ((var (intern (concat "tramp-cache-set-count-" property))) + (val (or (and (boundp var) (numberp (symbol-value var)) + (symbol-value var)) + 0))) + (set var (1+ val)))) + value))) (add-hook 'tramp-cache-unload-hook (lambda () @@ -202,19 +206,22 @@ Return VALUE." ;;;###tramp-autoload (defun tramp-file-property-p (key file property) "Check whether PROPERTY of FILE is defined in the cache context of KEY." - (not (eq (tramp-get-file-property key file property tramp-cache-undefined) - tramp-cache-undefined))) + (and + (not (eq key tramp-cache-undefined)) + (not (eq (tramp-get-file-property key file property tramp-cache-undefined) + tramp-cache-undefined)))) ;;;###tramp-autoload (defun tramp-flush-file-property (key file property) "Remove PROPERTY of FILE in the cache context of KEY." ;; Unify localname. Remove hop from `tramp-file-name' structure. (setq key (tramp-file-name-unify key file)) - (remhash property (tramp-get-hash-table key)) - (tramp-message key 8 "%s %s" (tramp-file-name-localname key) property) - (when (>= tramp-verbose 10) - (let ((var (intern (concat "tramp-cache-set-count-" property)))) - (makunbound var)))) + (unless (eq key tramp-cache-undefined) + (remhash property (tramp-get-hash-table key)) + (tramp-message key 8 "%s %s" (tramp-file-name-localname key) property) + (when (>= tramp-verbose 10) + (let ((var (intern (concat "tramp-cache-set-count-" property)))) + (makunbound var))))) (defun tramp-flush-file-upper-properties (key file) "Remove some properties of FILE's upper directory." @@ -224,12 +231,14 @@ Return VALUE." (file (directory-file-name file))) ;; Unify localname. Remove hop from `tramp-file-name' structure. (setq key (tramp-file-name-unify key file)) - (dolist (property (hash-table-keys (tramp-get-hash-table key))) - (when (string-match-p - (rx - bos (| "directory-" "file-name-all-completions" "file-entries")) - property) - (tramp-flush-file-property key file property)))))) + (unless (eq key tramp-cache-undefined) + (dolist (property (hash-table-keys (tramp-get-hash-table key))) + (when (string-match-p + (rx + bos (| "directory-" "file-name-all-completions" + "file-entries")) + property) + (tramp-flush-file-property key file property))))))) ;;;###tramp-autoload (defun tramp-flush-file-properties (key file) @@ -237,14 +246,15 @@ Return VALUE." (let ((truename (tramp-get-file-property key file "file-truename"))) ;; Unify localname. Remove hop from `tramp-file-name' structure. (setq key (tramp-file-name-unify key file)) - (tramp-message key 8 "%s" (tramp-file-name-localname key)) - (remhash key tramp-cache-data) - ;; Remove file properties of symlinks. - (when (and (stringp truename) - (not (string-equal file (directory-file-name truename)))) - (tramp-flush-file-properties key truename)) - ;; Remove selected properties of upper directory. - (tramp-flush-file-upper-properties key file))) + (unless (eq key tramp-cache-undefined) + (tramp-message key 8 "%s" (tramp-file-name-localname key)) + (remhash key tramp-cache-data) + ;; Remove file properties of symlinks. + (when (and (stringp truename) + (not (string-equal file (directory-file-name truename)))) + (tramp-flush-file-properties key truename)) + ;; Remove selected properties of upper directory. + (tramp-flush-file-upper-properties key file)))) ;;;###tramp-autoload (defun tramp-flush-directory-properties (key directory) @@ -278,7 +288,7 @@ Remove also properties of all files in subdirectories." This is suppressed for temporary buffers." (save-match-data (unless (or (null (buffer-name)) - (string-match-p (rx bos (| space "*")) (buffer-name))) + (string-match-p (rx bos (| blank "*")) (buffer-name))) (let ((bfn (if (stringp (buffer-file-name)) (buffer-file-name) default-directory)) diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index ad531b427a4..d36514bab26 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -355,7 +355,7 @@ The remote connection identified by SOURCE is flushed by (dir (tramp-rename-read-file-name-dir default)) (init (tramp-rename-read-file-name-init default)) (tramp-ignored-file-name-regexp - (rx (literal (file-remote-p source))))) + (tramp-compat-rx (literal (file-remote-p source))))) (read-file-name-default "Enter new Tramp connection: " dir default 'confirm init #'file-directory-p))))) @@ -466,7 +466,7 @@ For details, see `tramp-rename-files'." (dir (tramp-rename-read-file-name-dir default)) (init (tramp-rename-read-file-name-init default)) (tramp-ignored-file-name-regexp - (rx (literal (file-remote-p source))))) + (tramp-compat-rx (literal (file-remote-p source))))) (read-file-name-default (format "Change Tramp connection `%s': " source) dir default 'confirm init #'file-directory-p))))) @@ -621,10 +621,11 @@ buffer in your bug report. (unless (hash-table-p val) ;; Remove string quotation. (when (looking-at - (rx bol (group (* anychar)) "\"" ;; \1 " - (group "(base64-decode-string ") "\\" ;; \2 \ - (group "\"" (* anychar)) "\\" ;; \3 \ - (group "\")") "\"" eol)) ;; \4 " + (tramp-compat-rx + bol (group (* anychar)) "\"" ;; \1 " + (group "(base64-decode-string ") "\\" ;; \2 \ + (group "\"" (* anychar)) "\\" ;; \3 \ + (group "\")") "\"" eol)) ;; \4 " (replace-match "\\1\\2\\3\\4") (beginning-of-line) (insert " ;; Variable encoded due to non-printable characters.\n"))) diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index b7c0a3113ee..aae15fafdf2 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -180,6 +180,50 @@ CONDITION can also be a list of error conditions." (declare (debug t) (indent 1)) `(condition-case nil (progn ,@body) (,condition nil))) +;; `rx' in Emacs 26 doesn't know the `literal', `anychar' and +;; `multibyte' constructs. The `not' construct requires an `any' +;; construct as argument. The `regexp' construct requires a literal +;; string. +(defvar tramp-compat-rx--runtime-params) + +(defun tramp-compat-rx--transform-items (items) + (mapcar #'tramp-compat-rx--transform-item items)) + +;; There is an error in Emacs 26. `(rx "a" (? ""))' => "a?". +;; We must protect the string in regexp and literal, therefore. +(defun tramp-compat-rx--transform-item (item) + (pcase item + ('anychar 'anything) + ('multibyte 'nonascii) + (`(not ,expr) + (if (consp expr) item (list 'not (list 'any expr)))) + (`(regexp ,expr) + (setq tramp-compat-rx--runtime-params t) + `(regexp ,(list '\, `(concat "\\(?:" ,expr "\\)")))) + (`(literal ,expr) + (setq tramp-compat-rx--runtime-params t) + `(regexp ,(list '\, `(concat "\\(?:" (regexp-quote ,expr) "\\)")))) + (`(eval . ,_) item) + (`(,head . ,rest) (cons head (tramp-compat-rx--transform-items rest))) + (_ item))) + +(defun tramp-compat-rx--transform (items) + (let* ((tramp-compat-rx--runtime-params nil) + (new-rx (cons ': (tramp-compat-rx--transform-items items)))) + (if tramp-compat-rx--runtime-params + `(rx-to-string ,(list '\` new-rx) t) + (rx-to-string new-rx t)))) + +(if (ignore-errors (rx-to-string '(literal "a"))) ;; Emacs 27+. + (defalias 'tramp-compat-rx #'rx) + (defmacro tramp-compat-rx (&rest items) + (tramp-compat-rx--transform items))) + +;; This is needed for compilation in the Emacs source tree. +;;;###autoload (defalias 'tramp-compat-rx #'rx) + +(put #'tramp-compat-rx 'tramp-autoload t) + ;; `file-modes', `set-file-modes' and `set-file-times' got argument ;; FLAG in Emacs 28.1. (defalias 'tramp-compat-file-modes @@ -237,7 +281,7 @@ CONDITION can also be a list of error conditions." (lambda (from-string to-string in-string) (let (case-fold-search) (replace-regexp-in-string - (rx (literal from-string)) to-string in-string t t))))) + (regexp-quote from-string) to-string in-string t t))))) ;; Function `string-search' is new in Emacs 28.1. (defalias 'tramp-compat-string-search @@ -245,7 +289,7 @@ CONDITION can also be a list of error conditions." #'string-search (lambda (needle haystack &optional start-pos) (let (case-fold-search) - (string-match-p (rx (literal needle)) haystack start-pos))))) + (string-match-p (regexp-quote needle) haystack start-pos))))) ;; Function `make-lock-file-name' is new in Emacs 28.1. (defalias 'tramp-compat-make-lock-file-name diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index e7bb1ebe338..d556c876066 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -233,6 +233,7 @@ If NAME doesn't belong to an encrypted remote directory, return nil." (temporary-file-directory . tramp-handle-temporary-file-directory) ;; `tramp-get-home-directory' performed by default-handler. ;; `tramp-get-remote-gid' performed by default handler. + ;; `tramp-get-remote-groups' performed by default handler. ;; `tramp-get-remote-uid' performed by default handler. (tramp-set-file-uid-gid . tramp-crypt-handle-set-file-uid-gid) (unhandled-file-name-directory . ignore) @@ -554,7 +555,7 @@ localname." (defun tramp-crypt-handle-access-file (filename string) "Like `access-file' for Tramp files." (let* ((encrypt-filename (tramp-crypt-encrypt-file-name filename)) - (encrypt-regexp (rx (literal encrypt-filename) eos)) + (encrypt-regexp (tramp-compat-rx (literal encrypt-filename) eos)) tramp-crypt-enabled) (condition-case err (access-file encrypt-filename string) @@ -583,6 +584,7 @@ This function is invoked by `tramp-crypt-handle-copy-file' and `tramp-crypt-handle-rename-file'. It is an error if OP is neither of `copy' and `rename'. FILENAME and NEWNAME must be absolute file names." + ;; FILENAME and NEWNAME are already expanded. (unless (memq op '(copy rename)) (error "Unknown operation `%s', must be `copy' or `rename'" op)) @@ -706,7 +708,7 @@ absolute file names." (mapcar (lambda (x) (replace-regexp-in-string - (rx bos (literal directory)) "" + (tramp-compat-rx bos (literal directory)) "" (tramp-crypt-decrypt-file-name x))) (directory-files (tramp-crypt-encrypt-file-name directory) 'full))))) diff --git a/lisp/net/tramp-fuse.el b/lisp/net/tramp-fuse.el index 4b51af070aa..ea6b5a0622c 100644 --- a/lisp/net/tramp-fuse.el +++ b/lisp/net/tramp-fuse.el @@ -69,10 +69,11 @@ (tramp-fuse-local-file-name directory)))))))) (if full ;; Massage the result. - (let ((local (rx bol - (literal - (tramp-fuse-mount-point - (tramp-dissect-file-name directory))))) + (let ((local (tramp-compat-rx + bol + (literal + (tramp-fuse-mount-point + (tramp-dissect-file-name directory))))) (remote (directory-file-name (funcall (if (tramp-compat-file-name-quoted-p directory) @@ -179,7 +180,8 @@ It has the same meaning as `remote-file-name-inhibit-cache'.") (tramp-set-file-property vec "/" "mounted" (when (string-match - (rx bol (group (literal (tramp-fuse-mount-spec vec))) space) + (tramp-compat-rx + bol (group (literal (tramp-fuse-mount-spec vec))) blank) mount) (match-string 1 mount))))))) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 9c81bccffc9..cf23676b0c2 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -414,9 +414,10 @@ It has been changed in GVFS 1.14.") ;; </interface> (defconst tramp-goa-identity-regexp - (rx bol (? (group (regexp tramp-user-regexp))) - "@" (? (group (regexp tramp-host-regexp))) - (? ":" (group (regexp tramp-port-regexp)))) + (tramp-compat-rx + bol (? (group (regexp tramp-user-regexp))) + "@" (? (group (regexp tramp-host-regexp))) + (? ":" (group (regexp tramp-port-regexp)))) "Regexp matching GNOME Online Accounts \"PresentationIdentity\" property.") (defconst tramp-goa-interface-mail "org.gnome.OnlineAccounts.Mail" @@ -715,13 +716,15 @@ It has been changed in GVFS 1.14.") "GVFS file attributes.")) (defconst tramp-gvfs-file-attributes-with-gvfs-ls-regexp - (rx blank (group (regexp (regexp-opt tramp-gvfs-file-attributes))) - "=" (group (+? nonl))) + (tramp-compat-rx + blank (group (regexp (regexp-opt tramp-gvfs-file-attributes))) + "=" (group (+? nonl))) "Regexp to parse GVFS file attributes with `gvfs-ls'.") (defconst tramp-gvfs-file-attributes-with-gvfs-info-regexp - (rx bol (* blank) (group (regexp (regexp-opt tramp-gvfs-file-attributes))) - ":" (+ blank) (group (* nonl)) eol) + (tramp-compat-rx + bol (* blank) (group (regexp (regexp-opt tramp-gvfs-file-attributes))) + ":" (+ blank) (group (* nonl)) eol) "Regexp to parse GVFS file attributes with `gvfs-info'.") (defconst tramp-gvfs-file-system-attributes @@ -731,16 +734,17 @@ It has been changed in GVFS 1.14.") "GVFS file system attributes.") (defconst tramp-gvfs-file-system-attributes-regexp - (rx bol (* blank) - (group (regexp (regexp-opt tramp-gvfs-file-system-attributes))) - ":" (+ blank) (group (* nonl)) eol) + (tramp-compat-rx + bol (* blank) + (group (regexp (regexp-opt tramp-gvfs-file-system-attributes))) + ":" (+ blank) (group (* nonl)) eol) "Regexp to parse GVFS file system attributes with `gvfs-info'.") (defconst tramp-gvfs-nextcloud-default-prefix "/remote.php/webdav" "Default prefix for owncloud / nextcloud methods.") (defconst tramp-gvfs-nextcloud-default-prefix-regexp - (rx (literal tramp-gvfs-nextcloud-default-prefix) eol) + (tramp-compat-rx (literal tramp-gvfs-nextcloud-default-prefix) eol) "Regexp of default prefix for owncloud / nextcloud methods.") @@ -823,6 +827,7 @@ It has been changed in GVFS 1.14.") (temporary-file-directory . tramp-handle-temporary-file-directory) (tramp-get-home-directory . tramp-gvfs-handle-get-home-directory) (tramp-get-remote-gid . tramp-gvfs-handle-get-remote-gid) + (tramp-get-remote-groups . ignore) (tramp-get-remote-uid . tramp-gvfs-handle-get-remote-uid) (tramp-set-file-uid-gid . tramp-gvfs-handle-set-file-uid-gid) (unhandled-file-name-directory . ignore) @@ -966,7 +971,7 @@ The global value will always be nil; it is bound where needed.") (defun tramp-gvfs-info (filename &optional arg) "Check FILENAME via `gvfs-info'. Set file property \"file-exists-p\" with the result." - (with-parsed-tramp-file-name filename nil + (with-parsed-tramp-file-name (expand-file-name filename) nil (tramp-set-file-property v localname "file-exists-p" (tramp-gvfs-send-command @@ -989,6 +994,7 @@ This function is invoked by `tramp-gvfs-handle-copy-file' and `tramp-gvfs-handle-rename-file'. It is an error if OP is neither of `copy' and `rename'. FILENAME and NEWNAME must be absolute file names." + ;; FILENAME and NEWNAME are already expanded. (unless (memq op '(copy rename)) (error "Unknown operation `%s', must be `copy' or `rename'" op)) @@ -1132,7 +1138,7 @@ file names." (defun tramp-gvfs-handle-delete-file (filename &optional trash) "Like `delete-file' for Tramp files." - (with-parsed-tramp-file-name filename nil + (with-parsed-tramp-file-name (expand-file-name filename) nil (tramp-flush-file-properties v localname) (if (and delete-by-moving-to-trash trash) (move-file-to-trash filename) @@ -1161,7 +1167,7 @@ file names." (with-parsed-tramp-file-name name nil ;; If there is a default location, expand tilde. (when (string-match - (rx bos "~" (group (* (not (any "/")))) (group (* nonl)) eos) + (tramp-compat-rx bos "~" (group (* (not "/"))) (group (* nonl)) eos) localname) (let ((uname (match-string 1 localname)) (fname (match-string 2 localname)) @@ -1179,7 +1185,7 @@ file names." ;; We do not pass "/..". (if (string-match-p (rx bos (| "afp" (: "dav" (? "s")) "smb") eos) method) (when (string-match - (rx bos "/" (+ (not (any "/"))) (group "/.." (? "/"))) + (tramp-compat-rx bos "/" (+ (not "/")) (group "/.." (? "/"))) localname) (setq localname (replace-match "/" t t localname 1))) (when (string-match (rx bol "/.." (? "/")) localname) @@ -1202,7 +1208,7 @@ file names." ;; Don't modify `last-coding-system-used' by accident. (let ((last-coding-system-used last-coding-system-used) result) - (with-parsed-tramp-file-name directory nil + (with-parsed-tramp-file-name (expand-file-name directory) nil (with-tramp-file-property v localname "directory-attributes" (tramp-message v 5 "directory gvfs attributes: %s" localname) ;; Send command. @@ -1215,20 +1221,22 @@ file names." (with-current-buffer (tramp-get-connection-buffer v) (goto-char (point-min)) (while (looking-at - (rx bol (group (+ nonl)) blank - (group (+ digit)) blank - "(" (group (+? nonl)) ")" - (regexp tramp-gvfs-file-attributes-with-gvfs-ls-regexp))) + (tramp-compat-rx + bol (group (+ nonl)) blank + (group (+ digit)) blank + "(" (group (+? nonl)) ")" + (regexp tramp-gvfs-file-attributes-with-gvfs-ls-regexp))) (let ((item (list (cons "type" (match-string 3)) (cons "standard::size" (match-string 2)) (cons "name" (match-string 1))))) (goto-char (1+ (match-end 3))) (while (looking-at - (rx (regexp tramp-gvfs-file-attributes-with-gvfs-ls-regexp) - (group - (| (regexp - tramp-gvfs-file-attributes-with-gvfs-ls-regexp) - eol)))) + (tramp-compat-rx + (regexp tramp-gvfs-file-attributes-with-gvfs-ls-regexp) + (group + (| (regexp + tramp-gvfs-file-attributes-with-gvfs-ls-regexp) + eol)))) (push (cons (match-string 1) (match-string 2)) item) (goto-char (match-end 2))) ;; Add display name as head. @@ -1246,7 +1254,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." ;; Don't modify `last-coding-system-used' by accident. (let ((last-coding-system-used last-coding-system-used) result) - (with-parsed-tramp-file-name filename nil + (with-parsed-tramp-file-name (expand-file-name filename) nil (with-tramp-file-property v localname (if file-system "file-system-attributes" "file-attributes") @@ -1276,7 +1284,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." (if (or (and (string-match-p (rx bol (| "afp" (: "dav" (? "s")) "smb") eol) method) (string-match-p - (rx bol (? "/") (+ (not (any "/"))) eol) localname)) + (tramp-compat-rx bol (? "/") (+ (not "/")) eol) localname)) (string-equal localname "/")) (tramp-gvfs-get-root-attributes filename) (assoc @@ -1405,7 +1413,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." (defun tramp-gvfs-handle-file-executable-p (filename) "Like `file-executable-p' for Tramp files." - (with-parsed-tramp-file-name filename nil + (with-parsed-tramp-file-name (expand-file-name filename) nil (with-tramp-file-property v localname "file-executable-p" (or (tramp-check-cached-permissions v ?x) (tramp-check-cached-permissions v ?s))))) @@ -1476,7 +1484,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." (let* ((events (process-get proc 'events)) (rest-string (process-get proc 'rest-string)) (dd (tramp-get-default-directory (process-buffer proc))) - (ddu (rx (literal (tramp-gvfs-url-file-name dd))))) + (ddu (tramp-compat-rx (literal (tramp-gvfs-url-file-name dd))))) (when rest-string (tramp-message proc 10 "Previous string:\n%s" rest-string)) (tramp-message proc 6 "%S\n%s" proc string) @@ -1495,10 +1503,11 @@ If FILE-SYSTEM is non-nil, return file system attributes." (delete-process proc)) (while (string-match - (rx bol (+ nonl) ":" - space (group (+ nonl)) ":" - space (group (regexp (regexp-opt tramp-gio-events))) - (? (group space (group (+ nonl)))) eol) + (tramp-compat-rx + bol (+ nonl) ":" + blank (group (+ nonl)) ":" + blank (group (regexp (regexp-opt tramp-gio-events))) + (? (group blank (group (+ nonl)))) eol) string) (let ((file (match-string 1 string)) @@ -1729,7 +1738,8 @@ ID-FORMAT valid values are `string' and `integer'." "Retrieve file name from D-Bus OBJECT-PATH." (dbus-unescape-from-identifier (replace-regexp-in-string - (rx bol (* nonl) "/" (group (+ (not (any "/")))) eol) "\\1" object-path))) + (tramp-compat-rx bol (* nonl) "/" (group (+ (not "/"))) eol) "\\1" + object-path))) (defun tramp-gvfs-url-host (url) "Return the host name part of URL, a string. @@ -2004,8 +2014,9 @@ Their full names are \"org.gtk.vfs.MountTracker.mounted\" and (string-equal domain (tramp-file-name-domain vec)) (string-equal host (tramp-file-name-host vec)) (string-equal port (tramp-file-name-port vec)) - (string-match-p (rx bol "/" (literal (or share ""))) - (tramp-file-name-unquote-localname vec))) + (string-match-p + (tramp-compat-rx bol "/" (literal (or share ""))) + (tramp-file-name-unquote-localname vec))) ;; Set mountpoint and location. (tramp-set-file-property vec "/" "fuse-mountpoint" fuse-mountpoint) (tramp-set-connection-property @@ -2049,7 +2060,8 @@ It was \"a(say)\", but has changed to \"a{sv})\"." (tramp-media-device-port media) (tramp-file-name-port vec))) (localname (tramp-file-name-unquote-localname vec)) (share (when (string-match - (rx bol (? "/") (group (+ (not (any "/"))))) localname) + (tramp-compat-rx bol (? "/") (group (+ (not "/")))) + localname) (match-string 1 localname))) (ssl (if (string-match-p (rx bol (| "davs" "nextcloud")) method) "true" "false")) @@ -2092,7 +2104,8 @@ It was \"a(say)\", but has changed to \"a{sv})\"." (list (tramp-gvfs-mount-spec-entry "port" port))))) (mount-pref (if (and (string-match-p (rx bol "dav") method) - (string-match (rx bol (? "/") (+ (not (any "/")))) localname)) + (string-match + (tramp-compat-rx bol (? "/") (+ (not "/"))) localname)) (match-string 0 localname) (tramp-gvfs-get-remote-prefix vec)))) diff --git a/lisp/net/tramp-integration.el b/lisp/net/tramp-integration.el index afc3e945802..61b2c2ecb7c 100644 --- a/lisp/net/tramp-integration.el +++ b/lisp/net/tramp-integration.el @@ -218,11 +218,11 @@ NAME must be equal to `tramp-current-connection'." :mode 'tramp-info-lookup-mode :topic 'symbol :regexp (rx (+ (not (any "\t\n \"'(),[]`‘’")))) :doc-spec '(("(tramp)Function Index" nil - (rx bol space (+ "-") space (* nonl) ": ") - (rx (| space eol))) + (rx bol blank (+ "-") blank (* nonl) ": ") + (rx (| blank eol))) ("(tramp)Variable Index" nil - (rx bol space (+ "-") space (* nonl) ": ") - (rx (| space eol))))) + (rx bol blank (+ "-") blank (* nonl) ": ") + (rx (| blank eol))))) (add-hook 'tramp-integration-unload-hook diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index 435faf83294..9e379da8c1e 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -147,6 +147,7 @@ (temporary-file-directory . tramp-handle-temporary-file-directory) (tramp-get-home-directory . ignore) (tramp-get-remote-gid . ignore) + (tramp-get-remote-groups . ignore) (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) @@ -186,7 +187,7 @@ arguments to pass to the OPERATION." (delq nil (mapcar (lambda (line) - (when (string-match (rx bol (group (+ (not space))) ":" eol) line) + (when (string-match (rx bol (group (+ (not blank))) ":" eol) line) `(nil ,(match-string 1 line)))) (tramp-process-lines nil tramp-rclone-program "listremotes"))))) @@ -210,6 +211,7 @@ This function is invoked by `tramp-rclone-handle-copy-file' and `tramp-rclone-handle-rename-file'. It is an error if OP is neither of `copy' and `rename'. FILENAME and NEWNAME must be absolute file names." + ;; FILENAME and NEWNAME are already expanded. (unless (memq op '(copy rename)) (error "Unknown operation `%s', must be `copy' or `rename'" op)) @@ -300,11 +302,11 @@ file names." (let (total used free) (goto-char (point-min)) (while (not (eobp)) - (when (looking-at (rx "Total: " (+ space) (group (+ digit)))) + (when (looking-at (rx "Total: " (+ blank) (group (+ digit)))) (setq total (string-to-number (match-string 1)))) - (when (looking-at (rx "Used: " (+ space) (group (+ digit)))) + (when (looking-at (rx "Used: " (+ blank) (group (+ digit)))) (setq used (string-to-number (match-string 1)))) - (when (looking-at (rx "Free: " (+ space) (group (+ digit)))) + (when (looking-at (rx "Free: " (+ blank) (group (+ digit)))) (setq free (string-to-number (match-string 1)))) (forward-line)) (when used diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index dfb87059bdf..1c26e25e57e 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -411,7 +411,7 @@ The string is used in `tramp-methods'.") (add-to-list 'tramp-default-method-alist `(,tramp-local-host-regexp - ,(rx bos (literal tramp-root-id-string) eos) "su")) + ,(tramp-compat-rx bos (literal tramp-root-id-string) eos) "su")) (add-to-list 'tramp-default-user-alist `(,(rx bos (| "su" "sudo" "doas" "ksu") eos) @@ -783,6 +783,41 @@ characters need to be doubled.") Format specifiers are replaced by `tramp-expand-script', percent characters need to be doubled.") +(defconst tramp-perl-id + "%p -e ' +use strict; +use warnings; +use POSIX qw(getgroups); + +my ($user, $passwd, $uid, $gid) = getpwuid $< ; +my $group = getgrgid $gid ; +my @groups = map { $_ . \"(\" . getgrgid ($_) . \")\" } getgroups (); + +printf \"uid=%%d(%%s) gid=%%d(%%s) groups=%%s\\n\", + $uid, $user, $gid, $group, join \",\", @groups;' %n" + "Perl script printing `id' output. +Format specifiers are replaced by `tramp-expand-script', percent +characters need to be doubled.") + +(defconst tramp-python-id + "%y -c ' +import os, pwd, grp; + +def idform(id): + return \"{:d}({:s})\".format(id, grp.getgrgid(id)[0]); + +uid = os.getuid(); +user = pwd.getpwuid(uid)[0]; +gid = os.getgid(); +group = grp.getgrgid(gid)[0] +groups = map(idform, os.getgrouplist(user, gid)); + +print(\"uid={:d}({:s}) gid={:d}({:s}) groups={:s}\" + .format(uid, user, gid, group, \",\".join(groups)));' %n" + "Python script printing `id' output. +Format specifiers are replaced by `tramp-expand-script', percent +characters need to be doubled.") + ;; These two use base64 encoding. (defconst tramp-perl-encode-with-module "%p -MMIME::Base64 -0777 -ne 'print encode_base64($_)' %n" @@ -1082,6 +1117,7 @@ Format specifiers \"%s\" are replaced before the script is used.") (temporary-file-directory . tramp-handle-temporary-file-directory) (tramp-get-home-directory . tramp-sh-handle-get-home-directory) (tramp-get-remote-gid . tramp-sh-handle-get-remote-gid) + (tramp-get-remote-groups . tramp-sh-handle-get-remote-groups) (tramp-get-remote-uid . tramp-sh-handle-get-remote-uid) (tramp-set-file-uid-gid . tramp-sh-handle-set-file-uid-gid) (unhandled-file-name-directory . ignore) @@ -1100,66 +1136,63 @@ Operations not mentioned here will be handled by the normal Emacs functions.") If TARGET is a non-Tramp file, it is used verbatim as the target of the symlink. If TARGET is a Tramp file, only the localname component is used as the target of the symlink." - (if (not (tramp-tramp-file-p (expand-file-name linkname))) - (tramp-run-real-handler - #'make-symbolic-link (list target linkname ok-if-already-exists)) - - (with-parsed-tramp-file-name linkname nil - ;; If TARGET is a Tramp name, use just the localname component. - ;; Don't check for a proper method. - (let ((non-essential t)) - (when (and (tramp-tramp-file-p target) - (tramp-file-name-equal-p v (tramp-dissect-file-name target))) - (setq target (tramp-file-local-name (expand-file-name target)))) - ;; There could be a cyclic link. - (tramp-flush-file-properties - v (expand-file-name target (tramp-file-local-name default-directory)))) - - ;; If TARGET is still remote, quote it. - (if (tramp-tramp-file-p target) - (make-symbolic-link (tramp-compat-file-name-quote target 'top) - linkname ok-if-already-exists) - - (let ((ln (tramp-get-remote-ln v)) - (cwd (tramp-run-real-handler - #'file-name-directory (list localname)))) - (unless ln - (tramp-error - v 'file-error - (concat "Making a symbolic link. " - "ln(1) does not exist on the remote host."))) - - ;; Do the 'confirm if exists' thing. - (when (file-exists-p linkname) - ;; What to do? - (if (or (null ok-if-already-exists) ; not allowed to exist - (and (numberp ok-if-already-exists) - (not - (yes-or-no-p - (format - "File %s already exists; make it a link anyway?" - localname))))) - (tramp-error v 'file-already-exists localname) - (delete-file linkname))) - - (tramp-flush-file-properties v localname) - - ;; Right, they are on the same host, regardless of user, - ;; method, etc. We now make the link on the remote - ;; machine. This will occur as the user that TARGET belongs to. - (and (tramp-send-command-and-check - v (format "cd %s" (tramp-shell-quote-argument cwd))) - (tramp-send-command-and-check - v (format - "%s -sf %s %s" ln - (tramp-shell-quote-argument target) - ;; The command could exceed PATH_MAX, so we use - ;; relative file names. However, relative file - ;; names could start with "-". - ;; `tramp-shell-quote-argument' does not handle - ;; this, we must do it ourselves. - (tramp-shell-quote-argument - (concat "./" (file-name-nondirectory localname))))))))))) + (with-parsed-tramp-file-name (expand-file-name linkname) nil + ;; If TARGET is a Tramp name, use just the localname component. + ;; Don't check for a proper method. + (let ((non-essential t)) + (when (and (tramp-tramp-file-p target) + (tramp-file-name-equal-p v (tramp-dissect-file-name target))) + (setq target (tramp-file-local-name (expand-file-name target)))) + ;; There could be a cyclic link. + (tramp-flush-file-properties + v (expand-file-name target (tramp-file-local-name default-directory)))) + + ;; If TARGET is still remote, quote it. + (if (tramp-tramp-file-p target) + (make-symbolic-link + (tramp-compat-file-name-quote target 'top) + linkname ok-if-already-exists) + + (let ((ln (tramp-get-remote-ln v)) + (cwd (tramp-run-real-handler + #'file-name-directory (list localname)))) + (unless ln + (tramp-error + v 'file-error + (concat "Making a symbolic link. " + "ln(1) does not exist on the remote host."))) + + ;; Do the 'confirm if exists' thing. + (when (file-exists-p linkname) + ;; What to do? + (if (or (null ok-if-already-exists) ; not allowed to exist + (and (numberp ok-if-already-exists) + (not + (yes-or-no-p + (format + "File %s already exists; make it a link anyway?" + localname))))) + (tramp-error v 'file-already-exists localname) + (delete-file linkname))) + + (tramp-flush-file-properties v localname) + + ;; Right, they are on the same host, regardless of user, + ;; method, etc. We now make the link on the remote machine. + ;; This will occur as the user that TARGET belongs to. + (and (tramp-send-command-and-check + v (format "cd %s" (tramp-shell-quote-argument cwd))) + (tramp-send-command-and-check + v (format + "%s -sf %s %s" ln + (tramp-shell-quote-argument target) + ;; The command could exceed PATH_MAX, so we use + ;; relative file names. However, relative file names + ;; could start with "-". + ;; `tramp-shell-quote-argument' does not handle this, + ;; we must do it ourselves. + (tramp-shell-quote-argument + (concat "./" (file-name-nondirectory localname)))))))))) (defun tramp-sh-handle-file-truename (filename) "Like `file-truename' for Tramp files." @@ -1223,7 +1256,7 @@ component is used as the target of the symlink." ;; We don't want to run it when `non-essential' is t, or there is ;; no connection process yet. (when (tramp-connectable-p filename) - (with-parsed-tramp-file-name filename nil + (with-parsed-tramp-file-name (expand-file-name filename) nil (with-tramp-file-property v localname "file-exists-p" (if (tramp-file-property-p v localname "file-attributes") (not (null (tramp-get-file-property v localname "file-attributes"))) @@ -1398,7 +1431,7 @@ component is used as the target of the symlink." (buffer-name))) (if time-list (tramp-run-real-handler #'set-visited-file-modtime (list time-list)) - (let ((f (buffer-file-name)) + (let ((f (expand-file-name (buffer-file-name))) coding-system-used) (with-parsed-tramp-file-name f nil (let* ((remote-file-name-inhibit-cache t) @@ -1523,10 +1556,16 @@ ID-FORMAT valid values are `string' and `integer'." ;; The result is cached in `tramp-get-remote-uid'. (ignore-errors (cond - ((tramp-get-remote-id vec) (tramp-get-remote-uid-with-id vec id-format)) - ((tramp-get-remote-perl vec) (tramp-get-remote-uid-with-perl vec id-format)) + ((tramp-get-remote-id vec) + (tramp-send-command vec (tramp-get-remote-id vec))) + ((tramp-get-remote-perl vec) + (tramp-maybe-send-script vec tramp-perl-id "tramp_perl_id") + (tramp-send-command vec "tramp_perl_id")) ((tramp-get-remote-python vec) - (tramp-get-remote-uid-with-python vec id-format))))) + (tramp-maybe-send-script vec tramp-python-id "tramp_python_id") + (tramp-send-command vec "tramp_python_id"))) + (tramp-read-id-output vec) + (tramp-get-connection-property vec (format "uid-%s" id-format)))) (defun tramp-sh-handle-get-remote-gid (vec id-format) "The gid of the remote connection VEC, in ID-FORMAT. @@ -1534,10 +1573,33 @@ ID-FORMAT valid values are `string' and `integer'." ;; The result is cached in `tramp-get-remote-gid'. (ignore-errors (cond - ((tramp-get-remote-id vec) (tramp-get-remote-gid-with-id vec id-format)) - ((tramp-get-remote-perl vec) (tramp-get-remote-gid-with-perl vec id-format)) + ((tramp-get-remote-id vec) + (tramp-send-command vec (tramp-get-remote-id vec))) + ((tramp-get-remote-perl vec) + (tramp-maybe-send-script vec tramp-perl-id "tramp_perl_id") + (tramp-send-command vec "tramp_perl_id")) + ((tramp-get-remote-python vec) + (tramp-maybe-send-script vec tramp-python-id "tramp_python_id") + (tramp-send-command vec "tramp_python_id"))) + (tramp-read-id-output vec) + (tramp-get-connection-property vec (format "gid-%s" id-format)))) + +(defun tramp-sh-handle-get-remote-groups (vec id-format) + "Like `tramp-get-remote-groups' for Tramp files. +ID-FORMAT valid values are `string' and `integer'." + ;; The result is cached in `tramp-get-remote-groups'. + (ignore-errors + (cond + ((tramp-get-remote-id vec) + (tramp-send-command vec (tramp-get-remote-id vec))) + ((tramp-get-remote-perl vec) + (tramp-maybe-send-script vec tramp-perl-id "tramp_perl_id") + (tramp-send-command vec "tramp_perl_id")) ((tramp-get-remote-python vec) - (tramp-get-remote-gid-with-python vec id-format))))) + (tramp-maybe-send-script vec tramp-python-id "tramp_python_id") + (tramp-send-command vec "tramp_python_id"))) + (tramp-read-id-output vec) + (tramp-get-connection-property vec (format "groups-%s" id-format)))) (defun tramp-sh-handle-set-file-uid-gid (filename &optional uid gid) "Like `tramp-set-file-uid-gid' for Tramp files." @@ -1567,13 +1629,14 @@ ID-FORMAT valid values are `string' and `integer'." (defun tramp-sh-handle-file-selinux-context (filename) "Like `file-selinux-context' for Tramp files." - (with-parsed-tramp-file-name filename nil + (with-parsed-tramp-file-name (expand-file-name filename) nil (with-tramp-file-property v localname "file-selinux-context" (let ((context '(nil nil nil nil)) - (regexp (rx (group (+ (any "_" alnum))) ":" - (group (+ (any "_" alnum))) ":" - (group (+ (any "_" alnum))) ":" - (group (+ (any "_" alnum)))))) + (regexp (tramp-compat-rx + (group (+ (any "_" alnum))) ":" + (group (+ (any "_" alnum))) ":" + (group (+ (any "_" alnum))) ":" + (group (+ (any "_" alnum)))))) (when (and (tramp-remote-selinux-p v) (tramp-send-command-and-check v (format @@ -1590,7 +1653,7 @@ ID-FORMAT valid values are `string' and `integer'." (defun tramp-sh-handle-set-file-selinux-context (filename context) "Like `set-file-selinux-context' for Tramp files." - (with-parsed-tramp-file-name filename nil + (with-parsed-tramp-file-name (expand-file-name filename) nil (when (and (consp context) (tramp-remote-selinux-p v)) (let ((user (and (stringp (nth 0 context)) (nth 0 context))) @@ -1617,7 +1680,7 @@ ID-FORMAT valid values are `string' and `integer'." (defun tramp-sh-handle-file-acl (filename) "Like `file-acl' for Tramp files." - (with-parsed-tramp-file-name filename nil + (with-parsed-tramp-file-name (expand-file-name filename) nil (with-tramp-file-property v localname "file-acl" (when (and (tramp-remote-acl-p v) (tramp-send-command-and-check @@ -1654,7 +1717,7 @@ ID-FORMAT valid values are `string' and `integer'." (defun tramp-sh-handle-file-executable-p (filename) "Like `file-executable-p' for Tramp files." - (with-parsed-tramp-file-name filename nil + (with-parsed-tramp-file-name (expand-file-name filename) nil (with-tramp-file-property v localname "file-executable-p" ;; Examine `file-attributes' cache to see if request can be ;; satisfied without remote operation. @@ -1665,8 +1728,10 @@ ID-FORMAT valid values are `string' and `integer'." (defun tramp-sh-handle-file-readable-p (filename) "Like `file-readable-p' for Tramp files." - (with-parsed-tramp-file-name filename nil + (with-parsed-tramp-file-name (expand-file-name filename) nil (with-tramp-file-property v localname "file-readable-p" + ;; Examine `file-attributes' cache to see if request can be + ;; satisfied without remote operation. (if (tramp-file-property-p v localname "file-attributes") (tramp-handle-file-readable-p filename) (tramp-run-test "-r" filename))))) @@ -1675,7 +1740,7 @@ ID-FORMAT valid values are `string' and `integer'." (defun tramp-sh-handle-file-directory-p (filename) "Like `file-directory-p' for Tramp files." - (with-parsed-tramp-file-name filename nil + (with-parsed-tramp-file-name (expand-file-name filename) nil ;; `file-directory-p' is used as predicate for file name completion. ;; Sometimes, when a connection is not established yet, it is ;; desirable to return t immediately for "/method:foo:". It can @@ -1694,7 +1759,7 @@ ID-FORMAT valid values are `string' and `integer'." (defun tramp-sh-handle-file-writable-p (filename) "Like `file-writable-p' for Tramp files." - (with-parsed-tramp-file-name filename nil + (with-parsed-tramp-file-name (expand-file-name filename) nil (with-tramp-file-property v localname "file-writable-p" (if (file-exists-p filename) (if (tramp-file-property-p v localname "file-attributes") @@ -1703,12 +1768,13 @@ ID-FORMAT valid values are `string' and `integer'." (tramp-check-cached-permissions v ?w) (tramp-run-test "-w" filename)) ;; If file doesn't exist, check if directory is writable. - (and (file-exists-p (file-name-directory filename)) - (tramp-run-test "-w" (file-name-directory filename))))))) + (and + (file-directory-p (file-name-directory filename)) + (file-writable-p (file-name-directory filename))))))) (defun tramp-sh-handle-file-ownership-preserved-p (filename &optional group) "Like `file-ownership-preserved-p' for Tramp files." - (with-parsed-tramp-file-name filename nil + (with-parsed-tramp-file-name (expand-file-name filename) nil (with-tramp-file-property v localname (format "file-ownership-preserved-p%s" (if group "-group" "")) @@ -1845,8 +1911,8 @@ ID-FORMAT valid values are `string' and `integer'." v 'file-error "add-name-to-file: %s" "only implemented for same method, same user, same host"))) - (with-parsed-tramp-file-name filename v1 - (with-parsed-tramp-file-name newname v2 + (with-parsed-tramp-file-name (expand-file-name filename) v1 + (with-parsed-tramp-file-name (expand-file-name newname) v2 (let ((ln (when v1 (tramp-get-remote-ln v1)))) ;; Do the 'confirm if exists' thing. @@ -1942,7 +2008,7 @@ ID-FORMAT valid values are `string' and `integer'." ;; When newname did exist, we have wrong cached values. (when t2 - (with-parsed-tramp-file-name newname nil + (with-parsed-tramp-file-name (expand-file-name newname) nil (tramp-flush-file-properties v localname))))))) (defun tramp-sh-handle-rename-file @@ -1978,6 +2044,7 @@ This function is invoked by `tramp-sh-handle-copy-file' and `tramp-sh-handle-rename-file'. It is an error if OP is neither of `copy' and `rename'. FILENAME and NEWNAME must be absolute file names." + ;; FILENAME and NEWNAME are already expanded. (unless (memq op '(copy rename)) (error "Unknown operation `%s', must be `copy' or `rename'" op)) @@ -2090,6 +2157,7 @@ file names." First arg OP is either `copy' or `rename' and indicates the operation. FILENAME is the source file, NEWNAME the target file. KEEP-DATE is non-nil if NEWNAME should have the same timestamp as FILENAME." + ;; FILENAME and NEWNAME are already expanded. ;; Check, whether file is too large. Emacs checks in `insert-file-1' ;; and `find-file-noselect', but that's not called here. (abort-if-file-too-large @@ -2132,6 +2200,7 @@ the file (for rename). Both files must reside on the same host. KEEP-DATE means to make sure that NEWNAME has the same timestamp as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep the uid and gid from FILENAME." + ;; FILENAME and NEWNAME are already expanded. (let ((t1 (tramp-tramp-file-p filename)) (t2 (tramp-tramp-file-p newname)) (file-times (file-attribute-modification-time @@ -2280,6 +2349,7 @@ the uid and gid from FILENAME." (op filename newname ok-if-already-exists keep-date) "Invoke `scp' program to copy. The method used must be an out-of-band method." + ;; FILENAME and NEWNAME are already expanded. (let* ((v1 (and (tramp-tramp-file-p filename) (tramp-dissect-file-name filename))) (v2 (and (tramp-tramp-file-p newname) @@ -2515,7 +2585,7 @@ The method used must be an out-of-band method." (defun tramp-sh-handle-delete-file (filename &optional trash) "Like `delete-file' for Tramp files." - (setq filename (expand-file-name filename)) + (setq filename (expand-file-name (expand-file-name filename))) (with-parsed-tramp-file-name filename nil (if (and delete-by-moving-to-trash trash) (move-file-to-trash filename) @@ -2533,7 +2603,7 @@ The method used must be an out-of-band method." (if (>= emacs-major-version 29) (tramp-run-real-handler #'dired-compress-file (list file)) ;; Code stolen mainly from dired-aux.el. - (with-parsed-tramp-file-name file nil + (with-parsed-tramp-file-name (expand-file-name file) nil (tramp-flush-file-properties v localname) (let ((suffixes dired-compress-file-suffixes) suffix) @@ -2660,7 +2730,7 @@ The method used must be an out-of-band method." (narrow-to-region beg-marker end-marker) ;; Check for "--dired" output. (when (re-search-backward - (rx bol "//DIRED//" (+ space) (group (+ nonl)) eol) + (rx bol "//DIRED//" (+ blank) (group (+ nonl)) eol) nil 'noerror) (let ((beg (match-beginning 1)) (end (match-end 0))) @@ -2733,7 +2803,7 @@ The method used must be an out-of-band method." ;; Try to insert the amount of free space. (goto-char (point-min)) ;; First find the line to put it on. - (when (and (re-search-forward (rx bol (group (* space) "total")) nil t) + (when (and (re-search-forward (rx bol (group (* blank) "total")) nil t) ;; Emacs 29.1 or later. (not (fboundp 'dired--insert-disk-space))) (when-let ((available (get-free-disk-space "."))) @@ -2760,7 +2830,8 @@ the result will be a local, non-Tramp, file name." ;; by `file-name-absolute-p'. (if (and (eq system-type 'windows-nt) (string-match-p - (rx bol (| (: alpha ":") (: (literal null-device) eol))) name)) + (tramp-compat-rx bol (| (: alpha ":") (: (literal null-device) eol))) + name)) (tramp-run-real-handler #'expand-file-name (list name dir)) ;; Unless NAME is absolute, concat DIR and NAME. (unless (file-name-absolute-p name) @@ -2777,7 +2848,8 @@ the result will be a local, non-Tramp, file name." ;; supposed to find such a shell on the remote host. Please ;; tell me about it when this doesn't work on your system. (when (string-match - (rx bos "~" (group (* (not (any "/")))) (group (* nonl)) eos) + (tramp-compat-rx + bos "~" (group (* (not "/"))) (group (* nonl)) eos) localname) (let ((uname (match-string 1 localname)) (fname (match-string 2 localname)) @@ -3837,7 +3909,7 @@ Fall back to normal file name handler if no Tramp handler exists." ((string-match (rx "Supported arguments for " "GIO_USE_FILE_MONITOR environment variable:\n" - (* space) (group (+ alpha)) " - 20") + (* blank) (group (+ alpha)) " - 20") string) (setq pos (match-end 0)) (intern @@ -3849,10 +3921,11 @@ Fall back to normal file name handler if no Tramp handler exists." (setq string (tramp-compat-string-replace "\n\n" "\n" string)) (while (string-match - (rx bol (+ (not (any ":"))) ":" space - (group (+ (not (any ":")))) ":" space - (group (regexp (regexp-opt tramp-gio-events))) - (? space (group (+ (not (any ":"))))) eol) + (tramp-compat-rx + bol (+ (not ":")) ":" blank + (group (+ (not ":"))) ":" blank + (group (regexp (regexp-opt tramp-gio-events))) + (? blank (group (+ (not ":")))) eol) string) (let* ((file (match-string 1 string)) @@ -3926,9 +3999,9 @@ Fall back to normal file name handler if no Tramp handler exists." (goto-char (point-min)) (forward-line) (when (looking-at - (rx (? bol "/" (* (not space)) space) (* space) - (group (+ digit)) (+ space) - (group (+ digit)) (+ space) + (rx (? bol "/" (* (not blank)) blank) (* blank) + (group (+ digit)) (+ blank) + (group (+ digit)) (+ blank) (group (+ digit)))) (mapcar (lambda (d) @@ -3944,58 +4017,73 @@ Fall back to normal file name handler if no Tramp handler exists." (defun tramp-expand-script (vec script) "Expand SCRIPT with remote files or commands. -\"%a\", \"%h\", \"%l\", \"%o\", \"%p\", \"%r\" and \"%s\" format -specifiers are replaced by the respective `awk', `hexdump', `ls', -`od', `perl', `readlink' and `stat' commands. \"%n\" is replaced -by \"2>/dev/null\", and \"%t\" is replaced by a temporary file -name. If VEC is nil, the respective local commands are used. If -there is a format specifier which cannot be expanded, this -function returns nil." +\"%a\", \"%h\", \"%l\", \"%o\", \"%p\", \"%r\", \"%s\" and \"%y\" +format specifiers are replaced by the respective `awk', +`hexdump', `ls', `od', `perl', `readlink', `stat' and `python' +commands. \"%n\" is replaced by \"2>/dev/null\", and \"%t\" is +replaced by a temporary file name. If VEC is nil, the respective +local commands are used. If there is a format specifier which +cannot be expanded, this function returns nil." (if (not (string-match-p - (rx (| bol (not (any "%"))) "%" (any "ahlnoprst")) script)) + (tramp-compat-rx (| bol (not "%")) "%" (any "ahlnoprsty")) script)) script (catch 'wont-work - (let ((awk (when (string-match-p (rx (| bol (not (any "%"))) "%a") script) + (let ((awk (when (string-match-p + (tramp-compat-rx (| bol (not "%")) "%a") script) (or (if vec (tramp-get-remote-awk vec) (executable-find "awk")) (throw 'wont-work nil)))) - (hdmp (when (string-match-p (rx (| bol (not (any "%"))) "%h") script) + (hdmp (when (string-match-p + (tramp-compat-rx (| bol (not "%")) "%h") script) (or (if vec (tramp-get-remote-hexdump vec) (executable-find "hexdump")) (throw 'wont-work nil)))) - (dev (when (string-match-p (rx (| bol (not (any "%"))) "%n") script) + (dev (when (string-match-p + (tramp-compat-rx (| bol (not "%")) "%n") script) (or (if vec (concat "2>" (tramp-get-remote-null-device vec)) (if (eq system-type 'windows-nt) "" (concat "2>" null-device))) (throw 'wont-work nil)))) - (ls (when (string-match-p (rx (| bol (not (any "%"))) "%l") script) + (ls (when (string-match-p + (tramp-compat-rx (| bol (not "%")) "%l") script) (format "%s %s" (or (tramp-get-ls-command vec) (throw 'wont-work nil)) (tramp-sh--quoting-style-options vec)))) - (od (when (string-match-p (rx (| bol (not (any "%"))) "%o") script) + (od (when (string-match-p + (tramp-compat-rx (| bol (not "%")) "%o") script) (or (if vec (tramp-get-remote-od vec) (executable-find "od")) (throw 'wont-work nil)))) - (perl (when (string-match-p (rx (| bol (not (any "%"))) "%p") script) + (perl (when (string-match-p + (tramp-compat-rx (| bol (not "%")) "%p") script) (or (if vec (tramp-get-remote-perl vec) (executable-find "perl")) (throw 'wont-work nil)))) + (python (when (string-match-p + (tramp-compat-rx (| bol (not "%")) "%y") script) + (or + (if vec + (tramp-get-remote-python vec) + (executable-find "python")) + (throw 'wont-work nil)))) (readlink (when (string-match-p - (rx (| bol (not (any "%"))) "%r") script) + (tramp-compat-rx (| bol (not "%")) "%r") script) (or (if vec (tramp-get-remote-readlink vec) (executable-find "readlink")) (throw 'wont-work nil)))) - (stat (when (string-match-p (rx (| bol (not (any "%"))) "%s") script) + (stat (when (string-match-p + (tramp-compat-rx (| bol (not "%")) "%s") script) (or (if vec (tramp-get-remote-stat vec) (executable-find "stat")) (throw 'wont-work nil)))) - (tmp (when (string-match-p (rx (| bol (not (any "%"))) "%t") script) + (tmp (when (string-match-p + (tramp-compat-rx (| bol (not "%")) "%t") script) (or (if vec (tramp-file-local-name (tramp-make-tramp-temp-name vec)) @@ -4005,7 +4093,7 @@ function returns nil." script (format-spec-make ?a awk ?h hdmp ?l ls ?n dev ?o od ?p perl - ?r readlink ?s stat ?t tmp)))))) + ?r readlink ?s stat ?t tmp ?y python)))))) (defun tramp-maybe-send-script (vec script name) "Define in remote shell function NAME implemented as SCRIPT. @@ -4068,7 +4156,7 @@ This function expects to be in the right *tramp* buffer." (unless (or ignore-path (tramp-check-remote-uname vec tramp-sunos-unames)) (tramp-send-command vec (format "which \\%s | wc -w" progname)) (goto-char (point-min)) - (if (looking-at-p (rx bol (* space) "1" eol)) + (if (looking-at-p (rx bol (* blank) "1" eol)) (setq result (concat "\\" progname)))) (unless result (when ignore-tilde @@ -4256,7 +4344,8 @@ file exists and nonzero exit status otherwise." "Couldn't find remote shell prompt for %s" shell) (unless (tramp-check-for-regexp - (tramp-get-connection-process vec) (rx (literal tramp-end-of-output))) + (tramp-get-connection-process vec) + (tramp-compat-rx (literal tramp-end-of-output))) (tramp-wait-for-output (tramp-get-connection-process vec)) (tramp-message vec 5 "Setting shell prompt") (tramp-send-command @@ -4297,7 +4386,8 @@ file exists and nonzero exit status otherwise." (tramp-send-command vec (format "echo ~%s" tramp-root-id-string) t) (if (or (string-match-p - (rx bol "~" (literal tramp-root-id-string) eol) + (tramp-compat-rx + bol "~" (literal tramp-root-id-string) eol) (buffer-string)) ;; The default shell (ksh93) of OpenSolaris ;; and Solaris is buggy. We've got reports @@ -4336,9 +4426,9 @@ seconds. If not, it produces an error message with the given ERROR-ARGS." (condition-case nil (tramp-wait-for-regexp proc timeout - (rx (| (regexp shell-prompt-pattern) - (regexp tramp-shell-prompt-pattern)) - eos)) + (tramp-compat-rx + (| (regexp shell-prompt-pattern) (regexp tramp-shell-prompt-pattern)) + eos)) (error (delete-process proc) (apply #'tramp-error-with-buffer @@ -4698,7 +4788,7 @@ Goes through the list `tramp-local-coding-commands' and (with-current-buffer (tramp-get-connection-buffer vec) (goto-char (point-min)) - (unless (looking-at-p (rx (literal magic))) + (unless (looking-at-p (tramp-compat-rx (literal magic))) (throw 'wont-work-remote nil))) ;; `rem-enc' and `rem-dec' could be a string meanwhile. @@ -4784,7 +4874,7 @@ Goes through the list `tramp-inline-compress-commands'." nil t)) (throw 'next nil)) (goto-char (point-min)) - (unless (looking-at-p (rx (literal magic))) + (unless (looking-at-p (tramp-compat-rx (literal magic))) (throw 'next nil))) (tramp-message vec 5 @@ -4795,7 +4885,7 @@ Goes through the list `tramp-inline-compress-commands'." (throw 'next nil)) (with-current-buffer (tramp-get-buffer vec) (goto-char (point-min)) - (unless (looking-at-p (rx (literal magic))) + (unless (looking-at-p (tramp-compat-rx (literal magic))) (throw 'next nil))) (setq found t))) @@ -4976,9 +5066,9 @@ Goes through the list `tramp-inline-compress-commands'." string (and (string-match - (rx bol (+ (not (any space "#"))) space - (+ (not space)) space - (group (+ (not space))) eol) + (rx bol (+ (not (any blank "#"))) blank + (+ (not blank)) blank + (group (+ (not blank))) eol) string) (match-string 1 string)) found @@ -5284,14 +5374,15 @@ function waits for output unless NOOUTPUT is set." ;; Busyboxes built with the EDITING_ASK_TERMINAL config ;; option send also escape sequences, which must be ;; ignored. - (regexp (rx (* (not (any "#$\n"))) - (literal tramp-end-of-output) - (? (regexp tramp-device-escape-sequence-regexp)) - (? "\r") eol)) + (regexp (tramp-compat-rx + (* (not (any "#$\n"))) + (literal tramp-end-of-output) + (? (regexp tramp-device-escape-sequence-regexp)) + (? "\r") eol)) ;; Sometimes, the commands do not return a newline but a ;; null byte before the shell prompt, for example "git ;; ls-files -c -z ...". - (regexp1 (rx (| bol "\000") (regexp regexp))) + (regexp1 (tramp-compat-rx (| bol "\000") (regexp regexp))) (found (tramp-wait-for-regexp proc timeout regexp1))) (if found (let ((inhibit-read-only t)) @@ -5331,7 +5422,8 @@ the exit status." (let (cmd data) (if (and (stringp command) (string-match - (rx (* nonl) "<<'" (literal tramp-end-of-heredoc) "'" (* nonl)) + (tramp-compat-rx + (* nonl) "<<'" (literal tramp-end-of-heredoc) "'" (* nonl)) command)) (setq cmd (match-string 0 command) data (substring command (match-end 0))) @@ -5393,7 +5485,7 @@ raises an error." (unless noerror signal-hook-function))) (read (current-buffer))) ;; Error handling. - (when (re-search-forward (rx (not space)) (line-end-position) t) + (when (re-search-forward (rx (not blank)) (line-end-position) t) (error nil))) (error (unless noerror (tramp-error @@ -5501,7 +5593,7 @@ Nonexistent directories are removed from spec." (tramp-get-method-parameter vec 'tramp-remote-shell-args) " ") (tramp-shell-quote-argument tramp-end-of-heredoc)) - 'noerror (rx (literal tramp-end-of-heredoc))) + 'noerror (tramp-compat-rx (literal tramp-end-of-heredoc))) (progn (tramp-message vec 2 "Could not retrieve `tramp-own-remote-path'") @@ -5551,7 +5643,7 @@ Nonexistent directories are removed from spec." (while candidates (goto-char (point-min)) (if (string-match-p - (rx bol (literal (car candidates)) (? "\r") eol) + (tramp-compat-rx bol (literal (car candidates)) (? "\r") eol) (buffer-string)) (setq locale (car candidates) candidates nil) @@ -5630,7 +5722,7 @@ Nonexistent directories are removed from spec." vec (format "( %s / -nt / )" (tramp-get-test-command vec))) (with-current-buffer (tramp-get-buffer vec) (goto-char (point-min)) - (when (looking-at-p (rx (literal tramp-end-of-output))) + (when (looking-at-p (tramp-compat-rx (literal tramp-end-of-output))) (format "%s %%s -nt %%s" (tramp-get-test-command vec))))) (progn (tramp-send-command @@ -5789,36 +5881,9 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." (while (and dl (setq result (tramp-find-executable vec cmd dl t t))) ;; Check POSIX parameter. (when (tramp-send-command-and-check vec (format "%s -u" result)) - (tramp-set-connection-property - vec "uid-integer" - (with-current-buffer (tramp-get-connection-buffer vec) - (goto-char (point-min)) - (read (current-buffer)))) (throw 'id-found result)) (setq dl (cdr dl)))))))) -(defun tramp-get-remote-uid-with-id (vec id-format) - "Implement `tramp-get-remote-uid' for Tramp files using `id'." - ;; `tramp-get-remote-id' sets already connection property "uid-integer". - (with-tramp-connection-property vec (format "uid-%s" id-format) - (tramp-send-command-and-read - vec - (format "%s -u%s %s" - (tramp-get-remote-id vec) - (if (equal id-format 'integer) "" "n") - (if (equal id-format 'integer) - "" "| sed -e s/^/\\\"/ -e s/\\$/\\\"/"))))) - -(defun tramp-get-remote-uid-with-perl (vec id-format) - "Implement `tramp-get-remote-uid' for Tramp files using a Perl script." - (tramp-send-command-and-read - vec - (format "%s -le '%s'" - (tramp-get-remote-perl vec) - (if (equal id-format 'integer) - "print $>" - "print \"\\\"\", scalar getpwuid($>), \"\\\"\"")))) - (defun tramp-get-remote-python (vec) "Determine remote `python' command." (with-tramp-connection-property vec "python" @@ -5826,46 +5891,6 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." (or (tramp-find-executable vec "python" (tramp-get-remote-path vec)) (tramp-find-executable vec "python3" (tramp-get-remote-path vec))))) -(defun tramp-get-remote-uid-with-python (vec id-format) - "Implement `tramp-get-remote-uid' for Tramp files using `python'." - (tramp-send-command-and-read - vec - (format "%s -c \"%s\"" - (tramp-get-remote-python vec) - (if (equal id-format 'integer) - "import os; print (os.getuid())" - "import os, pwd; print ('\\\"' + pwd.getpwuid(os.getuid())[0] + '\\\"')")))) - -(defun tramp-get-remote-gid-with-id (vec id-format) - "Implement `tramp-get-remote-gid' for Tramp files using `id'." - (tramp-send-command-and-read - vec - (format "%s -g%s %s" - (tramp-get-remote-id vec) - (if (equal id-format 'integer) "" "n") - (if (equal id-format 'integer) - "" "| sed -e s/^/\\\"/ -e s/\\$/\\\"/")))) - -(defun tramp-get-remote-gid-with-perl (vec id-format) - "Implement `tramp-get-remote-gid' for Tramp files using a Perl script." - (tramp-send-command-and-read - vec - (format "%s -le '%s'" - (tramp-get-remote-perl vec) - (if (equal id-format 'integer) - "print ($)=~/(\\d+)/)" - "print \"\\\"\", scalar getgrgid($)), \"\\\"\"")))) - -(defun tramp-get-remote-gid-with-python (vec id-format) - "Implement `tramp-get-remote-gid' for Tramp files using `python'." - (tramp-send-command-and-read - vec - (format "%s -c \"%s\"" - (tramp-get-remote-python vec) - (if (equal id-format 'integer) - "import os; print (os.getgid())" - "import os, grp; print ('\\\"' + grp.getgrgid(os.getgid())[0] + '\\\"')")))) - (defun tramp-get-remote-busybox (vec) "Determine remote `busybox' command." (with-tramp-connection-property vec "busybox" diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 3d65520282b..11b3689df60 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -53,7 +53,7 @@ ;;;###tramp-autoload (tramp--with-startup (add-to-list 'tramp-default-user-alist - `(,(rx bos (literal tramp-smb-method) eos) nil nil)) + `(,(tramp-compat-rx bos (literal tramp-smb-method) eos) nil nil)) ;; Add completion function for SMB method. (tramp-set-completion-function @@ -92,15 +92,15 @@ this variable \"client min protocol=NT1\"." "Version string of the SMB client.") (defconst tramp-smb-server-version - (rx "Domain=[" (* (not (any "]"))) "] " - "OS=[" (* (not (any "]"))) "] " - "Server=[" (* (not (any "]"))) "]") + (tramp-compat-rx "Domain=[" (* (not "]")) "] " + "OS=[" (* (not "]")) "] " + "Server=[" (* (not "]")) "]") "Regexp of SMB server identification.") (defconst tramp-smb-prompt - (rx bol (| (: (| "smb:" "PS") space (+ nonl) "> ") - (: (+ space) "Server" - (+ space) "Comment" eol))) + (rx bol (| (: (| "smb:" "PS") blank (+ nonl) "> ") + (: (+ blank) "Server" + (+ blank) "Comment" eol))) "Regexp used as prompt in smbclient or powershell.") (defconst tramp-smb-wrong-passwd-regexp @@ -110,10 +110,10 @@ this variable \"client min protocol=NT1\"." (defconst tramp-smb-errors (rx (| ;; Connection error / timeout / unknown command. - (: "Connection" (? " to " (+ (not space))) " failed") + (: "Connection" (? " to " (+ (not blank))) " failed") "Read from server failed, maybe it closed the connection" "Call timed out: server did not respond" - (: (+ (not space)) ": command not found") + (: (+ (not blank)) ": command not found") "Server doesn't support UNIX CIFS calls" (| ;; Samba. "ERRDOS" @@ -298,6 +298,7 @@ See `tramp-actions-before-shell' for more info.") (temporary-file-directory . tramp-handle-temporary-file-directory) (tramp-get-home-directory . tramp-smb-handle-get-home-directory) (tramp-get-remote-gid . ignore) + (tramp-get-remote-groups . ignore) (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) @@ -728,7 +729,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (with-parsed-tramp-file-name name nil ;; Tilde expansion if necessary. (when (string-match - (rx bos "~" (group (* (not (any "/")))) (group (* nonl)) eos) + (tramp-compat-rx bos "~" (group (* (not "/"))) (group (* nonl)) eos) localname) (let ((uname (match-string 1 localname)) (fname (match-string 2 localname)) @@ -884,28 +885,28 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (while (not (eobp)) (cond ((looking-at - (rx "Size:" (+ space) (group (+ digit)) (+ space) - "Blocks:" (+ space) (+ digit) (+ space) (group (+ wordchar)))) + (rx "Size:" (+ blank) (group (+ digit)) (+ blank) + "Blocks:" (+ blank) (+ digit) (+ blank) (group (+ wordchar)))) (setq size (string-to-number (match-string 1)) id (if (string-equal "directory" (match-string 2)) t (if (string-equal "symbolic" (match-string 2)) "")))) ((looking-at - (rx "Inode:" (+ space) (group (+ digit)) (+ space) - "Links:" (+ space) (group (+ digit)))) + (rx "Inode:" (+ blank) (group (+ digit)) (+ blank) + "Links:" (+ blank) (group (+ digit)))) (setq inode (string-to-number (match-string 1)) link (string-to-number (match-string 2)))) ((looking-at - (rx "Access:" (+ space) - "(" (+ digit) "/" (group (+ (not space))) ")" (+ space) - "Uid:" (+ space) (group (+ digit)) (+ whitespace) - "Gid:" (+ space) (group (+ digit)))) + (rx "Access:" (+ blank) + "(" (+ digit) "/" (group (+ (not blank))) ")" (+ blank) + "Uid:" (+ blank) (group (+ digit)) (+ blank) + "Gid:" (+ blank) (group (+ digit)))) (setq mode (match-string 1) uid (match-string 2) gid (match-string 3))) ((looking-at - (rx "Access:" (+ space) + (rx "Access:" (+ blank) (group (+ digit)) "-" (group (+ digit)) "-" - (group (+ digit)) (+ space) + (group (+ digit)) (+ blank) (group (+ digit)) ":" (group (+ digit)) ":" (group (+ digit)))) (setq atime @@ -917,9 +918,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (string-to-number (match-string 2)) ;; month (string-to-number (match-string 1))))) ;; year ((looking-at - (rx "Modify:" (+ space) + (rx "Modify:" (+ blank) (group (+ digit)) "-" (group (+ digit)) "-" - (group (+ digit)) (+ space) + (group (+ digit)) (+ blank) (group (+ digit)) ":" (group (+ digit)) ":" (group (+ digit)))) (setq mtime @@ -931,9 +932,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (string-to-number (match-string 2)) ;; month (string-to-number (match-string 1))))) ;; year ((looking-at - (rx "Change:" (+ space) + (rx "Change:" (+ blank) (group (+ digit)) "-" (group (+ digit)) "-" - (group (+ digit)) (+ space) + (group (+ digit)) (+ blank) (group (+ digit)) ":" (group (+ digit)) ":" (group (+ digit)))) (setq ctime @@ -1008,7 +1009,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (goto-char (point-min)) (forward-line) (when (looking-at - (rx (* space) (group (+ digit)) + (rx (* blank) (group (+ digit)) " blocks of size " (group (+ digit)) ". " (group (+ digit)) " blocks available")) (setq blocksize (string-to-number (match-string 2)) @@ -1081,7 +1082,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Check for matching entries. (mapcar (lambda (x) - (when (string-match-p (rx bol (literal base)) (nth 0 x)) + (when (string-match-p + (tramp-compat-rx bol (literal base)) (nth 0 x)) x)) entries) ;; We just need the only and only entry FILENAME. @@ -1211,50 +1213,47 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." If TARGET is a non-Tramp file, it is used verbatim as the target of the symlink. If TARGET is a Tramp file, only the localname component is used as the target of the symlink." - (if (not (tramp-tramp-file-p (expand-file-name linkname))) - (tramp-run-real-handler - #'make-symbolic-link (list target linkname ok-if-already-exists)) - - (with-parsed-tramp-file-name linkname nil - ;; If TARGET is a Tramp name, use just the localname component. - ;; Don't check for a proper method. - (let ((non-essential t)) - (when (and (tramp-tramp-file-p target) - (tramp-file-name-equal-p v (tramp-dissect-file-name target))) - (setq target (tramp-file-local-name (expand-file-name target))))) - - ;; If TARGET is still remote, quote it. - (if (tramp-tramp-file-p target) - (make-symbolic-link (tramp-compat-file-name-quote target 'top) - linkname ok-if-already-exists) - - ;; Do the 'confirm if exists' thing. - (when (file-exists-p linkname) - ;; What to do? - (if (or (null ok-if-already-exists) ; not allowed to exist - (and (numberp ok-if-already-exists) - (not (yes-or-no-p - (format - "File %s already exists; make it a link anyway?" - localname))))) - (tramp-error v 'file-already-exists localname) - (delete-file linkname))) - - (unless (tramp-smb-get-cifs-capabilities v) - (tramp-error v 'file-error "make-symbolic-link not supported")) - - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v localname) + (with-parsed-tramp-file-name linkname nil + ;; If TARGET is a Tramp name, use just the localname component. + ;; Don't check for a proper method. + (let ((non-essential t)) + (when (and (tramp-tramp-file-p target) + (tramp-file-name-equal-p v (tramp-dissect-file-name target))) + (setq target (tramp-file-local-name (expand-file-name target))))) + + ;; If TARGET is still remote, quote it. + (if (tramp-tramp-file-p target) + (make-symbolic-link + (tramp-compat-file-name-quote target 'top) + linkname ok-if-already-exists) - (unless (tramp-smb-send-command - v (format "symlink %s %s" - (tramp-smb-shell-quote-argument target) - (tramp-smb-shell-quote-localname v))) - (tramp-error - v 'file-error - "error with make-symbolic-link, see buffer `%s' for details" - (tramp-get-connection-buffer v))))))) + ;; Do the 'confirm if exists' thing. + (when (file-exists-p linkname) + ;; What to do? + (if (or (null ok-if-already-exists) ; not allowed to exist + (and (numberp ok-if-already-exists) + (not (yes-or-no-p + (format + "File %s already exists; make it a link anyway?" + localname))))) + (tramp-error v 'file-already-exists localname) + (delete-file linkname))) + + (unless (tramp-smb-get-cifs-capabilities v) + (tramp-error v 'file-error "make-symbolic-link not supported")) + + ;; We must also flush the cache of the directory, because + ;; `file-attributes' reads the values from there. + (tramp-flush-file-properties v localname) + + (unless (tramp-smb-send-command + v (format "symlink %s %s" + (tramp-smb-shell-quote-argument target) + (tramp-smb-shell-quote-localname v))) + (tramp-error + v 'file-error + "error with make-symbolic-link, see buffer `%s' for details" + (tramp-get-connection-buffer v)))))) (defun tramp-smb-handle-process-file (program &optional infile destination display &rest args) @@ -1631,7 +1630,7 @@ VEC or USER, or if there is no home directory, return nil." (save-match-data (let ((localname (tramp-file-name-unquote-localname vec))) (when (string-match - (rx bol (? "/") (group (+ (not (any "/")))) "/") localname) + (tramp-compat-rx bol (? "/") (group (+ (not "/"))) "/") localname) (match-string 1 localname))))) (defun tramp-smb-get-localname (vec) @@ -1642,7 +1641,8 @@ If VEC has no cifs capabilities, exchange \"/\" by \"\\\\\"." (setq localname (if (string-match - (rx bol (? "/") (+ (not (any "/"))) (group "/" (* nonl))) localname) + (tramp-compat-rx bol (? "/") (+ (not "/")) (group "/" (* nonl))) + localname) ;; There is a share, separated by "/". (if (not (tramp-smb-get-cifs-capabilities vec)) (mapconcat @@ -1651,7 +1651,7 @@ If VEC has no cifs capabilities, exchange \"/\" by \"\\\\\"." (match-string 1 localname)) ;; There is just a share. (if (string-match - (rx bol (? "/") (group (+ (not (any "/")))) eol) localname) + (tramp-compat-rx bol (? "/") (group (+ (not "/"))) eol) localname) (match-string 1 localname) ""))) @@ -1660,7 +1660,7 @@ If VEC has no cifs capabilities, exchange \"/\" by \"\\\\\"." (setq localname (replace-match "$" nil nil localname 1))) ;; A trailing space is not supported. - (when (string-match-p (rx space eol) localname) + (when (string-match-p (rx blank eol) localname) (tramp-error vec 'file-error "Invalid file name %s" (tramp-make-tramp-file-name vec localname))) @@ -1780,7 +1780,7 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)." ;; Read share entries. (when (string-match - (rx bol "Disk|" (group (+ (not (any "|")))) "|") line) + (tramp-compat-rx bol "Disk|" (group (+ (not "|"))) "|") line) (setq localname (match-string 1 line) mode "dr-xr-xr-x" size 0)) @@ -1853,9 +1853,9 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)." ;; localname. (if (string-match - (rx bol (+ space) - (group (not space) (? (* nonl) (not space))) - (* space) eol) + (rx bol (+ blank) + (group (not blank) (? (* nonl) (not blank))) + (* blank) eol) line) (setq localname (match-string 1 line)) (cl-return)))) diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index 31720a605ec..b89e1282d21 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -150,6 +150,7 @@ (temporary-file-directory . tramp-handle-temporary-file-directory) (tramp-get-home-directory . ignore) (tramp-get-remote-gid . ignore) + (tramp-get-remote-groups . ignore) (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 893afcdbbee..f8b602e34ce 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -49,7 +49,7 @@ (tramp-password-previous-hop t))) (add-to-list 'tramp-default-user-alist - `(,(rx bos (literal tramp-sudoedit-method) eos) + `(,(tramp-compat-rx bos (literal tramp-sudoedit-method) eos) nil ,tramp-root-id-string)) (tramp-set-completion-function @@ -143,6 +143,7 @@ See `tramp-actions-before-shell' for more info.") (temporary-file-directory . tramp-handle-temporary-file-directory) (tramp-get-home-directory . tramp-sudoedit-handle-get-home-directory) (tramp-get-remote-gid . tramp-sudoedit-handle-get-remote-gid) + (tramp-get-remote-groups . tramp-sudoedit-handle-get-remote-groups) (tramp-get-remote-uid . tramp-sudoedit-handle-get-remote-uid) (tramp-set-file-uid-gid . tramp-sudoedit-handle-set-file-uid-gid) (unhandled-file-name-directory . ignore) @@ -193,8 +194,8 @@ arguments to pass to the OPERATION." v 'file-error "add-name-to-file: %s" "only implemented for same method, same user, same host"))) - (with-parsed-tramp-file-name filename v1 - (with-parsed-tramp-file-name newname v2 + (with-parsed-tramp-file-name (expand-file-name filename) v1 + (with-parsed-tramp-file-name (expand-file-name newname) v2 ;; Do the 'confirm if exists' thing. (when (file-exists-p newname) ;; What to do? @@ -234,6 +235,7 @@ This function is invoked by `tramp-sudoedit-handle-copy-file' and `tramp-sudoedit-handle-rename-file'. It is an error if OP is neither of `copy' and `rename'. FILENAME and NEWNAME must be absolute file names." + ;; FILENAME and NEWNAME are already expanded. (unless (memq op '(copy rename)) (error "Unknown operation `%s', must be `copy' or `rename'" op)) @@ -344,7 +346,7 @@ absolute file names." (defun tramp-sudoedit-handle-delete-file (filename &optional trash) "Like `delete-file' for Tramp files." - (with-parsed-tramp-file-name filename nil + (with-parsed-tramp-file-name (expand-file-name filename) nil (tramp-flush-file-properties v localname) (if (and delete-by-moving-to-trash trash) (move-file-to-trash filename) @@ -376,7 +378,7 @@ the result will be a local, non-Tramp, file name." (unless (file-name-absolute-p localname) (setq localname (format "~%s/%s" user localname))) (when (string-match - (rx bos "~" (group (* (not (any "/")))) (group (* nonl)) eos) + (tramp-compat-rx bos "~" (group (* (not "/"))) (group (* nonl)) eos) localname) (let ((uname (match-string 1 localname)) (fname (match-string 2 localname)) @@ -402,7 +404,7 @@ the result will be a local, non-Tramp, file name." (defun tramp-sudoedit-handle-file-acl (filename) "Like `file-acl' for Tramp files." - (with-parsed-tramp-file-name filename nil + (with-parsed-tramp-file-name (expand-file-name filename) nil (with-tramp-file-property v localname "file-acl" (let ((result (and (tramp-sudoedit-remote-acl-p v) (tramp-sudoedit-send-command-string @@ -439,10 +441,15 @@ the result will be a local, non-Tramp, file name." (defun tramp-sudoedit-handle-file-executable-p (filename) "Like `file-executable-p' for Tramp files." - (with-parsed-tramp-file-name filename nil + (with-parsed-tramp-file-name (expand-file-name filename) nil (with-tramp-file-property v localname "file-executable-p" - (tramp-sudoedit-send-command - v "test" "-x" (tramp-compat-file-name-unquote localname))))) + ;; Examine `file-attributes' cache to see if request can be + ;; satisfied without remote operation. + (if (tramp-file-property-p v localname "file-attributes") + (or (tramp-check-cached-permissions v ?x) + (tramp-check-cached-permissions v ?s)) + (tramp-sudoedit-send-command + v "test" "-x" (tramp-compat-file-name-unquote localname)))))) (defun tramp-sudoedit-handle-file-exists-p (filename) "Like `file-exists-p' for Tramp files." @@ -450,10 +457,12 @@ the result will be a local, non-Tramp, file name." ;; We don't want to run it when `non-essential' is t, or there is ;; no connection process yet. (when (tramp-connectable-p filename) - (with-parsed-tramp-file-name filename nil + (with-parsed-tramp-file-name (expand-file-name filename) nil (with-tramp-file-property v localname "file-exists-p" - (tramp-sudoedit-send-command - v "test" "-e" (tramp-compat-file-name-unquote localname)))))) + (if (tramp-file-property-p v localname "file-attributes") + (not (null (tramp-get-file-property v localname "file-attributes"))) + (tramp-sudoedit-send-command + v "test" "-e" (tramp-compat-file-name-unquote localname))))))) (defun tramp-sudoedit-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." @@ -473,18 +482,21 @@ the result will be a local, non-Tramp, file name." (delq nil (mapcar - (lambda (l) (and (not (string-match-p (rx bol (* space) eol) l)) l)) + (lambda (l) (and (not (string-match-p (rx bol (* blank) eol) l)) l)) (split-string (tramp-get-buffer-string (tramp-get-connection-buffer v)) "\n" 'omit)))))))) (defun tramp-sudoedit-handle-file-readable-p (filename) "Like `file-readable-p' for Tramp files." - (with-parsed-tramp-file-name filename nil + (with-parsed-tramp-file-name (expand-file-name filename) nil (with-tramp-file-property v localname "file-readable-p" - (or (tramp-handle-file-readable-p filename) - (tramp-sudoedit-send-command - v "test" "-r" (tramp-compat-file-name-unquote localname)))))) + ;; Examine `file-attributes' cache to see if request can be + ;; satisfied without remote operation. + (if (tramp-file-property-p v localname "file-attributes") + (tramp-handle-file-readable-p filename) + (tramp-sudoedit-send-command + v "test" "-r" (tramp-compat-file-name-unquote localname)))))) (defun tramp-sudoedit-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." @@ -504,13 +516,14 @@ the result will be a local, non-Tramp, file name." (defun tramp-sudoedit-handle-file-selinux-context (filename) "Like `file-selinux-context' for Tramp files." - (with-parsed-tramp-file-name filename nil + (with-parsed-tramp-file-name (expand-file-name filename) nil (with-tramp-file-property v localname "file-selinux-context" (let ((context '(nil nil nil nil)) - (regexp (rx (group (+ (any "_" alnum))) ":" - (group (+ (any "_" alnum))) ":" - (group (+ (any "_" alnum))) ":" - (group (+ (any "_" alnum)))))) + (regexp (tramp-compat-rx + (group (+ (any "_" alnum))) ":" + (group (+ (any "_" alnum))) ":" + (group (+ (any "_" alnum))) ":" + (group (+ (any "_" alnum)))))) (when (and (tramp-sudoedit-remote-selinux-p v) (tramp-sudoedit-send-command v "ls" "-d" "-Z" @@ -535,9 +548,9 @@ the result will be a local, non-Tramp, file name." (goto-char (point-min)) (forward-line) (when (looking-at - (rx (* space) (group (+ digit)) - (+ space) (group (+ digit)) - (+ space) (group (+ digit)))) + (rx (* blank) (group (+ digit)) + (+ blank) (group (+ digit)) + (+ blank) (group (+ digit)))) (list (string-to-number (match-string 1)) ;; The second value is the used size. We need the ;; free size. @@ -593,14 +606,19 @@ the result will be a local, non-Tramp, file name." (defun tramp-sudoedit-handle-file-writable-p (filename) "Like `file-writable-p' for Tramp files." - (with-parsed-tramp-file-name filename nil + (with-parsed-tramp-file-name (expand-file-name filename) nil (with-tramp-file-property v localname "file-writable-p" (if (file-exists-p filename) - (tramp-sudoedit-send-command - v "test" "-w" (tramp-compat-file-name-unquote localname)) - (let ((dir (file-name-directory filename))) - (and (file-exists-p dir) - (file-writable-p dir))))))) + (if (tramp-file-property-p v localname "file-attributes") + ;; Examine `file-attributes' cache to see if request can + ;; be satisfied without remote operation. + (tramp-check-cached-permissions v ?w) + (tramp-sudoedit-send-command + v "test" "-w" (tramp-compat-file-name-unquote localname))) + ;; If file doesn't exist, check if directory is writable. + (and + (file-directory-p (file-name-directory filename)) + (file-writable-p (file-name-directory filename))))))) (defun tramp-sudoedit-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." @@ -625,41 +643,38 @@ the result will be a local, non-Tramp, file name." If TARGET is a non-Tramp file, it is used verbatim as the target of the symlink. If TARGET is a Tramp file, only the localname component is used as the target of the symlink." - (if (not (tramp-tramp-file-p (expand-file-name linkname))) - (tramp-run-real-handler - #'make-symbolic-link (list target linkname ok-if-already-exists)) - - (with-parsed-tramp-file-name linkname nil - ;; If TARGET is a Tramp name, use just the localname component. - ;; Don't check for a proper method. - (let ((non-essential t)) - (when (and (tramp-tramp-file-p target) - (tramp-file-name-equal-p v (tramp-dissect-file-name target))) - (setq target (tramp-file-local-name (expand-file-name target))))) - - ;; If TARGET is still remote, quote it. - (if (tramp-tramp-file-p target) - (make-symbolic-link (tramp-compat-file-name-quote target 'top) - linkname ok-if-already-exists) - - ;; Do the 'confirm if exists' thing. - (when (file-exists-p linkname) - ;; What to do? - (if (or (null ok-if-already-exists) ; not allowed to exist - (and (numberp ok-if-already-exists) - (not - (yes-or-no-p - (format - "File %s already exists; make it a link anyway?" - localname))))) - (tramp-error v 'file-already-exists localname) - (delete-file linkname))) - - (tramp-flush-file-properties v localname) - (tramp-sudoedit-send-command - v "ln" "-sf" - (tramp-compat-file-name-unquote target) - (tramp-compat-file-name-unquote localname)))))) + (with-parsed-tramp-file-name (expand-file-name linkname) nil + ;; If TARGET is a Tramp name, use just the localname component. + ;; Don't check for a proper method. + (let ((non-essential t)) + (when (and (tramp-tramp-file-p target) + (tramp-file-name-equal-p v (tramp-dissect-file-name target))) + (setq target (tramp-file-local-name (expand-file-name target))))) + + ;; If TARGET is still remote, quote it. + (if (tramp-tramp-file-p target) + (make-symbolic-link + (tramp-compat-file-name-quote target 'top) + linkname ok-if-already-exists) + + ;; Do the 'confirm if exists' thing. + (when (file-exists-p linkname) + ;; What to do? + (if (or (null ok-if-already-exists) ; not allowed to exist + (and (numberp ok-if-already-exists) + (not + (yes-or-no-p + (format + "File %s already exists; make it a link anyway?" + localname))))) + (tramp-error v 'file-already-exists localname) + (delete-file linkname))) + + (tramp-flush-file-properties v localname) + (tramp-sudoedit-send-command + v "ln" "-sf" + (tramp-compat-file-name-unquote target) + (tramp-compat-file-name-unquote localname))))) (defun tramp-sudoedit-handle-rename-file (filename newname &optional ok-if-already-exists) @@ -689,7 +704,7 @@ component is used as the target of the symlink." (defun tramp-sudoedit-handle-set-file-selinux-context (filename context) "Like `set-file-selinux-context' for Tramp files." - (with-parsed-tramp-file-name filename nil + (with-parsed-tramp-file-name (expand-file-name filename) nil (when (and (consp context) (tramp-sudoedit-remote-selinux-p v)) (let ((user (and (stringp (nth 0 context)) (nth 0 context))) @@ -719,18 +734,23 @@ VEC or USER, or if there is no home directory, return nil." (defun tramp-sudoedit-handle-get-remote-uid (vec id-format) "The uid of the remote connection VEC, in ID-FORMAT. ID-FORMAT valid values are `string' and `integer'." - ;; The result is cached in `tramp-get-remote-uid'. - (if (equal id-format 'integer) - (tramp-sudoedit-send-command-and-read vec "id" "-u") - (tramp-sudoedit-send-command-string vec "id" "-un"))) + (tramp-sudoedit-send-command vec "id") + (tramp-read-id-output vec) + (tramp-get-connection-property vec (format "uid-%s" id-format))) (defun tramp-sudoedit-handle-get-remote-gid (vec id-format) "The gid of the remote connection VEC, in ID-FORMAT. ID-FORMAT valid values are `string' and `integer'." - ;; The result is cached in `tramp-get-remote-gid'. - (if (equal id-format 'integer) - (tramp-sudoedit-send-command-and-read vec "id" "-g") - (tramp-sudoedit-send-command-string vec "id" "-gn"))) + (tramp-sudoedit-send-command vec "id") + (tramp-read-id-output vec) + (tramp-get-connection-property vec (format "gid-%s" id-format))) + +(defun tramp-sudoedit-handle-get-remote-groups (vec id-format) + "Like `tramp-get-remote-groups' for Tramp files. +ID-FORMAT valid values are `string' and `integer'." + (tramp-sudoedit-send-command vec "id") + (tramp-read-id-output vec) + (tramp-get-connection-property vec (format "groups-%s" id-format))) (defun tramp-sudoedit-handle-set-file-uid-gid (filename &optional uid gid) "Like `tramp-set-file-uid-gid' for Tramp files." @@ -846,7 +866,7 @@ In case there is no valid Lisp expression, it raises an error." (condition-case nil (prog1 (read (current-buffer)) ;; Error handling. - (when (re-search-forward (rx (not space)) (line-end-position) t) + (when (re-search-forward (rx (not blank)) (line-end-position) t) (error nil))) (error (tramp-error vec 'file-error diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index b24525de3a5..90cc03c188e 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -516,9 +516,10 @@ interpreted as a regular expression which always matches." (defcustom tramp-restricted-shell-hosts-alist (when (and (eq system-type 'windows-nt) (not (string-match-p (rx "sh" eol) tramp-encoding-shell))) - (list (rx bos (| (literal (downcase tramp-system-name)) - (literal (upcase tramp-system-name))) - eos))) + (list (tramp-compat-rx + bos (| (literal (downcase tramp-system-name)) + (literal (upcase tramp-system-name))) + eos))) "List of hosts, which run a restricted shell. This is a list of regular expressions, which denote hosts running a restricted shell like \"rbash\". Those hosts can be used as @@ -529,10 +530,11 @@ host runs a restricted shell, it shall be added to this list, too." ;;;###tramp-autoload (defcustom tramp-local-host-regexp - (rx bos - (| (literal tramp-system-name) - (| "localhost" "localhost4" "localhost6" "127.0.0.1" "::1")) - eos) + (tramp-compat-rx + bos + (| (literal tramp-system-name) + (| "localhost" "localhost4" "localhost6" "127.0.0.1" "::1")) + eos) "Host names which are regarded as local host. If the local host runs a chrooted environment, set this to nil." :version "29.1" @@ -598,7 +600,7 @@ if you need to change this." :type 'string) (defcustom tramp-login-prompt-regexp - (rx (* nonl) (| "user" "login") (? space (* nonl)) ":" (* space)) + (rx (* nonl) (| "user" "login") (? blank (* nonl)) ":" (* blank)) "Regexp matching login-like prompts. The regexp should match at end of buffer. @@ -612,9 +614,9 @@ Sometimes the prompt is reported to look like \"login as:\"." ;; connection initialization; Tramp redefines the prompt afterwards. (rx (| bol "\r") (* (not (any "\n#$%>]"))) - (? "#") (any "#$%>]") (* space) + (? "#") (any "#$%>]") (* blank) ;; Escape characters. - (* "[" (* (any ";" digit)) alpha (* space))) + (* "[" (* (any ";" digit)) alpha (* blank))) "Regexp to match prompts from remote shell. Normally, Tramp expects you to configure `shell-prompt-pattern' correctly, but sometimes it happens that you are connecting to a @@ -629,9 +631,10 @@ This regexp must match both `tramp-initial-end-of-output' and :type 'regexp) (defcustom tramp-password-prompt-regexp - (rx bol (* nonl) - (group (regexp (regexp-opt password-word-equivalents))) - (* nonl) ":" (? "\^@") (* space)) + (tramp-compat-rx + bol (* nonl) + (group (regexp (regexp-opt password-word-equivalents))) + (* nonl) ":" (? "\^@") (* blank)) "Regexp matching password-like prompts. The regexp should match at end of buffer. @@ -664,7 +667,7 @@ The regexp should match at end of buffer." (defcustom tramp-yesno-prompt-regexp (rx "Are you sure you want to continue connecting (yes/no" (? "/[fingerprint]") ")?" - (* space)) + (* blank)) "Regular expression matching all yes/no queries which need to be confirmed. The confirmation should be done with yes or no. The regexp should match at end of buffer. @@ -674,7 +677,7 @@ See also `tramp-yn-prompt-regexp'." (defcustom tramp-yn-prompt-regexp (rx (| "Store key in cache? (y/n)" "Update cached key? (y/n, Return cancels connection)") - (* space)) + (* blank)) "Regular expression matching all y/n queries which need to be confirmed. The confirmation should be done with y or n. The regexp should match at end of buffer. @@ -693,7 +696,7 @@ files conditionalize this setup based on the TERM environment variable." (defcustom tramp-terminal-prompt-regexp (rx (| (: "TERM = (" (* nonl) ")") (: "Terminal type? [" (* nonl) "]")) - (* space)) + (* blank)) "Regular expression matching all terminal setting prompts. The regexp should match at end of buffer. The answer will be provided by `tramp-action-terminal', which see." @@ -736,7 +739,7 @@ The regexp should match at end of buffer." :type 'regexp) (defcustom tramp-operation-not-permitted-regexp - (rx (| (: "preserving times" (* nonl)) "set mode") ":" (* space) + (rx (| (: "preserving times" (* nonl)) "set mode") ":" (* blank) "Operation not permitted") "Regular expression matching keep-date problems in (s)cp operations. Copying has been performed successfully already, so this message can @@ -749,7 +752,7 @@ be ignored safely." "Permission denied" "is a directory" "not a regular file") - (* space)) + (* blank)) "Regular expression matching copy problems in (s)cp operations." :type 'regexp) @@ -887,17 +890,18 @@ Used in `tramp-make-tramp-file-name'.") (defun tramp-build-prefix-regexp () "Return `tramp-prefix-regexp'." - (rx bol (literal (tramp-build-prefix-format)))) + (tramp-compat-rx bol (literal (tramp-build-prefix-format)))) (defvar tramp-prefix-regexp nil ; Initialized when defining `tramp-syntax'! "Regexp matching the very beginning of Tramp file names. Should always start with \"^\". Derived from `tramp-prefix-format'.") (defconst tramp-method-regexp-alist - `((default . ,(rx (| (literal tramp-default-method-marker) (>= 2 alnum)))) + `((default . ,(tramp-compat-rx + (| (literal tramp-default-method-marker) (>= 2 alnum)))) (simplified . "") - (separate - . ,(rx (? (| (literal tramp-default-method-marker) (>= 2 alnum)))))) + (separate . ,(tramp-compat-rx + (? (| (literal tramp-default-method-marker) (>= 2 alnum)))))) "Alist mapping Tramp syntax to regexps matching methods identifiers.") (defun tramp-build-method-regexp () @@ -925,19 +929,20 @@ Used in `tramp-make-tramp-file-name'.") (defun tramp-build-postfix-method-regexp () "Return `tramp-postfix-method-regexp'." - (rx (literal (tramp-build-postfix-method-format)))) + (tramp-compat-rx (literal (tramp-build-postfix-method-format)))) (defvar tramp-postfix-method-regexp nil ; Init'd when defining `tramp-syntax'! "Regexp matching delimiter between method and user or host names. Derived from `tramp-postfix-method-format'.") -(defconst tramp-user-regexp (rx (+ (not (any "/:|" space)))) +(defconst tramp-user-regexp (rx (+ (not (any "/:|" blank)))) "Regexp matching user names.") (defconst tramp-prefix-domain-format "%" "String matching delimiter between user and domain names.") -(defconst tramp-prefix-domain-regexp (rx (literal tramp-prefix-domain-format)) +(defconst tramp-prefix-domain-regexp + (tramp-compat-rx (literal tramp-prefix-domain-format)) "Regexp matching delimiter between user and domain names. Derived from `tramp-prefix-domain-format'.") @@ -945,16 +950,18 @@ Derived from `tramp-prefix-domain-format'.") "Regexp matching domain names.") (defconst tramp-user-with-domain-regexp - (rx (group (regexp tramp-user-regexp)) - (regexp tramp-prefix-domain-regexp) - (group (regexp tramp-domain-regexp))) + (tramp-compat-rx + (group (regexp tramp-user-regexp)) + (regexp tramp-prefix-domain-regexp) + (group (regexp tramp-domain-regexp))) "Regexp matching user names with domain names.") (defconst tramp-postfix-user-format "@" "String matching delimiter between user and host names. Used in `tramp-make-tramp-file-name'.") -(defconst tramp-postfix-user-regexp (rx (literal tramp-postfix-user-format)) +(defconst tramp-postfix-user-regexp + (tramp-compat-rx (literal tramp-postfix-user-format)) "Regexp matching delimiter between user and host names. Derived from `tramp-postfix-user-format'.") @@ -977,7 +984,7 @@ Used in `tramp-make-tramp-file-name'.") (defun tramp-build-prefix-ipv6-regexp () "Return `tramp-prefix-ipv6-regexp'." - (rx (literal tramp-prefix-ipv6-format))) + (tramp-compat-rx (literal tramp-prefix-ipv6-format))) (defvar tramp-prefix-ipv6-regexp nil ; Initialized when defining `tramp-syntax'! "Regexp matching left hand side of IPv6 addresses. @@ -1005,7 +1012,7 @@ Used in `tramp-make-tramp-file-name'.") (defun tramp-build-postfix-ipv6-regexp () "Return `tramp-postfix-ipv6-regexp'." - (rx (literal tramp-postfix-ipv6-format))) + (tramp-compat-rx (literal tramp-postfix-ipv6-format))) (defvar tramp-postfix-ipv6-regexp nil ; Initialized when defining `tramp-syntax'! "Regexp matching right hand side of IPv6 addresses. @@ -1014,7 +1021,8 @@ Derived from `tramp-postfix-ipv6-format'.") (defconst tramp-prefix-port-format "#" "String matching delimiter between host names and port numbers.") -(defconst tramp-prefix-port-regexp (rx (literal tramp-prefix-port-format)) +(defconst tramp-prefix-port-regexp + (tramp-compat-rx (literal tramp-prefix-port-format)) "Regexp matching delimiter between host names and port numbers. Derived from `tramp-prefix-port-format'.") @@ -1022,15 +1030,17 @@ Derived from `tramp-prefix-port-format'.") "Regexp matching port numbers.") (defconst tramp-host-with-port-regexp - (rx (group (regexp tramp-host-regexp)) - (regexp tramp-prefix-port-regexp) - (group (regexp tramp-port-regexp))) + (tramp-compat-rx + (group (regexp tramp-host-regexp)) + (regexp tramp-prefix-port-regexp) + (group (regexp tramp-port-regexp))) "Regexp matching host names with port numbers.") (defconst tramp-postfix-hop-format "|" "String matching delimiter after ad-hoc hop definitions.") -(defconst tramp-postfix-hop-regexp (rx (literal tramp-postfix-hop-format)) +(defconst tramp-postfix-hop-regexp + (tramp-compat-rx (literal tramp-postfix-hop-format)) "Regexp matching delimiter after ad-hoc hop definitions. Derived from `tramp-postfix-hop-format'.") @@ -1050,7 +1060,7 @@ Used in `tramp-make-tramp-file-name'.") (defun tramp-build-postfix-host-regexp () "Return `tramp-postfix-host-regexp'." - (rx (literal tramp-postfix-host-format))) + (tramp-compat-rx (literal tramp-postfix-host-format))) (defvar tramp-postfix-host-regexp nil ; Initialized when defining `tramp-syntax'! "Regexp matching delimiter between host names and localnames. @@ -1077,17 +1087,18 @@ Derived from `tramp-postfix-host-format'.") (defun tramp-build-remote-file-name-spec-regexp () "Construct a regexp matching a Tramp file name for a Tramp syntax. It is expected, that `tramp-syntax' has the proper value." - (rx ;; Method. - (group (regexp tramp-method-regexp)) (regexp tramp-postfix-method-regexp) - ;; Optional user. - (? (group (regexp tramp-user-regexp)) (regexp tramp-postfix-user-regexp)) - ;; Optional host. - (? (group (| (regexp tramp-host-regexp) - (: (regexp tramp-prefix-ipv6-regexp) - (? (regexp tramp-ipv6-regexp)) - (regexp tramp-postfix-ipv6-regexp))) - ;; Optional port. - (? (regexp tramp-prefix-port-regexp) (regexp tramp-port-regexp)))))) + (tramp-compat-rx + ;; Method. + (group (regexp tramp-method-regexp)) (regexp tramp-postfix-method-regexp) + ;; Optional user. This includes domain. + (? (group (regexp tramp-user-regexp)) (regexp tramp-postfix-user-regexp)) + ;; Optional host. + (? (group (| (regexp tramp-host-regexp) + (: (regexp tramp-prefix-ipv6-regexp) + (? (regexp tramp-ipv6-regexp)) + (regexp tramp-postfix-ipv6-regexp))) + ;; Optional port. + (? (regexp tramp-prefix-port-regexp) (regexp tramp-port-regexp)))))) (defvar tramp-remote-file-name-spec-regexp nil ; Initialized when defining `tramp-syntax'! @@ -1098,12 +1109,13 @@ It is expected, that `tramp-syntax' has the proper value." It is expected, that `tramp-syntax' has the proper value. See `tramp-file-name-structure'." (list - (rx (regexp tramp-prefix-regexp) - (? (group (+ (regexp tramp-remote-file-name-spec-regexp) - (regexp tramp-postfix-hop-regexp)))) - (regexp tramp-remote-file-name-spec-regexp) - (regexp tramp-postfix-host-regexp) - (group (regexp tramp-localname-regexp))) + (tramp-compat-rx + (regexp tramp-prefix-regexp) + (? (group (+ (regexp tramp-remote-file-name-spec-regexp) + (regexp tramp-postfix-hop-regexp)))) + (regexp tramp-remote-file-name-spec-regexp) + (regexp tramp-postfix-host-regexp) + (group (regexp tramp-localname-regexp))) 5 6 7 8 1)) (defvar tramp-file-name-structure nil ; Initialized when defining `tramp-syntax'! @@ -1157,9 +1169,11 @@ initial value is overwritten by the car of `tramp-file-name-structure'.") ;; `tramp-method-regexp' needs at least two characters, in order to ;; distinguish from volume letter. This is in the way when completing. (defconst tramp-completion-method-regexp-alist - `((default . ,(rx (| (literal tramp-default-method-marker) (+ alnum)))) + `((default . ,(tramp-compat-rx + (| (literal tramp-default-method-marker) (+ alnum)))) (simplified . "") - (separate . ,(rx (| (literal tramp-default-method-marker) (* alnum))))) + (separate . ,(tramp-compat-rx + (| (literal tramp-default-method-marker) (* alnum))))) "Alist mapping Tramp syntax to regexps matching completion methods.") (defun tramp-build-completion-method-regexp () @@ -1175,27 +1189,28 @@ The `ftp' syntax does not support methods.") "Return `tramp-completion-file-name-regexp' according to `tramp-syntax'." (if (eq tramp-syntax 'separate) ;; FIXME: This shouldn't be necessary. - (rx bos "/" (? "[" (* (not (any "]")))) eos) - (rx bos - ;; `file-name-completion' uses absolute paths for matching. - ;; This means that on W32 systems, something like - ;; "/ssh:host:~/path" becomes "c:/ssh:host:~/path". See also - ;; `tramp-drop-volume-letter'. - (? (regexp tramp-volume-letter-regexp)) - (regexp tramp-prefix-regexp) - - ;; Optional multi hops. - (* (regexp tramp-remote-file-name-spec-regexp) - (regexp tramp-postfix-hop-regexp)) - - ;; Last hop. - (? (regexp tramp-completion-method-regexp) - ;; Method separator, user name and host name. - (? (regexp tramp-postfix-method-regexp) - ;; This is a little bit lax, but it serves. - (? (regexp tramp-host-regexp)))) - - eos))) + (tramp-compat-rx bos "/" (? "[" (* (not "]"))) eos) + (tramp-compat-rx + bos + ;; `file-name-completion' uses absolute paths for matching. + ;; This means that on W32 systems, something like + ;; "/ssh:host:~/path" becomes "c:/ssh:host:~/path". See also + ;; `tramp-drop-volume-letter'. + (? (regexp tramp-volume-letter-regexp)) + (regexp tramp-prefix-regexp) + + ;; Optional multi hops. + (* (regexp tramp-remote-file-name-spec-regexp) + (regexp tramp-postfix-hop-regexp)) + + ;; Last hop. + (? (regexp tramp-completion-method-regexp) + ;; Method separator, user name and host name. + (? (regexp tramp-postfix-method-regexp) + ;; This is a little bit lax, but it serves. + (? (regexp tramp-host-regexp)))) + + eos))) (defvar tramp-completion-file-name-regexp nil ; Initialized when defining `tramp-syntax'! @@ -1489,21 +1504,21 @@ If nil, return `tramp-default-port'." ;;;###tramp-autoload (defun tramp-file-name-unify (vec &optional localname) "Unify VEC by removing localname and hop from `tramp-file-name' structure. -If LOCALNAME is a string, set it as localname. +If LOCALNAME is an absolute file name, set it as localname. If +LOCALNAME is a relative file name, return `tramp-cache-undefined'. Objects returned by this function compare `equal' if they refer to the same connection. Make a copy in order to avoid side effects." - (when (tramp-file-name-p vec) - (setq vec (copy-tramp-file-name vec)) - (setf (tramp-file-name-localname vec) - (and (stringp localname) - ;; FIXME: This is a sanity check. When this error - ;; doesn't happen for a while, it can be removed. - (or (file-name-absolute-p localname) - (tramp-error - vec 'file-error "File `%s' must be absolute" localname)) - (tramp-compat-file-name-unquote (directory-file-name localname))) - (tramp-file-name-hop vec) nil)) - vec) + (if (and (stringp localname) + (not (file-name-absolute-p localname))) + (setq vec tramp-cache-undefined) + (when (tramp-file-name-p vec) + (setq vec (copy-tramp-file-name vec)) + (setf (tramp-file-name-localname vec) + (and (stringp localname) + (tramp-compat-file-name-unquote + (directory-file-name localname))) + (tramp-file-name-hop vec) nil)) + vec)) (put #'tramp-file-name-unify 'tramp-suppress-trace t) @@ -1733,7 +1748,7 @@ See `tramp-dissect-file-name' for details." (let ((v (tramp-dissect-file-name (concat tramp-prefix-format (replace-regexp-in-string - (rx (regexp tramp-postfix-hop-regexp) eos) + (tramp-compat-rx (regexp tramp-postfix-hop-regexp) eos) tramp-postfix-host-format name)) nodefault))) ;; Only some methods from tramp-sh.el do support multi-hops. @@ -1829,7 +1844,8 @@ the form (METHOD USER DOMAIN HOST PORT LOCALNAME &optional HOP)." (replace-regexp-in-string tramp-prefix-regexp "" (replace-regexp-in-string - (rx (regexp tramp-postfix-host-regexp) eos) tramp-postfix-hop-format + (tramp-compat-rx + (regexp tramp-postfix-host-regexp) eos) tramp-postfix-hop-format (tramp-make-tramp-file-name vec 'noloc))))) (defun tramp-completion-make-tramp-file-name (method user host localname) @@ -1945,9 +1961,9 @@ of `current-buffer'." (defconst tramp-debug-outline-regexp (rx ;; Timestamp. - (+ digit) ":" (+ digit) ":" (+ digit) "." (+ digit) space + (+ digit) ":" (+ digit) ":" (+ digit) "." (+ digit) blank ;; Thread. - (? (group "#<thread " (+ nonl) ">") space) + (? (group "#<thread " (+ nonl) ">") blank) ;; Function name, verbosity. (+ (any "-" alnum)) " (" (group (+ digit)) ") #") "Used for highlighting Tramp debug buffers in `outline-mode'.") @@ -1958,7 +1974,7 @@ of `current-buffer'." ;; Also, in `font-lock-defaults' you can specify a function name for ;; the "KEYWORDS" part, so font-lock calls it to get the actual keywords! '(list - (rx bol (regexp tramp-debug-outline-regexp) (+ nonl)) + (tramp-compat-rx bol (regexp tramp-debug-outline-regexp) (+ nonl)) '(1 font-lock-warning-face t t) '(0 (outline-font-lock-face) keep t)) "Used for highlighting Tramp debug buffers in `outline-mode'.") @@ -2413,9 +2429,9 @@ letter into the file name. This function removes it." (let ((quoted (tramp-compat-file-name-quoted-p name 'top)) (result (tramp-compat-file-name-unquote name 'top))) (setq result - (if (string-match - (rx (regexp tramp-volume-letter-regexp) "/") result) - (replace-match "/" nil t result) result)) + (replace-regexp-in-string + (tramp-compat-rx (regexp tramp-volume-letter-regexp) "/") + "/" result)) (if quoted (tramp-compat-file-name-quote result 'top) result)))) ;;; Config Manipulation Functions: @@ -2524,7 +2540,7 @@ coding system might not be determined. This function repairs it." ;; We found a matching entry in `file-coding-system-alist'. ;; So we add a similar entry, but with the temporary file name ;; as regexp. - (push (cons (rx (literal tmpname)) (cdr elt)) result))))) + (push (cons (tramp-compat-rx (literal tmpname)) (cdr elt)) result))))) (defun tramp-run-real-handler (operation args) "Invoke normal file name handler for OPERATION. @@ -2636,8 +2652,8 @@ Must be handled by the callers." (tramp-get-default-directory (process-buffer (nth 0 args))))) ;; VEC. ((member operation - '(tramp-get-home-directory - tramp-get-remote-gid tramp-get-remote-uid)) + '(tramp-get-home-directory tramp-get-remote-gid + tramp-get-remote-groups tramp-get-remote-uid)) (tramp-make-tramp-file-name (nth 0 args))) ;; Unknown file primitive. (t (error "Unknown file I/O primitive: %s" operation)))) @@ -2807,7 +2823,7 @@ remote file names." #'file-name-sans-extension (directory-files dir nil (rx bos "tramp" (+ nonl) ".el" (? "c") eos))))) - (files-regexp (rx bol (regexp (regexp-opt files)) eol))) + (files-regexp (tramp-compat-rx bol (regexp (regexp-opt files)) eol))) (mapatoms (lambda (atom) (when (and (functionp atom) @@ -2952,9 +2968,10 @@ not in completion mode." ;; Suppress hop from completion. (when (string-match - (rx (regexp tramp-prefix-regexp) - (group (+ (regexp tramp-remote-file-name-spec-regexp) - (regexp tramp-postfix-hop-regexp)))) + (tramp-compat-rx + (regexp tramp-prefix-regexp) + (group (+ (regexp tramp-remote-file-name-spec-regexp) + (regexp tramp-postfix-hop-regexp)))) fullname) (setq hop (match-string 1 fullname) fullname (replace-match "" nil nil fullname 1))) @@ -3044,54 +3061,60 @@ They are collected by `tramp-completion-dissect-file-name1'." (let (;; "/method" "/[method" (tramp-completion-file-name-structure1 (list - (rx (regexp tramp-prefix-regexp) - (group (? (regexp tramp-completion-method-regexp))) eol) + (tramp-compat-rx + (regexp tramp-prefix-regexp) + (group (? (regexp tramp-completion-method-regexp))) eol) 1 nil nil nil)) ;; "/method:user" "/[method/user" (tramp-completion-file-name-structure2 (list - (rx (regexp tramp-prefix-regexp) - (group (regexp tramp-method-regexp)) - (regexp tramp-postfix-method-regexp) - (group (? (regexp tramp-user-regexp))) eol) + (tramp-compat-rx + (regexp tramp-prefix-regexp) + (group (regexp tramp-method-regexp)) + (regexp tramp-postfix-method-regexp) + (group (? (regexp tramp-user-regexp))) eol) 1 2 nil nil)) ;; "/method:host" "/[method/host" (tramp-completion-file-name-structure3 (list - (rx (regexp tramp-prefix-regexp) - (group (regexp tramp-method-regexp)) - (regexp tramp-postfix-method-regexp) - (group (? (regexp tramp-host-regexp))) eol) + (tramp-compat-rx + (regexp tramp-prefix-regexp) + (group (regexp tramp-method-regexp)) + (regexp tramp-postfix-method-regexp) + (group (? (regexp tramp-host-regexp))) eol) 1 nil 2 nil)) ;; "/method:[ipv6" "/[method/ipv6" (tramp-completion-file-name-structure4 (list - (rx (regexp tramp-prefix-regexp) - (group (regexp tramp-method-regexp)) - (regexp tramp-postfix-method-regexp) - (regexp tramp-prefix-ipv6-regexp) - (group (? (regexp tramp-ipv6-regexp))) eol) + (tramp-compat-rx + (regexp tramp-prefix-regexp) + (group (regexp tramp-method-regexp)) + (regexp tramp-postfix-method-regexp) + (regexp tramp-prefix-ipv6-regexp) + (group (? (regexp tramp-ipv6-regexp))) eol) 1 nil 2 nil)) ;; "/method:user@host" "/[method/user@host" (tramp-completion-file-name-structure5 (list - (rx (regexp tramp-prefix-regexp) - (group (regexp tramp-method-regexp)) - (regexp tramp-postfix-method-regexp) - (group (regexp tramp-user-regexp)) - (regexp tramp-postfix-user-regexp) - (group (? (regexp tramp-host-regexp))) eol) + (tramp-compat-rx + (regexp tramp-prefix-regexp) + (group (regexp tramp-method-regexp)) + (regexp tramp-postfix-method-regexp) + (group (regexp tramp-user-regexp)) + (regexp tramp-postfix-user-regexp) + (group (? (regexp tramp-host-regexp))) eol) 1 2 3 nil)) ;; "/method:user@[ipv6" "/[method/user@ipv6" (tramp-completion-file-name-structure6 (list - (rx (regexp tramp-prefix-regexp) - (group (regexp tramp-method-regexp)) - (regexp tramp-postfix-method-regexp) - (group (regexp tramp-user-regexp)) - (regexp tramp-postfix-user-regexp) - (regexp tramp-prefix-ipv6-regexp) - (group (? (regexp tramp-ipv6-regexp))) eol) + (tramp-compat-rx + (regexp tramp-prefix-regexp) + (group (regexp tramp-method-regexp)) + (regexp tramp-postfix-method-regexp) + (group (regexp tramp-user-regexp)) + (regexp tramp-postfix-user-regexp) + (regexp tramp-prefix-ipv6-regexp) + (group (? (regexp tramp-ipv6-regexp))) eol) 1 2 3 nil))) (delq nil @@ -3217,8 +3240,9 @@ Either user or host may be nil." Either user or host may be nil." (let (result (regexp - (rx bol (group (regexp tramp-host-regexp)) - (? (+ space) (group (regexp tramp-user-regexp)))))) + (tramp-compat-rx + bol (group (regexp tramp-host-regexp)) + (? (+ blank) (group (regexp tramp-user-regexp)))))) (when (re-search-forward regexp (line-end-position) t) (setq result (append (list (match-string 2) (match-string 1))))) (forward-line 1) @@ -3232,7 +3256,8 @@ User is always nil." (defun tramp-parse-shosts-group () "Return a (user host) tuple allowed to access. User is always nil." - (tramp-parse-group (rx bol (group (regexp tramp-host-regexp))) 1 ",")) + (tramp-parse-group + (tramp-compat-rx bol (group (regexp tramp-host-regexp))) 1 ",")) (defun tramp-parse-sconfig (filename) "Return a list of (user host) tuples allowed to access. @@ -3243,10 +3268,11 @@ User is always nil." "Return a (user host) tuple allowed to access. User is always nil." (tramp-parse-group - (rx (| (: bol (* space) "Host") - (: bol (+ nonl)) ;; ??? - (group (regexp tramp-host-regexp)))) - 1 (rx space))) + (tramp-compat-rx + (| (: bol (* blank) "Host") + (: bol (+ nonl)) ;; ??? + (group (regexp tramp-host-regexp)))) + 1 (rx blank))) ;; Generic function. (defun tramp-parse-shostkeys-sknownhosts (dirname regexp) @@ -3267,15 +3293,16 @@ User is always nil." User is always nil." (tramp-parse-shostkeys-sknownhosts dirname - (rx bol "key_" (+ digit) "_" (group (regexp tramp-host-regexp)) ".pub" eol))) + (tramp-compat-rx + bol "key_" (+ digit) "_" (group (regexp tramp-host-regexp)) ".pub" eol))) (defun tramp-parse-sknownhosts (dirname) "Return a list of (user host) tuples allowed to access. User is always nil." (tramp-parse-shostkeys-sknownhosts dirname - (rx bol (group (regexp tramp-host-regexp)) - ".ssh-" (| "dss" "rsa") ".pub" eol))) + (tramp-compat-rx + bol (group (regexp tramp-host-regexp)) ".ssh-" (| "dss" "rsa") ".pub" eol))) (defun tramp-parse-hosts (filename) "Return a list of (user host) tuples allowed to access. @@ -3286,8 +3313,9 @@ User is always nil." "Return a (user host) tuple allowed to access. User is always nil." (tramp-parse-group - (rx bol (group (| (regexp tramp-ipv6-regexp) (regexp tramp-host-regexp)))) - 1 (rx space))) + (tramp-compat-rx + bol (group (| (regexp tramp-ipv6-regexp) (regexp tramp-host-regexp)))) + 1 (rx blank))) (defun tramp-parse-passwd (filename) "Return a list of (user host) tuples allowed to access. @@ -3305,7 +3333,7 @@ Host is always \"localhost\"." "Return a (user host) tuple allowed to access. Host is always \"localhost\"." (let (result - (regexp (rx bol (group (regexp tramp-user-regexp)) ":"))) + (regexp (tramp-compat-rx bol (group (regexp tramp-user-regexp)) ":"))) (when (re-search-forward regexp (line-end-position) t) (setq result (list (match-string 1) "localhost"))) (forward-line 1) @@ -3356,13 +3384,14 @@ User is always nil." (tramp-parse-putty-group registry-or-dirname))))) ;; UNIX case. (tramp-parse-shostkeys-sknownhosts - registry-or-dirname (rx bol (group (regexp tramp-host-regexp)) eol)))) + registry-or-dirname + (tramp-compat-rx bol (group (regexp tramp-host-regexp)) eol)))) (defun tramp-parse-putty-group (registry) "Return a (user host) tuple allowed to access. User is always nil." (let (result - (regexp (rx (literal registry) "\\" (group (+ nonl))))) + (regexp (tramp-compat-rx (literal registry) "\\" (group (+ nonl))))) (when (re-search-forward regexp (line-end-position) t) (setq result (list nil (match-string 1)))) (forward-line 1) @@ -3405,7 +3434,7 @@ BODY is the backend specific code." BODY is the backend specific code." (declare (indent 5) (debug t)) `(or - (with-parsed-tramp-file-name ,directory nil + (with-parsed-tramp-file-name (expand-file-name ,directory) nil (tramp-barf-if-file-missing v ,directory (when (file-directory-p ,directory) (setq ,directory @@ -3436,7 +3465,7 @@ BODY is the backend specific code." BODY is the backend specific code." (declare (indent 6) (debug t)) `(or - (with-parsed-tramp-file-name ,directory nil + (with-parsed-tramp-file-name (expand-file-name ,directory) nil (tramp-barf-if-file-missing v ,directory (when (file-directory-p ,directory) (let ((temp @@ -3498,7 +3527,7 @@ BODY is the backend specific code." "Skeleton for `tramp-*-set-file-{modes,times,uid-gid}'. BODY is the backend specific code." (declare (indent 1) (debug t)) - `(with-parsed-tramp-file-name ,filename nil + `(with-parsed-tramp-file-name (expand-file-name ,filename) nil (when (not (file-exists-p ,filename)) (tramp-error v 'file-missing ,filename)) (with-tramp-saved-file-properties @@ -3679,7 +3708,7 @@ Let-bind it when necessary.") (filename newname &optional ok-if-already-exists) "Like `add-name-to-file' for Tramp files." (with-parsed-tramp-file-name - (if (tramp-tramp-file-p newname) newname filename) nil + (expand-file-name (if (tramp-tramp-file-p newname) newname filename)) nil (unless (tramp-equal-remote filename newname) (tramp-error v 'file-error @@ -3763,7 +3792,7 @@ Let-bind it when necessary.") ;; not support tilde expansion. But users could declare a ;; respective connection property. (Bug#53847) (when (string-match - (rx bos "~" (group (* (not (any "/")))) (group (* nonl)) eos) + (tramp-compat-rx bos "~" (group (* (not "/"))) (group (* nonl)) eos) localname) (let ((uname (match-string 1 localname)) (fname (match-string 2 localname)) @@ -3816,7 +3845,7 @@ Let-bind it when necessary.") ;; We don't want to run it when `non-essential' is t, or there is ;; no connection process yet. (when (tramp-connectable-p filename) - (with-parsed-tramp-file-name filename nil + (with-parsed-tramp-file-name (expand-file-name filename) nil (with-tramp-file-property v localname "file-exists-p" (not (null (file-attributes filename))))))) @@ -3927,7 +3956,8 @@ Let-bind it when necessary.") (and completion-ignored-extensions (string-match-p - (rx (regexp (regexp-opt completion-ignored-extensions)) eos) + (tramp-compat-rx + (regexp (regexp-opt completion-ignored-extensions)) eos) x) ;; We remember the hit. (push x hits-ignored-extensions)))))) @@ -3963,7 +3993,7 @@ Let-bind it when necessary.") (defun tramp-handle-file-readable-p (filename) "Like `file-readable-p' for Tramp files." - (with-parsed-tramp-file-name filename nil + (with-parsed-tramp-file-name (expand-file-name filename) nil (with-tramp-file-property v localname "file-readable-p" (or (tramp-check-cached-permissions v ?r) ;; `tramp-check-cached-permissions' doesn't handle symbolic @@ -4062,7 +4092,7 @@ Let-bind it when necessary.") (defun tramp-handle-file-writable-p (filename) "Like `file-writable-p' for Tramp files." - (with-parsed-tramp-file-name filename nil + (with-parsed-tramp-file-name (expand-file-name filename) nil (with-tramp-file-property v localname "file-writable-p" (if (file-exists-p filename) (tramp-check-cached-permissions v ?w) @@ -4266,7 +4296,7 @@ Let-bind it when necessary.") (defun tramp-ps-time () "Read printed time oif \"ps\" in format \"[[DD-]hh:]mm:ss\". Return it as number of seconds. Used in `tramp-process-attributes-ps-format'." - (search-forward-regexp (rx (+ space))) + (search-forward-regexp (rx (+ blank))) (search-forward-regexp (rx (? (? (group (+ digit)) "-") (group (+ digit)) ":") (group (+ digit)) ":" @@ -4386,17 +4416,17 @@ It is not guaranteed, that all process attributes as described in (cond ((eq (cdr elt) 'number) (read (current-buffer))) ((eq (cdr elt) 'string) - (search-forward-regexp (rx (+ (not space)))) + (search-forward-regexp (rx (+ (not blank)))) (match-string 0)) ((numberp (cdr elt)) - (search-forward-regexp (rx (+ space))) + (search-forward-regexp (rx (+ blank))) (search-forward-regexp (rx (+ nonl)) (+ (point) (cdr elt))) (string-trim (match-string 0))) ((fboundp (cdr elt)) (funcall (cdr elt))) ((null (cdr elt)) - (search-forward-regexp (rx (+ whitespace))) + (search-forward-regexp (rx (+ blank))) (buffer-substring (point) (line-end-position))))) res)) ;; `nice' could be `-'. @@ -4570,9 +4600,9 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") tramp-prefix-format proxy tramp-postfix-host-format)) (entry (list (and (stringp host-port) - (rx bol (literal host-port) eol)) + (tramp-compat-rx bol (literal host-port) eol)) (and (stringp user-domain) - (rx bol (literal user-domain) eol)) + (tramp-compat-rx bol (literal user-domain) eol)) (propertize proxy 'tramp-ad-hoc t)))) (tramp-message vec 5 "Add %S to `tramp-default-proxies-alist'" entry) ;; Add the hop. @@ -4651,7 +4681,7 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") (setq tramp-default-proxies-alist saved-tdpa) (tramp-user-error vec "Host name `%s' does not match `%s'" host previous-host)) - (setq previous-host (rx bol (literal host) eol))))) + (setq previous-host (tramp-compat-rx bol (literal host) eol))))) ;; Result. target-alist)) @@ -4840,7 +4870,7 @@ support symbolic links." (defun tramp-handle-shell-command (command &optional output-buffer error-buffer) "Like `shell-command' for Tramp files." - (let* ((asynchronous (string-match-p (rx (* space) "&" (* space) eos) command)) + (let* ((asynchronous (string-match-p (rx (* blank) "&" (* blank) eos) command)) (command (substring command 0 asynchronous)) current-buffer-p (output-buffer-p output-buffer) @@ -5614,7 +5644,8 @@ the remote host use line-endings as defined in the variable (tramp-flush-directory-properties vec "/")) (when (buffer-live-p buf) (with-current-buffer buf - (when (and prompt (tramp-search-regexp (rx (literal prompt)))) + (when (and prompt + (tramp-search-regexp (tramp-compat-rx (literal prompt)))) (delete-region (point) (point-max)))))))) (defun tramp-get-inode (vec) @@ -5818,7 +5849,7 @@ VEC is used for tracing." (while candidates (goto-char (point-min)) (if (string-match-p - (rx bol (literal (car candidates)) (? "\r") eol) + (tramp-compat-rx bol (literal (car candidates)) (? "\r") eol) (buffer-string)) (setq locale (car candidates) candidates nil) @@ -5861,7 +5892,13 @@ be granted." (equal remote-gid tramp-unknown-id-integer) (equal remote-gid (file-attribute-group-id file-attr)) (equal tramp-unknown-id-integer - (file-attribute-group-id file-attr))))))) + (file-attribute-group-id file-attr)))) + ;; Group accessible and owned by user's secondary group. + (and + (eq access + (aref (file-attribute-modes file-attr) (+ offset 3))) + (member (file-attribute-group-id file-attr) + (tramp-get-remote-groups vec 'integer)))))) (defmacro tramp-convert-file-attributes (vec localname id-format attr) "Convert `file-attributes' ATTR generated Tramp backend functions. @@ -5999,6 +6036,52 @@ ID-FORMAT valid values are `string' and `integer'." (and (equal id-format 'integer) tramp-unknown-id-integer) (and (equal id-format 'string) tramp-unknown-id-string))) +(defun tramp-get-remote-groups (vec id-format) + "The list of groups of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (and (tramp-file-name-p vec) + (with-tramp-connection-property vec (format "groups-%s" id-format) + (tramp-file-name-handler #'tramp-get-remote-groups vec id-format)))) + +(defun tramp-read-id-output (vec) + "Read in connection buffer the output of the `id' command. +Set connection properties \"{uid,gid.groups}-{integer,string}\"." + (with-current-buffer (tramp-get-connection-buffer vec) + (let (uid-integer uid-string + gid-integer gid-string + groups-integer groups-string) + (goto-char (point-min)) + ;; Read uid. + (when (re-search-forward + (rx "uid=" (group (+ digit)) "(" (group (+ (any "_" word))) ")") + nil 'noerror) + (setq uid-integer (string-to-number (match-string 1)) + uid-string (match-string 2))) + ;; Read gid. + (when (re-search-forward + (rx "gid=" (group (+ digit)) "(" (group (+ (any "_" word))) ")") + nil 'noerror) + (setq gid-integer (string-to-number (match-string 1)) + gid-string (match-string 2))) + ;; Read groups. + (when (re-search-forward (rx "groups=") nil 'noerror) + (while (looking-at + (rx (group (+ digit)) "(" (group (+ (any "_" word))) ")")) + (setq groups-integer (cons (string-to-number (match-string 1)) + groups-integer) + groups-string (cons (match-string 2) groups-string)) + (goto-char (match-end 0)) + (skip-chars-forward ","))) + ;; Set connection properties. + (tramp-set-connection-property vec "uid-integer" uid-integer) + (tramp-set-connection-property vec "uid-string" uid-string) + (tramp-set-connection-property vec "gid-integer" gid-integer) + (tramp-set-connection-property vec "gid-string" gid-string) + (tramp-set-connection-property + vec "groups-integer" (nreverse groups-integer)) + (tramp-set-connection-property + vec "groups-string" (nreverse groups-string))))) + (defun tramp-local-host-p (vec) "Return t if this points to the local host, nil otherwise. This handles also chrooted environments, which are not regarded as local." @@ -6126,7 +6209,7 @@ ALIST is of the form ((FROM . TO) ...)." (let* ((pr (car alist)) (from (car pr)) (to (cdr pr))) - (while (string-match (rx (literal from)) string) + (while (string-match (tramp-compat-rx (literal from)) string) (setq string (replace-match to t t string))) (setq alist (cdr alist)))) string)) @@ -6394,7 +6477,7 @@ Only works for Bourne-like shells." (string= (substring result 0 2) "\\~")) (setq result (substring result 1))) (replace-regexp-in-string - (rx "\\" (literal tramp-rsh-end-of-line)) + (tramp-compat-rx "\\" (literal tramp-rsh-end-of-line)) (format "'%s'" tramp-rsh-end-of-line) result))))) ;;; Signal handling. This works for remote processes, which have set diff --git a/lisp/obsolete/crisp.el b/lisp/obsolete/crisp.el index 8424c42b69c..5e1a278a2c2 100644 --- a/lisp/obsolete/crisp.el +++ b/lisp/obsolete/crisp.el @@ -174,9 +174,6 @@ All the bindings are done here instead of globally to try and be nice to the world.") -(define-obsolete-variable-alias 'crisp-mode-modeline-string - 'crisp-mode-mode-line-string "24.3") - (defcustom crisp-mode-mode-line-string " *CRiSP*" "String to display in the mode line when CRiSP emulation mode is enabled." :type 'string) diff --git a/lisp/outline.el b/lisp/outline.el index 9a94cad6385..6579e12bfed 100644 --- a/lisp/outline.el +++ b/lisp/outline.el @@ -1582,7 +1582,7 @@ and body between `hide all', `headings only' and `show all'. (defvar-local outline--cycle-buffer-state 'show-all "Internal variable used for tracking buffer cycle state.") -(defun outline-cycle-buffer () +(defun outline-cycle-buffer (&optional level) "Cycle visibility state of the body lines of the whole buffer. This cycles the visibility of all the subheadings and bodies of all @@ -1591,20 +1591,28 @@ the heading lines in the buffer. It cycles them between `hide all', `Hide all' means hide all the buffer's subheadings and their bodies. `Headings only' means show all the subheadings, but not their bodies. -`Show all' means show all the buffer's subheadings and their bodies." - (interactive) - (let (has-top-level) +`Show all' means show all the buffer's subheadings and their bodies. + +With a prefix argument, show headings up to that LEVEL." + (interactive (list (when current-prefix-arg + (prefix-numeric-value current-prefix-arg)))) + (let (top-level) (save-excursion (goto-char (point-min)) - (while (not (or has-top-level (eobp))) - (when (outline-on-heading-p t) - (when (= (funcall outline-level) 1) - (setq has-top-level t))) + (while (not (or (eq top-level 1) (eobp))) + (when-let ((level (and (outline-on-heading-p t) + (funcall outline-level)))) + (when (< level (or top-level most-positive-fixnum)) + (setq top-level (max level 1)))) (outline-next-heading))) (cond + (level + (outline-hide-sublevels level) + (setq outline--cycle-buffer-state 'all-heading) + (message "All headings up to level %s" level)) ((and (eq outline--cycle-buffer-state 'show-all) - has-top-level) - (outline-hide-sublevels 1) + top-level) + (outline-hide-sublevels top-level) (setq outline--cycle-buffer-state 'top-level) (message "Top level headings")) ((or (eq outline--cycle-buffer-state 'show-all) diff --git a/lisp/pcomplete.el b/lisp/pcomplete.el index 15b9880df85..0e3d1df7814 100644 --- a/lisp/pcomplete.el +++ b/lisp/pcomplete.el @@ -155,9 +155,6 @@ This mirrors the optional behavior of tcsh. A non-nil value is useful if `pcomplete-autolist' is non-nil too." :type 'boolean) -(define-obsolete-variable-alias - 'pcomplete-arg-quote-list 'comint-file-name-quote-list "24.3") - (defcustom pcomplete-man-function #'man "A function to that will be called to display a manual page. It will be passed the name of the command to document." @@ -364,11 +361,10 @@ modified to be an empty string, or the desired separation string." ;;; Alternative front-end using the standard completion facilities. -;; The way pcomplete-parse-arguments, pcomplete-stub, and -;; pcomplete-quote-argument work only works because of some deep -;; hypothesis about the way the completion work. Basically, it makes -;; it pretty much impossible to have completion other than -;; prefix-completion. +;; The way pcomplete-parse-arguments and pcomplete-stub work only +;; works because of some deep hypothesis about the way the completion +;; work. Basically, it makes it pretty much impossible to have +;; completion other than prefix-completion. ;; ;; pcomplete--common-suffix and completion-table-subvert try to work around ;; this difficulty with heuristics, but it's really a hack. @@ -841,9 +837,6 @@ this is `comint-dynamic-complete-functions'." (throw 'pcompleted t) pcomplete-args)))))) -(define-obsolete-function-alias - 'pcomplete-quote-argument #'comint-quote-filename "24.3") - ;; file-system completion lists (defsubst pcomplete-dirs-or-entries (&optional regexp predicate) diff --git a/lisp/proced.el b/lisp/proced.el index a27638d3679..c278cce9dc7 100644 --- a/lisp/proced.el +++ b/lisp/proced.el @@ -445,60 +445,58 @@ Important: the match ends just after the marker.") (,(concat "^[" (char-to-string proced-marker-char) "]") ".+" (proced-move-to-goal-column) nil (0 'proced-marked)))) -(defvar proced-mode-map - (let ((km (make-sparse-keymap))) - ;; moving - (define-key km " " 'next-line) - (define-key km "n" 'next-line) - (define-key km "p" 'previous-line) - (define-key km "\C-n" 'next-line) - (define-key km "\C-p" 'previous-line) - (define-key km "\C-?" 'previous-line) - (define-key km [?\S-\ ] 'previous-line) - (define-key km [down] 'next-line) - (define-key km [up] 'previous-line) - ;; marking - (define-key km "d" 'proced-mark) ; Dired compatibility ("delete") - (define-key km "m" 'proced-mark) - (put 'proced-mark :advertised-binding "m") - (define-key km "u" 'proced-unmark) - (define-key km "\177" 'proced-unmark-backward) - (define-key km "M" 'proced-mark-all) - (define-key km "U" 'proced-unmark-all) - (define-key km "t" 'proced-toggle-marks) - (define-key km "C" 'proced-mark-children) - (define-key km "P" 'proced-mark-parents) - ;; filtering - (define-key km "f" 'proced-filter-interactive) - (define-key km [mouse-2] 'proced-refine) - (define-key km "\C-m" 'proced-refine) - ;; sorting - (define-key km "sc" 'proced-sort-pcpu) - (define-key km "sm" 'proced-sort-pmem) - (define-key km "sp" 'proced-sort-pid) - (define-key km "ss" 'proced-sort-start) - (define-key km "sS" 'proced-sort-interactive) - (define-key km "st" 'proced-sort-time) - (define-key km "su" 'proced-sort-user) - ;; similar to `Buffer-menu-sort-by-column' - (define-key km [header-line mouse-1] 'proced-sort-header) - (define-key km [header-line mouse-2] 'proced-sort-header) - (define-key km "T" 'proced-toggle-tree) - ;; formatting - (define-key km "F" 'proced-format-interactive) - ;; operate - (define-key km "o" 'proced-omit-processes) - (define-key km "x" 'proced-send-signal) ; Dired compatibility - (define-key km "k" 'proced-send-signal) ; kill processes - (define-key km "r" 'proced-renice) ; renice processes - ;; misc - (define-key km "h" 'describe-mode) - (define-key km "?" 'proced-help) - (define-key km [remap undo] 'proced-undo) - (define-key km [remap advertised-undo] 'proced-undo) - ;; Additional keybindings are inherited from `special-mode-map' - km) - "Keymap for Proced commands.") +(defvar-keymap proced-mode-map + :doc "Keymap for Proced commands." + ;; moving + "SPC" #'next-line + "n" #'next-line + "p" #'previous-line + "C-n" #'next-line + "C-p" #'previous-line + "S-SPC" #'previous-line + "<down>" #'next-line + "<up>" #'previous-line + ;; marking + "d" #'proced-mark ; Dired compatibility ("delete") + "m" #'proced-mark + "u" #'proced-unmark + "DEL" #'proced-unmark-backward + "M" #'proced-mark-all + "U" #'proced-unmark-all + "t" #'proced-toggle-marks + "C" #'proced-mark-children + "P" #'proced-mark-parents + ;; filtering + "f" #'proced-filter-interactive + "<mouse-2>" #'proced-refine + "RET" #'proced-refine + ;; sorting + "s c" #'proced-sort-pcpu + "s m" #'proced-sort-pmem + "s p" #'proced-sort-pid + "s s" #'proced-sort-start + "s S" #'proced-sort-interactive + "s t" #'proced-sort-time + "s u" #'proced-sort-user + ;; similar to `Buffer-menu-sort-by-column' + "<header-line> <mouse-1>" #'proced-sort-header + "<header-line> <mouse-2>" #'proced-sort-header + "T" #'proced-toggle-tree + ;; formatting + "F" #'proced-format-interactive + ;; operate + "o" #'proced-omit-processes + "x" #'proced-send-signal ; Dired compatibility + "k" #'proced-send-signal ; kill processes + "r" #'proced-renice ; renice processes + ;; misc + "h" #'describe-mode + "?" #'proced-help + "<remap> <undo>" #'proced-undo + "<remap> <advertised-undo>" #'proced-undo + ;; Additional keybindings are inherited from `special-mode-map' + ) +(put 'proced-mark :advertised-binding "m") (easy-menu-define proced-menu proced-mode-map "Proced Menu." @@ -1768,6 +1766,9 @@ The value returned is the value of the last form in BODY." (save-window-excursion ;; Analogous to `dired-pop-to-buffer' ;; Don't split window horizontally. (Bug#1806) + ;; FIXME: `dired-pop-to-buffer' was removed and replaced with + ;; `dired-mark-pop-up'. Should we just use + ;; `pop-to-buffer' here also? (display-buffer (current-buffer) '(display-buffer-in-direction (direction . bottom) diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el index 9327dbf7758..9309a546dbd 100644 --- a/lisp/progmodes/cc-mode.el +++ b/lisp/progmodes/cc-mode.el @@ -3148,8 +3148,6 @@ Key bindings: (message "Using CC Mode version %s" c-version) (c-keep-region-active)) -(define-obsolete-variable-alias 'c-prepare-bug-report-hooks - 'c-prepare-bug-report-hook "24.3") (defvar c-prepare-bug-report-hook nil) ;; Dynamic variables used by reporter. diff --git a/lisp/progmodes/hideif.el b/lisp/progmodes/hideif.el index d09e1f4cdfe..53788949ea4 100644 --- a/lisp/progmodes/hideif.el +++ b/lisp/progmodes/hideif.el @@ -196,9 +196,7 @@ Effective only if `hide-ifdef-expand-reinclusion-guard' is t." "C" #'hif-clear-all-ifdef-defined "C-q" #'hide-ifdef-toggle-read-only "C-w" #'hide-ifdef-toggle-shadowing - "<remap> <read-only-mode>" #'hide-ifdef-toggle-outside-read-only - ;; `toggle-read-only' is obsoleted by `read-only-mode'. - "<remap> <toggle-read-only>" #'hide-ifdef-toggle-outside-read-only) + "<remap> <read-only-mode>" #'hide-ifdef-toggle-outside-read-only) (defcustom hide-ifdef-mode-prefix-key "\C-c@" "Prefix key for all Hide-Ifdef mode commands." diff --git a/lisp/progmodes/octave.el b/lisp/progmodes/octave.el index 721dfa51ad3..18b98991692 100644 --- a/lisp/progmodes/octave.el +++ b/lisp/progmodes/octave.el @@ -1722,12 +1722,12 @@ code line." (dir (file-name-directory (directory-file-name (file-name-directory file))))) (replace-match "" nil nil nil 1) - (insert (substitute-command-keys "`")) + (insert (substitute-quotes "`")) ;; Include the parent directory which may be regarded as ;; the category for the FN. (help-insert-xref-button (file-relative-name file dir) 'octave-help-file fn) - (insert (substitute-command-keys "'")))) + (insert (substitute-quotes "'")))) ;; Make 'See also' clickable. (with-syntax-table octave-mode-syntax-table (when (re-search-forward "^\\s-*See also:" nil t) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 30f51704dca..ee94d0d85d8 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -1498,7 +1498,8 @@ the progress. The function returns the number of detected projects." (interactive "DDirectory: \nP") (project--ensure-read-project-list) - (let ((queue (directory-files dir t nil t)) (count 0) + (let ((queue (list dir)) + (count 0) (known (make-hash-table :size (* 2 (length project--list)) :test #'equal ))) @@ -1506,15 +1507,20 @@ projects." (puthash project t known)) (while queue (when-let ((subdir (pop queue)) - ((file-directory-p subdir)) - ((not (gethash subdir known)))) - (when-let (pr (project--find-in-directory subdir)) - (project-remember-project pr t) - (message "Found %s..." (project-root pr)) + ((file-directory-p subdir))) + (when-let ((project (project--find-in-directory subdir)) + (project-root (project-root project)) + ((not (gethash project-root known)))) + (project-remember-project project t) + (puthash project-root t known) + (message "Found %s..." project-root) (setq count (1+ count))) - (when (and recursive (file-symlink-p subdir)) - (setq queue (nconc (directory-files subdir t nil t) queue)) - (puthash subdir t known)))) + (when (and recursive (file-directory-p subdir)) + (setq queue + (nconc + (directory-files + subdir t directory-files-no-dot-files-regexp t) + queue))))) (unless (eq recursive 'in-progress) (if (zerop count) (message "No projects were found") diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 147c5f248d2..9f9439aac69 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -528,16 +528,6 @@ The type returned can be `comment', `string' or `paren'." (eql (syntax-class (syntax-after (point))) (syntax-class (string-to-syntax ")")))) -(define-obsolete-function-alias - 'python-info-ppss-context #'python-syntax-context "24.3") - -(define-obsolete-function-alias - 'python-info-ppss-context-type #'python-syntax-context-type "24.3") - -(define-obsolete-function-alias - 'python-info-ppss-comment-or-string-p - #'python-syntax-comment-or-string-p "24.3") - (defun python-font-lock-syntactic-face-function (state) "Return syntactic face given STATE." (if (nth 3 state) @@ -546,11 +536,22 @@ The type returned can be `comment', `string' or `paren'." font-lock-string-face) font-lock-comment-face)) +(defconst python--f-string-start-regexp + (rx bow + (or "f" "F" "fr" "Fr" "fR" "FR" "rf" "rF" "Rf" "RF") + (or "\"" "\"\"\"" "'" "'''")) + "A regular expression matching the beginning of an f-string. + +See URL `https://docs.python.org/3/reference/lexical_analysis.html#string-and-bytes-literals'.") + (defun python--f-string-p (ppss) "Return non-nil if the pos where PPSS was found is inside an f-string." (and (nth 3 ppss) - (let ((spos (1- (nth 8 ppss)))) - (and (memq (char-after spos) '(?f ?F)) + (let* ((spos (1- (nth 8 ppss))) + (before-quote + (buffer-substring-no-properties (max (- spos 4) (point-min)) + (min (+ spos 2) (point-max))))) + (and (string-match-p python--f-string-start-regexp before-quote) (or (< (point-min) spos) (not (memq (char-syntax (char-before spos)) '(?w ?_)))))))) @@ -569,7 +570,7 @@ the {...} holes that appear within f-strings." (while (progn (while (and (not (python--f-string-p ppss)) - (re-search-forward "\\<f['\"]" limit 'move)) + (re-search-forward python--f-string-start-regexp limit 'move)) (setq ppss (syntax-ppss))) (< (point) limit)) (cl-assert (python--f-string-p ppss)) @@ -942,17 +943,11 @@ It makes underscores and dots word constituent chars.") ;;; Indentation -(define-obsolete-variable-alias - 'python-indent 'python-indent-offset "24.3") - (defcustom python-indent-offset 4 "Default indentation offset for Python." :type 'integer :safe 'integerp) -(define-obsolete-variable-alias - 'python-guess-indent 'python-indent-guess-indent-offset "24.3") - (defcustom python-indent-guess-indent-offset t "Non-nil tells Python mode to guess `python-indent-offset' value." :type 'boolean @@ -3296,17 +3291,11 @@ be asked for their values." "Instead call `python-shell-get-process' and create one if returns nil." "25.1") -(define-obsolete-variable-alias - 'python-buffer 'python-shell-internal-buffer "24.3") - (defvar python-shell-internal-buffer nil "Current internal shell buffer for the current buffer. This is really not necessary at all for the code to work but it's there for compatibility with CEDET.") -(define-obsolete-variable-alias - 'python-preoutput-result 'python-shell-internal-last-output "24.3") - (defvar python-shell-internal-last-output nil "Last output captured by the internal shell. This is really not necessary at all for the code to work but it's @@ -3319,9 +3308,6 @@ there for compatibility with CEDET.") (get-process proc-name) (run-python-internal)))) -(define-obsolete-function-alias - 'python-proc #'python-shell-internal-get-or-create-process "24.3") - (defun python-shell--save-temp-file (string) (let* ((temporary-file-directory (if (file-remote-p default-directory) @@ -3438,12 +3424,6 @@ Returns the output. See `python-shell-send-string-no-output'." (replace-regexp-in-string "_emacs_out +" "" string) (python-shell-internal-get-or-create-process)))) -(define-obsolete-function-alias - 'python-send-receive #'python-shell-internal-send-string "24.3") - -(define-obsolete-function-alias - 'python-send-string #'python-shell-internal-send-string "24.3") - (defun python-shell-buffer-substring (start end &optional nomain no-cookie) "Send buffer substring from START to END formatted for shell. This is a wrapper over `buffer-substring' that takes care of @@ -4609,9 +4589,6 @@ JUSTIFY should be used (if applicable) as in `fill-paragraph'." ;;; Skeletons -(define-obsolete-variable-alias - 'python-use-skeletons 'python-skeleton-autoinsert "24.3") - (defcustom python-skeleton-autoinsert nil "Non-nil means template skeletons will be automagically inserted. This happens when pressing \"if<SPACE>\", for example, to prompt for diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el index be9f325d93d..517fbbd8e7b 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el @@ -2982,14 +2982,6 @@ option followed by a colon `:' if the option accepts an argument." (match-string 1)))))) -(defun sh-maybe-here-document (arg) - "Insert self. Without prefix, following unquoted `<' inserts here document. -The document is bounded by `sh-here-document-word'." - (declare (obsolete sh-electric-here-document-mode "24.3")) - (interactive "*P") - (self-insert-command (prefix-numeric-value arg)) - (or arg (sh--maybe-here-document))) - (defun sh--maybe-here-document () (when (and (looking-back "[^<]<<[ E-]" (line-beginning-position)) (save-excursion diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index a7e372c2ac6..ac04b64ce59 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -1,7 +1,7 @@ ;;; xref.el --- Cross-referencing commands -*-lexical-binding:t-*- ;; Copyright (C) 2014-2022 Free Software Foundation, Inc. -;; Version: 1.5.0 +;; Version: 1.5.1 ;; Package-Requires: ((emacs "26.1")) ;; This is a GNU ELPA :core package. Avoid functionality that is not diff --git a/lisp/replace.el b/lisp/replace.el index 06cde771b9e..6393c092886 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -73,14 +73,6 @@ See `query-replace-from-history-variable' and This is a list of cons cells (FROM-STRING . TO-STRING), or nil if there are no default values.") -(defvar query-replace-interactive nil - "Non-nil means `query-replace' uses the last search string. -That becomes the \"string to replace\".") -(make-obsolete-variable 'query-replace-interactive - "use `M-n' to pull the last incremental search string -to the minibuffer that reads the string to replace, or invoke replacements -from Isearch by using a key sequence like `C-s C-s M-%'." "24.3") - (defcustom query-replace-from-to-separator " → " "String that separates FROM and TO in the history of replacement pairs. When nil, the pair will not be added to the history (same behavior @@ -213,96 +205,94 @@ by this function to the end of values available via Prompt with PROMPT. REGEXP-FLAG non-nil means the response should be a regexp. The return value can also be a pair (FROM . TO) indicating that the user wants to replace FROM with TO." - (if query-replace-interactive - (car (if regexp-flag regexp-search-ring search-ring)) - (let* ((history-add-new-input nil) - (separator-string - (when query-replace-from-to-separator - ;; Check if the first non-whitespace char is displayable - (if (char-displayable-p - (string-to-char (string-replace - " " "" query-replace-from-to-separator))) - query-replace-from-to-separator - " -> "))) - (separator - (when separator-string - (propertize separator-string - 'display separator-string - 'face 'minibuffer-prompt - 'separator t))) - (minibuffer-history - (append - (when separator - (mapcar (lambda (from-to) - (concat (query-replace-descr (car from-to)) - separator - (query-replace-descr (cdr from-to)))) - query-replace-defaults)) - (symbol-value query-replace-from-history-variable))) - (minibuffer-allow-text-properties t) ; separator uses text-properties - (default (when (and query-replace-read-from-default (not regexp-flag)) - (funcall query-replace-read-from-default))) - (prompt - (cond ((and query-replace-read-from-regexp-default regexp-flag) prompt) - (default (format-prompt prompt default)) - ((and query-replace-defaults separator) - (format-prompt prompt (car minibuffer-history))) - (query-replace-defaults - (format-prompt - prompt (format "%s -> %s" - (query-replace-descr - (caar query-replace-defaults)) - (query-replace-descr - (cdar query-replace-defaults))))) - (t (format-prompt prompt nil)))) - (from - ;; The save-excursion here is in case the user marks and copies - ;; a region in order to specify the minibuffer input. - ;; That should not clobber the region for the query-replace itself. - (save-excursion - (minibuffer-with-setup-hook - (lambda () - (setq-local text-property-default-nonsticky - (append '((separator . t) (face . t)) - text-property-default-nonsticky))) - (if regexp-flag - (read-regexp - (if query-replace-read-from-regexp-default - (string-remove-suffix ": " prompt) - prompt) - query-replace-read-from-regexp-default - 'minibuffer-history) - (read-from-minibuffer - prompt nil nil nil nil - (if default - (delete-dups - (cons default (query-replace-read-from-suggestions))) - (query-replace-read-from-suggestions)) - t))))) - (to)) - (if (and (zerop (length from)) query-replace-defaults (not default)) - (cons (caar query-replace-defaults) - (query-replace-compile-replacement - (cdar query-replace-defaults) regexp-flag)) - (setq from (or (and (zerop (length from)) default) - (query-replace--split-string from))) - (when (consp from) (setq to (cdr from) from (car from))) - (add-to-history query-replace-from-history-variable from nil t) - ;; Warn if user types \n or \t, but don't reject the input. - (and regexp-flag - (string-match "\\(\\`\\|[^\\]\\)\\(\\\\\\\\\\)*\\(\\\\[nt]\\)" from) - (let ((match (match-string 3 from))) - (cond - ((string= match "\\n") - (message "Note: `\\n' here doesn't match a newline; to do that, type C-q C-j instead")) - ((string= match "\\t") - (message "Note: `\\t' here doesn't match a tab; to do that, just type TAB"))) - (sit-for 2))) - (if (not to) - from - (add-to-history query-replace-to-history-variable to nil t) - (add-to-history 'query-replace-defaults (cons from to) nil t) - (cons from (query-replace-compile-replacement to regexp-flag))))))) + (let* ((history-add-new-input nil) + (separator-string + (when query-replace-from-to-separator + ;; Check if the first non-whitespace char is displayable + (if (char-displayable-p + (string-to-char (string-replace + " " "" query-replace-from-to-separator))) + query-replace-from-to-separator + " -> "))) + (separator + (when separator-string + (propertize separator-string + 'display separator-string + 'face 'minibuffer-prompt + 'separator t))) + (minibuffer-history + (append + (when separator + (mapcar (lambda (from-to) + (concat (query-replace-descr (car from-to)) + separator + (query-replace-descr (cdr from-to)))) + query-replace-defaults)) + (symbol-value query-replace-from-history-variable))) + (minibuffer-allow-text-properties t) ; separator uses text-properties + (default (when (and query-replace-read-from-default (not regexp-flag)) + (funcall query-replace-read-from-default))) + (prompt + (cond ((and query-replace-read-from-regexp-default regexp-flag) prompt) + (default (format-prompt prompt default)) + ((and query-replace-defaults separator) + (format-prompt prompt (car minibuffer-history))) + (query-replace-defaults + (format-prompt + prompt (format "%s -> %s" + (query-replace-descr + (caar query-replace-defaults)) + (query-replace-descr + (cdar query-replace-defaults))))) + (t (format-prompt prompt nil)))) + (from + ;; The save-excursion here is in case the user marks and copies + ;; a region in order to specify the minibuffer input. + ;; That should not clobber the region for the query-replace itself. + (save-excursion + (minibuffer-with-setup-hook + (lambda () + (setq-local text-property-default-nonsticky + (append '((separator . t) (face . t)) + text-property-default-nonsticky))) + (if regexp-flag + (read-regexp + (if query-replace-read-from-regexp-default + (string-remove-suffix ": " prompt) + prompt) + query-replace-read-from-regexp-default + 'minibuffer-history) + (read-from-minibuffer + prompt nil nil nil nil + (if default + (delete-dups + (cons default (query-replace-read-from-suggestions))) + (query-replace-read-from-suggestions)) + t))))) + (to)) + (if (and (zerop (length from)) query-replace-defaults (not default)) + (cons (caar query-replace-defaults) + (query-replace-compile-replacement + (cdar query-replace-defaults) regexp-flag)) + (setq from (or (and (zerop (length from)) default) + (query-replace--split-string from))) + (when (consp from) (setq to (cdr from) from (car from))) + (add-to-history query-replace-from-history-variable from nil t) + ;; Warn if user types \n or \t, but don't reject the input. + (and regexp-flag + (string-match "\\(\\`\\|[^\\]\\)\\(\\\\\\\\\\)*\\(\\\\[nt]\\)" from) + (let ((match (match-string 3 from))) + (cond + ((string= match "\\n") + (message "Note: `\\n' here doesn't match a newline; to do that, type C-q C-j instead")) + ((string= match "\\t") + (message "Note: `\\t' here doesn't match a tab; to do that, just type TAB"))) + (sit-for 2))) + (if (not to) + from + (add-to-history query-replace-to-history-variable to nil t) + (add-to-history 'query-replace-defaults (cons from to) nil t) + (cons from (query-replace-compile-replacement to regexp-flag)))))) (defun query-replace-compile-replacement (to regexp-flag) "Maybe convert a regexp replacement TO to Lisp. diff --git a/lisp/server.el b/lisp/server.el index dd7bccaf331..3caa335c4eb 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -27,12 +27,12 @@ ;;; Commentary: -;; This Lisp code is run in Emacs when it is to operate as -;; a server for other processes. +;; This library allows Emacs to operate as a server for other +;; processes. -;; Load this library and do M-x server-edit to enable Emacs as a server. +;; Load this library and do `M-x server-start' to enable Emacs as a server. ;; Emacs opens up a socket for communication with clients. If there are no -;; client buffers to edit, server-edit acts like (switch-to-buffer +;; client buffers to edit, `server-edit' acts like (switch-to-buffer ;; (other-buffer)) ;; When some other program runs "the editor" to edit a file, @@ -42,10 +42,10 @@ ;; Note that any number of clients may dispatch files to Emacs to be edited. -;; When you finish editing a Server buffer, again call server-edit +;; When you finish editing a Server buffer, again call `server-edit' ;; to mark that buffer as done for the client and switch to the next ;; Server buffer. When all the buffers for a client have been edited -;; and exited with server-edit, the client "editor" will return +;; and exited with `server-edit', the client "editor" will return ;; to the program that invoked it. ;; Your editing commands and Emacs's display output go to and from @@ -54,25 +54,28 @@ ;; the client. This is possible in four cases: ;; 1. On a window system, where Emacs runs in one window and the -;; program that wants to use "the editor" runs in another. +;; program that wants to use "the editor" runs in another. -;; 2. On a multi-terminal system, where Emacs runs on one terminal and the -;; program that wants to use "the editor" runs on another. +;; 2. On a multi-terminal system, where Emacs runs on one terminal and +;; the program that wants to use "the editor" runs on another. -;; 3. When the program that wants to use "the editor" is running -;; as a subprocess of Emacs. +;; 3. When the program that wants to use "the editor" is running as a +;; subprocess of Emacs. -;; 4. On a system with job control, when Emacs is suspended, the program -;; that wants to use "the editor" will stop and display -;; "Waiting for Emacs...". It can then be suspended, and Emacs can be -;; brought into the foreground for editing. When done editing, Emacs is -;; suspended again, and the client program is brought into the foreground. +;; 4. On a system with job control, when Emacs is suspended, the +;; program that wants to use "the editor" will stop and display +;; "Waiting for Emacs...". It can then be suspended, and Emacs can +;; be brought into the foreground for editing. When done editing, +;; Emacs is suspended again, and the client program is brought into +;; the foreground. -;; The buffer local variable "server-buffer-clients" lists +;; The buffer local variable `server-buffer-clients' lists ;; the clients who are waiting for this buffer to be edited. -;; The global variable "server-clients" lists all the waiting clients, +;; The global variable `server-clients' lists all the waiting clients, ;; and which files are yet to be edited for each. +;;; Code: + ;; Todo: ;; - handle command-line-args-left. @@ -80,8 +83,6 @@ ;; to here. ;; - fix up handling of the client's environment (place it in the terminal?). -;;; Code: - (eval-when-compile (require 'cl-lib)) (defgroup server nil diff --git a/lisp/shell.el b/lisp/shell.el index 85225b128ab..87fd36a5929 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -99,6 +99,7 @@ (require 'pcomplete) (eval-when-compile (require 'files-x)) ;with-connection-local-variables (require 'subr-x) +(eval-when-compile (require 'cl-lib)) ;;; Customization and Buffer Variables @@ -307,6 +308,39 @@ for Shell mode only." (const :tag "on" t)) :group 'shell) +(defcustom shell-comint-fl-enable t + "Enable fontification of input in shell buffers. +This variable only has effect when the shell is started. Use the +command `comint-fl-mode' to toggle fontification of input." + :type 'boolean + :group 'shell + :safe 'booleanp + :version "29.1") + +(defcustom shell-indirect-setup-hook nil + "Hook run in an indirect buffer for input fontification. +Input fontification and indentation of a `shell-mode' buffer, if +enabled, is performed in an indirect buffer, whose indentation +and syntax highlighting is set up with `sh-mode'. In addition to +`comint-indirect-setup-hook', run this hook with the indirect +buffer as the current buffer after its setup is done. This can +be used to further customize fontification and other behaviour of +the indirect buffer." + :type 'boolean + :group 'shell + :safe 'booleanp + :version "29.1") + +(defcustom shell-highlight-undef-enable nil + "Enable highlighting of undefined commands in shell buffers. +This variable only has effect when the shell is started. Use the +command `shell-highlight-undef-mode' to toggle highlighting of +undefined commands." + :type 'boolean + :group 'shell + :safe 'booleanp + :version "29.1") + (defvar shell-dirstack nil "List of directories saved by pushd in this buffer's shell. Thus, this does not include the shell's current directory.") @@ -522,6 +556,8 @@ Shell buffers. It implements `shell-completion-execonly' for (put 'shell-mode 'mode-class 'special) +(defvar sh-shell-file) + (define-derived-mode shell-mode comint-mode "Shell" "Major mode for interacting with an inferior shell. \\<shell-mode-map> @@ -585,6 +621,13 @@ from `shell-mode-hook', Emacs will call the `ding' function whenever it receives the bell character in output from a command." :interactive nil + :after-hook + (unless comint-use-prompt-regexp + (if shell-comint-fl-enable + (comint-fl-mode)) + (if shell-highlight-undef-enable + (shell-highlight-undef-mode))) + (setq comint-prompt-regexp shell-prompt-pattern) (shell-completion-vars) (setq-local paragraph-separate "\\'") @@ -604,6 +647,23 @@ command." (setq-local ansi-color-apply-face-function #'shell-apply-ansi-color) (shell-reapply-ansi-color) + (add-hook 'comint-indirect-setup-hook + #'shell-indirect-setup-hook 'append t) + (setq comint-indirect-setup-function + (let ((shell shell--start-prog)) + (lambda () + (require 'sh-script) + (cl-letf + (((default-value 'sh-shell-file) + (or shell sh-shell-file)) + (inhibit-message t) + (message-log-max nil)) + (sh-mode))))) + + (setq-local indent-line-function #'comint-indent-input-line-default) + (setq-local indent-region-function + #'comint-indent-input-region-default) + ;; This is not really correct, since the shell buffer does not really ;; edit this directory. But it is useful in the buffer list and menus. (setq list-buffers-directory (expand-file-name default-directory)) @@ -658,6 +718,10 @@ command." ": [[:digit:]]+:[[:digit:]]+;"))) (comint-read-input-ring t))) +(defun shell-indirect-setup-hook () + "Run `shell-indirect-setup-hook'." + (run-hooks 'shell-indirect-setup-hook)) + (defun shell-apply-ansi-color (beg end face) "Apply FACE as the ansi-color face for the text between BEG and END." (when face @@ -1482,6 +1546,222 @@ Returns t if successful." ;; Remove the prompt. (replace-regexp-in-string "\n.*\\'" "\n" result))) +;;; Highlight undefined commands +;; +;; To highlight non-existent shell commands, customize +;; `shell-highlight-undef-enable' to t. To highlight some shell +;; commands as aliases, add them to `shell-highlight-undef-aliases'. + +(defcustom shell-highlight-undef-aliases nil + "List of shell commands to highlight as a command alias." + :group 'shell + :type '(repeat string) + :version "29.1") + +(defface shell-highlight-undef-defined-face + '((t :inherit 'font-lock-function-name-face)) + "Face used for existing shell commands." + :group 'shell + :version "29.1") + +(defface shell-highlight-undef-undefined-face + '((t :inherit 'font-lock-warning-face)) + "Face used for non-existent shell commands." + :group 'shell + :version "29.1") + +(defface shell-highlight-undef-alias-face + '((t :inherit 'font-lock-variable-name-face)) + "Face used for shell command aliases." + :group 'shell + :version "29.1") + +(defcustom shell-highlight-undef-remote-file-name-inhibit-cache nil + "Whether to inhibit cache for fontifying shell commands in remote buffers. +When fontification of non-existent commands is enabled in a +remote shell buffer, use a cache to speed up searching for +executable files on the remote machine. This options is used to +control expiry of this cache. See `remote-file-name-inhibit-cache' +for description." + :group 'faces + :type '(choice + (const :tag "Do not inhibit file name cache" nil) + (const :tag "Do not use file name cache" t) + (integer :tag "Do not use file name cache" + :format "Do not use file name cache older than %v seconds" + :value 10)) + :version "29.1") + +(defvar shell--highlight-undef-exec-cache nil + "Cache of executable files found in `exec-path'. +An alist, whose elements are of the form +\(REMOTE TIME EXECUTABLES), where REMOTE is a string, returned by +`file-remote-p', TIME is the return value of `float-time', and +EXECUTABLES is a hash table with keys being the base-names of +executable files. + +Cache expiry is controlled by the user option +`remote-file-name-inhibit-cache'.") + +(defvar shell--highlight-undef-face 'shell-highlight-undef-defined-face) + +(defvar shell-highlight-undef-keywords + `((,#'shell-highlight-undef-matcher 6 shell--highlight-undef-face))) + +(defvar-local shell-highlight-undef-regexp regexp-unmatchable) + +(defun shell--highlight-undef-executable-find (command) + "Return non-nil if COMMAND is found in `exec-path'. +Similar to `executable-find', but use cache stored in +`shell--highlight-undef-exec-cache'." + (let ((remote (file-remote-p default-directory)) + as ret found-in-cache delta-time) + (if (null remote) + (executable-find command) + + (setq delta-time + shell-highlight-undef-remote-file-name-inhibit-cache) + + (pcase (setq as (assoc remote shell--highlight-undef-exec-cache)) + (`(,_ ,time ,hash) + (when (pcase delta-time + ((pred numberp) (<= (float-time) (+ time delta-time))) + ('t nil) + ('nil t)) + (setq ret (gethash command hash)) + (setq found-in-cache t))) + (_ (setq as (list remote 0 (make-hash-table :test #'equal))) + (push as shell--highlight-undef-exec-cache))) + + (if found-in-cache + ret + ;; Build cache + (setcar (cdr as) (float-time)) + (let ((hash (clrhash (caddr as)))) + (dolist (dir (exec-path)) + (pcase-dolist (`(,f . ,attr) + (condition-case nil + (directory-files-and-attributes + (concat remote dir) nil nil 'nosort 'integer) + (file-error nil))) + ;; Approximation. Assume every non-directory file in $PATH is an + ;; executable. Alternatively, we could check + ;; `file-executable-p', but doing so for every file in $PATH is + ;; slow on remote machines. + (unless (eq t (file-attribute-type attr)) + (puthash f t hash)))) + (gethash command hash)))))) + +(defun shell-highlight-undef-matcher (end) + "Matcher used to highlight shell commands up to END." + (when (re-search-forward shell-highlight-undef-regexp end t) + (save-match-data + (let ((cmd (match-string 6)) + (beg (match-beginning 6))) + (setq shell--highlight-undef-face + (let* ((buf (buffer-base-buffer)) + (default-directory + (if buf (buffer-local-value 'default-directory buf) + default-directory))) + (cond + ;; Don't highlight command output. Mostly useful if + ;; `comint-fl-mode' is disabled. + ((text-property-any beg (point) 'field 'output) + nil) + ((member cmd shell-highlight-undef-aliases) + 'shell-highlight-undef-alias-face) + ;; Check if it contains a directory separator + ((file-name-directory cmd) + (when (file-name-absolute-p cmd) + (setq cmd (concat + (or (bound-and-true-p comint-file-name-prefix) + (file-remote-p default-directory)) + cmd))) + (if (or (file-executable-p cmd) + (file-directory-p cmd)) + 'shell-highlight-undef-defined-face + 'shell-highlight-undef-undefined-face)) + ((shell--highlight-undef-executable-find cmd) + 'shell-highlight-undef-defined-face) + (t 'shell-highlight-undef-undefined-face)))))) + t)) + +(defvar-local shell--highlight-undef-indirect nil + "Non-nil if shell commands are fontified in `comint-indirect-buffer'.") + +(declare-function sh-feature "sh-script" (alist &optional function)) +(defvar sh-leading-keywords) +(defvar sh-other-keywords) + +(define-minor-mode shell-highlight-undef-mode + "Highlight undefined shell commands and aliases. +This minor mode is mostly useful in `shell-mode' buffers and +works better if `comint-fl-mode' is enabled." + :init-value nil + (if shell--highlight-undef-indirect + (progn + (remove-hook 'comint-indirect-setup-hook shell--highlight-undef-indirect t) + (setq shell--highlight-undef-indirect nil) + (when-let ((buf (comint-indirect-buffer t))) + (with-current-buffer buf + (font-lock-remove-keywords nil shell-highlight-undef-keywords)))) + (font-lock-remove-keywords nil shell-highlight-undef-keywords)) + (remove-hook 'comint-fl-mode-hook + #'shell-highlight-undef-mode-restart t) + + (when shell-highlight-undef-mode + (when comint-use-prompt-regexp + (setq shell-highlight-undef-mode nil) + (error + "`shell-highlight-undef-mode' is incompatible with `comint-use-prompt-regexp'")) + + (require 'sh-script) + + (let* ((regexp + ;; Adapted from `sh-font-lock-keywords-1' + (concat + "\\(" + "[;(){}`|&]" + (if comint-fl-mode + ;; `comint-fl-mode' already puts point-min on end of + ;; prompt + "" + (concat "\\|" comint-prompt-regexp)) + "\\|^" + "\\)" + "[ \t]*\\(\\(" + (regexp-opt (sh-feature sh-leading-keywords) t) + "[ \t]+\\)?" + (regexp-opt (append (sh-feature sh-leading-keywords) + (sh-feature sh-other-keywords)) + t) + "[ \t]+\\)?\\_<\\(\\(?:\\s_\\|\\sw\\|/\\)+\\)\\_>")) + (setup + (lambda () + (setq shell-highlight-undef-regexp regexp) + (font-lock-add-keywords nil shell-highlight-undef-keywords t)))) + (cond (comint-fl-mode + (setq shell--highlight-undef-indirect setup) + (if-let ((buf (comint-indirect-buffer t))) + (with-current-buffer buf + (funcall setup)) + (add-hook 'comint-indirect-setup-hook setup nil t))) + (t (funcall setup)))) + + (add-hook 'comint-fl-mode-hook + #'shell-highlight-undef-mode-restart nil t)) + + (font-lock-flush)) + +(defun shell-highlight-undef-mode-restart () + "If `shell-highlight-undef-mode' is on, restart it. +`shell-highlight-undef-mode' performs its setup differently +depending on `comint-fl-mode'. It's useful to call this function +when switching `comint-fl-mode' in order to make +`shell-highlight-undef-mode' redo its setup." + (when shell-highlight-undef-mode + (shell-highlight-undef-mode 1))) + (provide 'shell) ;;; shell.el ends here diff --git a/lisp/speedbar.el b/lisp/speedbar.el index e74d6fd80a9..515f7d5d750 100644 --- a/lisp/speedbar.el +++ b/lisp/speedbar.el @@ -3509,7 +3509,7 @@ Returns the tag list, or t for an error." (error t))) ) -;;; Tag Management -- etags (old XEmacs compatibility part) +;;; Tag Management -- etags ;; (defvar speedbar-fetch-etags-parse-list '(;; Note that java has the same parse-group as c @@ -3552,10 +3552,7 @@ This variable is ignored if `speedbar-use-imenu-flag' is t." FLAG then becomes a member of etags command line arguments. If flag is \"sort\", then toggle the value of `speedbar-sort-tags'. If its value is \"show\" then toggle the value of -`speedbar-show-unknown-files'. - - This function is a convenience function for XEmacs menu created by -Farzin Guilak <farzin@protocol.com>." +`speedbar-show-unknown-files'." (interactive) (cond ((equal flag "sort") diff --git a/lisp/strokes.el b/lisp/strokes.el index d7a95393166..0edb20c2ebb 100644 --- a/lisp/strokes.el +++ b/lisp/strokes.el @@ -210,9 +210,6 @@ static char * stroke_xpm[] = { :link '(emacs-commentary-link "strokes") :group 'mouse) -(define-obsolete-variable-alias 'strokes-modeline-string 'strokes-lighter - "24.3") - (defcustom strokes-lighter " Strokes" "Mode line identifier for Strokes mode." :type 'string) diff --git a/lisp/subr.el b/lisp/subr.el index e4d32455371..8769fec2b95 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -311,29 +311,13 @@ Then evaluate RESULT to get return value, default nil. (signal 'wrong-type-argument (list 'consp spec))) (unless (<= 2 (length spec) 3) (signal 'wrong-number-of-arguments (list '(2 . 3) (length spec)))) - ;; It would be cleaner to create an uninterned symbol, - ;; but that uses a lot more space when many functions in many files - ;; use dolist. - ;; FIXME: This cost disappears in byte-compiled lexical-binding files. - (let ((temp '--dolist-tail--)) - ;; This test does not matter much because both semantics are acceptable, - ;; but one is slightly faster with dynamic scoping and the other is - ;; slightly faster (and has cleaner semantics) with lexical scoping. - (if lexical-binding - `(let ((,temp ,(nth 1 spec))) - (while ,temp - (let ((,(car spec) (car ,temp))) - ,@body - (setq ,temp (cdr ,temp)))) - ,@(cdr (cdr spec))) - `(let ((,temp ,(nth 1 spec)) - ,(car spec)) - (while ,temp - (setq ,(car spec) (car ,temp)) + (let ((tail (make-symbol "tail"))) + `(let ((,tail ,(nth 1 spec))) + (while ,tail + (let ((,(car spec) (car ,tail))) ,@body - (setq ,temp (cdr ,temp))) - ,@(if (cdr (cdr spec)) - `((setq ,(car spec) nil) ,@(cdr (cdr spec)))))))) + (setq ,tail (cdr ,tail)))) + ,@(cdr (cdr spec))))) (defmacro dotimes (spec &rest body) "Loop a certain number of times. @@ -346,33 +330,19 @@ in compilation warnings about unused variables. \(fn (VAR COUNT [RESULT]) BODY...)" (declare (indent 1) (debug dolist)) - ;; It would be cleaner to create an uninterned symbol, - ;; but that uses a lot more space when many functions in many files - ;; use dotimes. - ;; FIXME: This cost disappears in byte-compiled lexical-binding files. - (let ((temp '--dotimes-limit--) - (start 0) - (end (nth 1 spec))) - ;; This test does not matter much because both semantics are acceptable, - ;; but one is slightly faster with dynamic scoping and the other has - ;; cleaner semantics. - (if lexical-binding - (let ((counter '--dotimes-counter--)) - `(let ((,temp ,end) - (,counter ,start)) - (while (< ,counter ,temp) - (let ((,(car spec) ,counter)) - ,@body) - (setq ,counter (1+ ,counter))) - ,@(if (cddr spec) - ;; FIXME: This let often leads to "unused var" warnings. - `((let ((,(car spec) ,counter)) ,@(cddr spec)))))) - `(let ((,temp ,end) - (,(car spec) ,start)) - (while (< ,(car spec) ,temp) - ,@body - (setq ,(car spec) (1+ ,(car spec)))) - ,@(cdr (cdr spec)))))) + (let ((var (nth 0 spec)) + (end (nth 1 spec)) + (upper-bound (make-symbol "upper-bound")) + (counter (make-symbol "counter"))) + `(let ((,upper-bound ,end) + (,counter 0)) + (while (< ,counter ,upper-bound) + (let ((,var ,counter)) + ,@body) + (setq ,counter (1+ ,counter))) + ,@(if (cddr spec) + ;; FIXME: This let often leads to "unused var" warnings. + `((let ((,var ,counter)) ,@(cddr spec))))))) (defmacro declare (&rest _specs) "Do not evaluate any arguments, and return nil. @@ -1824,8 +1794,6 @@ be a list of the form returned by `event-start' and `event-end'." ;;;; Obsolescent names for functions. -(make-obsolete 'buffer-has-markers-at nil "24.3") - (make-obsolete 'invocation-directory "use the variable of the same name." "27.1") (make-obsolete 'invocation-name "use the variable of the same name." "27.1") @@ -3788,10 +3756,6 @@ This finishes the change group by reverting all of its changes." ;;;; Display-related functions. -;; For compatibility. -(define-obsolete-function-alias 'redraw-modeline - #'force-mode-line-update "24.3") - (defun momentary-string-display (string pos &optional exit-char message) "Momentarily display STRING in the buffer at POS. Display remains until next event is input. @@ -4255,15 +4219,17 @@ Comparisons and replacements are done with fixed case." (error "End after end of buffer")) (setq end (point-max))) (save-excursion - (let ((matches 0) - (case-fold-search nil)) - (goto-char start) - (while (search-forward string end t) - (delete-region (match-beginning 0) (match-end 0)) - (insert replacement) - (setq matches (1+ matches))) - (and (not (zerop matches)) - matches)))) + (goto-char start) + (save-restriction + (narrow-to-region start end) + (let ((matches 0) + (case-fold-search nil)) + (while (search-forward string nil t) + (delete-region (match-beginning 0) (match-end 0)) + (insert replacement) + (setq matches (1+ matches))) + (and (not (zerop matches)) + matches))))) (defun replace-regexp-in-region (regexp replacement &optional start end) "Replace REGEXP with REPLACEMENT in the region from START to END. @@ -4290,14 +4256,16 @@ REPLACEMENT can use the following special elements: (error "End after end of buffer")) (setq end (point-max))) (save-excursion - (let ((matches 0) - (case-fold-search nil)) - (goto-char start) - (while (re-search-forward regexp end t) - (replace-match replacement t) - (setq matches (1+ matches))) - (and (not (zerop matches)) - matches)))) + (goto-char start) + (save-restriction + (narrow-to-region start end) + (let ((matches 0) + (case-fold-search nil)) + (while (re-search-forward regexp nil t) + (replace-match replacement t) + (setq matches (1+ matches))) + (and (not (zerop matches)) + matches))))) (defun yank-handle-font-lock-face-property (face start end) "If `font-lock-defaults' is nil, apply FACE as a `face' property. @@ -4986,10 +4954,6 @@ If `default-directory' is already an existing directory, it's not changed." ;;; Matching and match data. -;; We use save-match-data-internal as the local variable because -;; that works ok in practice (people should not use that variable elsewhere). -;; We used to use an uninterned symbol; the compiler handles that properly -;; now, but it generates slower code. (defmacro save-match-data (&rest body) "Execute the BODY forms, restoring the global value of the match data. The value returned is the value of the last form in BODY. @@ -5001,13 +4965,12 @@ rather than your caller's match data." ;; because that makes a bootstrapping problem ;; if you need to recompile all the Lisp files using interpreted code. (declare (indent 0) (debug t)) - (list 'let - '((save-match-data-internal (match-data))) - (list 'unwind-protect - (cons 'progn body) - ;; It is safe to free (evaporate) markers immediately here, - ;; as Lisp programs should not copy from save-match-data-internal. - '(set-match-data save-match-data-internal 'evaporate)))) + (let ((saved-match-data (make-symbol "saved-match-data"))) + (list 'let + (list (list saved-match-data '(match-data))) + (list 'unwind-protect + (cons 'progn body) + (list 'set-match-data saved-match-data t))))) (defun match-string (num &optional string) "Return the string of text matched by the previous search or regexp operation. @@ -5245,6 +5208,8 @@ Modifies the match data; use `save-match-data' if necessary." (nreverse list))) +(defalias 'string-split #'split-string) + (defun combine-and-quote-strings (strings &optional separator) "Concatenate the STRINGS, adding the SEPARATOR (default \" \"). This tries to quote the strings to avoid ambiguity such that diff --git a/lisp/term.el b/lisp/term.el index 797fb18074f..755c2202703 100644 --- a/lisp/term.el +++ b/lisp/term.el @@ -755,25 +755,8 @@ Buffer local variable.") term-color-bright-cyan term-color-bright-white]) -(defcustom term-default-fg-color nil - "If non-nil, default color for foreground in Term mode." - :group 'term - :type '(choice (const nil) (string :tag "color"))) -(make-obsolete-variable 'term-default-fg-color "use the face `term' instead." - "24.3") - -(defcustom term-default-bg-color nil - "If non-nil, default color for foreground in Term mode." - :group 'term - :type '(choice (const nil) (string :tag "color"))) -(make-obsolete-variable 'term-default-bg-color "use the face `term' instead." - "24.3") - (defface term - `((t - :foreground ,term-default-fg-color - :background ,term-default-bg-color - :inherit default)) + `((t :inherit default)) "Default face to use in Term mode." :group 'term) diff --git a/lisp/textmodes/artist.el b/lisp/textmodes/artist.el index 2cf9ded04bf..76675328daa 100644 --- a/lisp/textmodes/artist.el +++ b/lisp/textmodes/artist.el @@ -5341,8 +5341,6 @@ The event, EV, is the mouse event." (require 'reporter) (if (y-or-n-p "Do you want to submit a bug report on Artist? ") (let ((vars '(window-system - window-system-version - ;; artist-rubber-banding artist-interface-with-rect artist-aspect-ratio diff --git a/lisp/textmodes/emacs-authors-mode.el b/lisp/textmodes/emacs-authors-mode.el index 866822c103d..3eba8e0e456 100644 --- a/lisp/textmodes/emacs-authors-mode.el +++ b/lisp/textmodes/emacs-authors-mode.el @@ -130,7 +130,20 @@ Provides some basic font locking and not much else." '(emacs-authors-mode-font-lock-keywords nil nil ((?_ . "w")))) (setq font-lock-multiline nil) (setq imenu-generic-expression emacs-authors-imenu-generic-expression) - (emacs-etc--hide-local-variables)) + (emacs-etc--hide-local-variables) + (setq-local outline-regexp (rx (+ (not (any ":\n"))) ": " + (or "changed" "co-wrote" "wrote") " ") + outline-minor-mode-cycle t + outline-level + (lambda () + (if (looking-at (rx bol + (or (or " " + (seq "and " (or "co-wrote" + "changed"))) + eol))) + 2 + 1))) + (outline-minor-mode)) (define-obsolete-face-alias 'etc-authors-default 'emacs-authors-default "29.1") (define-obsolete-face-alias 'etc-authors-author 'emacs-authors-author "29.1") diff --git a/lisp/textmodes/reftex-global.el b/lisp/textmodes/reftex-global.el index 062cea9c505..9f308646fc9 100644 --- a/lisp/textmodes/reftex-global.el +++ b/lisp/textmodes/reftex-global.el @@ -276,7 +276,18 @@ one with the `xr' package." ;; to ignore the problematic string. ;; If TEST is nil, it is ignored without query. ;; Return the number of replacements. - (let ((n 0) file label match-data buf macro pos cell) + (let ((n 0) + (opt-re (concat "\\(?:{[^}{]*" + "\\(?:{[^}{]*" + "\\(?:{[^}{]*}[^}{]*\\)*" + "}[^}{]*\\)*" + "}[^][]*\\)*")) + (man-re (concat "\\(?:{[^}{]*" + "\\(?:{[^}{]*" + "\\(?:{[^}{]*}[^}{]*\\)*" + "}[^}{]*\\)*" + "}[^}{]*\\)*")) + file label match-data buf macro pos cell) (while (setq file (pop files)) (setq buf (reftex-get-file-buffer-force file)) (unless buf @@ -301,7 +312,29 @@ one with the `xr' package." (looking-at "\\\\ref[a-zA-Z]*[^a-zA-Z]") (looking-at (format reftex-find-label-regexp-format - (regexp-quote label))))) + (regexp-quote label))) + ;; In case the label-keyval is inside an + ;; optional argument to \begin{env} + (looking-at (concat + "\\\\begin[[:space:]]*{[^}]+}" + "[[:space:]]*" + "\\[[^][]*" + opt-re + (format + reftex-find-label-regexp-format + (regexp-quote label)) + "[^]]*\\]")) + ;; In case the label-keyval is inside the + ;; first mandatory argument to \begin{env} + (looking-at (concat + "\\\\begin[[:space:]]*{[^}]+}" + "[[:space:]]*" + "{[^}{]*" + man-re + (format + reftex-find-label-regexp-format + (regexp-quote label)) + "[^}]*}")))) ;; OK, we should replace it. (set-match-data match-data) (cond diff --git a/lisp/textmodes/rst.el b/lisp/textmodes/rst.el index c0d4dc68afa..7fe46b9628c 100644 --- a/lisp/textmodes/rst.el +++ b/lisp/textmodes/rst.el @@ -3634,19 +3634,6 @@ Region is from BEG to END. With WITH-EMPTY prefix empty lines too." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(dolist (var '(rst-level-face-max rst-level-face-base-color - rst-level-face-base-light - rst-level-face-format-light - rst-level-face-step-light - rst-level-1-face - rst-level-2-face - rst-level-3-face - rst-level-4-face - rst-level-5-face - rst-level-6-face)) - (make-obsolete-variable var "customize the faces `rst-level-*' instead." - "24.3")) - ;; Define faces for the first 6 levels. More levels are possible, however. (defface rst-level-1 '((((background light)) (:background "grey85")) (((background dark)) (:background "grey15"))) diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el index e6c0f8c28c0..f624b604aac 100644 --- a/lisp/textmodes/tex-mode.el +++ b/lisp/textmodes/tex-mode.el @@ -1596,10 +1596,6 @@ Puts point on a blank line between them." ;;;; LaTeX completion. (defvar latex-complete-bibtex-cache nil) - -(define-obsolete-function-alias 'latex-string-prefix-p - #'string-prefix-p "24.3") - (defvar bibtex-reference-key) (declare-function reftex-get-bibfile-list "reftex-cite.el" ()) @@ -2174,8 +2170,6 @@ IN can be either a string (with the same % escapes in it) indicating OUT describes the output file and is either a %-escaped string or nil to indicate that there is no output file.") -(define-obsolete-function-alias 'tex-string-prefix-p #'string-prefix-p "24.3") - (defun tex-guess-main-file (&optional all) "Find a likely `tex-main-file'. Looks for hints in other buffers in the same directory or in diff --git a/lisp/url/url-parse.el b/lisp/url/url-parse.el index 24b064773b8..91f47d0325d 100644 --- a/lisp/url/url-parse.el +++ b/lisp/url/url-parse.el @@ -96,17 +96,6 @@ If the specified port number is the default, return nil." (or file "/") (if frag (concat "#" frag))))) -(defun url-recreate-url-attributes (urlobj) - "Recreate the attributes of an URL string from the parsed URLOBJ." - (declare (obsolete nil "24.3")) - (when (url-attributes urlobj) - (concat ";" - (mapconcat (lambda (x) - (if (cdr x) - (concat (car x) "=" (cdr x)) - (car x))) - (url-attributes urlobj) ";")))) - ;;;###autoload (defun url-generic-parse-url (url) "Return an URL-struct of the parts of URL. diff --git a/lisp/vc/add-log.el b/lisp/vc/add-log.el index d710578ffff..d617d5aebb2 100644 --- a/lisp/vc/add-log.el +++ b/lisp/vc/add-log.el @@ -208,8 +208,6 @@ a case simply use the directory containing the changed file." '((t (:inherit font-lock-comment-face))) "Face for highlighting acknowledgments." :version "21.1") -(define-obsolete-face-alias 'change-log-acknowledgement - 'change-log-acknowledgment "24.3") (defconst change-log-file-names-re "^\\( +\\|\t\\)\\* \\([^ ,:([\n]+\\)") (defconst change-log-start-entry-re "^\\sw.........[0-9:+ ]*") diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index a01943437c1..a9591c9d82e 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -279,20 +279,21 @@ and hunk-based syntax highlighting otherwise as a fallback." :doc "Keymap for `diff-minor-mode'. See also `diff-mode-shared-map'." (key-description diff-minor-mode-prefix) diff-mode-shared-map) -(define-minor-mode diff-auto-refine-mode - "Toggle automatic diff hunk finer highlighting (Diff Auto Refine mode). +(with-suppressed-warnings ((obsolete diff-auto-refine-mode)) + (define-minor-mode diff-auto-refine-mode + "Toggle automatic diff hunk finer highlighting (Diff Auto Refine mode). Diff Auto Refine mode is a buffer-local minor mode used with `diff-mode'. When enabled, Emacs automatically highlights changes in detail as the user visits hunks. When transitioning from disabled to enabled, it tries to refine the current hunk, as well." - :group 'diff-mode :init-value nil :lighter nil ;; " Auto-Refine" - (if diff-auto-refine-mode - (progn - (customize-set-variable 'diff-refine 'navigation) - (condition-case-unless-debug nil (diff-refine-hunk) (error nil))) - (customize-set-variable 'diff-refine nil))) + :group 'diff-mode :init-value nil :lighter nil ;; " Auto-Refine" + (if diff-auto-refine-mode + (progn + (customize-set-variable 'diff-refine 'navigation) + (condition-case-unless-debug nil (diff-refine-hunk) (error nil))) + (customize-set-variable 'diff-refine nil)))) (make-obsolete 'diff-auto-refine-mode "set `diff-refine' instead." "27.1") (make-obsolete-variable 'diff-auto-refine-mode "set `diff-refine' instead." "27.1") @@ -2336,10 +2337,22 @@ Call FUN with two args (BEG and END) for each hunk." (let ((inhibit-read-only t)) (undo arg))) +;;;###autoload +(defcustom diff-add-log-use-relative-names nil + "Use relative file names when generating ChangeLog skeletons. +The files will be relative to the root directory of the VC +repository. This option affects the behavior of +`diff-add-log-current-defuns'." + :type 'boolean + :safe #'booleanp + :version "29.1") + (defun diff-add-log-current-defuns () "Return an alist of defun names for the current diff. The elements of the alist are of the form (FILE . (DEFUN...)), -where DEFUN... is a list of function names found in FILE." +where DEFUN... is a list of function names found in FILE. If +`diff-add-log-use-relative-names' is non-nil, file names in the alist +are relative to the root directory of the VC repository." (save-excursion (goto-char (point-min)) (let* ((defuns nil) @@ -2373,7 +2386,12 @@ where DEFUN... is a list of function names found in FILE." ;; hunks (e.g., "diff --git ..." etc). (re-search-forward diff-hunk-header-re nil t) (setq hunk-end (save-excursion (diff-end-of-hunk))) - (pcase-let* ((filename (substring-no-properties (diff-find-file-name))) + (pcase-let* ((filename (substring-no-properties + (if diff-add-log-use-relative-names + (file-relative-name + (diff-find-file-name) + (vc-root-dir)) + (diff-find-file-name)))) (=lines 0) (+lines 0) (-lines 0) diff --git a/lisp/vc/ediff-wind.el b/lisp/vc/ediff-wind.el index d45e13ea725..bd2e9f19773 100644 --- a/lisp/vc/ediff-wind.el +++ b/lisp/vc/ediff-wind.el @@ -36,14 +36,6 @@ :group 'ediff :group 'frames) - -;; Determine which window setup function to use based on current window system. -(defun ediff-choose-window-setup-function-automatically () - (declare (obsolete ediff-setup-windows-default "24.3")) - (if (display-graphic-p) - #'ediff-setup-windows-multiframe - #'ediff-setup-windows-plain)) - (defcustom ediff-window-setup-function #'ediff-setup-windows-default "Function called to set up windows. Ediff provides a choice of three functions: diff --git a/lisp/vc/pcvs-util.el b/lisp/vc/pcvs-util.el index 89f8d26880b..ddc3ea6e810 100644 --- a/lisp/vc/pcvs-util.el +++ b/lisp/vc/pcvs-util.el @@ -164,8 +164,6 @@ arguments. If ARGS is not a list, no argument will be passed." (if oneline (line-end-position) (point-max)))) (file-error nil))) -(define-obsolete-function-alias 'cvs-string-prefix-p #'string-prefix-p "24.3") - ;;;; ;;;; file names ;;;; diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el index 068a66b25b8..b4568727ea0 100644 --- a/lisp/vc/vc-dir.el +++ b/lisp/vc/vc-dir.el @@ -356,10 +356,10 @@ See `run-hooks'." (define-key map "G" #'vc-dir-ignore) (let ((branch-map (make-sparse-keymap))) - (define-key map "B" branch-map) - (define-key branch-map "c" #'vc-create-tag) + (define-key map "b" branch-map) + (define-key branch-map "c" #'vc-create-branch) (define-key branch-map "l" #'vc-print-branch-log) - (define-key branch-map "s" #'vc-retrieve-tag)) + (define-key branch-map "s" #'vc-switch-branch)) (let ((mark-map (make-sparse-keymap))) (define-key map "*" mark-map) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 9dfdd9e7b13..8d8ea33f8b3 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -82,7 +82,7 @@ ;; - annotate-time () OK ;; - annotate-current-time () NOT NEEDED ;; - annotate-extract-revision-at-line () OK -;; TAG SYSTEM +;; TAG/BRANCH SYSTEM ;; - create-tag (dir name branchp) OK ;; - retrieve-tag (dir name update) OK ;; MISCELLANEOUS @@ -119,6 +119,14 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches." (repeat :tag "Argument List" :value ("") string)) :version "23.1") +;;;###autoload +(defun vc-git-annotate-switches-safe-p (switches) + "Check if local value of `vc-git-annotate-switches' is safe. +Currently only \"-w\" (ignore whitespace) is considered safe, but +this list might be extended in the future." + ;; TODO: Probably most options are perfectly safe. + (equal switches "-w")) + (defcustom vc-git-annotate-switches nil "String or list of strings specifying switches for Git blame under VC. If nil, use the value of `vc-annotate-switches'. If t, use no switches." @@ -127,6 +135,7 @@ If nil, use the value of `vc-annotate-switches'. If t, use no switches." (string :tag "Argument String") (repeat :tag "Argument List" :value ("") string)) :version "25.1") +;;;###autoload(put 'vc-git-annotate-switches 'safe-local-variable #'vc-git-annotate-switches-safe-p) (defcustom vc-git-log-switches nil "String or list of strings specifying switches for Git log under VC." @@ -1563,13 +1572,25 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"." (expand-file-name fname (vc-git-root default-directory)))) revision))))) -;;; TAG SYSTEM +;;; TAG/BRANCH SYSTEM + +(declare-function vc-read-revision "vc" + (prompt &optional files backend default initial-input)) (defun vc-git-create-tag (dir name branchp) - (let ((default-directory dir)) - (and (vc-git-command nil 0 nil "update-index" "--refresh") + (let ((default-directory dir) + (start-point (when branchp (vc-read-revision + (format-prompt "Start point" + (car (vc-git-branches))) + (list dir) 'Git)))) + (and (or (zerop (vc-git-command nil t nil "update-index" "--refresh")) + (y-or-n-p "Modified files exist. Proceed? ") + (user-error (format "Can't create %s with modified files" + (if branchp "branch" "tag")))) (if branchp - (vc-git-command nil 0 nil "checkout" "-b" name) + (vc-git-command nil 0 nil "checkout" "-b" name + (when (and start-point (not (eq start-point ""))) + start-point)) (vc-git-command nil 0 nil "tag" name))))) (defun vc-git-retrieve-tag (dir name _update) diff --git a/lisp/vc/vc-hooks.el b/lisp/vc/vc-hooks.el index 1f0eeb7e18a..7f0d9e4d862 100644 --- a/lisp/vc/vc-hooks.el +++ b/lisp/vc/vc-hooks.el @@ -857,6 +857,9 @@ In the latter case, VC mode is deactivated for this buffer." ;; (autoload 'vc-prefix-map "vc" nil nil 'keymap) (defvar-keymap vc-prefix-map "a" #'vc-update-change-log + "b c" #'vc-create-branch + "b l" #'vc-print-branch-log + "b s" #'vc-switch-branch "d" #'vc-dir "g" #'vc-annotate "G" #'vc-ignore @@ -883,9 +886,6 @@ In the latter case, VC mode is deactivated for this buffer." (fset 'vc-prefix-map vc-prefix-map) (define-key ctl-x-map "v" 'vc-prefix-map) -(with-suppressed-warnings ((obsolete vc-switch-backend)) - (keymap-set vc-prefix-map "b" #'vc-switch-backend)) - (defvar vc-menu-map (let ((map (make-sparse-keymap "Version Control"))) ;;(define-key map [show-files] diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index d93be951a3c..39a5be6654b 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -449,7 +449,7 @@ ;; ;; Return the common ancestor between REV1 and REV2 revisions. -;; TAG SYSTEM +;; TAG/BRANCH SYSTEM ;; ;; - create-tag (dir name branchp) ;; @@ -464,8 +464,9 @@ ;; - retrieve-tag (dir name update) ;; ;; Retrieve the version tagged by NAME of all registered files at or below DIR. +;; If NAME is a branch name, switch to that branch. ;; If UPDATE is non-nil, then update buffers of any files in the -;; tag that are currently visited. The default implementation +;; tag/branch that are currently visited. The default implementation ;; does a sanity check whether there aren't any uncommitted changes at ;; or below DIR, and then performs a tree walk, using the `checkout' ;; function to retrieve the corresponding revisions. @@ -664,8 +665,6 @@ ;; display the branch name in the mode-line. Replace ;; vc-cvs-sticky-tag with that. ;; -;; - Add a primitives for switching to a branch (creating it if required. -;; ;; - Add the ability to list tags and branches. ;; ;;;; Unify two different versions of the amend capability @@ -1050,7 +1049,8 @@ Within directories, only files already under version control are noticed." ((derived-mode-p 'log-edit-mode) log-edit-vc-backend) ((derived-mode-p 'diff-mode) diff-vc-backend) ;; Maybe we could even use comint-mode rather than shell-mode? - ((derived-mode-p 'dired-mode 'shell-mode 'compilation-mode) + ((derived-mode-p + 'dired-mode 'shell-mode 'eshell-mode 'compilation-mode) (ignore-errors (vc-responsible-backend default-directory))) (vc-mode (vc-backend buffer-file-name)))) @@ -1807,7 +1807,8 @@ in the output buffer." (setq buffer-read-only t) (diff-mode) (setq-local diff-vc-backend (vc-responsible-backend default-directory)) - (setq-local revert-buffer-function (lambda (_ _) (vc-diff-patch-string))) + (setq-local revert-buffer-function + (lambda (_ _) (vc-diff-patch-string patch-string))) (setq-local vc-patch-string patch-string) (pop-to-buffer (current-buffer)) (vc-run-delayed (vc-diff-finish (current-buffer) nil)))) @@ -2431,7 +2432,23 @@ checked out in that new branch." (message "Making %s... done" (if branchp "branch" "tag"))) ;;;###autoload -(defun vc-retrieve-tag (dir name) +(defun vc-create-branch (dir name) + "Descending recursively from DIR, make a branch called NAME. +After a new branch is made, the files are checked out in that new branch. +Uses `vc-create-tag' with the non-nil arg `branchp'." + (interactive + (let ((granularity + (vc-call-backend (vc-responsible-backend default-directory) + 'revision-granularity))) + (list + (if (eq granularity 'repository) + default-directory + (read-directory-name "Directory: " default-directory default-directory t)) + (read-string "New branch name: " nil 'vc-revision-history)))) + (vc-create-tag dir name t)) + +;;;###autoload +(defun vc-retrieve-tag (dir name &optional branchp) "For each file in or below DIR, retrieve their tagged version NAME. NAME can name a branch, in which case this command will switch to the named branch in the directory DIR. @@ -2441,6 +2458,8 @@ If NAME is empty, it refers to the latest revisions of the current branch. If locking is used for the files in DIR, then there must not be any locked files at or below DIR (but if NAME is empty, locked files are allowed and simply skipped). +If the prefix argument BRANCHP is given, switch the branch +and check out the files in that branch. This function runs the hook `vc-retrieve-tag-hook' when finished." (interactive (let* ((granularity @@ -2456,15 +2475,21 @@ This function runs the hook `vc-retrieve-tag-hook' when finished." (read-directory-name "Directory: " default-directory nil t)))) (list dir - (vc-read-revision (format-prompt "Tag name to retrieve" "latest revisions") + (vc-read-revision (format-prompt + (if current-prefix-arg + "Switch to branch" + "Tag name to retrieve") + "latest revisions") (list dir) - (vc-responsible-backend dir))))) + (vc-responsible-backend dir)) + current-prefix-arg))) (let* ((backend (vc-responsible-backend dir)) (update (when (vc-call-backend backend 'update-on-retrieve-tag) (yes-or-no-p "Update any affected buffers? "))) (msg (if (or (not name) (string= name "")) (format "Updating %s... " (abbreviate-file-name dir)) - (format "Retrieving tag %s into %s... " + (format "Retrieving %s %s into %s... " + (if branchp "branch" "tag") name (abbreviate-file-name dir))))) (message "%s" msg) (vc-call-backend backend 'retrieve-tag dir name update) @@ -2472,6 +2497,25 @@ This function runs the hook `vc-retrieve-tag-hook' when finished." (run-hooks 'vc-retrieve-tag-hook) (message "%s" (concat msg "done")))) +;;;###autoload +(defun vc-switch-branch (dir name) + "Switch to the branch NAME in the directory DIR. +If NAME is empty, it refers to the latest revisions of the current branch. +Uses `vc-retrieve-tag' with the non-nil arg `branchp'." + (interactive + (let* ((granularity + (vc-call-backend (vc-responsible-backend default-directory) + 'revision-granularity)) + (dir + (if (eq granularity 'repository) + (expand-file-name (vc-root-dir)) + (read-directory-name "Directory: " default-directory nil t)))) + (list + dir + (vc-read-revision (format-prompt "Switch to branch" "latest revisions") + (list dir) + (vc-responsible-backend dir))))) + (vc-retrieve-tag dir name t)) ;; Miscellaneous other entry points @@ -2697,8 +2741,10 @@ with its diffs (if the underlying VCS supports that)." (defun vc-print-branch-log (branch) "Show the change log for BRANCH root in a window." (interactive - (list - (vc-read-revision "Branch to log: "))) + (let* ((backend (vc-responsible-backend default-directory)) + (rootdir (vc-call-backend backend 'root default-directory))) + (list + (vc-read-revision "Branch to log: " (list rootdir) backend)))) (when (equal branch "") (error "No branch specified")) (let* ((backend (vc-responsible-backend default-directory)) @@ -3273,8 +3319,6 @@ to provide the `find-revision' operation instead." ;; These things should probably be generally available -(define-obsolete-function-alias 'vc-string-prefix-p 'string-prefix-p "24.3") - (defun vc-file-tree-walk (dirname func &rest args) "Walk recursively through DIRNAME. Invoke FUNC f ARGS on each VC-managed file f underneath it." diff --git a/lisp/wdired.el b/lisp/wdired.el index 33e0b96f0f5..6904bac4d0e 100644 --- a/lisp/wdired.el +++ b/lisp/wdired.el @@ -1024,7 +1024,8 @@ Like original function but it skips read-only words." (setq filename (wdired-get-filename nil t)) (if (= (length perms-new) 10) (condition-case nil - (set-file-modes filename (wdired-perms-to-number perms-new)) + (set-file-modes filename (wdired-perms-to-number perms-new) + 'nofollow) (error (setq errors (1+ errors)) (dired-log "Setting mode of `%s' to `%s' failed\n\n" diff --git a/lisp/whitespace.el b/lisp/whitespace.el index 41b0a34f9ea..ae4d8ae3f06 100644 --- a/lisp/whitespace.el +++ b/lisp/whitespace.el @@ -730,7 +730,7 @@ Used when `whitespace-style' includes `indentation', :group 'whitespace) -(defcustom whitespace-empty-at-bob-regexp "\\`\\(\\([ \t]*\n\\)+\\)" +(defcustom whitespace-empty-at-bob-regexp "\\`\\([ \t\n]*\\(?:\n\\|$\\)\\)" "Specify regexp for empty lines at beginning of buffer. Used when `whitespace-style' includes `empty'." @@ -1129,28 +1129,33 @@ SYMBOL is a valid symbol associated with CHAR. See `whitespace-style-value-list'.") -(defvar whitespace-active-style nil +(defvar-local whitespace-active-style nil "Used to save locally `whitespace-style' value.") -(defvar whitespace-point (point) +(defvar-local whitespace-point (point) "Used to save locally current point value. Used by function `whitespace-trailing-regexp' (which see).") (defvar-local whitespace-point--used nil "Region whose highlighting depends on `whitespace-point'.") -(defvar whitespace-font-lock-refontify nil - "Used to save locally the font-lock refontify state. -Used by function `whitespace-post-command-hook' (which see).") - -(defvar whitespace-bob-marker nil - "Used to save locally the bob marker value. -Used by function `whitespace-post-command-hook' (which see).") - -(defvar whitespace-eob-marker nil - "Used to save locally the eob marker value. -Used by function `whitespace-post-command-hook' (which see).") - -(defvar whitespace-buffer-changed nil +(defvar-local whitespace-bob-marker nil + "Position of the buffer's first non-empty line. +This marker is positioned at the beginning of the first line in +the buffer that contains a non-space character. If no such line +exists, this is positioned at the end of the buffer (which could +be after `whitespace-eob-marker' if the buffer contains nothing +but empty lines).") + +(defvar-local whitespace-eob-marker nil + "Position after the buffer's last non-empty line. +This marker is positioned at the beginning of the first line +immediately following the last line in the buffer that contains a +non-space character. If no such line exists, this is positioned +at the beginning of the buffer (which could be before +`whitespace-bob-marker' if the buffer contains nothing but empty +lines).") + +(defvar-local whitespace-buffer-changed nil "Used to indicate locally if buffer changed. Used by `whitespace-post-command-hook' and `whitespace-buffer-changed' functions (which see).") @@ -1770,7 +1775,7 @@ cleaning up these problems." ;;;; Internal functions -(defvar whitespace-font-lock-keywords nil +(defvar-local whitespace-font-lock-keywords nil "Used to save the value `whitespace-color-on' adds to `font-lock-keywords'.") @@ -1997,10 +2002,10 @@ resultant list will be returned." the-list) -(defvar whitespace-display-table nil +(defvar-local whitespace-display-table nil "Used to save a local display table.") -(defvar whitespace-display-table-was-local nil +(defvar-local whitespace-display-table-was-local nil "Used to remember whether a buffer initially had a local display table.") (defun whitespace-turn-on () @@ -2061,12 +2066,16 @@ resultant list will be returned." (setq whitespace-point--used (let ((ol (make-overlay (point) (point) nil nil t))) (delete-overlay ol) ol)) - (setq-local whitespace-font-lock-refontify 0) (setq-local whitespace-bob-marker (point-min-marker)) (setq-local whitespace-eob-marker (point-max-marker)) + (whitespace--update-bob-eob) (setq-local whitespace-buffer-changed nil) (add-hook 'post-command-hook #'whitespace-post-command-hook nil t) (add-hook 'before-change-functions #'whitespace-buffer-changed nil t) + (add-hook 'after-change-functions #'whitespace--update-bob-eob + ;; The -1 ensures that it runs before any + ;; `font-lock-mode' hook functions. + -1 t) ;; Add whitespace-mode color into font lock. (setq whitespace-font-lock-keywords @@ -2119,11 +2128,11 @@ resultant list will be returned." `((,whitespace-big-indent-regexp 1 'whitespace-big-indent t))) ,@(when (memq 'empty whitespace-active-style) ;; Show empty lines at beginning of buffer. - `((,#'whitespace-empty-at-bob-regexp - 1 whitespace-empty t) + `((,#'whitespace--empty-at-bob-matcher + 0 whitespace-empty t) ;; Show empty lines at end of buffer. - (,#'whitespace-empty-at-eob-regexp - 1 whitespace-empty t))) + (,#'whitespace--empty-at-eob-matcher + 0 whitespace-empty t))) ,@(when (or (memq 'space-after-tab whitespace-active-style) (memq 'space-after-tab::tab whitespace-active-style) (memq 'space-after-tab::space whitespace-active-style)) @@ -2158,6 +2167,8 @@ resultant list will be returned." (when (whitespace-style-face-p) (remove-hook 'post-command-hook #'whitespace-post-command-hook t) (remove-hook 'before-change-functions #'whitespace-buffer-changed t) + (remove-hook 'after-change-functions #'whitespace--update-bob-eob + t) (font-lock-remove-keywords nil whitespace-font-lock-keywords) (font-lock-flush))) @@ -2206,114 +2217,83 @@ resultant list will be returned." (format ".\\{%d\\}" rem))))) limit t)) -(defun whitespace-empty-at-bob-regexp (limit) - "Match spaces at beginning of buffer (BOB) which do not contain point at BOB." - (let ((b (point)) - r) - (cond - ;; at bob - ((= b 1) - (setq r (and (looking-at whitespace-empty-at-bob-regexp) - (or (/= whitespace-point 1) - (progn (whitespace-point--used (match-beginning 0) - (match-end 0)) - nil)))) - (set-marker whitespace-bob-marker (if r (match-end 1) b))) - ;; inside bob empty region - ((<= limit whitespace-bob-marker) - (setq r (looking-at whitespace-empty-at-bob-regexp)) - (if r - (when (< (match-end 1) limit) - (set-marker whitespace-bob-marker (match-end 1))) - (set-marker whitespace-bob-marker b))) - ;; intersection with end of bob empty region - ((<= b whitespace-bob-marker) - (setq r (looking-at whitespace-empty-at-bob-regexp)) - (set-marker whitespace-bob-marker (if r (match-end 1) b))) - ;; it is not inside bob empty region - (t - (setq r nil))) - ;; move to end of matching - (and r (goto-char (match-end 1))) - r)) - - -(defsubst whitespace-looking-back (regexp limit) +(defun whitespace--empty-at-bob-matcher (limit) + "Match empty/space-only lines at beginning of buffer (BoB). +Match does not extend past position LIMIT. For improved UX, the +line containing `whitespace-point' and subsequent lines are +excluded from the match. (The idea is that the user might be +about to start typing, and if they do, that line and any +following empty lines will no longer be BoB empty lines. +Highlighting those lines can be distracting.)" + (let ((p (point)) + (e (min whitespace-bob-marker limit + ;; EoB marker will be before BoB marker if the buffer + ;; has nothing but empty lines. + whitespace-eob-marker + (save-excursion (goto-char whitespace-point) + (line-beginning-position))))) + (when (= p 1) + ;; See the comment in `whitespace--update-bob-eob' for why this + ;; text property is added here. + (put-text-property 1 whitespace-bob-marker + 'font-lock-multiline t)) + (when (< p e) + (set-match-data (list p e)) + (goto-char e)))) + +(defsubst whitespace--looking-back (regexp) (save-excursion - (when (/= 0 (skip-chars-backward " \t\n" limit)) + (when (/= 0 (skip-chars-backward " \t\n")) (unless (bolp) (forward-line 1)) (looking-at regexp)))) - -(defun whitespace-empty-at-eob-regexp (limit) - "Match spaces at end of buffer which do not contain the point at end of \ -buffer." - (let ((b (point)) - (e (1+ (buffer-size))) - r) - (cond - ;; at eob - ((= limit e) - (goto-char limit) - (setq r (whitespace-looking-back whitespace-empty-at-eob-regexp b)) - (when (and r (= whitespace-point e)) - (setq r nil) - (whitespace-point--used (match-beginning 0) (match-end 0))) - (if r - (set-marker whitespace-eob-marker (match-beginning 1)) - (set-marker whitespace-eob-marker limit) - (goto-char b))) ; return back to initial position - ;; inside eob empty region - ((>= b whitespace-eob-marker) - (goto-char limit) - (setq r (whitespace-looking-back whitespace-empty-at-eob-regexp b)) - (if r - (when (> (match-beginning 1) b) - (set-marker whitespace-eob-marker (match-beginning 1))) - (set-marker whitespace-eob-marker limit) - (goto-char b))) ; return back to initial position - ;; intersection with beginning of eob empty region - ((>= limit whitespace-eob-marker) - (goto-char limit) - (setq r (whitespace-looking-back whitespace-empty-at-eob-regexp b)) - (if r - (set-marker whitespace-eob-marker (match-beginning 1)) - (set-marker whitespace-eob-marker limit) - (goto-char b))) ; return back to initial position - ;; it is not inside eob empty region - (t - (setq r nil))) - r)) - +(defun whitespace--empty-at-eob-matcher (limit) + "Match empty/space-only lines at end of buffer (EoB). +Match does not extend past position LIMIT. For improved UX, the +line containing `whitespace-point' and preceding lines are +excluded from the match. (The idea is that the user might be +about to start typing, and if they do, that line and previous +empty lines will no longer be EoB empty lines. Highlighting +those lines can be distracting.)" + (when (= limit (1+ (buffer-size))) + ;; See the comment in `whitespace--update-bob-eob' for why this + ;; text property is added here. + (put-text-property whitespace-eob-marker limit + 'font-lock-multiline t)) + (let ((b (max (point) whitespace-eob-marker + whitespace-bob-marker ; See comment in the bob func. + (save-excursion (goto-char whitespace-point) + (forward-line 1) + (point))))) + (when (< b limit) + (set-match-data (list b limit)) + (goto-char limit)))) (defun whitespace-buffer-changed (_beg _end) "Set `whitespace-buffer-changed' variable to t." (setq whitespace-buffer-changed t)) - (defun whitespace-post-command-hook () "Save current point into `whitespace-point' variable. Also refontify when necessary." (unless (and (eq whitespace-point (point)) (not whitespace-buffer-changed)) + (when (and (not whitespace-buffer-changed) + (memq 'empty whitespace-active-style)) + ;; No need to handle the `whitespace-buffer-changed' case here + ;; because that is taken care of by the `font-lock-multiline' + ;; text property. + (when (<= (min (point) whitespace-point) whitespace-bob-marker) + (font-lock-flush 1 whitespace-bob-marker)) + (when (>= (max (point) whitespace-point) whitespace-eob-marker) + (font-lock-flush whitespace-eob-marker (1+ (buffer-size))))) + (setq-local whitespace-buffer-changed nil) (setq whitespace-point (point)) ; current point position - (let ((refontify - (cond - ;; It is at end of buffer (eob). - ((= whitespace-point (1+ (buffer-size))) - (when (whitespace-looking-back whitespace-empty-at-eob-regexp - nil) - (match-beginning 0))) - ;; It is at end of line ... - ((and (eolp) - ;; ... with trailing SPACE or TAB - (or (memq (preceding-char) '(?\s ?\t)))) - (line-beginning-position)) - ;; It is at beginning of buffer (bob). - ((and (= whitespace-point 1) - (looking-at whitespace-empty-at-bob-regexp)) - (match-end 0)))) + (let ((refontify (and (eolp) ; It is at end of line ... + ;; ... with trailing SPACE or TAB + (or (memq (preceding-char) '(?\s ?\t))) + (line-beginning-position))) (ostart (overlay-start whitespace-point--used))) (cond ((not refontify) @@ -2367,6 +2347,77 @@ to `indent-tabs-mode' and `tab-width'." (when whitespace-mode (font-lock-flush))))) +(defun whitespace--update-bob-eob (&optional beg end &rest _) + "Update `whitespace-bob-marker' and `whitespace-eob-marker'. +Also apply `font-lock-multiline' text property. If BEG and END +are non-nil, assume that only characters in that range have +changed since the last call to this function (for optimization +purposes)." + (when (memq 'empty whitespace-active-style) + ;; When a line is changed, `font-lock-mode' normally limits + ;; re-processing to only the changed line. That behavior is + ;; problematic for highlighting `empty' lines because adding or + ;; deleting a character might affect lines before or after the + ;; change. To address this, all `empty' lines are marked with a + ;; non-nil `font-lock-multiline' text property. This forces + ;; `font-lock-mode' to re-process all of the lines whenever + ;; there's an edit within any one of them. + ;; + ;; The text property must be set on `empty' lines twice per + ;; relevant change: + ;; + ;; 1. Before the change. This is necessary to ensure that + ;; previously highlighted lines become un-highlighted if + ;; necessary. The text property must be added after the + ;; previous `font-lock-mode' run (the run in reaction to the + ;; previous change) because `font-lock-mode' clears the text + ;; property when it runs. + ;; + ;; 2. After the change, but before `font-lock-mode' reacts to + ;; the change. This is necessary to ensure that new `empty' + ;; lines become highlighted. + ;; + ;; This hook function is responsible for #2, while the + ;; `whitespace--empty-at-bob-matcher' and + ;; `whitespace--empty-at-eob-matcher' functions are responsible + ;; for #1. (Those functions run after `font-lock-mode' clears the + ;; text property and before the next change.) + (save-excursion + (save-restriction + (widen) + (when (or (null beg) + (<= beg (save-excursion + (goto-char whitespace-bob-marker) + ;; Any change in the first non-`empty' + ;; line, even if it's not the first + ;; character in the line, can potentially + ;; cause subsequent lines to become + ;; classified as `empty' (e.g., delete the + ;; "x" from " x"). + (forward-line 1) + (point)))) + (goto-char 1) + (set-marker whitespace-bob-marker (point)) + (save-match-data + (when (looking-at whitespace-empty-at-bob-regexp) + (set-marker whitespace-bob-marker (match-end 1)) + (put-text-property (match-beginning 1) (match-end 1) + 'font-lock-multiline t)))) + (when (or (null end) + (>= end (save-excursion + (goto-char whitespace-eob-marker) + ;; See above comment for the BoB case. + (forward-line -1) + (point)))) + (goto-char (1+ (buffer-size))) + (set-marker whitespace-eob-marker (point)) + (save-match-data + (when (whitespace--looking-back + whitespace-empty-at-eob-regexp) + (set-marker whitespace-eob-marker (match-beginning 1)) + (put-text-property (match-beginning 1) (match-end 1) + 'font-lock-multiline t)))))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Hacked from visws.el (Miles Bader <miles@gnu.org>) diff --git a/lisp/window.el b/lisp/window.el index 9ff55dc9807..d5f42dd10b4 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -6622,24 +6622,6 @@ fourth element is BUFFER." window 'quit-restore (list 'tab 'tab (selected-window) buffer))))) -(defcustom display-buffer-function nil - "If non-nil, function to call to handle `display-buffer'. -It will receive two args, the buffer and a flag which if non-nil -means that the currently selected window is not acceptable. It -should choose or create a window, display the specified buffer in -it, and return the window. - -The specified function should call `display-buffer-record-window' -with corresponding arguments to set up the quit-restore parameter -of the window used." - :type '(choice - (const nil) - (function :tag "function")) - :group 'windows) - -(make-obsolete-variable 'display-buffer-function - 'display-buffer-alist "24.3") - (defcustom pop-up-frame-alist nil "Alist of parameters for automatically generated new frames. If non-nil, the value you specify here is used by the default @@ -7745,38 +7727,34 @@ specified by the ACTION argument." ;; Handle the old form of the first argument. (inhibit-same-window (and action (not (listp action))))) (unless (listp action) (setq action nil)) - (if display-buffer-function - ;; If `display-buffer-function' is defined, let it do the job. - (funcall display-buffer-function buffer inhibit-same-window) - ;; Otherwise, use the defined actions. - (let* ((user-action - (display-buffer-assq-regexp - buffer display-buffer-alist action)) - (special-action (display-buffer--special-action buffer)) - ;; Extra actions from the arguments to this function: - (extra-action - (cons nil (append (if inhibit-same-window - '((inhibit-same-window . t))) - (if frame - `((reusable-frames . ,frame)))))) - ;; Construct action function list and action alist. - (actions (list display-buffer-overriding-action - user-action special-action action extra-action - display-buffer-base-action - display-buffer-fallback-action)) - (functions (apply 'append - (mapcar (lambda (x) - (setq x (car x)) - (if (functionp x) (list x) x)) - actions))) - (alist (apply 'append (mapcar 'cdr actions))) - window) - (unless (buffer-live-p buffer) - (error "Invalid buffer")) - (while (and functions (not window)) - (setq window (funcall (car functions) buffer alist) - functions (cdr functions))) - (and (windowp window) window))))) + (let* ((user-action + (display-buffer-assq-regexp + buffer display-buffer-alist action)) + (special-action (display-buffer--special-action buffer)) + ;; Extra actions from the arguments to this function: + (extra-action + (cons nil (append (if inhibit-same-window + '((inhibit-same-window . t))) + (if frame + `((reusable-frames . ,frame)))))) + ;; Construct action function list and action alist. + (actions (list display-buffer-overriding-action + user-action special-action action extra-action + display-buffer-base-action + display-buffer-fallback-action)) + (functions (apply 'append + (mapcar (lambda (x) + (setq x (car x)) + (if (functionp x) (list x) x)) + actions))) + (alist (apply 'append (mapcar 'cdr actions))) + window) + (unless (buffer-live-p buffer) + (error "Invalid buffer")) + (while (and functions (not window)) + (setq window (funcall (car functions) buffer alist) + functions (cdr functions))) + (and (windowp window) window)))) (defun display-buffer-other-frame (buffer) "Display buffer BUFFER preferably in another frame. @@ -10580,8 +10558,6 @@ displaying that processes's buffer." (define-key ctl-x-map "{" 'shrink-window-horizontally) (define-key ctl-x-map "-" 'shrink-window-if-larger-than-buffer) (define-key ctl-x-map "+" 'balance-windows) -(define-key ctl-x-map "7" 'split-root-window-below) -(define-key ctl-x-map "9" 'split-root-window-right) (define-key ctl-x-4-map "0" 'kill-buffer-and-window) (define-key ctl-x-4-map "1" 'same-window-prefix) (define-key ctl-x-4-map "4" 'other-window-prefix) @@ -10612,6 +10588,16 @@ displaying that processes's buffer." (put 'shrink-window-horizontally 'repeat-map 'resize-window-repeat-map) (put 'shrink-window 'repeat-map 'resize-window-repeat-map) +(defvar-keymap window-prefix-map + :doc "Keymap for subcommands of \\`C-x w'." + "2" #'split-root-window-below + "3" #'split-root-window-right + "s" #'window-toggle-side-windows + "f" #'tear-off-window + "-" #'fit-window-to-buffer + "0" #'delete-windows-on) +(define-key ctl-x-map "w" window-prefix-map) + (provide 'window) ;;; window.el ends here diff --git a/lisp/winner.el b/lisp/winner.el index 89f337170cc..4290f1fd239 100644 --- a/lisp/winner.el +++ b/lisp/winner.el @@ -318,9 +318,6 @@ You may want to include buffer names such as *Help*, *Apropos*, "Functions to run whenever Winner mode is turned on or off." :type 'hook) -(define-obsolete-variable-alias 'winner-mode-leave-hook - 'winner-mode-off-hook "24.3") - (defcustom winner-mode-off-hook nil "Functions to run whenever Winner mode is turned off." :type 'hook) diff --git a/src/alloc.c b/src/alloc.c index 34bedac36ba..419c5e558b4 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -5368,7 +5368,7 @@ void check_pure_size (void) { if (pure_bytes_used_before_overflow) - message (("emacs:0:Pure Lisp storage overflow (approx. %"pI"d" + message (("emacs:0:Pure Lisp storage overflow (approx. %jd" " bytes needed)"), pure_bytes_used + pure_bytes_used_before_overflow); } diff --git a/src/dispnew.c b/src/dispnew.c index 53a47c4b2f2..8932f103f1f 100644 --- a/src/dispnew.c +++ b/src/dispnew.c @@ -6504,9 +6504,6 @@ init_display_interactive (void) if (!inhibit_window_system && display_arg) { Vinitial_window_system = Qx; -#ifdef HAVE_X11 - Vwindow_system_version = make_fixnum (11); -#endif #ifdef USE_NCURSES /* In some versions of ncurses, tputs crashes if we have not called tgetent. @@ -6521,7 +6518,6 @@ init_display_interactive (void) if (!inhibit_window_system) { Vinitial_window_system = Qw32; - Vwindow_system_version = make_fixnum (1); return; } #endif /* HAVE_NTGUI */ @@ -6530,7 +6526,6 @@ init_display_interactive (void) if (!inhibit_window_system && !will_dump_p ()) { Vinitial_window_system = Qns; - Vwindow_system_version = make_fixnum (10); return; } #endif @@ -6539,7 +6534,6 @@ init_display_interactive (void) if (!inhibit_window_system && !will_dump_p ()) { Vinitial_window_system = Qpgtk; - Vwindow_system_version = make_fixnum (3); return; } #endif @@ -6548,7 +6542,6 @@ init_display_interactive (void) if (!inhibit_window_system && !will_dump_p ()) { Vinitial_window_system = Qhaiku; - Vwindow_system_version = make_fixnum (1); return; } #endif @@ -6766,10 +6759,6 @@ Use of this variable as a boolean is deprecated. Instead, use `display-graphic-p' or any of the other `display-*-p' predicates which report frame's specific UI-related capabilities. */); - DEFVAR_LISP ("window-system-version", Vwindow_system_version, - doc: /* The version number of the window system in use. -For X windows, this is 11. */); - DEFVAR_BOOL ("cursor-in-echo-area", cursor_in_echo_area, doc: /* Non-nil means put cursor in minibuffer, at end of any message there. */); @@ -6817,5 +6806,4 @@ static void syms_of_display_for_pdumper (void) { Vinitial_window_system = Qnil; - Vwindow_system_version = Qnil; } diff --git a/src/doc.c b/src/doc.c index 34b80d03aa9..d98d121ebd5 100644 --- a/src/doc.c +++ b/src/doc.c @@ -643,7 +643,14 @@ default_to_grave_quoting_style (void) DEFUN ("text-quoting-style", Ftext_quoting_style, Stext_quoting_style, 0, 0, 0, doc: /* Return the current effective text quoting style. -See variable `text-quoting-style'. */) +If the variable `text-quoting-style' is `grave', `straight' or +`curve', just return that value. If it is nil (the default), return +`grave' if curved quotes cannot be displayed (for instance, on a +terminal with no support for these characters), otherwise return +`quote'. Any other value is treated as `grave'. + +Note that in contrast to the variable `text-quoting-style', this +function will never return nil. */) (void) { /* Use grave accent and apostrophe `like this'. */ @@ -694,7 +701,11 @@ The value should be one of these symbols: `grave': quote with grave accent and apostrophe \\=`like this\\='; i.e., do not alter the original quote marks. nil: like `curve' if curved single quotes are displayable, - and like `grave' otherwise. This is the default. */); + and like `grave' otherwise. This is the default. + +You should never read the value of this variable directly from a Lisp +program. Use the function `text-quoting-style' instead, as that will +compute the correct value for the current terminal in the nil case. */); Vtext_quoting_style = Qnil; DEFVAR_BOOL ("internal--text-quoting-flag", text_quoting_flag, diff --git a/src/editfns.c b/src/editfns.c index cd5cddee79f..b774e79337f 100644 --- a/src/editfns.c +++ b/src/editfns.c @@ -4603,10 +4603,7 @@ it to be non-nil. */); DEFSYM (Qrestrictions_locked, "restrictions-locked"); DEFVAR_LISP ("restrictions-locked", Vrestrictions_locked, - doc: /* If non-nil, restrictions are currently locked. - -This happens when `narrow-to-region', which see, is called from Lisp -with an optional argument LOCK non-nil. */); + doc: /* If non-nil, restrictions are currently locked. */); Vrestrictions_locked = Qnil; Funintern (Qrestrictions_locked, Qnil); diff --git a/src/image.c b/src/image.c index f5004c2c4c7..549fe30ef7c 100644 --- a/src/image.c +++ b/src/image.c @@ -1,6 +1,6 @@ /* Functions for image support on window system. -Copyright (C) 1989, 1992-2022 Free Software Foundation, Inc. +Copyright (C) 1989-2022 Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -11491,7 +11491,7 @@ svg_load_image (struct frame *f, struct image *img, char *contents, if (!image_create_x_image_and_pixmap (f, img, width, height, 0, &ximg, 0)) { g_object_unref (pixbuf); - return 0; + return false; } init_color_table (); @@ -11536,7 +11536,7 @@ svg_load_image (struct frame *f, struct image *img, char *contents, image_put_x_image (f, img, ximg, 0); } - return 1; + return true; rsvg_error: if (rsvg_handle) @@ -11547,11 +11547,11 @@ svg_load_image (struct frame *f, struct image *img, char *contents, if (css && !STRINGP (lcss)) xfree (css); #endif - /* FIXME: Use error->message so the user knows what is the actual - problem with the image. */ - image_error ("Error parsing SVG image"); + image_error ("Error parsing SVG image: %s", + /* The -1 removes an extra newline. */ + make_string (err->message, strlen (err->message) - 1)); g_clear_error (&err); - return 0; + return false; } #endif /* defined (HAVE_RSVG) */ diff --git a/src/keyboard.c b/src/keyboard.c index 77280d08c5b..ca51c80da04 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -1880,13 +1880,22 @@ safe_run_hooks_error (Lisp_Object error, ptrdiff_t nargs, Lisp_Object *args) static Lisp_Object safe_run_hook_funcall (ptrdiff_t nargs, Lisp_Object *args) { - eassert (nargs >= 2); /* We need to swap args[0] and args[1] here or in `safe_run_hooks_1`. It's more convenient to do it here. */ + eassert (nargs >= 2); Lisp_Object fun = args[0], hook = args[1]; - args[0] = hook, args[1] = fun; - internal_condition_case_n (safe_run_hooks_1, nargs, args, + /* The `nargs` array cannot be mutated safely here because it is + reused by our caller `run_hook_with_args`. + We could arguably change it temporarily if we set it back + to its original state before returning, but it's too ugly. */ + USE_SAFE_ALLOCA; + Lisp_Object *newargs; + SAFE_ALLOCA_LISP (newargs, nargs); + newargs[0] = hook, newargs[1] = fun; + memcpy (newargs + 2, args + 2, (nargs - 2) * word_size); + internal_condition_case_n (safe_run_hooks_1, nargs, newargs, Qt, safe_run_hooks_error); + SAFE_FREE (); return Qnil; } diff --git a/src/marker.c b/src/marker.c index 9727586f424..0ed1e55ddc9 100644 --- a/src/marker.c +++ b/src/marker.c @@ -759,23 +759,6 @@ If TYPE is nil, it means the marker stays behind when you insert text at it. */ return type; } -DEFUN ("buffer-has-markers-at", Fbuffer_has_markers_at, Sbuffer_has_markers_at, - 1, 1, 0, - doc: /* Return t if there are markers pointing at POSITION in the current buffer. */) - (Lisp_Object position) -{ - register struct Lisp_Marker *tail; - register ptrdiff_t charpos; - - charpos = clip_to_bounds (BEG, XFIXNUM (position), Z); - - for (tail = BUF_MARKERS (current_buffer); tail; tail = tail->next) - if (tail->charpos == charpos) - return Qt; - - return Qnil; -} - #ifdef MARKER_DEBUG /* For debugging -- count the markers in buffer BUF. */ @@ -821,5 +804,4 @@ syms_of_marker (void) defsubr (&Scopy_marker); defsubr (&Smarker_insertion_type); defsubr (&Sset_marker_insertion_type); - defsubr (&Sbuffer_has_markers_at); } diff --git a/src/msdos.c b/src/msdos.c index 1608245904c..1d3fdd528d7 100644 --- a/src/msdos.c +++ b/src/msdos.c @@ -1794,7 +1794,6 @@ internal_terminal_init (void) } Vinitial_window_system = Qpc; - Vwindow_system_version = make_fixnum (29); /* RE Emacs version */ tty->terminal->type = output_msdos_raw; /* If Emacs was dumped on DOS/V machine, forget the stale VRAM diff --git a/src/nsfont.m b/src/nsfont.m index b54118afe5d..d072b5ce779 100644 --- a/src/nsfont.m +++ b/src/nsfont.m @@ -324,106 +324,98 @@ ns_get_family (Lisp_Object font_spec) static NSFontDescriptor * ns_spec_to_descriptor (Lisp_Object font_spec) { - NSFontDescriptor *fdesc; - NSMutableDictionary *fdAttrs = [NSMutableDictionary new]; - NSString *family = ns_get_family (font_spec); - NSMutableDictionary *tdict = [NSMutableDictionary new]; + NSFontDescriptor *fdesc; + NSMutableDictionary *fdAttrs = [NSMutableDictionary new]; + NSString *family = ns_get_family (font_spec); + NSMutableDictionary *tdict = [NSMutableDictionary new]; - Lisp_Object tem; + Lisp_Object tem; - tem = FONT_SLANT_SYMBOLIC (font_spec); - if (!NILP (tem)) - { - if (EQ (tem, Qitalic) || EQ (tem, Qoblique)) - [tdict setObject: [NSNumber numberWithFloat: 1.0] - forKey: NSFontSlantTrait]; - else if (EQ (tem, intern ("reverse-italic")) || - EQ (tem, intern ("reverse-oblique"))) - [tdict setObject: [NSNumber numberWithFloat: -1.0] - forKey: NSFontSlantTrait]; - else - [tdict setObject: [NSNumber numberWithFloat: 0.0] - forKey: NSFontSlantTrait]; - } + tem = FONT_SLANT_SYMBOLIC (font_spec); + if (!NILP (tem)) + { + if (EQ (tem, Qitalic) || EQ (tem, Qoblique)) + [tdict setObject: [NSNumber numberWithFloat: 1.0] + forKey: NSFontSlantTrait]; + else if (EQ (tem, intern ("reverse-italic")) + || EQ (tem, intern ("reverse-oblique"))) + [tdict setObject: [NSNumber numberWithFloat: -1.0] + forKey: NSFontSlantTrait]; + else + [tdict setObject: [NSNumber numberWithFloat: 0.0] + forKey: NSFontSlantTrait]; + } - tem = FONT_WIDTH_SYMBOLIC (font_spec); - if (!NILP (tem)) - { - if (EQ (tem, Qcondensed)) - [tdict setObject: [NSNumber numberWithFloat: -1.0] - forKey: NSFontWidthTrait]; - else if (EQ (tem, Qexpanded)) - [tdict setObject: [NSNumber numberWithFloat: 1.0] - forKey: NSFontWidthTrait]; - else - [tdict setObject: [NSNumber numberWithFloat: 0.0] - forKey: NSFontWidthTrait]; - } + tem = FONT_WIDTH_SYMBOLIC (font_spec); + if (!NILP (tem)) + { + if (EQ (tem, Qcondensed)) + [tdict setObject: [NSNumber numberWithFloat: -1.0] + forKey: NSFontWidthTrait]; + else if (EQ (tem, Qexpanded)) + [tdict setObject: [NSNumber numberWithFloat: 1.0] + forKey: NSFontWidthTrait]; + else + [tdict setObject: [NSNumber numberWithFloat: 0.0] + forKey: NSFontWidthTrait]; + } - tem = FONT_WEIGHT_SYMBOLIC (font_spec); + tem = FONT_WEIGHT_SYMBOLIC (font_spec); - if (!NILP (tem)) - { - if (EQ (tem, Qbold)) - { - [tdict setObject: [NSNumber numberWithFloat: 1.0] - forKey: NSFontWeightTrait]; - } - else if (EQ (tem, Qlight)) - { - [tdict setObject: [NSNumber numberWithFloat: -1.0] - forKey: NSFontWeightTrait]; - } - else - { - [tdict setObject: [NSNumber numberWithFloat: 0.0] - forKey: NSFontWeightTrait]; - } - } + if (!NILP (tem)) + { + if (EQ (tem, Qbold)) + { + [tdict setObject: [NSNumber numberWithFloat: 1.0] + forKey: NSFontWeightTrait]; + } + else if (EQ (tem, Qlight)) + { + [tdict setObject: [NSNumber numberWithFloat: -1.0] + forKey: NSFontWeightTrait]; + } + else + { + [tdict setObject: [NSNumber numberWithFloat: 0.0] + forKey: NSFontWeightTrait]; + } + } - tem = AREF (font_spec, FONT_SPACING_INDEX); + tem = AREF (font_spec, FONT_SPACING_INDEX); - if (family != nil) - { - [fdAttrs setObject: family - forKey: NSFontFamilyAttribute]; - } + if (family != nil) + [fdAttrs setObject: family + forKey: NSFontFamilyAttribute]; - if (FIXNUMP (tem)) - { - if (XFIXNUM (tem) != FONT_SPACING_PROPORTIONAL) - { - [fdAttrs setObject: [NSNumber numberWithBool:YES] - forKey: NSFontFixedAdvanceAttribute]; - } - else - { - [fdAttrs setObject: [NSNumber numberWithBool:NO] - forKey: NSFontFixedAdvanceAttribute]; - } - } + if (FIXNUMP (tem)) + { + if (XFIXNUM (tem) != FONT_SPACING_PROPORTIONAL) + [fdAttrs setObject: [NSNumber numberWithBool: YES] + forKey: NSFontFixedAdvanceAttribute]; + else + [fdAttrs setObject: [NSNumber numberWithBool: NO] + forKey: NSFontFixedAdvanceAttribute]; + } - /* Handle special families such as ``fixed'' or ``Sans Serif''. */ + /* Handle special families such as ``fixed'', ``monospace'' or + ``Sans Serif''. */ - if ([family isEqualToString: @"fixed"]) - { - [fdAttrs setObject: [[NSFont userFixedPitchFontOfSize: 0] familyName] - forKey: NSFontFamilyAttribute]; - } - else if ([family isEqualToString: @"Sans Serif"]) - { - [fdAttrs setObject: [[NSFont userFontOfSize: 0] familyName] - forKey: NSFontFamilyAttribute]; - } + if ([family isEqualToString: @"fixed"] + || [family isEqualToString: @"monospace"]) + [fdAttrs setObject: [[NSFont userFixedPitchFontOfSize: 0] familyName] + forKey: NSFontFamilyAttribute]; + else if ([family isEqualToString: @"Sans Serif"]) + [fdAttrs setObject: [[NSFont userFontOfSize: 0] familyName] + forKey: NSFontFamilyAttribute]; - [fdAttrs setObject: tdict forKey: NSFontTraitsAttribute]; + [fdAttrs setObject: tdict forKey: NSFontTraitsAttribute]; - fdesc = [[[NSFontDescriptor fontDescriptorWithFontAttributes: fdAttrs] - retain] autorelease]; + fdesc = [[[NSFontDescriptor fontDescriptorWithFontAttributes: fdAttrs] + retain] autorelease]; - [tdict release]; - [fdAttrs release]; - return fdesc; + [tdict release]; + [fdAttrs release]; + return fdesc; } @@ -477,7 +469,7 @@ ns_descriptor_to_entity (NSFontDescriptor *desc, ASET (font_entity, FONT_SIZE_INDEX, make_fixnum (0)); ASET (font_entity, FONT_AVGWIDTH_INDEX, make_fixnum (0)); ASET (font_entity, FONT_SPACING_INDEX, - make_fixnum ((data.specified & GS_SPECIFIED_WIDTH && data.monospace_p) + make_fixnum ((data.specified & GS_SPECIFIED_SPACING && data.monospace_p) ? FONT_SPACING_MONO : FONT_SPACING_PROPORTIONAL)); ASET (font_entity, FONT_EXTRA_INDEX, extra); @@ -792,53 +784,53 @@ static NSSet static Lisp_Object ns_findfonts (Lisp_Object font_spec, BOOL isMatch) { - Lisp_Object tem, list = Qnil; - NSFontDescriptor *fdesc; - NSArray *all_descs; - GSFontEnumerator *enumerator = [GSFontEnumerator sharedEnumerator]; + Lisp_Object tem, list = Qnil; + NSFontDescriptor *fdesc; + NSArray *all_descs; + GSFontEnumerator *enumerator = [GSFontEnumerator sharedEnumerator]; - NSSet *cFamilies; + NSSet *cFamilies; - block_input (); - if (NSFONT_TRACE) - { - fprintf (stderr, "nsfont: %s for fontspec:\n ", - (isMatch ? "match" : "list")); - debug_print (font_spec); - } + block_input (); + if (NSFONT_TRACE) + { + fprintf (stderr, "nsfont: %s for fontspec:\n ", + (isMatch ? "match" : "list")); + debug_print (font_spec); + } - cFamilies = ns_get_covering_families (ns_get_req_script (font_spec), 0.90); + cFamilies = ns_get_covering_families (ns_get_req_script (font_spec), 0.90); - fdesc = ns_spec_to_descriptor (font_spec); - all_descs = [enumerator availableFontDescriptors]; + fdesc = ns_spec_to_descriptor (font_spec); + all_descs = [enumerator availableFontDescriptors]; - for (NSFontDescriptor *desc in all_descs) - { - if (![cFamilies containsObject: - [desc objectForKey: NSFontFamilyAttribute]]) - continue; - if (!ns_font_descs_match_p (fdesc, desc)) - continue; - - tem = ns_descriptor_to_entity (desc, - AREF (font_spec, FONT_EXTRA_INDEX), - NULL); - if (isMatch) - return tem; - list = Fcons (tem, list); - } + for (NSFontDescriptor *desc in all_descs) + { + if (![cFamilies containsObject: + [desc objectForKey: NSFontFamilyAttribute]]) + continue; + if (!ns_font_descs_match_p (fdesc, desc)) + continue; + + tem = ns_descriptor_to_entity (desc, + AREF (font_spec, FONT_EXTRA_INDEX), + NULL); + if (isMatch) + return tem; + list = Fcons (tem, list); + } - unblock_input (); + unblock_input (); - /* Return something if was a match and nothing found. */ - if (isMatch) - return ns_fallback_entity (); + /* Return something if was a match and nothing found. */ + if (isMatch) + return ns_fallback_entity (); - if (NSFONT_TRACE) - fprintf (stderr, " Returning %"pD"d entities.\n", - list_length (list)); + if (NSFONT_TRACE) + fprintf (stderr, " Returning %"pD"d entities.\n", + list_length (list)); - return list; + return list; } diff --git a/src/nsterm.m b/src/nsterm.m index 6c6151701b8..b8b4e66cd11 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -5607,17 +5607,6 @@ ns_term_init (Lisp_Object display_name) NSTRACE_MSG ("Versions"); - { -#ifdef NS_IMPL_GNUSTEP - Vwindow_system_version = build_string (gnustep_base_version); -#else - /* PSnextrelease (128, c); */ - char c[DBL_BUFSIZE_BOUND]; - int len = dtoastr (c, sizeof c, 0, 0, NSAppKitVersionNumber); - Vwindow_system_version = make_unibyte_string (c, len); -#endif - } - delete_keyboard_wait_descriptor (0); ns_app_name = [[NSProcessInfo processInfo] processName]; @@ -7912,22 +7901,28 @@ ns_create_font_panel_buttons (id target, SEL select, SEL cancel_action) NSRect r = [win frame]; NSArray *screens = [NSScreen screens]; NSScreen *screen = [screens objectAtIndex: 0]; + struct input_event ie; NSTRACE ("[EmacsView windowDidMove:]"); if (!emacsframe->output_data.ns) return; + if (screen != nil) { - emacsframe->left_pos = NSMinX (r) - NS_PARENT_WINDOW_LEFT_POS (emacsframe); - emacsframe->top_pos = NS_PARENT_WINDOW_TOP_POS (emacsframe) - NSMaxY (r); + emacsframe->left_pos = (NSMinX (r) + - NS_PARENT_WINDOW_LEFT_POS (emacsframe)); + emacsframe->top_pos = (NS_PARENT_WINDOW_TOP_POS (emacsframe) + - NSMaxY (r)); - // FIXME: after event part below didExitFullScreen is not received - // if (emacs_event) - // { - // emacs_event->kind = MOVE_FRAME_EVENT; - // EV_TRAILER ((id)nil); - // } + if (emacs_event) + { + ie.kind = MOVE_FRAME_EVENT; + XSETFRAME (ie.frame_or_window, emacsframe); + XSETINT (ie.x, emacsframe->left_pos); + XSETINT (ie.y, emacsframe->top_pos); + kbd_buffer_store_event (&ie); + } } } diff --git a/src/pgtkfns.c b/src/pgtkfns.c index beaf28f69d9..9473e14f5cf 100644 --- a/src/pgtkfns.c +++ b/src/pgtkfns.c @@ -164,8 +164,6 @@ pgtk_display_info_for_name (Lisp_Object name) if (dpyinfo == 0) error ("Cannot connect to display server %s", SDATA (name)); - XSETFASTINT (Vwindow_system_version, 11); - return dpyinfo; } diff --git a/src/process.c b/src/process.c index 7a133cda00f..358899cdede 100644 --- a/src/process.c +++ b/src/process.c @@ -7391,7 +7391,8 @@ child_signal_notify (void) } /* LIB_CHILD_HANDLER is a SIGCHLD handler that Emacs calls while doing - its own SIGCHLD handling. On POSIXish systems, glib needs this to + its own SIGCHLD handling. On POSIXish systems lacking + pidfd_open+waitid or using Glib 2.73.1-, Glib needs this to keep track of its own children. GNUstep is similar. */ static void dummy_handler (int sig) {} @@ -8358,7 +8359,7 @@ DEFUN ("signal-names", Fsignal_names, Ssignal_names, 0, 0, 0, #ifdef subprocesses /* Arrange to catch SIGCHLD if this hasn't already been arranged. - Invoke this after init_process_emacs, and after glib and/or GNUstep + Invoke this after init_process_emacs, and after Glib and/or GNUstep futz with the SIGCHLD handler, but before Emacs forks any children. This function's caller should block SIGCHLD. */ @@ -8423,26 +8424,35 @@ init_process_emacs (int sockfd) if (!will_dump_with_unexec_p ()) { #if defined HAVE_GLIB && !defined WINDOWSNT - /* Tickle glib's child-handling code. Ask glib to install a + /* Tickle Glib's child-handling code. Ask Glib to install a watch source for Emacs itself which will initialize glib's private SIGCHLD handler, allowing catch_child_signal to copy - it into lib_child_handler. + it into lib_child_handler. This is a hacky workaround to get + glib's g_unix_signal_handler into lib_child_handler. - Unfortunately in glib commit 2e471acf, the behavior changed to + In Glib 2.37.5 (2013), commit 2e471acf changed Glib to always install a signal handler when g_child_watch_source_new - is called and not just the first time it's called. Glib also - now resets signal handlers to SIG_DFL when it no longer has a - watcher on that signal. This is a hackey work around to get - glib's g_unix_signal_handler into lib_child_handler. */ + is called and not just the first time it's called, and to + reset signal handlers to SIG_DFL when it no longer has a + watcher on that signal. Arrange for Emacs's signal handler + to be reinstalled even if this happens. + + In Glib 2.73.2 (2022), commit f615eef4 changed Glib again, + to not install a signal handler if the system supports + pidfd_open and waitid (as in Linux kernel 5.3+). The hacky + workaround is not needed in this case. */ GSource *source = g_child_watch_source_new (getpid ()); catch_child_signal (); g_source_unref (source); - eassert (lib_child_handler != dummy_handler); - signal_handler_t lib_child_handler_glib = lib_child_handler; - catch_child_signal (); - eassert (lib_child_handler == dummy_handler); - lib_child_handler = lib_child_handler_glib; + if (lib_child_handler != dummy_handler) + { + /* The hacky workaround is needed on this platform. */ + signal_handler_t lib_child_handler_glib = lib_child_handler; + catch_child_signal (); + eassert (lib_child_handler == dummy_handler); + lib_child_handler = lib_child_handler_glib; + } #else catch_child_signal (); #endif diff --git a/src/w32.c b/src/w32.c index 44c279602cf..9c7d536adad 100644 --- a/src/w32.c +++ b/src/w32.c @@ -6480,6 +6480,17 @@ chase_symlinks (const char *file) return target; } +/* Return non-zero if FILE's filesystem supports symlinks. */ +bool +symlinks_supported (const char *file) +{ + if (is_windows_9x () != TRUE + && get_volume_info (file, NULL) + && (volume_info.flags & FILE_SUPPORTS_REPARSE_POINTS) != 0) + return true; + return false; +} + /* Posix ACL emulation. */ diff --git a/src/w32.h b/src/w32.h index dc91c595c43..b914aa9bafa 100644 --- a/src/w32.h +++ b/src/w32.h @@ -228,6 +228,8 @@ extern int sys_link (const char *, const char *); extern int openat (int, const char *, int, int); extern int fchmodat (int, char const *, mode_t, int); extern int lchmod (char const *, mode_t); +extern bool symlinks_supported (const char *); + /* Return total and free memory info. */ extern int w32_memory_info (unsigned long long *, unsigned long long *, diff --git a/src/w32fns.c b/src/w32fns.c index 28d13a68d45..745458d0a03 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -6699,8 +6699,6 @@ w32_display_info_for_name (Lisp_Object name) if (dpyinfo == 0) error ("Cannot connect to server %s", SDATA (name)); - XSETFASTINT (Vwindow_system_version, w32_major_version); - return dpyinfo; } @@ -6781,7 +6779,6 @@ DEFUN ("x-open-connection", Fx_open_connection, Sx_open_connection, error ("Cannot connect to server %s", SDATA (display)); } - XSETFASTINT (Vwindow_system_version, w32_major_version); return Qnil; } diff --git a/src/w32image.c b/src/w32image.c index da748b8dab4..af10d2bd265 100644 --- a/src/w32image.c +++ b/src/w32image.c @@ -256,7 +256,7 @@ w32_can_use_native_image_api (Lisp_Object type) || EQ (type, Qbmp) || EQ (type, Qnative_image))) { - /* GDI+ can also display BMP, Exif, ICON, WMF, and EMF images. + /* GDI+ can also display Exif, ICON, WMF, and EMF images. But we don't yet support these in image.c. */ return false; } diff --git a/src/w32notify.c b/src/w32notify.c index 72e634f77c7..6b5fce9f927 100644 --- a/src/w32notify.c +++ b/src/w32notify.c @@ -367,6 +367,12 @@ add_watch (const char *parent_dir, const char *file, BOOL subdirs, DWORD flags) if (!file) return NULL; + /* Do not follow symlinks, so that the caller could watch symlink + files. */ + DWORD crflags = FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OVERLAPPED; + if (symlinks_supported (parent_dir)) + crflags |= FILE_FLAG_OPEN_REPARSE_POINT; + if (w32_unicode_filenames) { wchar_t dir_w[MAX_PATH], file_w[MAX_PATH]; @@ -383,8 +389,7 @@ add_watch (const char *parent_dir, const char *file, BOOL subdirs, DWORD flags) processes from deleting files inside parent_dir. */ FILE_SHARE_READ|FILE_SHARE_WRITE|FILE_SHARE_DELETE, - NULL, OPEN_EXISTING, - FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OVERLAPPED, + NULL, OPEN_EXISTING, crflags, NULL); } else @@ -400,8 +405,7 @@ add_watch (const char *parent_dir, const char *file, BOOL subdirs, DWORD flags) hdir = CreateFileA (dir_a, FILE_LIST_DIRECTORY, FILE_SHARE_READ|FILE_SHARE_WRITE|FILE_SHARE_DELETE, - NULL, OPEN_EXISTING, - FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OVERLAPPED, + NULL, OPEN_EXISTING, crflags, NULL); } if (hdir == INVALID_HANDLE_VALUE) diff --git a/src/xfns.c b/src/xfns.c index 2da1e7bcf80..ecb869bf360 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -2423,14 +2423,33 @@ x_set_use_frame_synchronization (struct frame *f, Lisp_Object arg, { #if defined HAVE_XSYNC && !defined USE_GTK && defined HAVE_CLOCK_GETTIME struct x_display_info *dpyinfo; + unsigned long bypass_compositor; dpyinfo = FRAME_DISPLAY_INFO (f); if (!NILP (arg) && FRAME_X_EXTENDED_COUNTER (f)) - FRAME_X_OUTPUT (f)->use_vsync_p - = x_wm_supports (f, dpyinfo->Xatom_net_wm_frame_drawn); + { + FRAME_X_OUTPUT (f)->use_vsync_p + = x_wm_supports (f, dpyinfo->Xatom_net_wm_frame_drawn); + + /* At the same time, write the bypass compositor property to the + outer window. 2 means to never bypass the compositor, as we + need its cooperation for frame synchronization. */ + bypass_compositor = 2; + XChangeProperty (dpyinfo->display, FRAME_OUTER_WINDOW (f), + dpyinfo->Xatom_net_wm_bypass_compositor, + XA_CARDINAL, 32, PropModeReplace, + (unsigned char *) &bypass_compositor, 1); + } else - FRAME_X_OUTPUT (f)->use_vsync_p = false; + { + FRAME_X_OUTPUT (f)->use_vsync_p = false; + + /* Remove the compositor bypass property from the outer + window. */ + XDeleteProperty (dpyinfo->display, FRAME_OUTER_WINDOW (f), + dpyinfo->Xatom_net_wm_bypass_compositor); + } store_frame_param (f, Quse_frame_synchronization, FRAME_X_OUTPUT (f)->use_vsync_p ? Qt : Qnil); @@ -7231,8 +7250,6 @@ x_display_info_for_name (Lisp_Object name) if (dpyinfo == 0) error ("Cannot connect to X server %s", SDATA (name)); - XSETFASTINT (Vwindow_system_version, 11); - return dpyinfo; } @@ -7276,7 +7293,6 @@ An insecure way to solve the problem may be to use `xhost'.\n", error ("Cannot connect to X server %s", SDATA (display)); } - XSETFASTINT (Vwindow_system_version, 11); return Qnil; } diff --git a/src/xrdb.c b/src/xrdb.c index faeea04a539..01c9ff5558a 100644 --- a/src/xrdb.c +++ b/src/xrdb.c @@ -511,107 +511,3 @@ x_get_string_resource (void *v_rdb, const char *name, const char *class) return NULL; } - -/* Stand-alone test facilities. */ - -#ifdef TESTRM - -typedef char **List; -#define arg_listify(len, list) (list) -#define car(list) (*(list)) -#define cdr(list) (list + 1) -#define NIL(list) (! *(list)) -#define free_arglist(list) - -static List -member (char *elt, List list) -{ - List p; - - for (p = list; ! NIL (p); p = cdr (p)) - if (! strcmp (elt, car (p))) - return p; - - return p; -} - -static void -fatal (char *msg, char *prog) -{ - fprintf (stderr, msg, prog); - exit (1); -} - -int -main (int argc, char **argv) -{ - Display *display; - char *displayname, *resource_string, *class, *name; - XrmDatabase xdb; - List arg_list, lp; - - arg_list = arg_listify (argc, argv); - - lp = member ("-d", arg_list); - if (!NIL (lp)) - displayname = car (cdr (lp)); - else - displayname = "localhost:0.0"; - - lp = member ("-xrm", arg_list); - resource_string = NIL (lp) ? 0 : car (cdr (lp)); - - lp = member ("-c", arg_list); - if (! NIL (lp)) - class = car (cdr (lp)); - else - class = "Emacs"; - - lp = member ("-n", arg_list); - if (! NIL (lp)) - name = car (cdr (lp)); - else - name = "emacs"; - - free_arglist (arg_list); - - if (!(display = XOpenDisplay (displayname))) - fatal ("Can't open display '%s'\n", XDisplayName (displayname)); - - xdb = x_load_resources (display, resource_string, name, class); - - /* In a real program, you'd want to also do this: */ - display->db = xdb; - - while (true) - { - char query_name[90]; - char query_class[90]; - - printf ("Name: "); - gets (query_name); - - if (strlen (query_name)) - { - char *value; - - printf ("Class: "); - gets (query_class); - - value = x_get_string_resource (&xdb, query_name, query_class); - - if (value != NULL) - printf ("\t%s(%s): %s\n\n", query_name, query_class, value); - else - printf ("\tNo Value.\n\n"); - } - else - break; - } - printf ("\tExit.\n\n"); - - XCloseDisplay (display); - - return 0; -} -#endif /* TESTRM */ diff --git a/src/xterm.c b/src/xterm.c index c58f2d15da2..48502f12d8d 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -998,6 +998,7 @@ static const struct x_atom_ref x_atom_refs[] = ATOM_REFS_INIT ("_NET_WM_SYNC_REQUEST", Xatom_net_wm_sync_request) ATOM_REFS_INIT ("_NET_WM_SYNC_REQUEST_COUNTER", Xatom_net_wm_sync_request_counter) ATOM_REFS_INIT ("_NET_WM_SYNC_FENCES", Xatom_net_wm_sync_fences) + ATOM_REFS_INIT ("_NET_WM_BYPASS_COMPOSITOR", Xatom_net_wm_bypass_compositor) ATOM_REFS_INIT ("_NET_WM_FRAME_DRAWN", Xatom_net_wm_frame_drawn) ATOM_REFS_INIT ("_NET_WM_FRAME_TIMINGS", Xatom_net_wm_frame_timings) ATOM_REFS_INIT ("_NET_WM_USER_TIME", Xatom_net_wm_user_time) @@ -1970,6 +1971,10 @@ xm_get_drag_window_1 (struct x_display_info *dpyinfo) && tmp_data) { drag_window = *(Window *) tmp_data; + + /* This has the side effect of selecting for + StructureNotifyMask, meaning that we will get notifications + once it is deleted. */ rc = x_special_window_exists_p (dpyinfo, drag_window); if (!rc) @@ -3977,12 +3982,10 @@ x_dnd_do_unsupported_drop (struct x_display_info *dpyinfo, x_ignore_errors_for_next_request (dpyinfo); XSendEvent (dpyinfo->display, child, True, ButtonPressMask, &event); - x_stop_ignoring_errors (dpyinfo); event.xbutton.type = ButtonRelease; event.xbutton.time = before + 2; - x_ignore_errors_for_next_request (dpyinfo); XSendEvent (dpyinfo->display, child, True, ButtonReleaseMask, &event); x_stop_ignoring_errors (dpyinfo); @@ -4456,7 +4459,8 @@ x_dnd_get_window_proto (struct x_display_info *dpyinfo, Window wdesc) } static void -x_dnd_send_enter (struct frame *f, Window target, int supported) +x_dnd_send_enter (struct frame *f, Window target, Window toplevel, + int supported) { struct x_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); int i; @@ -4465,7 +4469,7 @@ x_dnd_send_enter (struct frame *f, Window target, int supported) msg.xclient.type = ClientMessage; msg.xclient.message_type = dpyinfo->Xatom_XdndEnter; msg.xclient.format = 32; - msg.xclient.window = target; + msg.xclient.window = toplevel; msg.xclient.data.l[0] = FRAME_X_WINDOW (f); msg.xclient.data.l[1] = (((unsigned int) min (X_DND_SUPPORTED_VERSION, supported) << 24) @@ -4493,10 +4497,10 @@ x_dnd_send_enter (struct frame *f, Window target, int supported) } static void -x_dnd_send_position (struct frame *f, Window target, int supported, - unsigned short root_x, unsigned short root_y, - Time timestamp, Atom action, int button, - unsigned state) +x_dnd_send_position (struct frame *f, Window target, Window toplevel, + int supported, unsigned short root_x, + unsigned short root_y, Time timestamp, Atom action, + int button, unsigned state) { struct x_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); XEvent msg; @@ -4504,7 +4508,7 @@ x_dnd_send_position (struct frame *f, Window target, int supported, msg.xclient.type = ClientMessage; msg.xclient.message_type = dpyinfo->Xatom_XdndPosition; msg.xclient.format = 32; - msg.xclient.window = target; + msg.xclient.window = toplevel; msg.xclient.data.l[0] = FRAME_X_WINDOW (f); msg.xclient.data.l[1] = 0; @@ -4568,7 +4572,7 @@ x_dnd_send_position (struct frame *f, Window target, int supported, } static void -x_dnd_send_leave (struct frame *f, Window target) +x_dnd_send_leave (struct frame *f, Window target, Window toplevel) { struct x_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); XEvent msg; @@ -4576,7 +4580,7 @@ x_dnd_send_leave (struct frame *f, Window target) msg.xclient.type = ClientMessage; msg.xclient.message_type = dpyinfo->Xatom_XdndLeave; msg.xclient.format = 32; - msg.xclient.window = target; + msg.xclient.window = toplevel; msg.xclient.data.l[0] = FRAME_X_WINDOW (f); msg.xclient.data.l[1] = 0; msg.xclient.data.l[2] = 0; @@ -4592,15 +4596,15 @@ x_dnd_send_leave (struct frame *f, Window target) } static bool -x_dnd_send_drop (struct frame *f, Window target, Time timestamp, - int supported) +x_dnd_send_drop (struct frame *f, Window target, Window toplevel, + Time timestamp, int supported) { struct x_display_info *dpyinfo; XEvent msg; if (x_dnd_action == None) { - x_dnd_send_leave (f, target); + x_dnd_send_leave (f, target, toplevel); return false; } @@ -4609,7 +4613,7 @@ x_dnd_send_drop (struct frame *f, Window target, Time timestamp, msg.xclient.type = ClientMessage; msg.xclient.message_type = dpyinfo->Xatom_XdndDrop; msg.xclient.format = 32; - msg.xclient.window = target; + msg.xclient.window = toplevel; msg.xclient.data.l[0] = FRAME_X_WINDOW (f); msg.xclient.data.l[1] = 0; msg.xclient.data.l[2] = 0; @@ -4626,10 +4630,10 @@ x_dnd_send_drop (struct frame *f, Window target, Time timestamp, } static bool -x_dnd_do_drop (Window target, int supported) +x_dnd_do_drop (Window target, Window toplevel, int supported) { if (x_dnd_waiting_for_status_window != target) - return x_dnd_send_drop (x_dnd_frame, target, + return x_dnd_send_drop (x_dnd_frame, target, toplevel, x_dnd_selection_timestamp, supported); x_dnd_need_send_drop = true; @@ -4734,7 +4738,8 @@ x_dnd_cancel_dnd_early (void) if (x_dnd_last_seen_window != None && x_dnd_last_protocol_version != -1) x_dnd_send_leave (x_dnd_frame, - x_dnd_last_seen_window); + x_dnd_last_seen_window, + x_dnd_last_seen_toplevel); else if (x_dnd_last_seen_window != None && !XM_DRAG_STYLE_IS_DROP_ONLY (x_dnd_last_motif_style) && x_dnd_last_motif_style != XM_DRAG_STYLE_NONE @@ -4792,7 +4797,8 @@ x_dnd_cleanup_drag_and_drop (void *frame) if (x_dnd_last_seen_window != None && x_dnd_last_protocol_version != -1) x_dnd_send_leave (x_dnd_frame, - x_dnd_last_seen_window); + x_dnd_last_seen_window, + x_dnd_last_seen_toplevel); else if (x_dnd_last_seen_window != None && !XM_DRAG_STYLE_IS_DROP_ONLY (x_dnd_last_motif_style) && x_dnd_last_motif_style != XM_DRAG_STYLE_NONE @@ -6629,22 +6635,21 @@ x_set_frame_alpha (struct frame *f) Do this unconditionally as this function is called on reparent when alpha has not changed on the frame. */ + x_ignore_errors_for_next_request (dpyinfo); + if (!FRAME_PARENT_FRAME (f)) { parent = x_find_topmost_parent (f); if (parent != None) { - x_ignore_errors_for_next_request (dpyinfo); XChangeProperty (dpy, parent, dpyinfo->Xatom_net_wm_window_opacity, XA_CARDINAL, 32, PropModeReplace, (unsigned char *) &opac, 1); - x_stop_ignoring_errors (dpyinfo); } } - x_ignore_errors_for_next_request (dpyinfo); XChangeProperty (dpy, win, dpyinfo->Xatom_net_wm_window_opacity, XA_CARDINAL, 32, PropModeReplace, (unsigned char *) &opac, 1); @@ -11914,7 +11919,8 @@ x_dnd_process_quit (struct frame *f, Time timestamp) { if (x_dnd_last_seen_window != None && x_dnd_last_protocol_version != -1) - x_dnd_send_leave (f, x_dnd_last_seen_window); + x_dnd_send_leave (f, x_dnd_last_seen_window, + x_dnd_last_seen_toplevel); else if (x_dnd_last_seen_window != None && !XM_DRAG_STYLE_IS_DROP_ONLY (x_dnd_last_motif_style) && x_dnd_last_motif_style != XM_DRAG_STYLE_NONE @@ -13207,8 +13213,13 @@ x_mouse_leave (struct x_display_info *dpyinfo) device = xi_device_from_id (dpyinfo, dpyinfo->client_pointer_device); - if (device) - device->focus_implicit_frame = NULL; + if (device && device->focus_implicit_frame) + { + device->focus_implicit_frame = NULL; + + /* The focus might have changed; compute the new focus. */ + xi_handle_focus_change (dpyinfo); + } } #endif } @@ -17109,7 +17120,8 @@ x_dnd_update_state (struct x_display_info *dpyinfo, Time timestamp) if (x_dnd_last_seen_window != None && x_dnd_last_protocol_version != -1 && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) - x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window); + x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window, + x_dnd_last_seen_toplevel); else if (x_dnd_last_seen_window != None && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style) && !x_dnd_disable_motif_drag @@ -17149,7 +17161,8 @@ x_dnd_update_state (struct x_display_info *dpyinfo, Time timestamp) if (x_dnd_last_seen_window != None && x_dnd_last_protocol_version != -1 && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) - x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window); + x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window, + x_dnd_last_seen_toplevel); else if (x_dnd_last_seen_window != None && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style) && !x_dnd_disable_motif_drag @@ -17177,7 +17190,7 @@ x_dnd_update_state (struct x_display_info *dpyinfo, Time timestamp) x_dnd_last_window_is_frame = was_frame; if (target != None && x_dnd_last_protocol_version != -1) - x_dnd_send_enter (x_dnd_frame, target, + x_dnd_send_enter (x_dnd_frame, target, x_dnd_last_seen_toplevel, x_dnd_last_protocol_version); else if (target != None && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style) && !x_dnd_disable_motif_drag) @@ -17203,6 +17216,7 @@ x_dnd_update_state (struct x_display_info *dpyinfo, Time timestamp) x_dnd_note_self_position (dpyinfo, target, root_x, root_y); else if (x_dnd_last_protocol_version != -1 && target != None) x_dnd_send_position (x_dnd_frame, target, + x_dnd_last_seen_toplevel, x_dnd_last_protocol_version, root_x, root_y, x_dnd_selection_timestamp, @@ -17246,7 +17260,8 @@ x_dnd_update_state (struct x_display_info *dpyinfo, Time timestamp) if (x_dnd_last_seen_window != None && x_dnd_last_protocol_version != -1) x_dnd_send_leave (x_dnd_frame, - x_dnd_last_seen_window); + x_dnd_last_seen_window, + x_dnd_last_seen_toplevel); else if (x_dnd_last_seen_window != None && !XM_DRAG_STYLE_IS_DROP_ONLY (x_dnd_last_motif_style) && x_dnd_last_motif_style != XM_DRAG_STYLE_NONE @@ -17758,7 +17773,9 @@ handle_one_xevent (struct x_display_info *dpyinfo, x_dnd_waiting_for_finish = x_dnd_send_drop (x_dnd_finish_frame, - target, x_dnd_selection_timestamp, + target, + x_dnd_last_seen_toplevel, + x_dnd_selection_timestamp, x_dnd_send_drop_proto); } } @@ -19626,7 +19643,8 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (x_dnd_last_seen_window != None && x_dnd_last_protocol_version != -1 && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) - x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window); + x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window, + x_dnd_last_seen_toplevel); else if (x_dnd_last_seen_window != None && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style) && !x_dnd_disable_motif_drag @@ -19666,7 +19684,8 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (x_dnd_last_seen_window != None && x_dnd_last_protocol_version != -1 && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) - x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window); + x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window, + x_dnd_last_seen_toplevel); else if (x_dnd_last_seen_window != None && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style) && x_dnd_disable_motif_drag @@ -19716,6 +19735,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (target != None && x_dnd_last_protocol_version != -1) x_dnd_send_enter (x_dnd_frame, target, + x_dnd_last_seen_toplevel, x_dnd_last_protocol_version); else if (target != None && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style) && !x_dnd_disable_motif_drag) @@ -19743,6 +19763,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, event->xbutton.y_root); else if (x_dnd_last_protocol_version != -1 && target != None) x_dnd_send_position (x_dnd_frame, target, + x_dnd_last_seen_toplevel, x_dnd_last_protocol_version, event->xmotion.x_root, event->xmotion.y_root, @@ -20304,6 +20325,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, else if (x_dnd_last_protocol_version != -1) x_dnd_send_position (x_dnd_frame, x_dnd_last_seen_window, + x_dnd_last_seen_toplevel, x_dnd_last_protocol_version, event->xbutton.x_root, event->xbutton.y_root, @@ -20356,6 +20378,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, x_dnd_waiting_for_finish = x_dnd_do_drop (x_dnd_last_seen_window, + x_dnd_last_seen_toplevel, x_dnd_last_protocol_version); x_dnd_finish_display = dpyinfo->display; } @@ -20693,6 +20716,15 @@ handle_one_xevent (struct x_display_info *dpyinfo, == dpyinfo->net_supported_window) dpyinfo->net_supported_window = None; + if (event->xdestroywindow.window + == dpyinfo->motif_drag_window) + /* We get DestroyNotify events for the drag window because + x_special_window_exists_p selects for structure + notification. The drag window is not supposed to go away + but not all clients obey that requirement when setting the + drag window property. */ + dpyinfo->motif_drag_window = None; + xft_settings_event (dpyinfo, event); break; @@ -21482,7 +21514,8 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (x_dnd_last_seen_window != None && x_dnd_last_protocol_version != -1 && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) - x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window); + x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window, + x_dnd_last_seen_toplevel); else if (x_dnd_last_seen_window != None && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style) && !x_dnd_disable_motif_drag @@ -21522,7 +21555,8 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (x_dnd_last_seen_window != None && x_dnd_last_protocol_version != -1 && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) - x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window); + x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window, + x_dnd_last_seen_toplevel); else if (x_dnd_last_seen_window != None && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style) && !x_dnd_disable_motif_drag @@ -21574,6 +21608,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (target != None && x_dnd_last_protocol_version != -1) x_dnd_send_enter (x_dnd_frame, target, + x_dnd_last_seen_toplevel, x_dnd_last_protocol_version); else if (target != None && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style) && !x_dnd_disable_motif_drag) @@ -21604,6 +21639,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, dnd_state = xi_convert_event_state (xev); x_dnd_send_position (x_dnd_frame, target, + x_dnd_last_seen_toplevel, x_dnd_last_protocol_version, lrint (xev->root_x), lrint (xev->root_y), @@ -21822,6 +21858,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, else x_dnd_send_position (x_dnd_frame, x_dnd_last_seen_window, + x_dnd_last_seen_toplevel, x_dnd_last_protocol_version, lrint (xev->root_x), lrint (xev->root_y), @@ -21878,6 +21915,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, x_dnd_waiting_for_finish = x_dnd_do_drop (x_dnd_last_seen_window, + x_dnd_last_seen_toplevel, x_dnd_last_protocol_version); x_dnd_finish_display = dpyinfo->display; } @@ -24819,7 +24857,8 @@ x_connection_closed (Display *dpy, const char *error_message, bool ioerror) if (x_dnd_last_seen_window != None && x_dnd_last_protocol_version != -1) x_dnd_send_leave (x_dnd_frame, - x_dnd_last_seen_window); + x_dnd_last_seen_window, + x_dnd_last_seen_toplevel); else if (x_dnd_last_seen_window != None && !XM_DRAG_STYLE_IS_DROP_ONLY (x_dnd_last_motif_style) && x_dnd_last_motif_style != XM_DRAG_STYLE_NONE @@ -28741,10 +28780,13 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) (RRScreenChangeNotifyMask | RRCrtcChangeNotifyMask | RROutputChangeNotifyMask - /* Emacs doesn't actually need this, but GTK - selects for it when the display is +#ifdef USE_GTK + /* Emacs doesn't actually need this, but + GTK selects for it when the display is initialized. */ - | RROutputPropertyNotifyMask)); + | RROutputPropertyNotifyMask +#endif + )); dpyinfo->last_monitor_attributes_list = Fx_display_monitor_attributes_list (term); diff --git a/src/xterm.h b/src/xterm.h index 7c5a889af30..d6ff15e40f7 100644 --- a/src/xterm.h +++ b/src/xterm.h @@ -656,7 +656,8 @@ struct x_display_info Xatom_net_wm_sync_request, Xatom_net_wm_sync_request_counter, Xatom_net_wm_sync_fences, Xatom_net_wm_frame_drawn, Xatom_net_wm_frame_timings, Xatom_net_wm_user_time, Xatom_net_wm_user_time_window, - Xatom_net_client_list_stacking, Xatom_net_wm_pid; + Xatom_net_client_list_stacking, Xatom_net_wm_pid, + Xatom_net_wm_bypass_compositor; /* XSettings atoms and windows. */ Atom Xatom_xsettings_sel, Xatom_xsettings_prop, Xatom_xsettings_mgr; diff --git a/test/lisp/ansi-color-tests.el b/test/lisp/ansi-color-tests.el index 1b04e8e9def..f672f334914 100644 --- a/test/lisp/ansi-color-tests.el +++ b/test/lisp/ansi-color-tests.el @@ -135,7 +135,7 @@ strings with `eq', this function compares them with `equal'." (with-temp-buffer (should (equal-including-properties filtered-str - (mapconcat ansi-filt strs "")))) + (mapconcat ansi-filt strs)))) ;; Tests for `ansi-color-filter-region' (with-temp-buffer @@ -156,7 +156,7 @@ strings with `eq', this function compares them with `equal'." (with-temp-buffer (should (ansi-color-tests-equal-props propertized-str - (mapconcat ansi-app strs "")))) + (mapconcat ansi-app strs)))) ;; Tests for `ansi-color-apply-on-region' (with-temp-buffer diff --git a/test/lisp/char-fold-tests.el b/test/lisp/char-fold-tests.el index 749ec0a8d3e..e7f5ff6fd2f 100644 --- a/test/lisp/char-fold-tests.el +++ b/test/lisp/char-fold-tests.el @@ -26,7 +26,7 @@ (defun char-fold--random-word (n) (mapconcat (lambda (_) (string (+ 9 (random 117)))) - (make-list n nil) "")) + (make-list n nil))) (defun char-fold--ascii-upcase (string) "Like `upcase' but acts on ASCII characters only." diff --git a/test/lisp/dired-tests.el b/test/lisp/dired-tests.el index 9cf01519052..09becc7fe7a 100644 --- a/test/lisp/dired-tests.el +++ b/test/lisp/dired-tests.el @@ -456,8 +456,8 @@ (dolist (file '(a b c d)) (make-empty-file (expand-file-name (symbol-name file) testdir))) (should (= 6 (length (directory-files testdir)))) - (should (equal "abcd" (mapconcat 'identity (directory-files - testdir nil nod) ""))) + (should (equal "abcd" (mapconcat #'identity (directory-files + testdir nil nod)))) (should (= 2 (length (directory-files testdir nil "[bc]")))) (should (= 3 (length (directory-files testdir nil nod nil 3)))) (dolist (file '(5 4 3 2 1)) diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index a246c25e24f..bc9f8d802a6 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -912,7 +912,7 @@ byte-compiled. Run with dynamic binding." "next-line.*interactive use only.*forward-line") (bytecomp--define-warning-file-test "warn-lambda-malformed-interactive-spec.el" - "malformed interactive spec") + "malformed .interactive. specification") (bytecomp--define-warning-file-test "warn-obsolete-defun.el" "foo-obsolete. is an obsolete function (as of 99.99)") diff --git a/test/lisp/emacs-lisp/cl-extra-tests.el b/test/lisp/emacs-lisp/cl-extra-tests.el index 801885c0d40..297e413d858 100644 --- a/test/lisp/emacs-lisp/cl-extra-tests.el +++ b/test/lisp/emacs-lisp/cl-extra-tests.el @@ -77,7 +77,7 @@ (fn3 (lambda (x _y _z) (string-to-char (format "%S" x))))) (should (equal lst (cl-map 'list fn1 lst))) (should (equal (vconcat lst2) (cl-map 'vector fn2 lst lst2))) - (should (equal (mapconcat (lambda (x) (format "%S" x)) lst "") + (should (equal (mapconcat (lambda (x) (format "%S" x)) lst) (cl-map 'string fn3 lst lst2 lst3))))) (ert-deftest cl-extra-test-maplist () diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el index 8d2b187e33a..b19494af746 100644 --- a/test/lisp/emacs-lisp/cl-lib-tests.el +++ b/test/lisp/emacs-lisp/cl-lib-tests.el @@ -511,9 +511,6 @@ (ert-deftest cl-lib-symbol-macrolet-hide () - :expected-result :failed - ;; FIXME -- it's unclear what the semantics here should be, but - ;; 2dd1c2ab19f7fb99ecee flipped them. ;; bug#26325, bug#26073 (should (equal (let ((y 5)) (cl-symbol-macrolet ((x y)) diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index 2a647e08305..68898720d9c 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -552,7 +552,14 @@ collection clause." x) x)) (error err)) - '(1 7 3)))) + '(1 7 3))) + (should (equal + (let ((x (list 42))) + (cl-symbol-macrolet ((m (car x))) + (list m + (cl-letf ((m 5)) m) + m))) + '(42 5 42)))) (ert-deftest cl-macs-loop-conditional-step-clauses () "These tests failed under the initial fixes in #bug#29799." diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el index 008e1e467ba..dea6e9ed611 100644 --- a/test/lisp/emacs-lisp/edebug-tests.el +++ b/test/lisp/emacs-lisp/edebug-tests.el @@ -428,7 +428,8 @@ test and possibly others should be updated." (verify-keybinding "-" 'negative-argument) (verify-keybinding "=" 'edebug-temp-display-freq-count) (should (eq (lookup-key backtrace-mode-map "n") 'backtrace-forward-frame)) - (should (eq (lookup-key backtrace-mode-map "s") 'backtrace-goto-source)))) + (should (eq (lookup-key edebug-backtrace-mode-map "s") + 'backtrace-goto-source)))) (ert-deftest edebug-tests-stop-point-at-start-of-first-instrumented-function () "Edebug stops at the beginning of an instrumented function." diff --git a/test/lisp/emacs-lisp/ert-x-tests.el b/test/lisp/emacs-lisp/ert-x-tests.el index 38698041102..63e7cd7608f 100644 --- a/test/lisp/emacs-lisp/ert-x-tests.el +++ b/test/lisp/emacs-lisp/ert-x-tests.el @@ -82,6 +82,21 @@ (should-not (buffer-live-p buffer-1)) (should (buffer-live-p buffer-2)))))) +(ert-deftest ert-test-with-test-buffer-selected/selected () + (ert-with-test-buffer-selected () + (should (eq (window-buffer) (current-buffer))))) + +(ert-deftest ert-test-with-test-buffer-selected/modification-hooks () + (ert-with-test-buffer-selected () + (should (null inhibit-modification-hooks)))) + +(ert-deftest ert-test-with-test-buffer-selected/return-value () + (should (equal (ert-with-test-buffer-selected () "foo") "foo"))) + +(ert-deftest ert-test-with-test-buffer-selected/buffer-name () + (should (equal (ert-with-test-buffer (:name "foo") (buffer-name)) + (ert-with-test-buffer-selected (:name "foo") + (buffer-name))))) (ert-deftest ert-filter-string () (should (equal (ert-filter-string "foo bar baz" "quux") diff --git a/test/lisp/eshell/esh-proc-tests.el b/test/lisp/eshell/esh-proc-tests.el index 52a0d1eeeb8..abe363bee0d 100644 --- a/test/lisp/eshell/esh-proc-tests.el +++ b/test/lisp/eshell/esh-proc-tests.el @@ -128,8 +128,10 @@ (eshell-match-command-output ;; The first command is like `yes' but slower. This is to prevent ;; it from taxing Emacs's process filter too much and causing a - ;; hang. - (concat "sh -c 'while true; do echo y; sleep 1; done' | " + ;; hang. Note that we use "|&" to connect the processes so that + ;; Emacs doesn't create an extra pipe process for the first "sh" + ;; invocation. + (concat "sh -c 'while true; do echo y; sleep 1; done' |& " "sh -c 'read NAME; echo ${NAME}'") "y\n") (eshell-wait-for-subprocess t) diff --git a/test/lisp/help-tests.el b/test/lisp/help-tests.el index 833c32ffb27..6f1dcfa5b6b 100644 --- a/test/lisp/help-tests.el +++ b/test/lisp/help-tests.el @@ -200,25 +200,45 @@ M-g M-c switch-to-completions "\nUses keymap [`'‘]foobar-map['’], which is not currently defined.\n"))) (ert-deftest help-tests-substitute-command-keys/quotes () - (with-substitute-command-keys-test + (with-substitute-command-keys-test + (let ((text-quoting-style 'curve)) + (test "quotes ‘like this’" "quotes ‘like this’") + (test "`x'" "‘x’") + (test "`" "‘") + (test "'" "’") + (test "\\`" "\\‘")) + (let ((text-quoting-style 'straight)) + (test "quotes `like this'" "quotes 'like this'") + (test "`x'" "'x'") + (test "`" "'") + (test "'" "'") + (test "\\`" "\\'")) + (let ((text-quoting-style 'grave)) + (test "quotes `like this'" "quotes `like this'") + (test "`x'" "`x'") + (test "`" "`") + (test "'" "'") + (test "\\`" "\\`")))) + +(ert-deftest help-tests-substitute-quotes () (let ((text-quoting-style 'curve)) - (test "quotes ‘like this’" "quotes ‘like this’") - (test "`x'" "‘x’") - (test "`" "‘") - (test "'" "’") - (test "\\`" "\\‘")) + (should (string= (substitute-quotes "quotes ‘like this’") "quotes ‘like this’")) + (should (string= (substitute-quotes "`x'") "‘x’")) + (should (string= (substitute-quotes "`") "‘")) + (should (string= (substitute-quotes "'") "’")) + (should (string= (substitute-quotes "\\`") "\\‘"))) (let ((text-quoting-style 'straight)) - (test "quotes `like this'" "quotes 'like this'") - (test "`x'" "'x'") - (test "`" "'") - (test "'" "'") - (test "\\`" "\\'")) + (should (string= (substitute-quotes "quotes `like this'") "quotes 'like this'")) + (should (string= (substitute-quotes "`x'") "'x'")) + (should (string= (substitute-quotes "`") "'")) + (should (string= (substitute-quotes "'") "'")) + (should (string= (substitute-quotes "\\`") "\\'"))) (let ((text-quoting-style 'grave)) - (test "quotes `like this'" "quotes `like this'") - (test "`x'" "`x'") - (test "`" "`") - (test "'" "'") - (test "\\`" "\\`")))) + (should (string= (substitute-quotes "quotes `like this'") "quotes `like this'")) + (should (string= (substitute-quotes "`x'") "`x'")) + (should (string= (substitute-quotes "`") "`")) + (should (string= (substitute-quotes "'") "'")) + (should (string= (substitute-quotes "\\`") "\\`")))) (ert-deftest help-tests-substitute-command-keys/literals () (with-substitute-command-keys-test diff --git a/test/lisp/md4-tests.el b/test/lisp/md4-tests.el index fb7df652bc6..d1f227cb90a 100644 --- a/test/lisp/md4-tests.el +++ b/test/lisp/md4-tests.el @@ -29,7 +29,7 @@ (defun md4-tests-digest->hex (str) "Print digest STR in hexadecimal." - (mapconcat (lambda (x) (format "%02x" x)) str "")) + (mapconcat (lambda (x) (format "%02x" x)) str)) (ert-deftest md4-test-rfc1320 () "Verify the test suite results in RFC 1320. diff --git a/test/lisp/net/hmac-md5-tests.el b/test/lisp/net/hmac-md5-tests.el index ce08dd89d10..09bbb8015e9 100644 --- a/test/lisp/net/hmac-md5-tests.el +++ b/test/lisp/net/hmac-md5-tests.el @@ -48,7 +48,7 @@ (should (equal (encode-hex-string (hmac-md5 (decode-hex-string (mapconcat (lambda (c) (concat (list c) "d")) - (make-string 50 ?c) "")) + (make-string 50 ?c))) (decode-hex-string "0102030405060708090a0b0c0d0e0f10111213141516171819"))) "697eaf0aca3a3aea3a75164746ffaa79")) diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el index aa5d1cc496c..f8a0aa03e32 100644 --- a/test/lisp/net/tramp-archive-tests.el +++ b/test/lisp/net/tramp-archive-tests.el @@ -616,13 +616,15 @@ This checks also `file-name-as-directory', `file-name-directory', (insert-directory tramp-archive-test-archive nil) (goto-char (point-min)) (should - (looking-at-p (rx (literal tramp-archive-test-archive))))) + (looking-at-p + (tramp-compat-rx (literal tramp-archive-test-archive))))) (with-temp-buffer (insert-directory tramp-archive-test-archive "-al") (goto-char (point-min)) (should (looking-at-p - (rx bol (+ nonl) space (literal tramp-archive-test-archive) eol)))) + (tramp-compat-rx + bol (+ nonl) blank (literal tramp-archive-test-archive) eol)))) (with-temp-buffer (insert-directory (file-name-as-directory tramp-archive-test-archive) @@ -633,11 +635,11 @@ This checks also `file-name-as-directory', `file-name-directory', (rx-to-string `(: ;; There might be a summary line. - (? "total" (+ nonl) (+ digit) (? space) + (? "total" (+ nonl) (+ digit) (? blank) (? (any "EGKMPTYZk")) (? "i") (? "B") "\n") ;; We don't know in which order the files appear. (= ,(length (directory-files tramp-archive-test-archive)) - (+ nonl) space + (+ nonl) blank (regexp ,(regexp-opt (directory-files tramp-archive-test-archive))) (? " ->" (+ nonl)) "\n")))))) @@ -917,14 +919,15 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (dolist (file `("/mock::foo" ,(concat tramp-archive-test-archive "foo"))) (should (string-match - (rx "tramp-archive loaded: " - (literal (symbol-name - (tramp-archive-file-name-p default-directory))) - (+ ascii) - "tramp-archive loaded: " - (literal (symbol-name - (or (tramp-archive-file-name-p default-directory) - (and enabled (tramp-archive-file-name-p file)))))) + (tramp-compat-rx + "tramp-archive loaded: " + (literal (symbol-name + (tramp-archive-file-name-p default-directory))) + (+ ascii) + "tramp-archive loaded: " + (literal (symbol-name + (or (tramp-archive-file-name-p default-directory) + (and enabled (tramp-archive-file-name-p file)))))) (shell-command-to-string (format "%s -batch -Q -L %s --eval %s --eval %s" @@ -961,9 +964,10 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (dolist (tae '(t nil)) (should (string-match - (rx "tramp-archive loaded: nil" (+ ascii) - "tramp-archive loaded: nil" (+ ascii) - "tramp-archive loaded: " (literal (symbol-name tae))) + (tramp-compat-rx + "tramp-archive loaded: nil" (+ ascii) + "tramp-archive loaded: nil" (+ ascii) + "tramp-archive loaded: " (literal (symbol-name tae))) (shell-command-to-string (format "%s -batch -Q -L %s --eval %s" diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index fed1d881c57..2db44494388 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -2295,9 +2295,9 @@ This checks also `file-name-as-directory', `file-name-directory', ;; Check `directory-abbrev-alist' abbreviation. (let ((directory-abbrev-alist - `((,(rx bos (literal home-dir) "/foo") + `((,(tramp-compat-rx bos (literal home-dir) "/foo") . ,(concat home-dir "/f")) - (,(rx bos (literal remote-host) "/nowhere") + (,(tramp-compat-rx bos (literal remote-host) "/nowhere") . ,(concat remote-host "/nw"))))) (should (equal (abbreviate-file-name (concat home-dir "/foo/bar")) (concat remote-host-nohop "~/f/bar"))) @@ -2510,7 +2510,8 @@ This checks also `file-name-as-directory', `file-name-directory', (string-match-p (if (and (null noninteractive) (or (eq visit t) (null visit) (stringp visit))) - (rx bol "Wrote " (literal tmp-name) "\n" eos) + (tramp-compat-rx + bol "Wrote " (literal tmp-name) "\n" eos) (rx bos)) tramp--test-messages)))))) @@ -3211,24 +3212,26 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (with-temp-buffer (insert-directory tmp-name1 nil) (goto-char (point-min)) - (should (looking-at-p (rx (literal tmp-name1))))) + (should (looking-at-p (tramp-compat-rx (literal tmp-name1))))) (with-temp-buffer (insert-directory (file-name-as-directory tmp-name1) nil) (goto-char (point-min)) (should (looking-at-p - (rx (literal (file-name-as-directory tmp-name1)))))) + (tramp-compat-rx (literal (file-name-as-directory tmp-name1)))))) (with-temp-buffer (insert-directory tmp-name1 "-al") (goto-char (point-min)) (should - (looking-at-p (rx bol (+ nonl) space (literal tmp-name1) eol)))) + (looking-at-p + (tramp-compat-rx bol (+ nonl) blank (literal tmp-name1) eol)))) (with-temp-buffer (insert-directory (file-name-as-directory tmp-name1) "-al") (goto-char (point-min)) (should (looking-at-p - (rx bol (+ nonl) space (literal tmp-name1) "/" eol)))) + (tramp-compat-rx + bol (+ nonl) blank (literal tmp-name1) "/" eol)))) (with-temp-buffer (insert-directory (file-name-as-directory tmp-name1) "-al" nil 'full-directory-p) @@ -3238,11 +3241,11 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (rx-to-string `(: ;; There might be a summary line. - (? "total" (+ nonl) (+ digit) (? space) + (? "total" (+ nonl) (+ digit) (? blank) (? (any "EGKMPTYZk")) (? "i") (? "B") "\n") ;; We don't know in which order ".", ".." and "foo" appear. (= ,(length (directory-files tmp-name1)) - (+ nonl) space + (+ nonl) blank (regexp ,(regexp-opt (directory-files tmp-name1))) (? " ->" (+ nonl)) "\n")))))) @@ -3312,15 +3315,17 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (goto-char (point-min)) (should (re-search-forward - (rx (literal - (file-relative-name - tmp-name1 ert-remote-temporary-file-directory))))) + (tramp-compat-rx + (literal + (file-relative-name + tmp-name1 ert-remote-temporary-file-directory))))) (goto-char (point-min)) (should (re-search-forward - (rx (literal - (file-relative-name - tmp-name2 ert-remote-temporary-file-directory)))))) + (tramp-compat-rx + (literal + (file-relative-name + tmp-name2 ert-remote-temporary-file-directory)))))) (kill-buffer buffer) ;; Check for expanded directory and file names. @@ -3332,16 +3337,18 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (goto-char (point-min)) (should (re-search-forward - (rx (literal - (file-relative-name - tmp-name3 ert-remote-temporary-file-directory))))) + (tramp-compat-rx + (literal + (file-relative-name + tmp-name3 ert-remote-temporary-file-directory))))) (goto-char (point-min)) (should (re-search-forward - (rx (literal - (file-relative-name - tmp-name4 - ert-remote-temporary-file-directory)))))) + (tramp-compat-rx + (literal + (file-relative-name + tmp-name4 + ert-remote-temporary-file-directory)))))) (kill-buffer buffer) ;; Check for special characters. @@ -3360,16 +3367,18 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (goto-char (point-min)) (should (re-search-forward - (rx (literal - (file-relative-name - tmp-name3 ert-remote-temporary-file-directory))))) + (tramp-compat-rx + (literal + (file-relative-name + tmp-name3 ert-remote-temporary-file-directory))))) (goto-char (point-min)) (should (re-search-forward - (rx (literal - (file-relative-name - tmp-name4 - ert-remote-temporary-file-directory)))))) + (tramp-compat-rx + (literal + (file-relative-name + tmp-name4 + ert-remote-temporary-file-directory)))))) (kill-buffer buffer)) ;; Cleanup. @@ -3599,6 +3608,9 @@ This tests also `access-file', `file-readable-p', (cons '(nil "perl" nil) tramp-connection-properties))) (progn + ;; `ert-test-result-duration' exists since Emacs 27. It + ;; doesn't hurt to call it unconditionally, because + ;; `skip-unless' hides the error. (skip-unless (< (ert-test-result-duration result) 300)) (funcall (ert-test-body ert-test))) (ert-skip (format "Test `%s' must run before" ',test))))) @@ -3622,9 +3634,14 @@ This tests also `access-file', `file-readable-p', (append '((nil "stat" nil) ;; See `tramp-sh-handle-file-truename'. - (nil "readlink" nil)) + (nil "readlink" nil) + ;; See `tramp-sh-handle-get-remote-*'. + (nil "id" nil)) tramp-connection-properties))) (progn + ;; `ert-test-result-duration' exists since Emacs 27. It + ;; doesn't hurt to call it unconditionally, because + ;; `skip-unless' hides the error. (skip-unless (< (ert-test-result-duration result) 300)) (funcall (ert-test-body ert-test))) (ert-skip (format "Test `%s' must run before" ',test))))) @@ -3651,6 +3668,9 @@ This tests also `access-file', `file-readable-p', (nil "readlink" nil)) tramp-connection-properties))) (progn + ;; `ert-test-result-duration' exists since Emacs 27. It + ;; doesn't hurt to call it unconditionally, because + ;; `skip-unless' hides the error. (skip-unless (< (ert-test-result-duration result) 300)) (funcall (ert-test-body ert-test))) (ert-skip (format "Test `%s' must run before" ',test))))) @@ -5677,7 +5697,7 @@ INPUT, if non-nil, is a string sent to the process." ;; Variable is set. (should (string-match-p - (rx (literal envvar)) + (tramp-compat-rx (literal envvar)) (funcall this-shell-command-to-string "set")))) (unless (tramp-direct-async-process-p) @@ -5704,7 +5724,7 @@ INPUT, if non-nil, is a string sent to the process." ;; Variable is unset. (should-not (string-match-p - (rx (literal envvar)) + (tramp-compat-rx (literal envvar)) ;; We must remove PS1, the output is truncated otherwise. ;; We must suppress "_=VAR...". (funcall @@ -6596,7 +6616,7 @@ This is used in tests which we don't want to tag :body nil :tags '(:tramp-asynchronous-processes)))) ;; tramp-adb.el cannot apply multi-byte commands. (not (and (tramp--test-adb-p) - (string-match-p (rx multibyte) default-directory))))) + (string-match-p (tramp-compat-rx multibyte) default-directory))))) (defun tramp--test-crypt-p () "Check, whether the remote directory is encrypted." @@ -6904,14 +6924,14 @@ This requires restrictions of file name syntax." (should (string-equal (caar (directory-files-and-attributes - file1 nil (rx (literal elt1)))) + file1 nil (tramp-compat-rx (literal elt1)))) elt1)) (should (string-equal (funcall (if quoted #'tramp-compat-file-name-quote #'identity) (cadr (car (directory-files-and-attributes - file1 nil (rx (literal elt1)))))) + file1 nil (tramp-compat-rx (literal elt1)))))) (file-remote-p (file-truename file2) 'localname))) (delete-file file3) (should-not (file-exists-p file3)))) @@ -6966,8 +6986,9 @@ This requires restrictions of file name syntax." (goto-char (point-min)) (should (re-search-forward - (rx bol (literal envvar) - "=" (literal (getenv envvar)) eol)))))))) + (tramp-compat-rx + bol (literal envvar) + "=" (literal (getenv envvar)) eol)))))))) ;; Cleanup. (ignore-errors (kill-buffer buffer)) @@ -7509,9 +7530,10 @@ process sentinels. They shall not disturb each other." (dolist (tm '(t nil)) (should (string-match-p - (rx "Tramp loaded: nil" (+ (any "\n\r")) - "Tramp loaded: nil" (+ (any "\n\r")) - "Tramp loaded: " (literal (symbol-name tm)) (+ (any "\n\r"))) + (tramp-compat-rx + "Tramp loaded: nil" (+ (any "\n\r")) + "Tramp loaded: nil" (+ (any "\n\r")) + "Tramp loaded: " (literal (symbol-name tm)) (+ (any "\n\r"))) (shell-command-to-string (format "%s -batch -Q -L %s --eval %s" @@ -7556,10 +7578,11 @@ process sentinels. They shall not disturb each other." (tramp-cleanup-all-connections))")) (should (string-match-p - (rx "Loading " - (literal - (expand-file-name - "tramp-cmds" (file-name-directory (locate-library "tramp"))))) + (tramp-compat-rx + "Loading " + (literal + (expand-file-name + "tramp-cmds" (file-name-directory (locate-library "tramp"))))) (shell-command-to-string (format "%s -batch -Q -L %s -l tramp-sh --eval %s" @@ -7663,6 +7686,7 @@ If INTERACTIVE is non-nil, the tests are run interactively." ;; * file-in-directory-p ;; * file-name-case-insensitive-p ;; * tramp-get-remote-gid +;; * tramp-get-remote-groups ;; * tramp-get-remote-uid ;; * tramp-set-file-uid-gid diff --git a/test/lisp/progmodes/python-tests.el b/test/lisp/progmodes/python-tests.el index 906f7eca7de..20a7a0132a8 100644 --- a/test/lisp/progmodes/python-tests.el +++ b/test/lisp/progmodes/python-tests.el @@ -574,10 +574,14 @@ u\"\\n\"" (195 . font-lock-string-face) (196 . font-lock-constant-face) (215 . font-lock-string-face) (218) - (221 . font-lock-string-face) (274) - (277 . font-lock-string-face) (330) - (333 . font-lock-string-face) (386) - (389 . font-lock-string-face) (442) + (221 . font-lock-string-face) (254) + (271 . font-lock-string-face) (274) + (277 . font-lock-string-face) (310) + (327 . font-lock-string-face) (330) + (333 . font-lock-string-face) (366) + (383 . font-lock-string-face) (386) + (389 . font-lock-string-face) (422) + (439 . font-lock-string-face) (442) (444 . font-lock-string-face) (497) (499 . font-lock-string-face) (552) (555 . font-lock-string-face) (608) diff --git a/test/lisp/sort-tests.el b/test/lisp/sort-tests.el index 7f49cc38d1b..d8d42452ec8 100644 --- a/test/lisp/sort-tests.el +++ b/test/lisp/sort-tests.el @@ -28,7 +28,7 @@ (mapconcat (lambda (_) (string (let ((c (random 52))) (+ (if (> c 25) 71 65) c)))) - (make-list n nil) "")) + (make-list n nil))) (defun sort-tests--insert-words-sort-and-compare (words separator function reverse less-predicate) (with-temp-buffer diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index 3d03057f567..30117132101 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -635,7 +635,7 @@ cf. Bug#25477." (let ((default "foo") res) (cl-letf (((symbol-function 'read-string) (lambda (_prompt &optional _init _hist def _inher-input) def))) - (setq res (read-passwd "pass: " 'confirm (mapconcat #'string default ""))) + (setq res (read-passwd "pass: " 'confirm (mapconcat #'string default))) (should (string= default res))))) (ert-deftest subr-tests--gensym () @@ -968,7 +968,21 @@ See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19350." (insert "Foo bar zot foobar") (should (= (replace-string-in-region "Foo" "new" (point-min)) 1)) - (should (equal (buffer-string) "new bar zot foobar")))) + (should (equal (buffer-string) "new bar zot foobar"))) + + (with-temp-buffer + (insert "foo bar baz") + (should (= (replace-string-in-region "ba" "quux corge grault" (point-min)) + 2)) + (should (equal (buffer-string) + "foo quux corge graultr quux corge graultz"))) + + (with-temp-buffer + (insert "foo bar bar") + (should (= (replace-string-in-region " bar" "" (point-min) 8) + 1)) + (should (equal (buffer-string) + "foo bar")))) (ert-deftest test-replace-regexp-in-region () (with-temp-buffer @@ -991,7 +1005,21 @@ See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19350." (insert "Foo bar zot foobar") (should (= (replace-regexp-in-region "Fo+" "new" (point-min)) 1)) - (should (equal (buffer-string) "new bar zot foobar")))) + (should (equal (buffer-string) "new bar zot foobar"))) + + (with-temp-buffer + (insert "foo bar baz") + (should (= (replace-regexp-in-region "ba." "quux corge grault" (point-min)) + 2)) + (should (equal (buffer-string) + "foo quux corge grault quux corge grault"))) + + (with-temp-buffer + (insert "foo bar bar") + (should (= (replace-regexp-in-region " bar" "" (point-min) 8) + 1)) + (should (equal (buffer-string) + "foo bar")))) (ert-deftest test-with-existing-directory () (let ((dir (make-temp-name "/tmp/not-exist-"))) diff --git a/test/lisp/tabify-tests.el b/test/lisp/tabify-tests.el index eaa3527df07..1c8940c30fe 100644 --- a/test/lisp/tabify-tests.el +++ b/test/lisp/tabify-tests.el @@ -27,9 +27,9 @@ (defun tabify-tests--test-changes (fun changes width) (with-temp-buffer (let ((tab-width width)) - (insert (mapconcat #'car changes "")) + (insert (mapconcat #'car changes)) (funcall fun (point-min) (point-max)) - (should (equal (buffer-string) (mapconcat #'cadr changes "")))))) + (should (equal (buffer-string) (mapconcat #'cadr changes)))))) (ert-deftest tabify-tests-untabify () (let ((changes '(("***\n" "***\n") diff --git a/test/lisp/textmodes/reftex-tests.el b/test/lisp/textmodes/reftex-tests.el index 97ff3908177..67e01004755 100644 --- a/test/lisp/textmodes/reftex-tests.el +++ b/test/lisp/textmodes/reftex-tests.el @@ -334,6 +334,179 @@ And this should be % \\cite{ignored}. #'string<))) (kill-buffer (file-name-nondirectory tex-file))))) +(ert-deftest reftex-renumber-simple-labels () + "Test `reftex-renumber-simple-labels'. +The function must recognize labels defined with macros like +\\label and the ones as key=value option in optional or mandatory +argument of other macros or environments." + (ert-with-temp-directory temp-dir + (let ((tex-file (expand-file-name "renumber.tex" temp-dir))) + (with-temp-buffer + (insert "\ +\\documentclass{article} +\\usepackage{tcolorbox} +\\tcbuselibrary{theorems} +\\usepackage{fancyvrb} +\\usepackage{listings} + +\\begin{document} + +This is with tcolorbox package: +\\begin{problem}[% + colback = white , + colframe = red!50!black , + fonttitle = \\bfseries , + description delimiters = {\\flqq}{\\frqq} , + label = {problem:2}]{Prove RH2}{} + Problem +\\end{problem} + +This is with vanilla \\LaTeX: +\\begin{equation} + \\label{eq:2} + 2 +\\end{equation} +By \\eqref{eq:2} and \\ref{problem:2} + +This is with tcolorbox package: +\\begin{problem}[% + colback=white, + colframe=red!50!black, + fonttitle=\\bfseries, + theorem label supplement={hypertarget={XYZ-##1}}, + theorem full label supplement={code={\\marginnote{##1}}}, + label={problem:1}]{Prove RH1}{} + Problem +\\end{problem} + +This is with vanilla \\LaTeX: +\\begin{equation} + \\label{eq:1} + 1 +\\end{equation} + +\\Cref{problem:1} and \\pageref{eq:1}. + +\\begin{problem}[label={problem:6}]{Some Problem}{} + Problem +\\end{problem} + +\\Ref{problem:6}. + +This is with fancyvrb package: +\\begin{Verbatim}[reflabel={lst:6}] +Some Verb Content +\\end{Verbatim} + +\\pageref{lst:6} + +This is with listings package: +\\begin{lstlisting}[language=elisp,caption=Some Caption,label={lst:3}] +(car (cons 1 '(2))) +\\end{lstlisting} + +\\ref{lst:3} + +\\end{document}") + (write-region (point-min) (point-max) tex-file)) + ;; The label prefix must be known to RefTeX: + (add-to-list 'reftex-label-alist + '("problem" ?p "problem:" "~\\ref{%s}" + nil nil nil) + t) + (add-to-list 'reftex-label-alist + '("Verbatim" ?l "lst:" "~\\ref{%s}" + nil nil nil) + t) + ;; The environments must be known to RefTeX otherwise the labels + ;; aren't parsed correctly: + (add-to-list 'reftex-label-regexps + (concat "\\\\begin{\\(?:problem\\|Verbatim\\)}" + "\\[[^][]*" + "\\(?:{[^}{]*" + "\\(?:{[^}{]*" + "\\(?:{[^}{]*}[^}{]*\\)*" + "}[^}{]*\\)*" + "}[^][]*\\)*" + "\\<\\(?:ref\\)?label[[:space:]]*=[[:space:]]*" + "{?\\(?1:[^] ,}\r\n\t%]+\\)" + "[^]]*\\]") + t) + ;; Always run this after changing `reftex-label-regexps': + (reftex-compile-variables) + (find-file tex-file) + ;; Silence the user query: + (cl-letf (((symbol-function 'yes-or-no-p) #'always)) + (reftex-renumber-simple-labels)) + (should (string= (buffer-string) + "\ +\\documentclass{article} +\\usepackage{tcolorbox} +\\tcbuselibrary{theorems} +\\usepackage{fancyvrb} +\\usepackage{listings} + +\\begin{document} + +This is with tcolorbox package: +\\begin{problem}[% + colback = white , + colframe = red!50!black , + fonttitle = \\bfseries , + description delimiters = {\\flqq}{\\frqq} , + label = {problem:1}]{Prove RH2}{} + Problem +\\end{problem} + +This is with vanilla \\LaTeX: +\\begin{equation} + \\label{eq:1} + 2 +\\end{equation} +By \\eqref{eq:1} and \\ref{problem:1} + +This is with tcolorbox package: +\\begin{problem}[% + colback=white, + colframe=red!50!black, + fonttitle=\\bfseries, + theorem label supplement={hypertarget={XYZ-##1}}, + theorem full label supplement={code={\\marginnote{##1}}}, + label={problem:2}]{Prove RH1}{} + Problem +\\end{problem} + +This is with vanilla \\LaTeX: +\\begin{equation} + \\label{eq:2} + 1 +\\end{equation} + +\\Cref{problem:2} and \\pageref{eq:2}. + +\\begin{problem}[label={problem:3}]{Some Problem}{} + Problem +\\end{problem} + +\\Ref{problem:3}. + +This is with fancyvrb package: +\\begin{Verbatim}[reflabel={lst:1}] +Some Verb Content +\\end{Verbatim} + +\\pageref{lst:1} + +This is with listings package: +\\begin{lstlisting}[language=elisp,caption=Some Caption,label={lst:2}] +(car (cons 1 '(2))) +\\end{lstlisting} + +\\ref{lst:2} + +\\end{document}")) + (kill-buffer (file-name-nondirectory tex-file))))) + ;;; Autoload tests ;; Test to check whether reftex autoloading mechanisms are working diff --git a/test/lisp/whitespace-tests.el b/test/lisp/whitespace-tests.el index 2a59bfe9d80..792e157ec08 100644 --- a/test/lisp/whitespace-tests.el +++ b/test/lisp/whitespace-tests.el @@ -20,8 +20,35 @@ ;;; Code: (require 'ert) +(require 'ert-x) +(require 'faceup) (require 'whitespace) +(defmacro whitespace-tests--with-test-buffer (style &rest body) + "Run BODY in a buffer with `whitespace-mode' style STYLE. +The buffer is displayed in `selected-window', and +`noninteractive' is set to nil even in batch mode." + (declare (debug ((style form) def-body)) + (indent 1)) + `(ert-with-test-buffer-selected () + ;; In case global-*-mode is enabled. + (whitespace-mode -1) + (font-lock-mode -1) + (let ((noninteractive nil) + (whitespace-style ,style)) + (font-lock-mode 1) + (whitespace-mode 1) + ,@body))) + +(defun whitespace-tests--faceup (&rest lines) + "Convenience wrapper around `faceup-test-font-lock-buffer'. +Returns non-nil if the concatenated LINES match the current +buffer's content." + (faceup-test-font-lock-buffer nil (apply #'concat lines))) +(let ((x (get 'faceup-test-font-lock-buffer 'ert-explainer))) + (put 'whitespace-tests--faceup 'ert-explainer + (lambda (&rest lines) (funcall x nil (apply #'concat lines))))) + (defun whitespace-tests--cleanup-string (string) (with-temp-buffer (insert string) @@ -80,6 +107,209 @@ (whitespace-turn-off) buffer-display-table)))))) +(ert-deftest whitespace-tests--empty-bob () + (whitespace-tests--with-test-buffer '(face empty) + (electric-indent-mode -1) + + ;; Insert some empty lines. None of the lines should be + ;; highlighted even though point is on the last line because the + ;; entire buffer is empty lines. + (execute-kbd-macro (kbd "SPC RET C-q TAB RET RET SPC")) + (should (equal (buffer-string) " \n\t\n\n ")) + (should (equal (line-number-at-pos) 4)) + (should (whitespace-tests--faceup " \n" + "\t\n" + "\n" + " ")) + + ;; Adding content on the last line (and keeping point there) + ;; should cause the previous lines to be highlighted. Note that + ;; the `whitespace-empty' face applies to the newline just before + ;; the last line, which has the desired property of extending the + ;; highlight the full width of the window. + (execute-kbd-macro (kbd "x")) + (should (equal (buffer-string) " \n\t\n\n x")) + (should (equal (line-number-at-pos) 4)) + (should (whitespace-tests--faceup "«:whitespace-empty: \n" + "\t\n" + "\n" + "» x")) + + ;; Lines should become un-highlighted as point moves up into the + ;; empty lines. + (execute-kbd-macro (kbd "<up>")) + (should (equal (line-number-at-pos) 3)) + (should (whitespace-tests--faceup "«:whitespace-empty: \n" + "\t\n" + "»\n" + " x")) + (execute-kbd-macro (kbd "<up>")) + (should (equal (line-number-at-pos) 2)) + (should (whitespace-tests--faceup "«:whitespace-empty: \n" + "»\t\n" + "\n" + " x")) + (execute-kbd-macro (kbd "<up> <home>")) + (should (equal (point) 1)) + (should (whitespace-tests--faceup " \n" + "\t\n" + "\n" + " x")) + + ;; Line 1 should be un-highlighted when point is in line 1 even if + ;; point is not bobp. + (execute-kbd-macro (kbd "<right>")) + (should (equal (line-number-at-pos) 1)) + (should (> (point) 1)) + (should (whitespace-tests--faceup " \n" + "\t\n" + "\n" + " x")) + + ;; Make sure lines become re-highlighted as point moves down. + (execute-kbd-macro (kbd "<down>")) + (should (equal (line-number-at-pos) 2)) + (should (whitespace-tests--faceup "«:whitespace-empty: \n" + "»\t\n" + "\n" + " x")) + (execute-kbd-macro (kbd "<down>")) + (should (equal (line-number-at-pos) 3)) + (should (whitespace-tests--faceup "«:whitespace-empty: \n" + "\t\n" + "»\n" + " x")) + (execute-kbd-macro (kbd "<down>")) + (should (equal (line-number-at-pos) 4)) + (should (whitespace-tests--faceup "«:whitespace-empty: \n" + "\t\n" + "\n" + "» x")) + + ;; Inserting content on line 2 should un-highlight lines 2 and 3. + (execute-kbd-macro (kbd "<up> <up> <end>")) + (should (equal (line-number-at-pos) 2)) + (should (equal (- (point) (line-beginning-position)) 1)) + (execute-kbd-macro (kbd "y <down> <down>")) + (should (equal (line-number-at-pos) 4)) + (should (whitespace-tests--faceup "«:whitespace-empty: \n" + "»\ty\n" + "\n" + " x")) + + ;; Removing the content on line 2 should re-highlight lines 2 and + ;; 3. + (execute-kbd-macro (kbd "<up> <up> <end>")) + (should (equal (line-number-at-pos) 2)) + (should (equal (- (point) (line-beginning-position)) 2)) + (execute-kbd-macro (kbd "DEL <down> <down>")) + (should (equal (line-number-at-pos) 4)) + (should (whitespace-tests--faceup "«:whitespace-empty: \n" + "\t\n" + "\n" + "» x")))) + +(ert-deftest whitespace-tests--empty-eob () + (whitespace-tests--with-test-buffer '(face empty) + (electric-indent-mode -1) + + ;; Insert some empty lines. None of the lines should be + ;; highlighted even though point is on line 1 because the entire + ;; buffer is empty lines. + (execute-kbd-macro (kbd "RET RET C-q TAB RET SPC C-<home>")) + (should (equal (buffer-string) "\n\n\t\n ")) + (should (equal (line-number-at-pos) 1)) + (should (whitespace-tests--faceup "\n" + "\n" + "\t\n" + " ")) + + ;; Adding content on the first line (and keeping point there) + ;; should cause the subsequent lines to be highlighted. + (execute-kbd-macro (kbd "x")) + (should (equal (buffer-string) "x\n\n\t\n ")) + (should (equal (line-number-at-pos) 1)) + (should (whitespace-tests--faceup "x\n" + "«:whitespace-empty:\n" + "\t\n" + " »")) + + ;; Lines should become un-highlighted as point moves down into the + ;; empty lines. + (execute-kbd-macro (kbd "<down>")) + (should (equal (line-number-at-pos) 2)) + (should (whitespace-tests--faceup "x\n" + "\n" + "«:whitespace-empty:\t\n" + " »")) + (execute-kbd-macro (kbd "<down>")) + (should (equal (line-number-at-pos) 3)) + (should (whitespace-tests--faceup "x\n" + "\n" + "\t\n" + "«:whitespace-empty: »")) + (execute-kbd-macro (kbd "C-<end>")) + (should (equal (line-number-at-pos) 4)) + (should (eobp)) + (should (equal (- (point) (line-beginning-position)) 1)) + (should (whitespace-tests--faceup "x\n" + "\n" + "\t\n" + " ")) + + ;; The last line should be un-highlighted when point is in that + ;; line even if point is not eobp. + (execute-kbd-macro (kbd "<left>")) + (should (equal (line-number-at-pos) 4)) + (should (not (eobp))) + (should (whitespace-tests--faceup "x\n" + "\n" + "\t\n" + " ")) + + ;; Make sure lines become re-highlighted as point moves up. + (execute-kbd-macro (kbd "<up>")) + (should (equal (line-number-at-pos) 3)) + (should (whitespace-tests--faceup "x\n" + "\n" + "\t\n" + "«:whitespace-empty: »")) + (execute-kbd-macro (kbd "<up>")) + (should (equal (line-number-at-pos) 2)) + (should (whitespace-tests--faceup "x\n" + "\n" + "«:whitespace-empty:\t\n" + " »")) + (execute-kbd-macro (kbd "<up>")) + (should (equal (line-number-at-pos) 1)) + (should (whitespace-tests--faceup "x\n" + "«:whitespace-empty:\n" + "\t\n" + " »")) + + ;; Inserting content on line 3 should un-highlight lines 2 and 3. + (execute-kbd-macro (kbd "<down> <down> <home>")) + (should (equal (line-number-at-pos) 3)) + (should (equal (- (point) (line-beginning-position)) 0)) + (execute-kbd-macro (kbd "y <up> <up>")) + (should (equal (line-number-at-pos) 1)) + (should (whitespace-tests--faceup "x\n" + "\n" + "y\t\n" + "«:whitespace-empty: »")) + + ;; Removing the content on line 3 should re-highlight lines 2 and + ;; 3. + (execute-kbd-macro (kbd "<down> <down> <home>")) + (should (equal (line-number-at-pos) 3)) + (should (equal (- (point) (line-beginning-position)) 0)) + (execute-kbd-macro (kbd "<deletechar> <up> <up>")) + (should (equal (line-number-at-pos) 1)) + (should (whitespace-tests--faceup "x\n" + "«:whitespace-empty:\n" + "\t\n" + " »")))) + (provide 'whitespace-tests) ;;; whitespace-tests.el ends here diff --git a/test/manual/image-tests.el b/test/manual/image-tests.el new file mode 100644 index 00000000000..f867047d08e --- /dev/null +++ b/test/manual/image-tests.el @@ -0,0 +1,270 @@ +;;; image-tests.el --- tests for image.c -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-2022 Free Software Foundation, Inc. + +;; Author: Stefan Kangas <stefankangas@gmail.com> +;; Keywords: internal + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; These tests will only run in a GUI session. You must run them +;; manually in an interactive session with, for example, `M-x +;; eval-buffer' followed by `M-x ert'. +;; +;; To run them from the command line instead, try: +;; ./src/emacs -Q -l test/manual/image-tests.el -eval "(ert t)" + +;;; Code: + +(defmacro image-skip-unless (format &rest condition) + `(skip-unless (or (and (display-images-p) + (image-type-available-p ,format)) + ,@condition))) + +(defconst image-tests--images + `((gif . ,(expand-file-name "test/data/image/black.gif" + source-directory)) + (jpeg . ,(expand-file-name "test/data/image/black.jpg" + source-directory)) + (pbm . ,(find-image '((:file "splash.svg" :type svg)))) + (png . ,(find-image '((:file "splash.png" :type png)))) + (svg . ,(find-image '((:file "splash.pbm" :type pbm)))) + (tiff . ,(expand-file-name + "nextstep/GNUstep/Emacs.base/Resources/emacs.tiff" + source-directory)) + (webp . ,(expand-file-name "test/data/image/black.webp" + source-directory)) + (xbm . ,(find-image '((:file "gnus/gnus.xbm" :type xbm)))) + (xpm . ,(find-image '((:file "splash.xpm" :type xpm)))))) + + +;;;; Load image + +(defmacro image-tests-make-load-image-test (type) + `(ert-deftest ,(intern (format "image-tests-load-image/%s" + (eval type t))) + () + (image-skip-unless ,type) + (let* ((img (cdr (assq ,type image-tests--images))) + (file (if (listp img) + (plist-get (cdr img) :file) + img))) + (find-file file)) + (should (equal major-mode 'image-mode)) + ;; Cleanup + (kill-buffer (current-buffer)))) + +(image-tests-make-load-image-test 'gif) +(image-tests-make-load-image-test 'jpeg) +(image-tests-make-load-image-test 'pbm) +(image-tests-make-load-image-test 'png) +(image-tests-make-load-image-test 'svg) +(image-tests-make-load-image-test 'tiff) +(image-tests-make-load-image-test 'webp) +(image-tests-make-load-image-test 'xbm) +(image-tests-make-load-image-test 'xpm) + +(ert-deftest image-tests-load-image/svg-invalid () + (with-temp-buffer + (let ((messages-buffer-name (buffer-name (current-buffer)))) + (with-temp-buffer + (pop-to-buffer (current-buffer)) + (insert (propertize " " + 'display '(image :data + "invalid foo bar" + :type svg))) + (redisplay)) + ;; librsvg error: "... Start tag expected, '<' not found [3 times]" + (should (string-match "[Ee]rror.+Start tag expected" (buffer-string)))))) + + +;;;; image-test-size + +(declare-function image-size "image.c" (spec &optional pixels frame)) + +(ert-deftest image-tests-image-size/gif () + (image-skip-unless 'gif) + (pcase (image-size (create-image (cdr (assq 'gif image-tests--images)))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/jpeg () + (image-skip-unless 'jpeg) + (pcase (image-size (create-image (cdr (assq 'jpeg image-tests--images)))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/pbm () + (image-skip-unless 'pbm) + (pcase (image-size (cdr (assq 'pbm image-tests--images))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/png () + (image-skip-unless 'png) + (pcase (image-size (cdr (assq 'png image-tests--images))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/svg () + (image-skip-unless 'svg) + (pcase (image-size (cdr (assq 'svg image-tests--images))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/tiff () + (image-skip-unless 'tiff) + (pcase (image-size (create-image (cdr (assq 'tiff image-tests--images)))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/webp () + (image-skip-unless 'webp) + (pcase (image-size (create-image (cdr (assq 'webp image-tests--images)))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/xbm () + (image-skip-unless 'xbm) + (pcase (image-size (cdr (assq 'xbm image-tests--images))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/xpm () + (image-skip-unless 'xpm) + (pcase (image-size (cdr (assq 'xpm image-tests--images))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/error-on-invalid-spec () + (skip-unless (display-images-p)) + (should-error (image-size 'invalid-spec))) + + +;;;; image-mask-p + +(declare-function image-mask-p "image.c" (spec &optional frame)) + +(ert-deftest image-tests-image-mask-p/gif () + (image-skip-unless 'gif) + (should-not (image-mask-p (create-image + (cdr (assq 'gif image-tests--images)))))) + +(ert-deftest image-tests-image-mask-p/jpeg () + (image-skip-unless 'jpeg) + (should-not (image-mask-p (create-image + (cdr (assq 'jpeg image-tests--images)))))) + +(ert-deftest image-tests-image-mask-p/pbm () + (image-skip-unless 'pbm) + (should-not (image-mask-p (cdr (assq 'pbm image-tests--images))))) + +(ert-deftest image-tests-image-mask-p/png () + (image-skip-unless 'png) + (should-not (image-mask-p (cdr (assq 'png image-tests--images))))) + +(ert-deftest image-tests-image-mask-p/svg () + (image-skip-unless 'svg) + (should-not (image-mask-p (cdr (assq 'svg image-tests--images))))) + +(ert-deftest image-tests-image-mask-p/tiff () + (image-skip-unless 'tiff) + (should-not (image-mask-p (create-image + (cdr (assq 'tiff image-tests--images)))))) + +(ert-deftest image-tests-image-mask-p/webp () + (image-skip-unless 'webp) + (should-not (image-mask-p (create-image + (cdr (assq 'webp image-tests--images)))))) + +(ert-deftest image-tests-image-mask-p/xbm () + (image-skip-unless 'xbm) + (should-not (image-mask-p (cdr (assq 'xbm image-tests--images))))) + +(ert-deftest image-tests-image-mask-p/xpm () + (image-skip-unless 'xpm) + (should-not (image-mask-p (cdr (assq 'xpm image-tests--images))))) + +(ert-deftest image-tests-image-mask-p/error-on-invalid-spec () + (skip-unless (display-images-p)) + (should-error (image-mask-p 'invalid-spec))) + + +;;;; image-metadata + +(declare-function image-metadata "image.c" (spec &optional frame)) + +;; TODO: These tests could be expanded with files that actually +;; contain metadata. + +(ert-deftest image-tests-image-metadata/gif () + (image-skip-unless 'gif (not w32-use-native-image-API)) + (should (memq 'delay + (image-metadata + (create-image (cdr (assq 'gif image-tests--images))))))) + +(ert-deftest image-tests-image-metadata/jpeg () + (image-skip-unless 'jpeg) + (should-not (image-metadata + (create-image (cdr (assq 'jpeg image-tests--images)))))) + +(ert-deftest image-tests-image-metadata/pbm () + (image-skip-unless 'pbm) + (should-not (image-metadata (cdr (assq 'pbm image-tests--images))))) + +(ert-deftest image-tests-image-metadata/png () + (image-skip-unless 'png) + (should-not (image-metadata (cdr (assq 'png image-tests--images))))) + +(ert-deftest image-tests-image-metadata/svg () + (image-skip-unless 'svg) + (should-not (image-metadata (cdr (assq 'svg image-tests--images))))) + +(ert-deftest image-tests-image-metadata/tiff () + (image-skip-unless 'tiff) + (should-not (image-metadata + (create-image (cdr (assq 'tiff image-tests--images)))))) + +(ert-deftest image-tests-image-metadata/webp () + (image-skip-unless 'webp) + (should (memq 'delay + (image-metadata + (create-image (cdr (assq 'webp image-tests--images))))))) + +(ert-deftest image-tests-image-metadata/xbm () + (image-skip-unless 'xbm) + (should-not (image-metadata (cdr (assq 'xbm image-tests--images))))) + +(ert-deftest image-tests-image-metadata/xpm () + (image-skip-unless 'xpm) + (should-not (image-metadata (cdr (assq 'xpm image-tests--images))))) + +(ert-deftest image-tests-image-metadata/nil-on-invalid-spec () + (skip-unless (display-images-p)) + (should-not (image-metadata 'invalid-spec))) + +;;; image-size-tests.el ends here diff --git a/test/src/casefiddle-tests.el b/test/src/casefiddle-tests.el index eb096f21129..652af417293 100644 --- a/test/src/casefiddle-tests.el +++ b/test/src/casefiddle-tests.el @@ -57,7 +57,7 @@ errors))) (setq expected (cdr expected))))) (when errors - (ert-fail (mapconcat (lambda (line) line) (nreverse errors) ""))))) + (ert-fail (mapconcat #'identity (nreverse errors)))))) (defconst casefiddle-tests--characters @@ -98,7 +98,7 @@ errors))) (setq props (cdr props) tabs (cdr tabs) expected (cdr expected))))) (when errors - (mapconcat (lambda (line) line) (nreverse errors) ""))))) + (mapconcat #'identity (nreverse errors)))))) (ert-deftest casefiddle-tests-casing-character () @@ -116,7 +116,7 @@ errors))) (setq funcs (cdr funcs) expected (cdr expected))))) (when errors - (mapconcat (lambda (line) line) (nreverse errors) ""))))) + (mapconcat (lambda (line) line) (nreverse errors)))))) (ert-deftest casefiddle-tests-casing-word () diff --git a/test/src/data-tests.el b/test/src/data-tests.el index 0f84b2fb776..463a894d095 100644 --- a/test/src/data-tests.el +++ b/test/src/data-tests.el @@ -200,8 +200,7 @@ this is exactly representable and is greater than nibbles) (setf v (nthcdr 4 v))) (mapconcat (lambda (n) (format "%X" n)) - (nreverse nibbles) - ""))) + (nreverse nibbles)))) (defun test-bool-vector-count-consecutive-tc (desc) "Run a test case for `bool-vector-count-consecutive'. diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el index 4ef428af03e..fe8df7097a7 100644 --- a/test/src/fns-tests.el +++ b/test/src/fns-tests.el @@ -614,9 +614,9 @@ (should (string= (mapconcat #'identity '("Ä" "ø" "☭" "தமிழ்") "_漢字_") "Ä_漢字_ø_漢字_☭_漢字_தமிழ்")) ;; vector - (should (string= (mapconcat #'identity ["a" "b"] "") "ab")) + (should (string= (mapconcat #'identity ["a" "b"]) "ab")) ;; bool-vector - (should (string= (mapconcat #'identity [nil nil] "") "")) + (should (string= (mapconcat #'identity [nil nil]) "")) (should-error (mapconcat #'identity [nil nil t]) :type 'wrong-type-argument)) diff --git a/test/src/image-tests.el b/test/src/image-tests.el index 36278f4b9fa..bf79faca52e 100644 --- a/test/src/image-tests.el +++ b/test/src/image-tests.el @@ -19,25 +19,13 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. -;;; Commentary: - -;; Most of these tests will only run in a GUI session, and not with -;; "make check". Run them manually in an interactive session with -;; `M-x eval-buffer' followed by `M-x ert'. - ;;; Code: (require 'ert) -(defmacro image-skip-unless (format) - `(skip-unless (and (display-images-p) - (image-type-available-p ,format)))) - -;;;; Images - (defconst image-tests--images `((gif . ,(expand-file-name "test/data/image/black.gif" - source-directory)) + source-directory)) (jpeg . ,(expand-file-name "test/data/image/black.jpg" source-directory)) (pbm . ,(find-image '((:file "splash.svg" :type svg)))) @@ -51,197 +39,23 @@ (xbm . ,(find-image '((:file "gnus/gnus.xbm" :type xbm)))) (xpm . ,(find-image '((:file "splash.xpm" :type xpm)))))) -;;;; image-test-size - -(declare-function image-size "image.c" (spec &optional pixels frame)) - -(ert-deftest image-tests-image-size/gif () - (image-skip-unless 'gif) - (pcase (image-size (create-image (cdr (assq 'gif image-tests--images)))) - (`(,a . ,b) - (should (floatp a)) - (should (floatp b))))) - -(ert-deftest image-tests-image-size/jpeg () - (image-skip-unless 'jpeg) - (pcase (image-size (create-image (cdr (assq 'jpeg image-tests--images)))) - (`(,a . ,b) - (should (floatp a)) - (should (floatp b))))) - -(ert-deftest image-tests-image-size/pbm () - (image-skip-unless 'pbm) - (pcase (image-size (cdr (assq 'pbm image-tests--images))) - (`(,a . ,b) - (should (floatp a)) - (should (floatp b))))) - -(ert-deftest image-tests-image-size/png () - (image-skip-unless 'png) - (pcase (image-size (cdr (assq 'png image-tests--images))) - (`(,a . ,b) - (should (floatp a)) - (should (floatp b))))) - -(ert-deftest image-tests-image-size/svg () - (image-skip-unless 'svg) - (pcase (image-size (cdr (assq 'svg image-tests--images))) - (`(,a . ,b) - (should (floatp a)) - (should (floatp b))))) - -(ert-deftest image-tests-image-size/tiff () - (image-skip-unless 'tiff) - (pcase (image-size (create-image (cdr (assq 'tiff image-tests--images)))) - (`(,a . ,b) - (should (floatp a)) - (should (floatp b))))) - -(ert-deftest image-tests-image-size/webp () - (image-skip-unless 'webp) - (pcase (image-size (create-image (cdr (assq 'webp image-tests--images)))) - (`(,a . ,b) - (should (floatp a)) - (should (floatp b))))) - -(ert-deftest image-tests-image-size/xbm () - (image-skip-unless 'xbm) - (pcase (image-size (cdr (assq 'xbm image-tests--images))) - (`(,a . ,b) - (should (floatp a)) - (should (floatp b))))) - -(ert-deftest image-tests-image-size/xpm () - (image-skip-unless 'xpm) - (pcase (image-size (cdr (assq 'xpm image-tests--images))) - (`(,a . ,b) - (should (floatp a)) - (should (floatp b))))) - -(ert-deftest image-tests-image-size/error-on-invalid-spec () - (skip-unless (display-images-p)) - (should-error (image-size 'invalid-spec))) - (ert-deftest image-tests-image-size/error-on-nongraphical-display () (skip-unless (not (display-images-p))) (should-error (image-size 'invalid-spec))) -;;;; image-mask-p - -(declare-function image-mask-p "image.c" (spec &optional frame)) - -(ert-deftest image-tests-image-mask-p/gif () - (image-skip-unless 'gif) - (should-not (image-mask-p (create-image - (cdr (assq 'gif image-tests--images)))))) - -(ert-deftest image-tests-image-mask-p/jpeg () - (image-skip-unless 'jpeg) - (should-not (image-mask-p (create-image - (cdr (assq 'jpeg image-tests--images)))))) - -(ert-deftest image-tests-image-mask-p/pbm () - (image-skip-unless 'pbm) - (should-not (image-mask-p (cdr (assq 'pbm image-tests--images))))) - -(ert-deftest image-tests-image-mask-p/png () - (image-skip-unless 'png) - (should-not (image-mask-p (cdr (assq 'png image-tests--images))))) - -(ert-deftest image-tests-image-mask-p/svg () - (image-skip-unless 'svg) - (should-not (image-mask-p (cdr (assq 'svg image-tests--images))))) - -(ert-deftest image-tests-image-mask-p/tiff () - (image-skip-unless 'tiff) - (should-not (image-mask-p (create-image - (cdr (assq 'tiff image-tests--images)))))) - -(ert-deftest image-tests-image-mask-p/webp () - (image-skip-unless 'webp) - (should-not (image-mask-p (create-image - (cdr (assq 'webp image-tests--images)))))) - -(ert-deftest image-tests-image-mask-p/xbm () - (image-skip-unless 'xbm) - (should-not (image-mask-p (cdr (assq 'xbm image-tests--images))))) - -(ert-deftest image-tests-image-mask-p/xpm () - (image-skip-unless 'xpm) - (should-not (image-mask-p (cdr (assq 'xpm image-tests--images))))) - -(ert-deftest image-tests-image-mask-p/error-on-invalid-spec () - (skip-unless (display-images-p)) - (should-error (image-mask-p 'invalid-spec))) - (ert-deftest image-tests-image-mask-p/error-on-nongraphical-display () (skip-unless (not (display-images-p))) (should-error (image-mask-p (cdr (assq 'xpm image-tests--images))))) -;;;; image-metadata - -(declare-function image-metadata "image.c" (spec &optional frame)) - -;; TODO: These tests could be expanded with files that actually -;; contain metadata. - -(ert-deftest image-tests-image-metadata/gif () - (image-skip-unless 'gif) - (should-not (image-metadata - (create-image (cdr (assq 'gif image-tests--images)))))) - -(ert-deftest image-tests-image-metadata/jpeg () - (image-skip-unless 'jpeg) - (should-not (image-metadata - (create-image (cdr (assq 'jpeg image-tests--images)))))) - -(ert-deftest image-tests-image-metadata/pbm () - (image-skip-unless 'pbm) - (should-not (image-metadata (cdr (assq 'pbm image-tests--images))))) - -(ert-deftest image-tests-image-metadata/png () - (image-skip-unless 'png) - (should-not (image-metadata (cdr (assq 'png image-tests--images))))) - -(ert-deftest image-tests-image-metadata/svg () - (image-skip-unless 'svg) - (should-not (image-metadata (cdr (assq 'svg image-tests--images))))) - -(ert-deftest image-tests-image-metadata/tiff () - (image-skip-unless 'tiff) - (should-not (image-metadata - (create-image (cdr (assq 'tiff image-tests--images)))))) - -(ert-deftest image-tests-image-metadata/webp () - (image-skip-unless 'webp) - (should-not (image-metadata - (create-image (cdr (assq 'webp image-tests--images)))))) - -(ert-deftest image-tests-image-metadata/xbm () - (image-skip-unless 'xbm) - (should-not (image-metadata (cdr (assq 'xbm image-tests--images))))) - -(ert-deftest image-tests-image-metadata/xpm () - (image-skip-unless 'xpm) - (should-not (image-metadata (cdr (assq 'xpm image-tests--images))))) - -(ert-deftest image-tests-image-metadata/nil-on-invalid-spec () - (skip-unless (display-images-p)) - (should-not (image-metadata 'invalid-spec))) - (ert-deftest image-tests-image-metadata/error-on-nongraphical-display () (skip-unless (not (display-images-p))) (should-error (image-metadata (cdr (assq 'xpm image-tests--images))))) -;;;; ImageMagick - (ert-deftest image-tests-imagemagick-types () (skip-unless (fboundp 'imagemagick-types)) (when (fboundp 'imagemagick-types) (should (listp (imagemagick-types))))) -;;;; Initialization - (ert-deftest image-tests-init-image-library () (skip-unless (fboundp 'init-image-library)) (declare-function init-image-library "image.c" (type)) diff --git a/test/src/print-tests.el b/test/src/print-tests.el index 5c349342eb3..faab196f22f 100644 --- a/test/src/print-tests.el +++ b/test/src/print-tests.el @@ -190,7 +190,8 @@ otherwise, use a different charset." "Printing observes `print-continuous-numbering'." ;; cl-print does not support print-continuous-numbering. :expected-result (if (eq (symbol-function #'print-tests--prin1-to-string) - #'cl-prin1-to-string) :failed :passed) + #'cl-prin1-to-string) + :failed :passed) (let* ((x (list 1)) (y "hello") (g (gensym)) @@ -201,7 +202,8 @@ otherwise, use a different charset." (print-number-table nil)) (should (string-match "(#1=(1) #1# #2=\"hello\" #2#)(#3=#:g[[:digit:]]+ #3#)(#1# #2# #3#)#2#$" - (mapconcat #'print-tests--prin1-to-string `((,x ,x ,y ,y) (,g ,g) (,x ,y ,g) ,y) "")))) + (mapconcat #'print-tests--prin1-to-string + `((,x ,x ,y ,y) (,g ,g) (,x ,y ,g) ,y))))) ;; This is the special case for byte-compile-output-docform ;; mentioned in a comment in print_preprocess. When diff --git a/test/src/process-tests.el b/test/src/process-tests.el index 6e1e148332c..7d3d9eb72b8 100644 --- a/test/src/process-tests.el +++ b/test/src/process-tests.el @@ -134,12 +134,12 @@ process to complete." (should (equal 1 (with-current-buffer stdout-buffer (point-max)))) (should (equal "hello stdout!\n" - (mapconcat #'identity (nreverse stdout-output) ""))) + (mapconcat #'identity (nreverse stdout-output)))) (should stderr-sentinel-called) (should (equal 1 (with-current-buffer stderr-buffer (point-max)))) (should (equal "hello stderr!\n" - (mapconcat #'identity (nreverse stderr-output) "")))))) + (mapconcat #'identity (nreverse stderr-output))))))) (ert-deftest set-process-filter-t () "Test setting process filter to t and back." ;; Bug#36591 |