diff options
168 files changed, 4861 insertions, 4523 deletions
diff --git a/CONTRIBUTE b/CONTRIBUTE index d624fe85245..94d757daafe 100644 --- a/CONTRIBUTE +++ b/CONTRIBUTE @@ -347,7 +347,10 @@ tests: If committing changes written by someone else, commit in their name, not yours. You can use 'git commit --author="AUTHOR"' to specify a -change's author. Note that the validity checks described in the +change's author. When using Emacs VC to commit, the author can be +specified in the log-edit buffer by adding an "Author: AUTHOR" header +line (set 'log-edit-setup-add-author' non-nil to have this header line +added automatically). Note that the validity checks described in the previous section are still applied, so you will have to correct any problems they uncover in the changes submitted by others. diff --git a/ChangeLog.3 b/ChangeLog.3 index 0eabd57bc56..a75c7963b68 100644 --- a/ChangeLog.3 +++ b/ChangeLog.3 @@ -1,3 +1,361 @@ +2022-07-28 Lars Ingebrigtsen <larsi@gnus.org> + + Revert the `...' documentation back to actual usage + + * doc/lispref/tips.texi (Documentation Tips): Document how `...' + is really used now (bug#55780). ‘...’ is not really used in the + Emacs sources. + + (cherry picked from commit 1ed9c1c7f9fe32ff5123091033350beb1ccae4ca) + +2022-07-28 Paul Pogonyshev <pogonyshev@gmail.com> + + Release the desktop lock in 'kill-emacs-hook' + + * lisp/desktop.el: Run 'desktop--on-kill' in 'kill-emacs-hook'. + (desktop--on-kill): New function, refactored from 'desktop-kill'. + (desktop-kill): Call 'desktop--on-kill'. (Bug#56800) + +2022-07-25 Eli Zaretskii <eliz@gnu.org> + + Avoid infloop in 'recenter' + + * src/window.c (Frecenter): Avoid infinite loop in the minibuffer + under 'fido-vertical-mode'. (Bug#56765) + +2022-07-25 Eli Zaretskii <eliz@gnu.org> + + Fix inaccuracies in "lax search" documentation + + * doc/emacs/search.texi (Lax Search): Update the examples of + character folding in search. (Bug#56747) + +2022-07-24 Kyle Meyer <kyle@kyleam.com> + + Update to Org 9.5.4-17-g6e991f + +2022-07-24 Eugene Ha <eha@posteo.de> (tiny change) + + Find libgccjit.dylib on Homebrew Macos + + * configure.ac: Also find libggcjit on Homebrew (bug#55173). + + (cherry picked from commit faa29fa2c9e9d5a5d7544a1a39b2a89cf57a8439) + +2022-07-23 Michael Albinus <michael.albinus@gmx.de> + + Set `default-directory' of Tramp archive connection buffer + + * lisp/net/tramp-archive.el (tramp-archive-file-name-handler): + Set `default-directory' of Tramp connection buffer. (Bug#56628) + +2022-07-23 Eli Zaretskii <eliz@gnu.org> + + Update the documentation of 'declare' forms + + * doc/lispref/compile.texi (Native-Compilation Variables): Mention + the 'declare' alternative for 'native-comp-speed'. + * doc/lispref/functions.texi (Declare Form): Document 'declare' + forms that were previously undocumented. + +2022-07-23 Eli Zaretskii <eliz@gnu.org> + + Fix bookmark support for Help functions in native-compilation builds + + * lisp/help.el (describe-key--helper, describe-function--helper): + New helper functions. + (describe-key): Call 'describe-key--helper' instead of a + lambda-function. + * lisp/help-fns.el (describe-function): Call + 'describe-function--helper' instead of a lambda-function. + (Bug#56643) + +2022-07-23 Miha Rihtarsic <miha@kamnitnik.top> + + Fix mode line mouse-1 binding when showing only column numbers + + * lisp/bindings.el (mode-line-position): Fix the mouse-1 binding + when showing only column numbers (bug#56694). Do not merge to + master. + +2022-07-23 Stefan Kangas <stefan@marxist.se> + + Adjust help-fns.el tests for recent change + + * test/lisp/help-fns-tests.el (help-fns-test-lisp-defun) + (help-fns-test-lisp-defsubst): Adjust tests for recent change. + +2022-07-22 Robert Pluim <rpluim@gmail.com> + + * src/terminal.c (Fframe_terminal): Use active voice + +2022-07-22 Robert Pluim <rpluim@gmail.com> + + Improve 'terminal-live-p' docstring some more + + * src/terminal.c (Fterminal_live_p): Improve description of + arguments and return value. + +2022-07-22 Robert Pluim <rpluim@gmail.com> + + Improve terminal-live-p docstring + + * src/terminal.c (Fterminal_live_p): Explain what happens when the + argument is nil. + +2022-07-22 Robert Pluim <rpluim@gmail.com> + + * lisp/net/tramp-gvfs.el (tramp-gvfs-dbus-event-vector): Fix grammar + +2022-07-21 Stefan Kangas <stefan@marxist.se> + + * lisp/progmodes/cperl-mode.el: Don't mention obsolete archive. + +2022-07-21 Eli Zaretskii <eliz@gnu.org> + + Make 'describe-function' say "byte-compiled" when appropriate + + * lisp/help-fns.el (help-fns-function-description-header): Say + "byte-compiled" when describing byte-compiled functions. + +2022-07-21 Eli Zaretskii <eliz@gnu.org> + + ;Improve documentation of locale-specific string comparison + + * doc/lispref/strings.texi (Text Comparison): Mention the Unicode + collation rules and buffer-local case-tables. + +2022-07-19 Gerd Moellmann <gerd.moellmann@gmail.com> + + Prevent GC of window referenced from EmacsScroller + + * src/nsterm.m (EmacsScroller.mark, mark_nsterm): New functions. + * src/nsterm.h (EmacsScroller.mark, mark_nsterm): Declare. + * src/alloc.c (garbage_collect) [MAVE_NS]: Call mark_nsterm. + (Bug#56095) + + (cherry picked from commit 5f1bd872478927ad4bc635502e74628d39885286) + +2022-07-16 Stefan Kangas <stefan@marxist.se> + + Fix obsoletion of nntp-authinfo-file + + * lisp/gnus/nntp.el (nntp-authinfo-file): Fix obsoletion. + +2022-07-15 Philipp Stephani <phst@google.com> + + Build Seccomp filter only if we have a 64-bit userspace (Bug#56549) + + * configure.ac (SIZEOF_LONG): New variable. + * lib-src/Makefile.in (SIZEOF_LONG): New variable; added conditional. + +2022-07-14 Stefan Kangas <stefan@marxist.se> + + Update the Samaritan's contact details in M-x doctor + + * lisp/play/doctor.el (doctor-death): Update the Samaritans's contact + details; anon.twwells.com is no longer valid. Add link to Wikipedia. + +2022-07-14 Eli Zaretskii <eliz@gnu.org> + + * etc/PROBLEMS: Describe problems with remote files. (Bug#56499) + +2022-07-13 Andrea Corallo <akrl@sdf.org> + + Remove uneffective test + + * test/src/comp-tests.el (45603-1): Remove test. + * test/src/comp-resources/comp-test-45603.el: Delete. + +2022-07-13 Andrea Corallo <akrl@sdf.org> + + Mark async worker tmp file as utf-8-emacs-unix (bug#48029) + + * lisp/emacs-lisp/comp.el (comp-final): Mark async worker tmp file + as utf-8. + * test/src/comp-tests.el (48029-1): New test. + * test/src/comp-resources/comp-test-funcs.el + (comp-test-48029-nonascii-žžž-f): New function. + +2022-07-13 Michael Albinus <michael.albinus@gmx.de> + + Adapt Tramp version (don't merge) + + * doc/misc/trampver.texi: + * lisp/net/trampver.el: Change version to "2.5.3.28.2". + (customize-package-emacs-version-alist): + Add Tramp version integrated in Emacs 28.2. + +2022-07-13 Michael Albinus <michael.albinus@gmx.de> + + Adapt Tramp doc + + * doc/misc/tramp.texi (Configuration): Mention enable-remote-dir-locals. + (Traces and Profiles): Fix tramp-verbose description. + + * lisp/net/tramp.el (tramp-verbose): Fix docstring. + +2022-07-12 Stefan Kangas <stefan@marxist.se> + + Don't mention cl-cXXXr aliases in cl-lib manual + + * doc/misc/cl.texi (Lists, List Functions, Efficiency Concerns): Don't + mention 'cl-cXXXr' compatibility aliases for built-in 'cXXXr' + functions. They shouldn't be used in new code. + +2022-07-11 Ken Brown <kbrown@cornell.edu> + + etc/PROBLEMS: Describe issues with native compilation on Cygwin + +2022-07-11 Stefan Kangas <stefan@marxist.se> + + * lisp/find-dired.el (find-dired): Doc fix; add crossreference. + +2022-07-08 Stefan Kangas <stefan@marxist.se> + + Doc fix; don't mention obsolete variable + + * src/window.c (Fset_window_hscroll): Doc fix; don't mention obsolete + variable. + +2022-07-05 Stefan Kangas <stefan@marxist.se> + + Add index entry for "ignore case" + + * doc/emacs/glossary.texi (Glossary): Add index entry for "ignore + case" pointing to "Case Folding". + +2022-07-05 Stefan Kangas <stefan@marxist.se> + + Expand docstrings related to auto-saving + + * lisp/files.el (auto-save-visited-mode): + * lisp/simple.el (auto-save-mode): Expand docstring. + +2022-07-04 Lars Ingebrigtsen <larsi@gnus.org> + + Don't bug out in manual-html-fix-index-2 on newer makeinfo versions + + Backport from master. + + * admin/admin.el (manual-html-fix-index-2): Don't bug out if the + makeinfo version doesn't include <ul>. + + (cherry picked from commit e0e3f2b672bc42da52ac9c7596c7560a88684651) + +2022-07-04 Lars Ingebrigtsen <larsi@gnus.org> + + Preserve <title> in the Emacs manuals + + Backport from master. + + * admin/admin.el (manual-html-fix-headers): Preserve the <title> + element (bug#48334). + + (cherry picked from commit b778e71af7ca8c59917334b4bb1b34cdb52faca9) + +2022-07-03 Eli Zaretskii <eliz@gnu.org> + + Document 'jit-lock-debug-mode' + + * doc/lispref/modes.texi (Other Font Lock Variables): Document + 'jit-lock-debug-mode'. + +2022-07-02 Alan Mackenzie <acm@muc.de> + + * lisp/progmodes/cc-mode.el (c-common-init): Bind case-fold-search to nil + + Backport: This fixes bug #53605. + +2022-07-02 Alan Mackenzie <acm@muc.de> + + CC Mode: Fix a c-backward-token-2 call wrongly jumping back over macros. + + This fixes bug #56256. + + * lisp/progmodes/cc-fonts.el (c-font-lock-c++-lambda-captures): Replace a + c-backward-token-2, which could jump back too far leading to an infinite + loop, with a save-excursion to remember the point we've got to go back to. + +2022-07-02 Stefan Kangas <stefan@marxist.se> + + Doc fixes; don't use obsolete names + + * etc/compilation.txt: + * lisp/mh-e/mh-funcs.el (mh-kill-folder): Don't use obsolete + names. + +2022-07-02 Stefan Kangas <stefan@marxist.se> + + Don't refer to obsolete alias for insert-char + + * lisp/leim/quail/persian.el: Don't refer to obsolete alias for + insert-char. + +2022-07-02 Stefan Kangas <stefan@marxist.se> + + Don't use obsolete face name in manoj-dark-theme + + * etc/themes/manoj-dark-theme.el (change-log-acknowledgment): Don't + use obsolete/non-existent face name. + +2022-07-01 Eli Zaretskii <eliz@gnu.org> + + Fix "C-u C-x =" for SPC + + * lisp/descr-text.el (describe-char): Don't report 'nobreak-space' + face for SPC. (Bug#56337) + +2022-06-30 Stefan Kangas <stefan@marxist.se> + + Doc fixes: don't refer to some obsolete items + + * admin/notes/multi-tty: + * lisp/chistory.el (command-history): + * lisp/emacs-lisp/nadvice.el: + * lisp/vc/diff-mode.el: Doc fix; don't refer to obsolete variables and + functions. + +2022-06-30 Stefan Kangas <stefan@marxist.se> + + Remove obsolete cust-print from elisp index + + * doc/lispref/edebug.texi (Printing in Edebug): Remove obsolete + library "cust-print" from index. + +2022-06-30 Stefan Kangas <stefan@marxist.se> + + * admin/make-tarball.txt: Minor clarifications. + +2022-06-30 Eli Zaretskii <eliz@gnu.org> + + Fix external image conversion on MS-Windows + + * lisp/image/image-converter.el (image-converter--convert-magick) + (image-converter--convert): Force encoding/decoding to avoid any + text or EOL conversions, since we are reading/writing binary + data. (Bug#56317) + +2022-06-29 Stefan Monnier <monnier@iro.umontreal.ca> + + * doc/emacs/buffers.texi (Indirect Buffers): Mention modification hook quirk + +2022-06-29 Stefan Kangas <stefan@marxist.se> + + Bump Emacs version to 28.1.90 + + * README: + * configure.ac: + * msdos/sed2v2.inp: + * nt/README.W32: Bump Emacs version to 28.1.90. + +2022-06-29 Stefan Kangas <stefan@marxist.se> + + Update ChangeLog and AUTHORS for 28.1.90 pretest + + * ChangeLog.3: + * etc/AUTHORS: Update. + 2022-06-29 Michael Albinus <michael.albinus@gmx.de> Update Tramp version (don't merge with master) @@ -236200,7 +236558,7 @@ This file records repository revisions from commit 9d56a21e6a696ad19ac65c4b405aeca44785884a (exclusive) to -commit 7f749e44dbd50430e14f319b4c4d3f767740b10b (inclusive). +commit 05df70e755f72b7a4c7b7d94ca2349f1c5c67968 (inclusive). See ChangeLog.2 for earlier changes. ;; Local Variables: diff --git a/admin/authors.el b/admin/authors.el index 8a62520d6c5..de43d914544 100644 --- a/admin/authors.el +++ b/admin/authors.el @@ -163,6 +163,7 @@ files.") ("Michael R. Cook" "Michael Cook") ("Michael Sperber" "Mike Sperber" "Michael Sperber \\[Mr. Preprocessor\\]") ("Michalis V" "^mvar") + ("Miha Rihtaršič" "Miha Rihtarsic") ("Mikio Nakajima" "Nakajima Mikio") ("Nelson Jose dos Santos Ferreira" "Nelson Ferreira") ("Noorul Islam" "Noorul Islam K M") diff --git a/doc/emacs/custom.texi b/doc/emacs/custom.texi index 46a2291b74d..6ed43bcb790 100644 --- a/doc/emacs/custom.texi +++ b/doc/emacs/custom.texi @@ -511,6 +511,9 @@ Set up a customization buffer for just one user option, @var{option}. @item M-x customize-face @key{RET} @var{face} @key{RET} Set up a customization buffer for just one face, @var{face}. +@item M-x customize-icon @key{RET} @var{face} @key{RET} +Set up a customization buffer for just one icon, @var{icon}. + @item M-x customize-group @key{RET} @var{group} @key{RET} Set up a customization buffer for just one group, @var{group}. diff --git a/doc/emacs/display.texi b/doc/emacs/display.texi index 96e05a902d6..b87ca81faea 100644 --- a/doc/emacs/display.texi +++ b/doc/emacs/display.texi @@ -24,6 +24,7 @@ the text is displayed. * Faces:: How to change the display style using faces. * Colors:: Specifying colors for faces. * Standard Faces:: The main predefined faces. +* Icons:: How to change how icons look. * Text Scale:: Increasing or decreasing text size in a buffer. * Font Lock:: Minor mode for syntactic highlighting using faces. * Highlight Interactively:: Tell Emacs what text to highlight. @@ -851,6 +852,38 @@ This face is used to display on text-mode terminals the menu item that would be selected if you click a mouse or press @key{RET}. @end table +@node Icons +@section Icons + +Emacs sometimes displays clickable buttons (or other informative +icons), and the look of these can be customized by the user. + +@vindex icon-preference +The main customization point here is the @code{icon-preference} user +option. By using this, you can tell Emacs your overall preferences +for icons. This is a list of icon types, and the first icon type +that's supported will be used. The supported types are: + +@table @code +@item image +Use an image for the icon. + +@item emoji +Use a colorful emoji for the icon. + +@item symbol +Use a monochrome symbol for the icon. + +@item text +Use a simple text for the icon. +@end table + +In addition, each individual icon can be customized with @kbd{M-x +customize-icon}, and themes can further alter the looks of the icons. + +To get a quick description of an icon, use the @kbd{M-x describe-icon} +command. + @node Text Scale @section Text Scale diff --git a/doc/emacs/search.texi b/doc/emacs/search.texi index f4e12d29e99..27d4db85412 100644 --- a/doc/emacs/search.texi +++ b/doc/emacs/search.texi @@ -1428,16 +1428,18 @@ of its accented cousins like @code{@"a} and @code{@'a}, i.e., the match disregards the diacritics that distinguish these variants. In addition, @code{a} matches other characters that resemble it, or have it as part of their graphical representation, -such as U+249C @sc{parenthesized latin small letter a} and U+2100 -@sc{account of} (which looks like a small @code{a} over @code{c}). +such as U+00AA @sc{feminine ordinal indicator} and U+24D0 +@sc{circled latin small letter a} (which looks like a small @code{a} +inside a circle). Similarly, the @acronym{ASCII} double-quote character @code{"} matches all the other variants of double quotes defined by the Unicode standard. Finally, character folding can make a sequence of one or more characters match another sequence of a different length: for example, the sequence of two characters @code{ff} matches U+FB00 -@sc{latin small ligature ff}. Character sequences that are not identical, -but match under character folding are known as @dfn{equivalent -character sequences}. +@sc{latin small ligature ff} and the sequence @code{(a)} matches +U+249C @sc{parenthesized latin small letter a}. Character sequences +that are not identical, but match under character folding are known as +@dfn{equivalent character sequences}. @kindex M-s ' @r{(Incremental Search)} @findex isearch-toggle-char-fold diff --git a/doc/lispref/compile.texi b/doc/lispref/compile.texi index 9bb7b590a2c..60fc11a22ed 100644 --- a/doc/lispref/compile.texi +++ b/doc/lispref/compile.texi @@ -981,7 +981,9 @@ corresponding compiler @option{-O0}, @option{-O1}, etc.@: command-line options of the compiler. The value @minus{}1 means disable native-compilation: functions and files will be only byte-compiled; however, the @file{*.eln} files will still be produced, they will just -contain the compiled code in bytecode form. +contain the compiled code in bytecode form. (This can be achieved at +function granularity by using the @w{@code{(declare (speed -1))}} +form, @pxref{Declare Form}.) The default value is 2. @end defopt diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index f5fb0aaee70..d2e075c54ec 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -27,6 +27,7 @@ that Emacs presents to the user. * Window Dividers:: Separating windows visually. * Display Property:: Images, margins, text size, etc. * Images:: Displaying images in Emacs buffers. +* Icons:: Displaying icons in Emacs buffers. * Xwidgets:: Displaying native widgets in Emacs buffers. * Buttons:: Adding clickable buttons to Emacs buffers. * Abstract Display:: Emacs's Widget for Object Collections. @@ -6985,6 +6986,165 @@ bytes. An image of size 200x100 with 24 bits per color will have a cache size of 60000 bytes, for instance. @end defun +@node Icons +@section Icons + +Emacs sometimes uses buttons (for clicking on) or small graphics (to +illustrate something). Since Emacs is available on a wide variety of +systems with different capabilities, and users have different +preferences, Emacs provides a facility to handle this in a convenient +way, allowing customization, graceful degradation, accessibility, as +well as themability: @dfn{Icons}. + +The central macro here is @code{define-icon}, and here's a simple +example: + +@lisp +(define-icon outline-open button + '((image "right.svg" "open.xpm" "open.pbm" :height line) + (emoji "▶️") + (symbol "▶" "➤") + (text "open" :face icon-button)) + "Icon used for buttons for opening a section in outline buffers." + :version "29.1" + :help-echo "Open this section") +@end lisp + +Which alternative will actually be displayed depends on the value of +the user option @code{icon-preference} (@pxref{Icons,,, emacs, The GNU +Emacs Manual}) and on the results of run-time checks for what the +current frame's terminal can actually display. + +The macro in the example above defines @code{outline-open} as an icon, +and inherits properties from the icon called @code{button} (so this is +meant as a clickable button to be inserted in a buffer). It is +followed by a list of @dfn{icon types} along with the actual icon +shapes themselves. In addition, there's a doc string and various +keywords that contain additional information and properties. + +To instantiate an icon, you use @code{icon-string}, which will +consult the current Customize theming, and the @code{icon-preference} +user option, and finally what the Emacs is able to actually display. +If @code{icon-preference} is @code{(image emoji symbol text)} (i.e., +allowing all of these forms of icons), in this case, +@code{icon-string} will first check that Emacs is able to display +images at all, and then whether it has support for each of those +different image formats. If that fails, Emacs will check whether +Emacs can display emojis (in the current frame). If that fails, it'll +check whether it can display the symbol in question. If that fails, +it'll use the plain text version. + +For instance, if @code{icon-preference} doesn't contain @code{image} +or @code{emoji}, it'll skip those entries. + +Code can confidently call @code{icon-string} in all circumstances and +be sure that something readable will appear on the screen, no +matter whether the user is on a graphical terminal or a text terminal, +and no matter which features Emacs was built with. + +@defmac define-icon name parent specs doc &rest keywords +Define an icon @var{name}, a symbol, with the display alternatives in +@var{spec}, that can be later instantiated using @code{icon-string}. +The @var{name} is the name of the resulting keyword. + +The resulting icon will inherit specs from @var{parent}, and from +their parent's parents, and so on, and the lowest descendent element +wins. + +@var{specs} is a list of icon specifications. The first element of each +specification is the type, and the rest is something that can be used +as an icon of that type, and then optionally followed by a keyword +list. The following icon types are available: + +@cindex icon types +@table @code +@item image +In this case, there may be many images listed as candidates. Emacs +will choose the first one that the current Emacs instance can show. +If an image is listed is an absolute file name, it's used as is, but it's +otherwise looked up in the list @code{image-load-path} +(@pxref{Defining Images}). + +@item emoji +This should be a (possibly colorful) emoji. + +@item symbol +This should be a (monochrome) symbol character. + +@item text +Icons should also have a textual fallback. This can also be used for +the visually impaired: if @code{icon-preference} is just +@code{(text)}, all icons will be replaced by text. +@end table + +Various keywords may follow the list of icon specifications. For +instance: + +@example +(symbol "▶" "➤" :face icon-button) +@end example + +Unknown keywords are ignored. The following keywords are allowed: + +@cindex icon keywords +@table @code +@item :face +The face to be used for the icon. + +@item :height +This is only valid for @code{image} icons, and can be either a number +(which specifies the height in pixels), or the symbol @code{line}, +which will use the default line height in the currently selected +window. +@end table + +@var{doc} should be a doc string. + +@var{keywords} is a list of keyword/value pairs. The following +keywords are allowed: + +@table @code +@item :version +The (approximate) Emacs version this button first appeared. (This +keyword is mandatory.) + +@item :group +The customization group this icon belongs in. If not present, it is +inferred. + +@item :help-echo +The help string shown when hovering over the icon with the mouse +pointer. +@end table +@end defmac + +@defun icon-string icon +This function returns a string suitable for display in the current +buffer for @var{icon}. +@end defun + +@defun icon-elements icon +Alternatively, you can get a ``deconstructed'' version of @var{icon} +with this function. It returns a plist (@pxref{Property Lists}) where +the keys are @code{string}, @code{face} and @var{image}. (The latter +is only present if the icon is represented by an image.) This can be +useful if the icon isn't to be inserted directly in the buffer, but +needs some sort of pre-processing first. +@end defun + +Icons can be customized with @kbd{M-x customize-icon}. Themes can +specify changes to icons with, for instance: + +@lisp +(custom-theme-set-icons + 'my-theme + '(outline-open ((image :height 100) + (text " OPEN "))) + '(outline-close ((image :height 100) + (text " CLOSE " :face warning)))) +@end lisp + + @node Xwidgets @section Embedded Native Widgets @cindex xwidget diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi index e3de6009e90..8e8cc5fd9c0 100644 --- a/doc/lispref/functions.texi +++ b/doc/lispref/functions.texi @@ -2497,6 +2497,30 @@ the current buffer. @item (modes @var{modes}) Specify that this command is meant to be applicable for @var{modes} only. + +@item (pure @var{val}) +If @var{val} is non-@code{nil}, this function is @dfn{pure} +(@pxref{What Is a Function}). This is the same as the @code{pure} +property of the function's symbol (@pxref{Standard Properties}). + +@item (side-effect-free @var{val}) +If @var{val} is non-@code{nil}, this function is free of side effects, +so the byte compiler can ignore calls whose value is ignored. This is +the same as the @code{side-effect-free} property of the function's +symbol, @pxref{Standard Properties}. + +@item (speed @var{n}) +Specify the value of @code{native-comp-speed} in effect for native +compilation of this function (@pxref{Native-Compilation Variables}). +This allows function-level control of the optimization level used for +native code emitted for the function. In particular, if @var{n} is +@minus{}1, native compilation of the function will emit bytecode +instead of native code for the function. + +@item no-font-lock-keyword +This is valid for macros only. Macros with this declaration are +highlighted by font-lock (@pxref{Font Lock Mode}) as normal functions, +not specially as macros. @end table @end defmac diff --git a/doc/lispref/hash.texi b/doc/lispref/hash.texi index d3ae673d44d..25a56bd7151 100644 --- a/doc/lispref/hash.texi +++ b/doc/lispref/hash.texi @@ -324,15 +324,13 @@ the same integer. compared case-insensitively. @example -(defun case-fold-string= (a b) - (eq t (compare-strings a nil nil b nil nil t))) -(defun case-fold-string-hash (a) +(defun string-hash-ignore-case (a) (sxhash-equal (upcase a))) -(define-hash-table-test 'case-fold - 'case-fold-string= 'case-fold-string-hash) +(define-hash-table-test 'ignore-case + 'string-equal-ignore-case 'string-hash-ignore-case) -(make-hash-table :test 'case-fold) +(make-hash-table :test 'ignore-case) @end example Here is how you could define a hash table test equivalent to the diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index 80c371e1c6a..1ef8fc3d03a 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -3204,20 +3204,39 @@ If the vector does not include the port number, @var{p}, or if @code{:@var{p}} suffix. @end defun -@defun network-lookup-address-info name &optional family -This function is used to perform hostname lookups on @var{name}, which -is expected to be an ASCII-only string, otherwise an error is -signaled. Call @code{puny-encode-domain} on @var{name} -first if you wish to lookup internationalized hostnames. - -If successful it returns a list of Lisp representations of network -addresses, otherwise it returns @code{nil}. In the latter case, it -also displays the error message hopefully explaining what went wrong. - -By default both IPv4 and IPv6 lookups are attempted. The optional -argument @var{family} controls this behavior, specifying the symbol -@code{ipv4} or @code{ipv6} restricts lookups to IPv4 and IPv6 +@defun network-lookup-address-info name &optional family hints +This function perform hostname lookups on @var{name}, which is +expected to be an ASCII-only string, otherwise it signals an error. Call +@code{puny-encode-domain} on @var{name} first if you wish to lookup +internationalized hostnames. + +If successful, this function returns a list of Lisp representations of network +addresses (@pxref{Network Processes}, for a description of the +format), otherwise return @code{nil}. In the latter case, it also logs +an error message hopefully explaining what went wrong. + +By default, this function attempts both IPv4 and IPv6 lookups. The +optional argument @var{family} controls this behavior, specifying the +symbol @code{ipv4} or @code{ipv6} restricts lookups to IPv4 and IPv6 respectively. + +If optional argument @var{hints} is @code{numeric}, the function +treats the @var{name} as a numerical IP address (and does not perform DNS +lookups). This can be used to check whether a string is a valid +numerical representation of an IP address, or to convert a numerical +string to its canonical representation. e.g.@: + +@example +(network-lookup-address-info "127.1" 'ipv4 'numeric) + @result{} ([127 0 0 1 0]) + +(network-lookup-address-info "::1" nil 'numeric) + @result{} ([0 0 0 0 0 0 0 1 0]) +@end example + +Be warned that there are some surprising valid forms, +especially for IPv4, e.g @samp{0xe3010203} and @samp{0343.1.2.3} are both +valid, as are @samp{0} and @samp{1} (but they are invalid for IPv6). @end defun @node Serial Ports diff --git a/doc/lispref/strings.texi b/doc/lispref/strings.texi index addf195fad2..374381e5955 100644 --- a/doc/lispref/strings.texi +++ b/doc/lispref/strings.texi @@ -560,6 +560,12 @@ Representations}. @code{string-equal} is another name for @code{string=}. @end defun +@defun string-equal-ignore-case string1 string2 +@code{string-equal-ignore-case} compares strings ignoring case +differences, like @code{char-equal} when @code{case-fold-search} is +@code{t}. +@end defun + @cindex locale-dependent string equivalence @defun string-collate-equalp string1 string2 &optional locale ignore-case This function returns @code{t} if @var{string1} and @var{string2} are @@ -567,11 +573,19 @@ equal with respect to collation rules. A collation rule is not only determined by the lexicographic order of the characters contained in @var{string1} and @var{string2}, but also further rules about relations between these characters. Usually, it is defined by the -@var{locale} environment Emacs is running with. - -For example, characters with different coding points but -the same meaning might be considered as equal, like different grave -accent Unicode characters: +@var{locale} environment Emacs is running with and by the Standard C +library against which Emacs was linked@footnote{ +For more information about collation rules and their locale +dependencies, see @uref{https://unicode.org/reports/tr10/, The Unicode +Collation Algorithm}. Some Standard C libraries, such as the +@acronym{GNU} C Library (a.k.a.@: @dfn{glibc}) implement large +portions of the Unicode Collation Algorithm and use the associated +locale data, Common Locale Data Repository, or @acronym{CLDR}. +}. + +For example, characters with different code points but the same +meaning, like different grave accent Unicode characters, might, in +some locales, be considered as equal: @example @group @@ -759,7 +773,8 @@ The strings are compared by the numeric values of their characters. For instance, @var{str1} is considered less than @var{str2} if its first differing character has a smaller numeric value. If @var{ignore-case} is non-@code{nil}, characters are converted to -upper-case before comparing them. Unibyte strings are converted to +upper-case, using the current buffer's case-table (@pxref{Case +Tables}), before comparing them. Unibyte strings are converted to multibyte for comparison (@pxref{Text Representations}), so that a unibyte string and its conversion to multibyte are always regarded as equal. diff --git a/doc/lispref/tips.texi b/doc/lispref/tips.texi index 30146a89ebf..9faf3f33ba8 100644 --- a/doc/lispref/tips.texi +++ b/doc/lispref/tips.texi @@ -689,6 +689,18 @@ line. This looks nice in the source code, but looks bizarre when users view the documentation. Remember that the indentation before the starting double-quote is not part of the string! +@item +When documentation should display an ASCII apostrophe or grave accent, +use @samp{\\='} or @samp{\\=`} in the documentation string literal so +that the character is displayed as-is. + +@item +In documentation strings, do not quote expressions that are not Lisp symbols, +as these expressions can stand for themselves. For example, write +@samp{Return the list (NAME TYPE RANGE) ...}@: instead of +@samp{Return the list `(NAME TYPE RANGE)' ...}@: or +@samp{Return the list \\='(NAME TYPE RANGE) ...}. + @anchor{Docstring hyperlinks} @item @cindex curly quotes @@ -700,7 +712,7 @@ two exceptions: write @code{t} and @code{nil} without surrounding punctuation. For example: @example - CODE can be `lambda', nil, or t. +CODE can be `lambda', nil, or t. @end example Note that when Emacs displays these doc strings, Emacs will usually @@ -856,7 +868,7 @@ find an alternate phrasing that conveys the meaning. @item Try to avoid using abbreviations such as ``e.g.'' (for ``for example''), ``i.e.'' (for ``that is''), ``no.'' (for ``number''), -``c.f.'' (for ``in contrast to'') and ``w.r.t.'' (for ``with respect +``cf.'' (for ``in contrast to'') and ``w.r.t.'' (for ``with respect to'') as much as possible. It is almost always clearer and easier to read the expanded version.@footnote{We do use these occasionally, but try not to overdo it.} diff --git a/doc/lispref/windows.texi b/doc/lispref/windows.texi index 535571b3161..c7f014e2f3b 100644 --- a/doc/lispref/windows.texi +++ b/doc/lispref/windows.texi @@ -737,7 +737,7 @@ with any other @var{round} it returns the internal value of @cindex window width @cindex width of a window @cindex total width of a window -The @dfn{total width} of a window is the number of lines comprising its +The @dfn{total width} of a window is the number of columns comprising its body and its left and right decorations (@pxref{Basic Windows}). @defun window-total-width &optional window round @@ -747,7 +747,7 @@ the selected window. If @var{window} is internal, the return value is the total width occupied by its descendant windows. If a window's pixel width is not an integral multiple of its frame's -character width, the number of lines occupied by the window is rounded +character width, the number of columns occupied by the window is rounded internally. This is done in a way such that, if the window is a parent window, the sum of the total widths of all its children internally equals the total width of their parent. This means that although two diff --git a/doc/misc/autotype.texi b/doc/misc/autotype.texi index b005c9c34f7..93c65692d01 100644 --- a/doc/misc/autotype.texi +++ b/doc/misc/autotype.texi @@ -92,7 +92,6 @@ completions and expansions of text at point. * Copyrights:: Inserting and updating copyrights. * Executables:: Turning interpreter scripts into executables. * Timestamps:: Updating dates and times in modified files. -* QuickURL:: Inserting URLs based on text at point. * Tempo:: Flexible template insertion. * Hippie Expand:: Expansion of text trying various methods. * Skeleton Language:: Making skeleton commands insert what you want. @@ -478,31 +477,6 @@ The time stamp is written between the brackets or quotes: Time-stamp: <1998-02-18 10:20:51 gildea> @end example -@node QuickURL -@chapter QuickURL: Inserting URLs Based on Text at Point - -@vindex quickurl-url-file -@findex quickurl -@cindex URLs -@kbd{M-x quickurl} can be used to insert a URL into a buffer based on -the text at point. The URLs are stored in an external file defined by -the variable @code{quickurl-url-file} as a list of either cons cells of -the form @code{(@var{key} . @var{URL})} or -lists of the form @code{(@var{key} @var{URL} @var{comment})}. These -specify that @kbd{M-x quickurl} should insert @var{URL} if the word -@var{key} is at point, for example: - -@example -(("FSF" "https://www.fsf.org/" "The Free Software Foundation") - ("emacs" . "https://www.gnu.org/software/emacs/")) -@end example - -@findex quickurl-add-url -@findex quickurl-list -@kbd{M-x quickurl-add-url} can be used to add a new @var{key}/@var{URL} -pair. @kbd{M-x quickurl-list} provides interactive editing of the URL -list. - @node Tempo @chapter Tempo: Flexible Template Insertion diff --git a/doc/misc/ede.texi b/doc/misc/ede.texi index af8e2153dd8..9867883b24a 100644 --- a/doc/misc/ede.texi +++ b/doc/misc/ede.texi @@ -1551,14 +1551,14 @@ This is a URL to be sent to a web site for documentation. @item :web-site-directory @* A directory where web pages can be found by Emacs. -For remote locations use a path compatible with ange-ftp or EFS@. +For remote locations use a path compatible with ange-ftp. You can also use TRAMP for use with rcp & scp. @item :web-site-file @* A file which contains the website for this project. This file can be relative to slot @code{web-site-directory}. -This can be a local file, use ange-ftp, EFS, or TRAMP. +This can be a local file, use ange-ftp or TRAMP. @item :ftp-site Type: @code{string} @* diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi index 6b5173d3c2f..7da90dfb1d6 100644 --- a/doc/misc/gnus.texi +++ b/doc/misc/gnus.texi @@ -17518,16 +17518,16 @@ If you have a directory that has lots of articles in separate files in it, you might treat it as a newsgroup. The files have to have numerical names, of course. -This might be an opportune moment to mention @code{ange-ftp} (and its -successor @code{efs}), that most wonderful of all wonderful Emacs -packages. When I wrote @code{nndir}, I didn't think much about it---a -back end to read directories. Big deal. +This might be an opportune moment to mention @code{ange-ftp}, that +most wonderful of all wonderful Emacs packages. When I wrote +@code{nndir}, I didn't think much about it---a back end to read +directories. Big deal. @code{ange-ftp} changes that picture dramatically. For instance, if you enter the @code{ange-ftp} file name @file{/ftp.hpc.uh.edu:/pub/emacs/ding-list/} as the directory name, -@code{ange-ftp} or @code{efs} will actually allow you to read this -directory over at @samp{sina} as a newsgroup. Distributed news ahoy! +@code{ange-ftp} will actually allow you to read this directory over at +@samp{sina} as a newsgroup. Distributed news ahoy! @code{nndir} will use @acronym{NOV} files if they are present. @@ -26778,7 +26778,7 @@ on finding a separator line between the head and the body. If this variable is @code{nil}, there is no upper read bound. If it is @code{t}, the back ends won't try to read the articles piece by piece, but read the entire articles. This makes sense with some versions of -@code{ange-ftp} or @code{efs}. +@code{ange-ftp}. @item nnheader-head-chop-length @vindex nnheader-head-chop-length diff --git a/etc/AUTHORS b/etc/AUTHORS index b5444e60a76..8946800e0b8 100644 --- a/etc/AUTHORS +++ b/etc/AUTHORS @@ -281,8 +281,8 @@ Andrea Corallo: wrote comp-cstr-tests.el comp-cstr.el comp-tests.el comp.el and changed comp.c pdumper.c lread.c bytecomp.el comp.h configure.ac lisp.h startup.el loadup.el alloc.c data.c emacs.c .gitlab-ci.yml - nadvice.el cl-macs.el advice.el help.el lisp/Makefile.in package.el - Makefile.in comp-test-funcs.el and 62 other files + nadvice.el cl-macs.el advice.el comp-test-funcs.el help.el + lisp/Makefile.in package.el Makefile.in and 61 other files André A. Gomes: changed ispell.el @@ -1733,6 +1733,8 @@ Etienne Prud’Homme: changed align.el css-mode-tests.el css-mode.el Eugene Exarevsky: changed sql.el +Eugene Ha: changed configure.ac + Evangelos Evangelou: changed progmodes/f90.el Evan Moses: changed progmodes/python.el @@ -1981,7 +1983,7 @@ Gerd Möllmann: wrote authors.el ebrowse.el jit-lock.el tooltip.el and changed xdisp.c xterm.c dispnew.c dispextern.h xfns.c xfaces.c window.c keyboard.c lisp.h faces.el alloc.c buffer.c startup.el xterm.h fns.c simple.el term.c configure.ac frame.c xmenu.c emacs.c - and 607 other files + and 609 other files Gergely Nagy: changed erc.el @@ -3311,7 +3313,7 @@ and co-wrote gnus-kill.el gnus-mh.el gnus-msg.el gnus-score.el and changed gnus.texi simple.el subr.el files.el process.c display.texi text.texi dired.el gnutls.c gnus-ems.el smtpmail.el help-fns.el auth-source.el url-http.el edebug.el image.el gnus-cite.el pop3.el - dired-aux.el fns.c image.c and 866 other files + dired-aux.el fns.c image.c and 867 other files Lars Rasmusson: changed ebrowse.c @@ -3930,8 +3932,8 @@ Miguel Ruiz: changed ob-gnuplot.el Mihai Olteanu: changed hexl.el Miha Rihtaršič: changed keyboard.c commands.texi minibuf.c minibuffer.el - simple.el comint.el data.c delsel.el errors.texi esh-mode.el eval.c - ibuffer.el macros.c process.c sh-script.el + simple.el bindings.el comint.el data.c delsel.el errors.texi + esh-mode.el eval.c ibuffer.el macros.c process.c sh-script.el Mihir Rege: changed js.el @@ -4327,9 +4329,9 @@ and changed message.el gnus-util.el gnus-int.el gnus.el gnus-agent.el Paul Pogonyshev: changed subr.el byte-opt.el bytecomp.el emacs-lisp/debug.el eval.c progmodes/python.el which-func.el align.el - bytecode.c cc-langs.el cl-macs.el configure.ac dabbrev.el display.texi - eldoc.el elisp-mode.el ert.el ert.texi etags.el fns-tests.el fns.c - and 20 other files + bytecode.c cc-langs.el cl-macs.el configure.ac dabbrev.el desktop.el + display.texi eldoc.el elisp-mode.el ert.el ert.texi etags.el + fns-tests.el and 21 other files Paul Rankin: changed outline.el @@ -4785,7 +4787,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 136 other files + nsterm.m unicode xfns.c auth.texi composite.c and 138 other files Robert Thorpe: changed cus-start.el indent.el rmail.texi @@ -5179,7 +5181,7 @@ 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 1339 other files + emacs-lisp-intro.texi flyspell.el ibuffer.el and 1344 other files Stefan Merten: co-wrote rst.el @@ -81,7 +81,7 @@ by saying make -C leim generate-ja-dic JA_DIC_NO_REDUCTION_OPTION='' -after deleting lisp/leim/ja-dic/ja-dic.el. +after deleting "lisp/leim/ja-dic/ja-dic.el". +++ ** Emacs now supports being built with pure GTK. @@ -117,7 +117,7 @@ Emacs Sessions" node in the Emacs manual for more details. * Startup Changes in Emacs 29.1 +++ -** -batch and -script now adjusts the garbage collection levels. +** '--batch' and '--script' now adjust the garbage collection levels. These switches now set 'gc-cons-percentage' to 1.0 (up from the default of 0.1). This means that batch processes will typically use more memory than before, but use less time doing garbage collection. @@ -152,7 +152,7 @@ time. --- *** New command 'native-compile-prune-cache'. -This command deletes older .eln cache entries (but not the ones for +This command deletes older ".eln" cache entries (but not the ones for the current Emacs version). --- @@ -167,19 +167,36 @@ of 'user-emacs-directory'. * Incompatible changes in Emacs 29.1 --- -** 'w' ('dired-copy-filename-as-kill') has changed behaviour. +*** The Gtk selection face is no longer used for the region. +The combination of a Gtk-controlled background and a foreground color +controlled by the internal Emacs machinery led to low-contrast faces +in common default setups. Emacs now uses the same 'region' face on +Gtk and non-Gtk setups. + +** Dired + +--- +*** 'w' ('dired-copy-filename-as-kill') has changed behavior. If there are several files marked, file names containing space and quote characters will be quoted "like this". +--- +*** The 'd' command now more consistently skips dot files. +In previous Emacs versions, commands like 'C-u 10 d' would put the "D" +mark on the next ten files, no matter whether they were dot files +(i.e., "." and "..") or not, while marking the next ten lines with the +mouse (in 'transient-mark-mode') and then hitting 'd' would skip dot +files. These now work equivalently. + +++ ** Warning about "eager macro-expansion failure" is changed into an error. --- -** Previously, the X reverseVideo value at startup was heeded for all frames. -This meant that if you had a reverseVideo resource on the initial +** Previously, the X "reverseVideo" value at startup was heeded for all frames. +This meant that if you had a "reverseVideo" resource on the initial display, and then opened up a new frame on a display without any -explicit reverseVideo setting, it would get heeded there, too. (This -included terminal frames.) In Emacs 29, the reverseVideo X resource +explicit "reverseVideo" setting, it would get heeded there, too. (This +included terminal frames.) In Emacs 29, the "reverseVideo" X resource is handled like all the other X resources, and set on a per-frame basis. +++ @@ -187,7 +204,7 @@ is handled like all the other X resources, and set on a per-frame basis. Previously, this command did the same as 'e'. --- -** '/ a' in *Packages* now limits by package name(s) instead of regexp. +** '/ a' in "*Packages*" buffer now limits by package name(s) instead of regexp. +++ ** Setting the goal columns now also affects '<prior>' and '<next>'. @@ -195,14 +212,6 @@ Previously, 'C-x C-n' only affected 'next-line' and 'previous-line', but it now also affects 'scroll-up-command' and 'scroll-down-command'. --- -** The 'd' command in Dired now more consistently skip dot files. -In previous Emacs versions, commands like `C-u 10 d' would put the "D" -mark on the next ten files, no matter whether they were dot files -(i.e., "." and "..") or not, while marking the next ten lines with the -mouse (in 'transient-mark-mode') and then hitting 'd' would skip dot -files. These now work equivalently. - ---- ** Isearch in "*Help*" and "*info*" now char-folds quote characters by default. This means that you can say 'C-s `foo' (GRAVE ACCENT) if the buffer contains "‘foo" (LEFT SINGLE QUOTATION MARK) and the like. These @@ -327,9 +336,21 @@ startup. Previously, these functions ignored 'initial-scratch-message' and left "*scratch*" in 'fundamental-mode'. --- +** The quickurl.el library is now obsolete. +Use 'skeleton' or 'tempo' instead. + +--- ** The rlogin.el library and 'rsh' command are now obsolete. Use something like 'M-x shell RET ssh <host> RET' instead. +--- +** The fast-lock.el and lazy-lock.el library have been removed. +They have been obsolete since Emacs 22.1. + +The variable 'font-lock-support-mode' is occasionally useful for +debugging purposes. It is now a regular variable (instead of a user +option) and can be set to nil to disable Just-in-time Lock mode. + * Changes in Emacs 29.1 @@ -358,9 +379,9 @@ decrease it, type 'C-x C-M--'; to restore the font size, type 'C-x C-M-0'. The final key in these commands may be repeated without the leading 'C-x' and without the modifiers, e.g. 'C-x C-M-+ C-M-+ C-M-+' and 'C-x C-M-+ + +' increase the font size by three steps. When -mouse-wheel-mode is enabled, 'C-M-wheel-up' and 'C-M-wheel-down' also +'mouse-wheel-mode' is enabled, 'C-M-wheel-up' and 'C-M-wheel-down' also increase and decrease the font size globally. Additionally, the -variable 'global-text-scale-adjust-resizes-frames' controls whether +user option 'global-text-scale-adjust-resizes-frames' controls whether the frames are resized when the font size is changed. +++ @@ -398,11 +419,23 @@ between these modes while the user is inputting a command by hitting ** Interactively, 'kill-buffer' will now offer to save the buffer if unsaved. --- -** New command 'duplicate-line'. -This command duplicates the current line the specified number of times. +** New commands 'duplicate-line' and 'duplicate-dwim'. +'duplicate-line' duplicates the current line the specified number of times. +'duplicate-dwim' duplicates the region if it is active. If not, it +works like 'duplicate-line'. An active rectangular region is +duplicated on its right-hand side. --- -** Files with the '.eld' extension are now visited in 'lisp-data-mode'. +** Files with the ".eld" extension are now visited in 'lisp-data-mode'. + ++++ +** 'network-lookup-address-info' can now check numeric IP address validity. +Specifying 'numeric as the new optional 'hints' argument makes it +check if the passed address is a valid IPv4/IPv6 address (without DNS +traffic). + + (network-lookup-address-info "127.1" 'ipv4 'numeric) + => ([127 0 0 1 0]) +++ ** New command 'find-sibling-file'. @@ -560,7 +593,7 @@ This controls the style of the pre-edit and status areas of X input methods. +++ -** New X resources: "highlightForeground" and "highlightBackground" +** New X resources: "highlightForeground" and "highlightBackground". Only in the Lucid build, this controls colors used for highlighted menu item widgets. @@ -707,19 +740,19 @@ or ':scream:'. ** Help --- -*** Variable values displayed by 'C-h v' in *Help* are now font-locked. +*** Variable values displayed by 'C-h v' in "*Help*" are now font-locked. +++ *** New user option 'help-clean-buttons'. -If non-nil, link buttons in *Help* will have any surrounding quotes +If non-nil, link buttons in "*Help*" will have any surrounding quotes removed. --- *** 'M-x apropos-variable' output now includes values of variables. +++ -*** New doc string syntax to indicate that symbols shouldn't be links. -When displaying doc strings in "*Help*" buffers, strings that are +*** New docstring syntax to indicate that symbols shouldn't be links. +When displaying docstrings in "*Help*" buffers, strings that are "`like-this'" are made into links (if they point to a bound function/variable). This can lead to false positives when talking about values that are symbols that happen to have the same names as @@ -811,10 +844,6 @@ or is itself too long. If non-nil, Outline Minor Mode will use buttons to hide/show outlines in addition to the ellipsis. The default is nil. ---- -*** New user option 'outline-minor-mode-buttons'. -This is a list of pairs of open/close strings used to display buttons. - +++ ** Support for the WebP image format. This support is built by default when the libwebp library is @@ -929,7 +958,7 @@ option 'cycle-spacing-actions'. ** 'zap-to-char' and 'zap-up-to-char' are case-sensitive for upper-case chars. These commands now behave as case-sensitive for interactive calls when they are invoked with an uppercase character, regardless of the -`case-fold-search' value. +'case-fold-search' value. --- ** 'scroll-other-window' and 'scroll-other-window-down' now respect remapping. @@ -1000,6 +1029,12 @@ The user option 'comint-terminfo-terminal' and the variable 'system-uses-terminfo' can now be set as connection-local variables to change the terminal used on a remote host. +--- +*** New user option 'comint-delete-old-input'. +When nil, this prevents comint from deleting the current input when +inserting previous input using '<mouse-2>'. The default is t, to +preserve past behavior. + ** Mwheel --- @@ -1090,21 +1125,21 @@ related user option 'dired-clean-confirm-killing-deleted-buffers' +++ *** 'dired-do-relsymlink' moved from dired-x to dired. -The corresponding key "Y" is now bound by default in Dired. +The corresponding key 'Y' is now bound by default in Dired. +++ *** 'dired-do-relsymlink-regexp' moved from dired-x to dired. -The corresponding key "% Y" is now bound by default in Dired. +The corresponding key '% Y' is now bound by default in Dired. --- *** 'M-G' is now bound to 'dired-goto-subdir'. -Before, that binding was only available if the 'dired-x' package was +Before, that binding was only available if the dired-x package was loaded. +++ *** 'dired-info' and 'dired-man' moved from dired-x to dired. The 'dired-info' and 'dired-man' commands have been moved from the -'dired-x' package to 'dired'. They have also been renamed to +dired-x package to dired. They have also been renamed to 'dired-do-info' and 'dired-do-man'; the old command names are obsolete aliases. @@ -1150,7 +1185,7 @@ This can be used to trigger actions based on the battery status. +++ *** New command 'enriched-toggle-markup'. This allows you to see the markup in 'enriched-mode' buffers (e.g., -the HELLO file). +the "HELLO" file). ** Shell Script Mode @@ -1181,6 +1216,15 @@ the run/continue command. This is bound to 'H' and toggles whether to hide or show the widget contents. +** Diff mode + +--- +*** New user option 'diff-whitespace-style'. +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. + + ** Ispell --- @@ -1212,7 +1256,7 @@ This command allows updating all packages without any queries. +++ *** New commands 'package-recompile' and 'package-recompile-all'. -These commands can be useful if the .elc files are out of date +These commands can be useful if the ".elc" files are out of date (invalid byte code and macros). +++ @@ -1231,7 +1275,7 @@ inadvertently delete the "*scratch*" buffer. ** Debugging --- -*** 'q' in a *Backtrace* buffer no longer clears the buffer. +*** 'q' in a "*Backtrace*" buffer no longer clears the buffer. Instead it just buries the buffer and switches the mode from 'debugger-mode' to 'backtrace-mode', since commands like 'e' are no longer available after exiting the recursive edit. @@ -1281,7 +1325,7 @@ files that have few newlines. +++ ** New minor mode 'word-wrap-whitespace-mode' for extending 'word-wrap'. This mode switches 'word-wrap' on, and breaks on all the whitespace -characters instead of just SPC and TAB. +characters instead of just 'SPC' and 'TAB'. --- ** New mode, 'emacs-news-mode', for editing the NEWS file. @@ -1342,9 +1386,9 @@ the completions if they are already visible. The default value 't' always hides the completion buffer after some completion is made. *** New commands to complete the minibuffer history. -'minibuffer-complete-history' ('C-x up') is like 'minibuffer-complete' +'minibuffer-complete-history' ('C-x <up>') is like 'minibuffer-complete' but completes on the history items instead of the default completion -table. 'minibuffer-complete-defaults' ('C-x down') completes +table. 'minibuffer-complete-defaults' ('C-x <down>') completes on the list of default items. +++ @@ -1572,7 +1616,7 @@ pre-defined toolbars. --- *** Gnus now uses a variable-pitch font in the headers by default. To get the monospace font back, you can put something like the -following in your .gnus file: +following in your ".gnus" file: (set-face-attribute 'gnus-header nil :inherit 'unspecified) @@ -1984,7 +2028,7 @@ This support has been obsolete since Emacs 25.1. The final version of the Galeon web browser was released in September, 2008. --- -*** Support for the "Mozilla" web browser is now obsolete. +*** Support for the Mozilla web browser is now obsolete. Note that this historical web browser is different from Mozilla Firefox; it is its predecessor. @@ -2052,8 +2096,8 @@ symlinks in the latter case). --- *** New user option 'shell-kill-buffer-on-exit'. -Enabling this will automatically kill a *shell* buffer as soon as the -shell session terminates. +Enabling this will automatically kill a "*shell*" buffer as soon as +the shell session terminates. ** Calc @@ -2104,7 +2148,7 @@ If non-nil, files untracked by a VCS are considered to be part of the project by a VC project based on that VCS. --- -*** 'recentf-mode' now uses shortened filenames by default. +*** 'recentf-mode' now uses abbreviated file names by default. This means that e.g. "/home/foo/bar" is now displayed as "~/bar". Customize the user option 'recentf-filename-handlers' to nil to get back the old behavior. @@ -2165,36 +2209,36 @@ Emacs buffers, like indentation and the like. The new ert function --- ** 'find-image' now uses 'create-image'. -This means that images found through 'find-image' also has +This means that images found through 'find-image' also have auto-scaling applied. (This only makes a difference on HiDPI displays.) +++ ** Changes to "raw" in-memory xbm images are specified. Some years back Emacs gained the ability to scale images, and you -could then specify :width and :height when using 'create-image' on all +could then specify ':width' and ':height' when using 'create-image' on all image types -- except xbm images, because this format already used the -:width and :height arguments to specify the width/height of the "raw" +':width' and ':height' arguments to specify the width/height of the "raw" in-memory format. This meant that if you used these specifications on, for instance, xbm files, Emacs would refuse to display them. This -has been changed, and :width/:height now works as with all other image +has been changed, and ':width'/':height' now works as with all other image formats, and the way to specify the width/height of the "raw" -in-memory format is now by using :data-width and :data-height. +in-memory format is now by using ':data-width' and ':data-height'. +++ -** loaddefs.el generation has been reimplemented. -The various loaddefs.el files in the Emacs tree (which contain +** "loaddefs.el" generation has been reimplemented. +The various "loaddefs.el" files in the Emacs tree (which contain information about autoloads, built-in packages and package prefixes) -used to be generated by functions in autoloads.el. These are now -generated by loaddefs-gen.el instead. This leads to functionally +used to be generated by functions in "autoloads.el". These are now +generated by "loaddefs-gen.el" instead. This leads to functionally equivalent loaddef files, but they do not use exactly the same syntax, so using 'M-x update-file-autoloads' no longer works. (This didn't work well in most files in the past, either, but it will now signal an error in any file.) In addition, files are scanned in a slightly different way. -Previously ;;;### specs inside a top-level form (i.e., something like -(when ... ;;;### ...) would be ignored. They are now parsed as +Previously ';;;###' specs inside a top-level form (i.e., something +like '(when ... ;;;### ...)' would be ignored. They are now parsed as normal. +++ @@ -2320,6 +2364,18 @@ Use 'exif-parse-file' and 'exif-field' instead. This change is now applied in 'dired-insert-directory'. --- +** 'compilation-last-buffer' is (finally) declared obsolete. +It's been obsolete since Emacs-22.1, actually. + +--- +** Calling 'lsh' now elicits a byte-compiler warning. +'lsh' behaves in somewhat surprising and platform-dependent ways for +negative arguments, and is generally slower than 'ash', which should be +used instead. This warning can be suppressed by surrounding calls to +'lsh' with the construct '(with-suppressed-warnings ((suspicious lsh)) ...)', +but switching to `ash` is generally much preferable. + +--- ** Some functions and variables obsolete since Emacs 24 have been removed: 'Info-edit-map', 'allout-abbreviate-flattened-numbering', 'allout-mode-deactivate-hook', 'ansi-color-unfontify-region', @@ -2330,13 +2386,13 @@ This change is now applied in 'dired-insert-directory'. 'chart-map', 'comint-dynamic-complete', 'comint-dynamic-complete-as-filename', 'comint-dynamic-simple-complete', 'command-history-map', -'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', 'gnus-carpal', -'gnus-debug-exclude-variables', 'gnus-debug-files', +'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', +'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', 'image-extension-data', 'image-library-alist', @@ -2376,7 +2432,7 @@ This change is now applied in 'dired-insert-directory'. 'vc-arch-command'. +++ -** New generic function 'function-doumentation'. +** New generic function 'function-documentation'. Can dynamically generate a raw docstring depending on the type of a function. Used mainly for docstrings of OClosures. @@ -2409,6 +2465,11 @@ patcomp.el, pc-mode.el, pc-select.el, s-region.el, and sregex.el. * Lisp Changes in Emacs 29.1 +++ +** Emacs now supports user-customizable and themable icons. +These can be used for buttons in buffers and the like. See +'(elisp)Icons' and '(emacs)Icons' for details. + ++++ ** New arguments MESSAGE and TIMEOUT of 'set-transient-map'. MESSAGE specifies a message to display after activating the transient map, including a special formatting spec to list available keys. @@ -2452,15 +2513,18 @@ If DATA is a string, then its text properties are searched for values for each specific data type while the selection is being converted. --- -** New eldoc function: 'elisp-eldoc-var-docstring-with-value'. +** New eldoc function 'elisp-eldoc-var-docstring-with-value'. This function includes the current value of the variable in eldoc display and can be used as a more detailed alternative to 'elisp-eldoc-var-docstring'. ** 'save-some-buffers' can now be extended to save other things. Traditionally, 'save-some-buffers' saved buffers, and also saved abbrevs. This has been generalized via the -'save-some-buffers-functions', and packages can now register things to -be saved. +'save-some-buffers-functions' variable, and packages can now register +things to be saved. + +** New function 'string-equal-ignore-case'. +This compares strings ignoring case differences. +++ ** New argument LOCK of 'narrow-to-region'. @@ -2507,7 +2571,7 @@ selecting some text into the clipboard or primary selection, and then delete the current frame, you will still be able to insert the contents of that selection into other programs as long as another frame is open on the same display. This behavior can be disabled by -setting the variable 'x-auto-preserve-selections' to nil. +setting the user option 'x-auto-preserve-selections' to nil. +++ ** New predicate 'char-uppercase-p'. @@ -2516,18 +2580,18 @@ This returns non-nil if its argument its an uppercase character. ** Byte compilation --- -*** Byte compilation will now warn about some quoting mistakes in doc strings. -When writing code snippets that contains the ' character (APOSTROPHE), +*** Byte compilation will now warn about some quoting mistakes in docstrings. +When writing code snippets that contains the "'" character (APOSTROPHE), that quote character has to be escaped to avoid Emacs displaying it as -’ (LEFT SINGLE QUOTATION MARK), which would make code examples like +"’" (LEFT SINGLE QUOTATION MARK), which would make code examples like (setq foo '(1 2 3)) invalid. Emacs will now warn during byte compilation if it seems something like that, and also warn about when using RIGHT/LEFT SINGLE QUOTATION MARK directly. In both these cases, if these characters -should really be present in the doc string, they should be quoted with -\=. +should really be present in the docstring, they should be quoted with +"\=". --- *** Byte compilation will now warn about some malformed 'defcustom' types. @@ -2540,12 +2604,12 @@ value. The byte compiler will now issue a warning if it encounters these forms. +++ -*** 'restore-buffer-modified-p' can now alter buffer auto-save state. +** 'restore-buffer-modified-p' can now alter buffer auto-save state. With a FLAG value of 'autosaved', it will mark the buffer as having been auto-saved since the time of last modification. --- -*** New minor mode 'isearch-fold-quotes-mode'. +** New minor mode 'isearch-fold-quotes-mode'. This sets up 'search-default-mode' so that quote characters are char-folded into each other. It is used, by default, in "*Help*" and "*info*" buffers. @@ -2780,7 +2844,7 @@ option. +++ *** 'where-is-internal' can now filter events marked as non key events. -If a command maps to a key binding like [some-event], and 'some-event' +If a command maps to a key binding like '[some-event]', and 'some-event' has a symbol plist containing a non-nil 'non-key-event' property, then that binding is ignored by 'where-is-internal'. diff --git a/lisp/bindings.el b/lisp/bindings.el index 1d795c7a308..2e321282742 100644 --- a/lisp/bindings.el +++ b/lisp/bindings.el @@ -517,31 +517,31 @@ mouse-1: Display Line and Column Mode Menu") 'help-echo "Size indication mode\n\ mouse-1: Display Line and Column Mode Menu"))) (line-number-mode - ((column-number-mode - (column-number-indicator-zero-based - (10 - (:propertize - mode-line-position-column-line-format - display (min-width (10.0)) - ,@mode-line-position--column-line-properties)) - (10 - (:propertize - (:eval (string-replace - "%c" "%C" (car mode-line-position-column-line-format))) - display (min-width (10.0)) - ,@mode-line-position--column-line-properties))) - (6 + (column-number-mode + (column-number-indicator-zero-based + (10 (:propertize - mode-line-position-line-format - display (min-width (6.0)) - ,@mode-line-position--column-line-properties)))) + mode-line-position-column-line-format + display (min-width (10.0)) + ,@mode-line-position--column-line-properties)) + (10 + (:propertize + (:eval (string-replace + "%c" "%C" (car mode-line-position-column-line-format))) + display (min-width (10.0)) + ,@mode-line-position--column-line-properties))) + (6 + (:propertize + mode-line-position-line-format + display (min-width (6.0)) + ,@mode-line-position--column-line-properties))) (column-number-mode (column-number-indicator-zero-based (6 (:propertize mode-line-position-column-format display (min-width (6.0)) - (,@mode-line-position--column-line-properties))) + ,@mode-line-position--column-line-properties)) (6 (:propertize (:eval (string-replace diff --git a/lisp/button.el b/lisp/button.el index 80b73033d68..21047ad5541 100644 --- a/lisp/button.el +++ b/lisp/button.el @@ -623,12 +623,15 @@ itself will be used instead as the function argument. If HELP-ECHO, use that as the `help-echo' property. Also see `buttonize-region'." - (apply #'propertize string - (button--properties callback data help-echo))) + (let ((string + (apply #'propertize string + (button--properties callback data help-echo)))) + ;; Add the face to the end so that it can be overridden. + (add-face-text-property 0 (length string) 'button t string) + string)) (defun button--properties (callback data help-echo) - (list 'face 'button - 'font-lock-face 'button + (list 'font-lock-face 'button 'mouse-face 'highlight 'help-echo help-echo 'button t @@ -647,7 +650,8 @@ itself will be used instead as the function argument. If HELP-ECHO, use that as the `help-echo' property. Also see `buttonize'." - (add-text-properties start end (button--properties callback data help-echo))) + (add-text-properties start end (button--properties callback data help-echo)) + (add-face-text-property start end 'button t)) (provide 'button) diff --git a/lisp/cedet/ede/base.el b/lisp/cedet/ede/base.el index 9d23909d62e..27016f0f5cc 100644 --- a/lisp/cedet/ede/base.el +++ b/lisp/cedet/ede/base.el @@ -204,7 +204,7 @@ This is a URL to be sent to a web site for documentation.") :group name :documentation "A directory where web pages can be found by Emacs. -For remote locations use a path compatible with ange-ftp or EFS. +For remote locations use a path compatible with ange-ftp. You can also use TRAMP for use with rcp & scp.") (web-site-file :initarg :web-site-file :initform "" @@ -214,7 +214,7 @@ You can also use TRAMP for use with rcp & scp.") :documentation "A file which contains the website for this project. This file can be relative to slot `web-site-directory'. -This can be a local file, use ange-ftp, EFS, or TRAMP.") +This can be a local file, use ange-ftp or TRAMP.") (ftp-site :initarg :ftp-site :initform "" :type string diff --git a/lisp/cedet/semantic/complete.el b/lisp/cedet/semantic/complete.el index 6a09adca32d..436ad08c5fc 100644 --- a/lisp/cedet/semantic/complete.el +++ b/lisp/cedet/semantic/complete.el @@ -1011,20 +1011,14 @@ Output must be in semanticdb Find result format." (oref obj last-prefix))) (completionlist (cond ((or same-prefix-p - (and last-prefix (eq (compare-strings - last-prefix 0 nil - prefix 0 (length last-prefix)) - t))) + (and last-prefix (string-prefix-p last-prefix prefix t))) ;; We have the same prefix, or last-prefix is a ;; substring of the of new prefix, in which case we are ;; refining our symbol so just re-use cache. (oref obj last-all-completions)) ((and last-prefix (> (length prefix) 1) - (eq (compare-strings - prefix 0 nil - last-prefix 0 (length prefix)) - t)) + (string-prefix-p prefix last-prefix t)) ;; The new prefix is a substring of the old ;; prefix, and it's longer than one character. ;; Perform a full search to pull in additional @@ -1638,8 +1632,10 @@ This will not happen if you directly set this variable via `setq'." :set (lambda (sym var) (set-default sym var) (when (boundp 'x-max-tooltip-size) - (setcdr x-max-tooltip-size (max (1+ var) (cdr x-max-tooltip-size)))))) - + (if (not (consp x-max-tooltip-size)) + (setq x-max-tooltip-size '(80 . 40))) + (setcdr x-max-tooltip-size + (max (1+ var) (cdr x-max-tooltip-size)))))) (defclass semantic-displayer-tooltip (semantic-displayer-traditional) ((mode :initarg :mode diff --git a/lisp/comint.el b/lisp/comint.el index d52623c00ae..3ed04f098c7 100644 --- a/lisp/comint.el +++ b/lisp/comint.el @@ -905,6 +905,12 @@ series of processes in the same Comint buffer. The hook "Return non-nil if STR contains non-whitespace syntax." (not (string-match "\\`\\s *\\'" str))) +(defcustom comint-delete-old-input t + "When non-nil, delete old input on inserting previous input with \\<comint-mode-map>\\[comint-insert-input]." + :type 'boolean + :group 'comint + :version "29.1") + (defun comint-insert-input (event) "In a Comint buffer, set the current input to the previous input at point. If there is no previous input at point, run the command specified @@ -936,10 +942,11 @@ by the global keymap (usually `mouse-yank-at-click')." ;; Otherwise, insert the previous input. (goto-char (point-max)) ;; First delete any old unsent input at the end - (delete-region - (or (marker-position comint-accum-marker) - (process-mark (get-buffer-process (current-buffer)))) - (point)) + (when comint-delete-old-input + (delete-region + (or (marker-position comint-accum-marker) + (process-mark (get-buffer-process (current-buffer)))) + (point))) ;; Insert the input at point (insert input))))) diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index 50dce5ee285..1012d08ab51 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -139,6 +139,7 @@ (require 'cus-face) (require 'wid-edit) +(require 'icons) (defvar custom-versions-load-alist) ; from cus-load (defvar recentf-exclude) ; from recentf.el @@ -4849,7 +4850,8 @@ if only the first line of the docstring is shown.")) (print-escape-control-characters t)) (atomic-change-group (custom-save-variables) - (custom-save-faces))) + (custom-save-faces) + (custom-save-icons))) (let ((file-precious-flag t)) (save-buffer)) (if old-buffer @@ -5290,6 +5292,292 @@ if that value is non-nil." (put 'Custom-mode 'mode-class 'special) +;; Icons. + +(define-widget 'custom-icon 'custom + "A widget for displaying an icon. +The following properties have special meanings for this widget: + +:hidden-states should be a list of widget states for which the + widget's initial contents are to be hidden. + +:custom-form should be a symbol describing how to display and + edit the variable---either `edit' (using edit widgets), + `lisp' (as a Lisp sexp), or `mismatch' (should not happen); + if nil, use the return value of `custom-variable-default-form'. + +:shown-value, if non-nil, should be a list whose `car' is the + variable value to display in place of the current value. + +:custom-style describes the widget interface style; nil is the + default style, while `simple' means a simpler interface that + inhibits the magic custom-state widget." + :format "%v" + :help-echo "Alter or reset this icon." + :documentation-property #'icon-documentation + :custom-category 'option + :custom-state nil + :custom-form nil + :value-create 'custom-icon-value-create + :hidden-states '(standard) + :custom-set 'custom-icon-set + :custom-reset-current 'custom-redraw + :custom-reset-saved 'custom-variable-reset-saved) + +(defun custom-icon-value-create (widget) + "Here is where you edit the icon's specification." + (custom-load-widget widget) + (unless (widget-get widget :custom-form) + (widget-put widget :custom-form custom-variable-default-form)) + (let* ((buttons (widget-get widget :buttons)) + (children (widget-get widget :children)) + (form (widget-get widget :custom-form)) + (symbol (widget-get widget :value)) + (tag (widget-get widget :tag)) + (type '(repeat + (list (choice (const :tag "Images" image) + (const :tag "Colorful Emojis" emoji) + (const :tag "Monochrome Symbols" symbol) + (const :tag "Text Only" text)) + (repeat string) + plist))) + (prefix (widget-get widget :custom-prefix)) + (last (widget-get widget :custom-last)) + (style (widget-get widget :custom-style)) + (value (let ((shown-value (widget-get widget :shown-value))) + (cond (shown-value + (car shown-value)) + (t (icon-complete-spec symbol nil t))))) + (state (or (widget-get widget :custom-state) + (if (memq (custom-icon-state symbol value) + (widget-get widget :hidden-states)) + 'hidden)))) + + ;; Transform the spec into something that agrees with the type. + (setq value + (mapcar + (lambda (elem) + (list (car elem) + (icon-spec-values elem) + (icon-spec-keywords elem))) + value)) + + ;; Now we can create the child widget. + (cond ((eq custom-buffer-style 'tree) + (insert prefix (if last " `--- " " |--- ")) + (push (widget-create-child-and-convert + widget 'custom-browse-variable-tag) + buttons) + (insert " " tag "\n") + (widget-put widget :buttons buttons)) + ((eq state 'hidden) + ;; Indicate hidden value. + (push (widget-create-child-and-convert + widget 'custom-visibility + :help-echo "Show the value of this option." + :on-glyph "down" + :on "Hide" + :off-glyph "right" + :off "Show Value" + :action 'custom-toggle-hide-icon + nil) + buttons) + (insert " ") + (push (widget-create-child-and-convert + widget 'item + :format "%{%t%} " + :sample-face 'custom-variable-tag + :tag tag + :parent widget) + buttons)) + (t + ;; Edit mode. + (push (widget-create-child-and-convert + widget 'custom-visibility + :help-echo "Hide or show this option." + :on "Hide" + :off "Show" + :on-glyph "down" + :off-glyph "right" + :action 'custom-toggle-hide-icon + t) + buttons) + (insert " ") + (let* ((format (widget-get type :format)) + tag-format) + (unless (string-match ":\\s-?" format) + (error "Bad format")) + (setq tag-format (substring format 0 (match-end 0))) + (push (widget-create-child-and-convert + widget 'item + :format tag-format + :action 'custom-tag-action + :help-echo "Change specs of this face." + :mouse-down-action 'custom-tag-mouse-down-action + :button-face 'custom-variable-button + :sample-face 'custom-variable-tag + :tag tag) + buttons) + (push (widget-create-child-and-convert + widget type + :value value) + children)))) + (unless (eq custom-buffer-style 'tree) + (unless (eq (preceding-char) ?\n) + (widget-insert "\n")) + ;; Create the magic button. + (unless (eq style 'simple) + (let ((magic (widget-create-child-and-convert + widget 'custom-magic nil))) + (widget-put widget :custom-magic magic) + (push magic buttons))) + (widget-put widget :buttons buttons) + ;; Insert documentation. + (widget-put widget :documentation-indent 3) + (unless (and (eq style 'simple) + (eq state 'hidden)) + (widget-add-documentation-string-button + widget :visibility-widget 'custom-visibility)) + + ;; Update the rest of the properties. + (widget-put widget :custom-form form) + (widget-put widget :children children) + ;; Now update the state. + (if (eq state 'hidden) + (widget-put widget :custom-state state) + (custom-icon-state-set widget)) + ;; See also. + (unless (eq state 'hidden) + (when (eq (widget-get widget :custom-level) 1) + (custom-add-parent-links widget)) + (custom-add-see-also widget))))) + +(defun custom-toggle-hide-icon (visibility-widget &rest _ignore) + "Toggle the visibility of a `custom-icon' parent widget. +By default, this signals an error if the parent has unsaved +changes." + (let ((widget (widget-get visibility-widget :parent))) + (unless (eq (widget-type widget) 'custom-icon) + (error "Invalid widget type")) + (custom-load-widget widget) + (let ((state (widget-get widget :custom-state))) + (if (eq state 'hidden) + (widget-put widget :custom-state 'unknown) + ;; In normal interface, widget can't be hidden if modified. + (when (memq state '(invalid modified set)) + (error "There are unsaved changes")) + (widget-put widget :custom-state 'hidden)) + (custom-redraw widget) + (widget-setup)))) + +(defun custom--icons-widget-value (widget) + ;; Transform back to the real format. + (mapcar + (lambda (elem) + (cons (nth 0 elem) + (append (nth 1 elem) (nth 2 elem)))) + (widget-value widget))) + +(defun custom-icon-set (widget) + "Set the current spec for the icon being edited by WIDGET." + (let* ((state (widget-get widget :custom-state)) + (child (car (widget-get widget :children))) + (symbol (widget-value widget)) + val) + (when (eq state 'hidden) + (user-error "Cannot update hidden icon")) + + (setq val (custom--icons-widget-value child)) + (unless (equal val (icon-complete-spec symbol)) + (custom-variable-backup-value widget)) + (custom-push-theme 'theme-icon symbol 'user 'set val) + (custom-redraw-magic widget))) + +;;;###autoload +(defun customize-icon (icon) + "Customize ICON." + (interactive + (let* ((v (symbol-at-point)) + (default (and (iconp v) (symbol-name v))) + val) + (setq val (completing-read (format-prompt "Customize icon" default) + obarray 'iconp t nil nil default)) + (list (if (equal val "") + (if (symbolp v) v nil) + (intern val))))) + (unless icon + (error "No icon specified")) + (custom-buffer-create (list (list icon 'custom-icon)) + (format "*Customize Icon: %s*" + (custom-unlispify-tag-name icon)))) + +(defun custom-icon-state-set (widget &optional state) + "Set the state of WIDGET to STATE." + (let ((value (custom--icons-widget-value + (car (widget-get widget :children))))) + (widget-put + widget :custom-state + (or state + (custom-icon-state (widget-value widget) value))))) + +;;; FIXME -- more work is needed here. We don't properly +;;; differentiate between `saved' and `set'. +(defun custom-icon-state (symbol value) + "Return the state of customize icon SYMBOL for VALUE. +Possible return values are `standard', `saved', `set', `themed', +and `changed'." + (cond + ((equal (icon-complete-spec symbol t t) value) + 'standard) + ((equal (icon-complete-spec symbol nil t) value) + (if (eq (caar (get symbol 'theme-icon)) 'user) + 'set + 'themed)) + (t 'changed))) + +(defun custom-theme-set-icons (theme &rest specs) + "Apply a list of icon specs associated with THEME. +THEME should be a symbol, and SPECS are icon name/spec pairs. +See `define-icon' for details." + (custom-check-theme theme) + (pcase-dolist (`(,icon ,spec) specs) + (custom-push-theme 'theme-icon icon theme 'set spec))) + +(defun custom-set-icons (&rest args) + "Install user customizations of icon specs specified in ARGS. +These settings are registered as theme `user'. +The arguments should each be a list of the form: + + (SYMBOL EXP) + +This stores EXP (without evaluating it) as the saved spec for SYMBOL." + (apply #'custom-theme-set-icons 'user args)) + +;;;###autoload +(defun custom-save-icons () + "Save all customized icons in `custom-file'." + (save-excursion + (custom-save-delete 'custom-set-icons) + (let ((values nil)) + (mapatoms + (lambda (symbol) + (let ((value (car-safe (get symbol 'theme-icon)))) + (when (eq (car value) 'user) + (push (list symbol (cadr value)) values))))) + (ensure-empty-lines) + (insert "(custom-set-icons + ;; custom-set-icons was added by Custom. + ;; If you edit it by hand, you could mess it up, so be careful. + ;; Your init file should contain only one such instance. + ;; If there is more than one, they won't work right.\n") + (dolist (value (sort values (lambda (s1 s2) + (string< (car s1) (car s2))))) + (unless (bolp) + (insert "\n")) + (insert " '") + (prin1 value (current-buffer))) + (insert ")\n")))) + (provide 'cus-edit) ;;; cus-edit.el ends here diff --git a/lisp/custom.el b/lisp/custom.el index bbbe70c5ea8..5ece5047a86 100644 --- a/lisp/custom.el +++ b/lisp/custom.el @@ -910,7 +910,7 @@ symbol `set', then VALUE is the value to use. If it is the symbol `reset', then SYMBOL will be removed from THEME (VALUE is ignored). See `custom-known-themes' for a list of known themes." - (unless (memq prop '(theme-value theme-face)) + (unless (memq prop '(theme-value theme-face theme-icon)) (error "Unknown theme property")) (let* ((old (get symbol prop)) (setting (assq theme old)) ; '(theme value) diff --git a/lisp/desktop.el b/lisp/desktop.el index 850d2a86efa..a0931e053eb 100644 --- a/lisp/desktop.el +++ b/lisp/desktop.el @@ -791,7 +791,10 @@ if different)." ;; ---------------------------------------------------------------------------- (unless noninteractive - (add-hook 'kill-emacs-query-functions #'desktop-kill)) + (add-hook 'kill-emacs-query-functions #'desktop-kill) + ;; Certain things should be done even if + ;; `kill-emacs-query-functions' are not called. + (add-hook 'kill-emacs-hook #'desktop--on-kill)) (defun desktop-kill () "If `desktop-save-mode' is non-nil, do what `desktop-save' says to do. @@ -818,12 +821,15 @@ is nil, ask the user where to save the desktop." (file-error (unless (yes-or-no-p "Error while saving the desktop. Ignore? ") (signal (car err) (cdr err)))))) + (desktop--on-kill) + t) + +(defun desktop--on-kill () ;; If we own it, we don't anymore. (when (eq (emacs-pid) (desktop-owner)) ;; Allow exiting Emacs even if we can't delete the desktop file. (ignore-error 'file-error - (desktop-release-lock))) - t) + (desktop-release-lock)))) ;; ---------------------------------------------------------------------------- (defun desktop-list* (&rest args) diff --git a/lisp/dired.el b/lisp/dired.el index 59346a19014..7cdcc3438d8 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -2964,10 +2964,11 @@ See options: `dired-hide-details-hide-symlink-targets' and ;; approximate ("anywhere on the line is fine"). ;; FIXME: This also removes other invisible properties! (save-excursion - (remove-list-of-text-properties - (progn (goto-char start) (line-end-position)) - (progn (goto-char end) (line-end-position)) - '(invisible)))) + (let ((inhibit-read-only t)) + (remove-list-of-text-properties + (progn (goto-char start) (line-end-position)) + (progn (goto-char end) (line-end-position)) + '(invisible))))) ;;; Functions for finding the file name in a dired buffer line diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 86a42b208e7..2a2bcca7007 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -1,6 +1,6 @@ ;;; advice.el --- An overloading mechanism for Emacs Lisp functions -*- lexical-binding: t -*- -;; Copyright (C) 1993-1994, 2000-2022 Free Software Foundation, Inc. +;; Copyright (C) 1993-2022 Free Software Foundation, Inc. ;; Author: Hans Chalupsky <hans@cs.buffalo.edu> ;; Maintainer: emacs-devel@gnu.org @@ -23,12 +23,6 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. -;; LCD Archive Entry: -;; advice|Hans Chalupsky|hans@cs.buffalo.edu| -;; Overloading mechanism for Emacs Lisp functions| -;; 1994/08/05 03:42:04|2.14|~/packages/advice.el.Z| - - ;;; Commentary: ;; Advice is documented in the Emacs Lisp Manual. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index a457e2044d8..9817fa0eb15 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -921,7 +921,7 @@ for speeding up processing.") (defun byte-optimize--fixnump (o) "Return whether O is guaranteed to be a fixnum in all Emacsen. See Info node `(elisp) Integer Basics'." - (and (fixnump o) (<= -536870912 o 536870911))) + (and (integerp o) (<= -536870912 o 536870911))) (defun byte-optimize-equal (form) ;; Replace `equal' or `eql' with `eq' if at least one arg is a @@ -1451,8 +1451,7 @@ See Info node `(elisp) Integer Basics'." radians-to-degrees rassq rassoc read-from-string regexp-opt regexp-quote region-beginning region-end reverse round sin sqrt string string< string= string-equal string-lessp - string> string-greaterp string-empty-p - string-prefix-p string-suffix-p string-blank-p + string> string-greaterp string-empty-p string-blank-p string-search string-to-char string-to-number string-to-syntax substring sxhash sxhash-equal sxhash-eq sxhash-eql @@ -1500,7 +1499,7 @@ See Info node `(elisp) Integer Basics'." natnump nlistp not null number-or-marker-p numberp one-window-p overlayp point point-marker point-min point-max preceding-char primary-charset - processp + processp proper-list-p recent-keys recursion-depth safe-length selected-frame selected-window sequencep standard-case-table standard-syntax-table stringp subrp symbolp @@ -1545,7 +1544,7 @@ See Info node `(elisp) Integer Basics'." floor ceiling round truncate ffloor fceiling fround ftruncate string= string-equal string< string-lessp string> string-greaterp - string-empty-p string-blank-p string-prefix-p string-suffix-p + string-empty-p string-blank-p string-search consp atom listp nlistp proper-list-p sequencep arrayp vectorp stringp bool-vector-p hash-table-p diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index dd90bcf4d82..9370bd3a097 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -672,7 +672,7 @@ types. The types that can be suppressed with this macro are `suspicious'. For the `mapcar' case, only the `mapcar' function can be used in -the symbol list. For `suspicious', only `set-buffer' can be used." +the symbol list. For `suspicious', only `set-buffer' and `lsh' can be used." ;; Note: during compilation, this definition is overridden by the one in ;; byte-compile-initial-macro-environment. (declare (debug (sexp body)) (indent 1)) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 86681cf4dd4..b4954eee9ff 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -846,6 +846,8 @@ the unwind-action") (byte-defop 178 -1 byte-stack-set) ; Stack offset in following one byte. (byte-defop 179 -1 byte-stack-set2) ; Stack offset in following two bytes. +;; unused: 180-181 + ;; If (following one byte & 0x80) == 0 ;; discard (following one byte & 0x7F) stack entries ;; else @@ -2077,7 +2079,6 @@ value is `no-byte-compile'. See also `emacs-lisp-byte-compile-and-load'." (declare (advertised-calling-convention (filename) "28.1")) -;; (interactive "fByte compile file: \nP") (interactive (let ((file buffer-file-name) (file-dir nil)) @@ -3759,7 +3760,6 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (put 'byte-insertN 'byte-opcode-invert 'insert) (byte-defop-compiler point 0) -;;(byte-defop-compiler mark 0) ;; obsolete (byte-defop-compiler point-max 0) (byte-defop-compiler point-min 0) (byte-defop-compiler following-char 0) @@ -3770,8 +3770,6 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-defop-compiler bolp 0) (byte-defop-compiler bobp 0) (byte-defop-compiler current-buffer 0) -;;(byte-defop-compiler read-char 0) ;; obsolete -;; (byte-defop-compiler interactive-p 0) ;; Obsolete. (byte-defop-compiler widen 0) (byte-defop-compiler end-of-line 0-1) (byte-defop-compiler forward-char 0-1) @@ -3792,7 +3790,6 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-defop-compiler goto-char 1) (byte-defop-compiler char-after 0-1) (byte-defop-compiler set-buffer 1) -;;(byte-defop-compiler set-mark 1) ;; obsolete (byte-defop-compiler forward-word 0-1) (byte-defop-compiler char-syntax 1) (byte-defop-compiler nreverse 1) @@ -3845,7 +3842,6 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-defop-compiler (+ byte-plus) byte-compile-variadic-numeric) (byte-defop-compiler (* byte-mult) byte-compile-variadic-numeric) -;;####(byte-defop-compiler move-to-column 1) (byte-defop-compiler-1 interactive byte-compile-noop) @@ -4800,8 +4796,6 @@ binding slots have been popped." (byte-defop-compiler-1 save-excursion) (byte-defop-compiler-1 save-current-buffer) (byte-defop-compiler-1 save-restriction) -;; (byte-defop-compiler-1 save-window-excursion) ;Obsolete: now a macro. -;; (byte-defop-compiler-1 with-output-to-temp-buffer) ;Obsolete: now a macro. (defun byte-compile-catch (form) (byte-compile-form (car (cdr form))) diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 8e38df43c87..607810ee141 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -71,8 +71,7 @@ numbers of different types (float vs. integer), and also compares strings case-insensitively." (cond ((eq x y) t) ((stringp x) - (and (stringp y) (= (length x) (length y)) - (eq (compare-strings x nil nil y nil nil t) t))) + (and (stringp y) (string-equal-ignore-case x y))) ((numberp x) (and (numberp y) (= x y))) ((consp x) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9a635a47763..5ee10fcbca2 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -4293,6 +4293,8 @@ of (commands) to run simultaneously." (defun native-compile-prune-cache () "Remove .eln files that aren't applicable to the current Emacs invocation." (interactive) + (unless (featurep 'native-compile) + (user-error "This Emacs isn't built with native-compile support")) (dolist (dir native-comp-eln-load-path) ;; If a directory is non absolute it is assumed to be relative to ;; `invocation-directory'. diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index e5f055d0321..8d7f182e0cd 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -491,9 +491,9 @@ If INTERACTIVE, display it. Else, return said buffer." (setq-local eldoc--doc-buffer-docs docs) (let ((inhibit-read-only t) (things-reported-on)) - (erase-buffer) (setq buffer-read-only t) + (special-mode) + (erase-buffer) (setq-local nobreak-char-display nil) - (local-set-key "q" 'quit-window) (cl-loop for (docs . rest) on docs for (this-doc . plist) = docs for thing = (plist-get plist :thing) diff --git a/lisp/emacs-lisp/icons.el b/lisp/emacs-lisp/icons.el new file mode 100644 index 00000000000..00784c4d95d --- /dev/null +++ b/lisp/emacs-lisp/icons.el @@ -0,0 +1,265 @@ +;;; icons.el --- Handling icons -*- lexical-binding:t -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; Author: Lars Ingebrigtsen <larsi@gnus.org> +;; Keywords: icons buttons + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'cl-lib) + +(defface icon + '((t :underline nil)) + "Face for buttons." + :version "29.1" + :group 'customize) + +(defface icon-button + '((((type x w32 ns haiku pgtk) (class color)) + :inherit icon + :box (:line-width (3 . -1) :color "#404040" :style flat-button) + :background "#808080" + :foreground "black")) + "Face for buttons." + :version "29.1" + :group 'customize) + +(defcustom icon-preference '(image emoji symbol text) + "List of icon types to use, in order of preference. +Emacs will choose the icon of the highest preference possible +on the current display, and \"degrade\" gracefully to an icon +type that's available." + :version "29.1" + :group 'customize + :type '(repeat (const :tag "Images" image) + (const :tag "Colorful Emojis" emoji) + (const :tag "Monochrome Symbols" symbol) + (const :tag "Text Only" text))) + +(defmacro define-icon (name parent specification documentation &rest keywords) + "Define an icon identified by NAME. +If non-nil, inherit the specification from PARENT. Entries from +SPECIFICATION will override inherited specifications. + +SPECIFICATION is an alist of entries where the first element is +the type, and the rest are icons of that type. Valid types are +`image', `emoji', `symbol' and `text'. + +KEYWORDS specify additional information. Valid keywords are: + +`:version': The first Emacs version to include this icon; this is +mandatory. + +`:group': The customization group the icon belongs in; this is +inferred if not present. + +`:help-echo': Informational text that explains what happens if +the icon is used as a button and you click it." + (declare (indent 2)) + (unless (symbolp name) + (error "NAME must be a symbol: %S" name)) + (unless (plist-get keywords :version) + (error "There must be a :version keyword in `define-icon'")) + `(icons--register ',name ',parent ,specification ,documentation + ',keywords)) + +(defun icons--register (name parent spec doc keywords) + (put name 'icon--properties (list parent spec doc keywords)) + (custom-add-to-group + (or (plist-get keywords :group) + (custom-current-group)) + name 'custom-icon)) + +(defun icon-spec-keywords (spec) + (seq-drop-while (lambda (e) (not (keywordp e))) (cdr spec))) + +(defun icon-spec-values (spec) + (seq-take-while (lambda (e) (not (keywordp e))) (cdr spec))) + +(defun iconp (object) + "Return nil if OBJECT is not an icon. +If OBJECT is an icon, return the icon properties." + (get object 'icon--properties)) + +(defun icon-documentation (icon) + "Return the documentation for ICON." + (let ((props (iconp icon))) + (unless props + (user-error "%s is not a valid icon" icon)) + (nth 2 props))) + +(defun icons--spec (icon) + (nth 1 (iconp icon))) + +(defun icons--copy-spec (spec) + (mapcar #'copy-sequence spec)) + +(defun icon-complete-spec (icon &optional inhibit-theme inhibit-inheritance) + "Return the merged spec for ICON." + (pcase-let ((`(,parent ,spec _ _) (iconp icon))) + ;; We destructively modify `spec' when merging, so copy it. + (setq spec (icons--copy-spec spec)) + ;; Let the Customize theme override. + (unless inhibit-theme + (when-let ((theme-spec (cadr (car (get icon 'theme-icon))))) + (setq spec (icons--merge-spec (icons--copy-spec theme-spec) spec)))) + ;; Inherit from the parent spec (recursively). + (unless inhibit-inheritance + (while parent + (let ((parent-props (get parent 'icon--properties))) + (when parent-props + (setq spec (icons--merge-spec spec (cadr parent-props)))) + (setq parent (car parent-props))))) + spec)) + +(defun icon-string (name) + "Return a string suitable for display in the current buffer for icon NAME." + (let ((props (iconp name))) + (unless props + (user-error "%s is not a valid icon" name)) + (pcase-let ((`(_ ,spec _ ,keywords) props)) + (setq spec (icon-complete-spec name)) + ;; We now have a full spec, so check the intersection of what + ;; the user wants and what this Emacs is capable of showing. + (let ((icon-string + (catch 'found + (dolist (type icon-preference) + (let* ((type-spec (assq type spec)) + ;; Find the keywords at the end of the section + ;; (if any). + (type-keywords (icon-spec-keywords type-spec))) + ;; Go through all the variations in this section + ;; and return the first one we can display. + (dolist (icon (icon-spec-values type-spec)) + (when-let ((result + (icons--create type icon type-keywords))) + (throw 'found + (if-let ((face (plist-get type-keywords :face))) + (propertize result 'face face) + result))))))))) + (unless icon-string + (error "Couldn't find any way to display the %s icon" name)) + (when-let ((help (plist-get keywords :help-echo))) + (setq icon-string (propertize icon-string 'help-echo help))) + (propertize icon-string 'rear-nonsticky t))))) + +(defun icon-elements (name) + "Return the elements of icon NAME. +The elements are represented as a plist where the keys are +`string', `face' and `display'. The `image' element is only +present if the icon is represented by an image." + (let ((string (icon-string name))) + (list 'face (get-text-property 0 'face string) + 'image (get-text-property 0 'display string) + 'string (substring-no-properties string)))) + +(defun icons--merge-spec (merged parent-spec) + (dolist (elem parent-spec) + (let ((current (assq (car elem) merged))) + (if (not current) + ;; Just add the entry. + (push elem merged) + ;; See if there are any keywords to inherit. + (let ((parent-keywords (icon-spec-keywords elem)) + (current-keywords (icon-spec-keywords current))) + (while parent-keywords + (unless (plist-get (car parent-keywords) current-keywords) + (nconc current (take 2 parent-keywords)) + (setq parent-keywords (cddr parent-keywords)))))))) + merged) + +(cl-defmethod icons--create ((_type (eql 'image)) icon keywords) + (let ((file (if (file-name-absolute-p icon) + icon + (image-search-load-path icon)))) + (and (display-images-p) + (image-supported-file-p file) + (propertize + " " 'display + (if-let ((height (plist-get keywords :height))) + (create-image file + nil nil + :height (if (eq height 'line) + (window-default-line-height) + height) + :scale 1) + (create-image file)))))) + +(cl-defmethod icons--create ((_type (eql 'emoji)) icon _keywords) + (when-let ((font (and (display-multi-font-p) + ;; FIXME: This is not enough for ensuring + ;; display of color Emoji. + (car (internal-char-font nil ?😀))))) + (and (font-has-char-p font (aref icon 0)) + icon))) + +(cl-defmethod icons--create ((_type (eql 'symbol)) icon _keywords) + (and (cl-every #'char-displayable-p icon) + icon)) + +(cl-defmethod icons--create ((_type (eql 'text)) icon _keywords) + icon) + +(define-icon button nil + '((image :face icon-button) + (emoji "🔵" :face icon) + (symbol "●" :face icon-button) + (text "button" :face icon-button)) + "Base icon for buttons." + :version "29.1") + +;;;###autoload +(defun describe-icon (icon) + "Pop to a buffer to describe ICON." + (interactive + (list (intern (completing-read "Describe icon: " obarray 'iconp t)))) + (let ((help-buffer-under-preparation t)) + (help-setup-xref (list #'describe-icon icon) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) + (with-current-buffer standard-output + (insert "Icon: " (symbol-name icon) "\n\n") + (insert "Documentation:\n" + (substitute-command-keys (icon-documentation icon))) + (ensure-empty-lines) + (let ((spec (icon-complete-spec icon)) + (plain (icon-complete-spec icon t t))) + (insert "Specification including inheritance and theming:\n") + (icons--describe-spec spec) + (unless (equal spec plain) + (insert "\nSpecification not including inheritance and theming:\n") + (icons--describe-spec plain))))))) + +(defun icons--describe-spec (spec) + (dolist (elem spec) + (let ((type (car elem)) + (values (icon-spec-values elem)) + (keywords (icon-spec-keywords elem))) + (when (or values keywords) + (insert (format "\nType: %s\n" type)) + (dolist (value values) + (insert (format " %s\n" value))) + (while keywords + (insert (format " %s: %s\n" (pop keywords) (pop keywords)))))))) + +(provide 'icons) + +;;; icons.el ends here diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 00beee811ba..b25865f429f 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -785,10 +785,14 @@ byte-compilation of the new package to fail." (with-demoted-errors "Error in package--load-files-for-activation: %s" (let* (result (dir (package-desc-dir pkg-desc)) - (load-path-sans-dir - (cl-remove-if (apply-partially #'string= dir) - (or (bound-and-true-p find-function-source-path) - load-path))) + ;; A previous implementation would skip `dir' itself. + ;; However, in normal use reloading from the same directory + ;; never happens anyway, while in certain cases external to + ;; Emacs a package in the same directory not necessary + ;; stays byte-identical, e.g. during development. Just + ;; don't special-case `dir'. + (effective-path (or (bound-and-true-p find-library-source-path) + load-path)) (files (directory-files-recursively dir "\\`[^\\.].*\\.el\\'")) (history (mapcar #'file-truename (cl-remove-if-not #'stringp @@ -796,8 +800,19 @@ byte-compilation of the new package to fail." (dolist (file files) (when-let ((library (package--library-stem (file-relative-name file dir))) - (canonical (locate-library library nil load-path-sans-dir)) - (found (member (file-truename canonical) history)) + (canonical (locate-library library nil effective-path)) + (truename (file-truename canonical)) + ;; Normally, all files in a package are compiled by + ;; now, but don't assume that. E.g. different + ;; versions can add or remove `no-byte-compile'. + (altname (if (string-suffix-p ".el" truename) + (replace-regexp-in-string + "\\.el\\'" ".elc" truename t) + (replace-regexp-in-string + "\\.elc\\'" ".el" truename t))) + (found (or (member truename history) + (and (not (string= altname truename)) + (member altname history)))) (recent-index (length found))) (unless (equal (file-name-base library) (format "%s-autoloads" (package-desc-name pkg-desc))) @@ -1310,7 +1325,7 @@ errors signaled by ERROR-FORM or by BODY). (cl-defun package--with-response-buffer-1 (url body &key async file error-function noerror &allow-other-keys) (if (string-match-p "\\`https?:" url) - (let ((url (concat url file))) + (let ((url (url-expand-file-name file url))) (if async (package--unless-error #'ignore (url-retrieve diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el index 2343a9b589f..da32e4564f6 100644 --- a/lisp/emacs-lisp/shadow.el +++ b/lisp/emacs-lisp/shadow.el @@ -128,11 +128,8 @@ See the documentation for `list-load-path-shadows' for further information." (if (setq orig-dir (assoc file files - (when dir-case-insensitive - (lambda (f1 f2) - (eq (compare-strings f1 nil nil - f2 nil nil t) - t))))) + (and dir-case-insensitive + #'string-equal-ignore-case))) ;; This file was seen before, we have a shadowing. ;; Report it unless the files are identical. (let ((base1 (concat (cdr orig-dir) "/" (car orig-dir))) diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index 05b3361cb3d..315afd4312b 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -243,6 +243,8 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), "Predicates for Strings" (string-equal :eval (string-equal "foo" "foo")) + (string-equal-ignore-case + :eval (string-equal-ignore-case "foo" "FOO")) (eq :eval (eq "foo" "foo")) (eql diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 5037ae47e83..d5d7bfeb6f5 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -107,12 +107,16 @@ characters; nil stands for the empty string." ;;;###autoload (defun string-truncate-left (string length) - "Truncate STRING to LENGTH, replacing initial surplus with \"...\"." + "If STRING is longer than LENGTH, return a truncated version. +When truncating, \"...\" is always prepended to the string, so +the resulting string may be longer than the original if LENGTH is +3 or smaller." (let ((strlen (length string))) (if (<= strlen length) string (setq length (max 0 (- length 3))) - (concat "..." (substring string (max 0 (- strlen 1 length))))))) + (concat "..." (substring string (min (1- strlen) + (max 0 (- strlen length)))))))) (defsubst string-blank-p (string) "Check whether STRING is either empty or only whitespace. diff --git a/lisp/emacs-lisp/trace.el b/lisp/emacs-lisp/trace.el index c2f6c162269..aea12f146da 100644 --- a/lisp/emacs-lisp/trace.el +++ b/lisp/emacs-lisp/trace.el @@ -1,6 +1,6 @@ ;;; trace.el --- tracing facility for Emacs Lisp functions -*- lexical-binding: t -*- -;; Copyright (C) 1993, 1998, 2000-2022 Free Software Foundation, Inc. +;; Copyright (C) 1993-2022 Free Software Foundation, Inc. ;; Author: Hans Chalupsky <hans@cs.buffalo.edu> ;; Maintainer: emacs-devel@gnu.org @@ -22,12 +22,6 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. -;; LCD Archive Entry: -;; trace|Hans Chalupsky|hans@cs.buffalo.edu| -;; Tracing facility for Emacs Lisp functions| -;; 1993/05/18 00:41:16|2.0|~/packages/trace.el.Z| - - ;;; Commentary: ;; Introduction: diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el index 23e20c3b10c..516fdeb10ea 100644 --- a/lisp/emacs-lisp/warnings.el +++ b/lisp/emacs-lisp/warnings.el @@ -27,6 +27,8 @@ ;;; Code: +(require 'icons) + (defgroup warnings nil "Log and display warnings." :version "22.1" @@ -201,20 +203,28 @@ SUPPRESS-LIST is the list of kinds of warnings to suppress." ;; we return t. some-match)) -(define-button-type 'warning-suppress-warning - 'action #'warning-suppress-action - 'help-echo "mouse-2, RET: Don't display this warning automatically") -(defun warning-suppress-action (button) - (customize-save-variable 'warning-suppress-types - (cons (list (button-get button 'warning-type)) - warning-suppress-types))) -(define-button-type 'warning-suppress-log-warning - 'action #'warning-suppress-log-action - 'help-echo "mouse-2, RET: Don't log this warning") -(defun warning-suppress-log-action (button) - (customize-save-variable 'warning-suppress-log-types - (cons (list (button-get button 'warning-type)) - warning-suppress-types))) +(define-icon warnings-suppress button + '((emoji "⛔") + (symbol " ■ ") + (text " stop ")) + "Suppress warnings." + :version "29.1" + :help-echo "Click to supress this warning type") + +(defun warnings-suppress (type) + (pcase (car + (read-multiple-choice + (format "Suppress `%s' warnings? " type) + `((?y ,(format "yes, ignore `%s' warnings completely" type)) + (?n "no, just disable showing them") + (?q "quit and do nothing")))) + (?y + (customize-save-variable 'warning-suppress-log-types + (cons type warning-suppress-log-types))) + (?n + (customize-save-variable 'warning-suppress-types + (cons type warning-suppress-types))) + (_ (message "Exiting")))) ;;;###autoload (defun display-warning (type message &optional level buffer-name) @@ -289,23 +299,18 @@ entirely by setting `warning-suppress-types' or (unless (bolp) (funcall newline)) (setq start (point)) + ;; Don't output the button when doing batch compilation + ;; and similar. + (unless (or noninteractive (eq type 'bytecomp)) + (insert (buttonize (icon-string 'warnings-suppress) + #'warnings-suppress type) + " ")) (if warning-prefix-function (setq level-info (funcall warning-prefix-function level level-info))) (insert (format (nth 1 level-info) (format warning-type-format typename)) message) - ;; Don't output the buttons when doing batch compilation - ;; and similar. - (unless (or noninteractive (eq type 'bytecomp)) - (insert " ") - (insert-button "Disable showing" - 'type 'warning-suppress-warning - 'warning-type type) - (insert " ") - (insert-button "Disable logging" - 'type 'warning-suppress-log-warning - 'warning-type type)) (funcall newline) (when (and warning-fill-prefix (not (string-search "\n" message)) diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index 8be4894ecbb..df9efe4b0c3 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -230,7 +230,7 @@ current IRC process is still alive.") (defvar-local erc-server-lines-sent nil "Line counter.") -(defvar-local erc-server-last-peers '(nil . nil) +(defvar-local erc-server-last-peers nil "Last peers used, both sender and receiver. Those are used for /MSG destination shortcuts.") @@ -562,7 +562,7 @@ TLS (see `erc-session-client-certificate' for more details)." (setq erc-server-last-received-time time)) (setq erc-server-lines-sent 0) ;; last peers (sender and receiver) - (setq erc-server-last-peers '(nil . nil))) + (setq erc-server-last-peers (cons nil nil))) ;; we do our own encoding and decoding (when (fboundp 'set-process-coding-system) (set-process-coding-system process 'raw-text)) @@ -939,21 +939,20 @@ be used. If the target is \".\", the last person you've sent a message to will be used." (cond ((string-match "^\\s-*\\(\\S-+\\) ?\\(.*\\)" line) - (let ((tgt (match-string 1 line)) - (s (match-string 2 line))) + (let* ((tgt (match-string 1 line)) + (s (match-string 2 line)) + (server-buffer (erc-server-buffer)) + (peers (buffer-local-value 'erc-server-last-peers server-buffer))) (erc-log (format "cmd: MSG(%s): [%s] %s" message-command tgt s)) (cond ((string= tgt ",") - (if (car erc-server-last-peers) - (setq tgt (car erc-server-last-peers)) - (setq tgt nil))) + (setq tgt (car peers))) ((string= tgt ".") - (if (cdr erc-server-last-peers) - (setq tgt (cdr erc-server-last-peers)) - (setq tgt nil)))) + (setq tgt (cdr peers)))) (cond (tgt - (setcdr erc-server-last-peers tgt) + (with-current-buffer server-buffer + (setq erc-server-last-peers (cons (car peers) tgt))) (erc-server-send (format "%s %s :%s" message-command tgt s) force)) (t @@ -1012,21 +1011,15 @@ PROCs `process-buffer' is `current-buffer' when this function is called." (save-match-data (let* ((tag-list (when (eq (aref string 0) ?@) (substring string 1 - (if (>= emacs-major-version 28) - (string-search " " string) - (string-match " " string))))) + (string-search " " string)))) (msg (make-erc-response :unparsed string :tags (when tag-list (erc-parse-tags tag-list)))) (string (if tag-list - (substring string (+ 1 (if (>= emacs-major-version 28) - (string-search " " string) - (string-match " " string)))) + (substring string (+ 1 (string-search " " string))) string)) (posn (if (eq (aref string 0) ?:) - (if (>= emacs-major-version 28) - (string-search " " string) - (string-match " " string)) + (string-search " " string) 0))) (setf (erc-response.sender msg) @@ -1036,9 +1029,7 @@ PROCs `process-buffer' is `current-buffer' when this function is called." (setf (erc-response.command msg) (let* ((bposn (string-match "[^ \n]" string posn)) - (eposn (if (>= emacs-major-version 28) - (string-search " " string bposn) - (string-match " " string bposn)))) + (eposn (string-search " " string bposn))) (setq posn (and eposn (string-match "[^ \n]" string eposn))) (substring string bposn eposn))) @@ -1046,9 +1037,7 @@ PROCs `process-buffer' is `current-buffer' when this function is called." (while (and posn (not (eq (aref string posn) ?:))) (push (let* ((bposn posn) - (eposn (if (>= emacs-major-version 28) - (string-search " " string bposn) - (string-match " " string bposn)))) + (eposn (string-search " " string bposn))) (setq posn (and eposn (string-match "[^ \n]" string eposn))) (substring string bposn eposn)) @@ -1526,11 +1515,13 @@ add things to `%s' instead." (setf (erc-response.contents parsed) msg) (setq buffer (erc-get-buffer (if privp nick tgt) proc)) ;; Even worth checking for empty target here? (invalid anyway) - (unless (or buffer noticep (string-empty-p tgt) (eq ?$ (aref tgt 0))) - (if (and privp msgp (not (erc-is-message-ctcp-and-not-action-p msg))) + (unless (or buffer noticep (string-empty-p tgt) (eq ?$ (aref tgt 0)) + (erc-is-message-ctcp-and-not-action-p msg)) + (if privp (when erc-auto-query (let ((erc-join-buffer erc-auto-query)) (setq buffer (erc--open-target nick)))) + ;; A channel buffer has been killed but is still joined (setq buffer (erc--open-target tgt)))) (when buffer (with-current-buffer buffer @@ -1550,7 +1541,7 @@ add things to `%s' instead." (erc-process-ctcp-reply proc parsed nick login host (match-string 1 msg))))) (t - (setcar erc-server-last-peers nick) + (setq erc-server-last-peers (cons nick (cdr erc-server-last-peers))) (setq s (erc-format-privmessage (or fnick nick) msg ;; If buffer is a query buffer, @@ -1667,9 +1658,7 @@ Then display the welcome message." start (- (match-end 0) 3)) (setq start (match-end 0)))) v)) - (if (if (>= emacs-major-version 28) - (string-search "," value) - (string-match-p "," value)) + (if (string-search "," value) (split-string value ",") (list value))))) diff --git a/lisp/erc/erc-compat.el b/lisp/erc/erc-compat.el index 16cfb15a5ae..8a00e711acd 100644 --- a/lisp/erc/erc-compat.el +++ b/lisp/erc/erc-compat.el @@ -25,8 +25,14 @@ ;; This mostly defines stuff that cannot be worked around easily. +;; ERC depends on the `compat' library from GNU ELPA for supporting +;; older versions of Emacs. See this discussion for additional info: +;; https://lists.gnu.org/archive/html/emacs-devel/2022-07/msg00512.html + ;;; Code: +(require 'compat nil 'noerror) + ;;;###autoload(autoload 'erc-define-minor-mode "erc-compat") (define-obsolete-function-alias 'erc-define-minor-mode #'define-minor-mode "28.1") diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el index d0e1848e0eb..977080a4de1 100644 --- a/lisp/erc/erc-dcc.el +++ b/lisp/erc/erc-dcc.el @@ -191,9 +191,7 @@ compared with `erc-nick-equal-p' which is IRC case-insensitive." test (cadr (plist-member elt prop))) ;; if the property exists and is equal, we continue, else, try the ;; next element of the list - (or (and (eq prop :nick) (if (>= emacs-major-version 28) - (string-search "!" val) - (string-match "!" val)) + (or (and (eq prop :nick) (string-search "!" val) test (string-equal test val)) (and (eq prop :nick) test val @@ -659,13 +657,7 @@ that subcommand." (define-inline erc-dcc-unquote-filename (filename) (inline-quote - (if (>= emacs-major-version 28) - (string-replace - "\\\\" "\\" - (string-replace "\\\"" "\"" ,filename)) - (replace-regexp-in-string - "\\\\\\\\" "\\" - (replace-regexp-in-string "\\\\\"" "\"" ,filename t t) t t)))) + (string-replace "\\\\" "\\" (string-replace "\\\"" "\"" ,filename)))) (defun erc-dcc-handle-ctcp-send (proc query nick login host to) "This is called if a CTCP DCC SEND subcommand is sent to the client. @@ -987,7 +979,7 @@ The contents of the BUFFER will then be erased." ;; If people really need this, we can convert it into a proper option. -(defvar erc-dcc--X-send-final-turbo-ack nil +(defvar erc-dcc--send-final-turbo-ack nil "Workaround for maverick turbo senders that only require a final ACK. The only known culprit is WeeChat, with its xfer.network.fast_send option, which is on by default. Leaving this set to nil and calling @@ -1032,7 +1024,7 @@ rather than every 1024 byte block, but nobody seems to care." ;; Some senders want us to hang up. Only observed w. TSEND. ((and (plist-get erc-dcc-entry-data :turbo) (= received-bytes (plist-get erc-dcc-entry-data :size))) - (when erc-dcc--X-send-final-turbo-ack + (when erc-dcc--send-final-turbo-ack (process-send-string proc (erc-pack-int received-bytes))) (delete-process proc)) ((not (or (plist-get erc-dcc-entry-data :turbo) @@ -1182,18 +1174,18 @@ other client." (proc (plist-get entry :peer)) (parent-proc (plist-get entry :parent))) (erc-setup-buffer buffer) - ;; buffer is now the current buffer. - (erc-dcc-chat-mode) - (setq erc-server-process parent-proc) - (setq erc-dcc-from nick) - (setq erc-dcc-entry-data entry) - (setq erc-dcc-unprocessed-output "") - (setq erc-insert-marker (point-max-marker)) - (setq erc-input-marker (make-marker)) - (erc-display-prompt buffer (point-max)) - (set-process-buffer proc buffer) - (add-hook 'kill-buffer-hook #'erc-dcc-chat-buffer-killed nil t) - (run-hook-with-args 'erc-dcc-chat-connect-hook proc) + (with-current-buffer buffer + (erc-dcc-chat-mode) + (setq erc-server-process parent-proc + erc-dcc-from nick + erc-dcc-entry-data entry + erc-dcc-unprocessed-output "" + erc-insert-marker (point-max-marker) + erc-input-marker (make-marker)) + (erc-display-prompt buffer (point-max)) + (set-process-buffer proc buffer) + (add-hook 'kill-buffer-hook #'erc-dcc-chat-buffer-killed nil t) + (run-hook-with-args 'erc-dcc-chat-connect-hook proc)) buffer)) (defun erc-dcc-chat-accept (entry parent-proc) diff --git a/lisp/erc/erc-speedbar.el b/lisp/erc/erc-speedbar.el index 5b06c21612f..19113c5aad0 100644 --- a/lisp/erc/erc-speedbar.el +++ b/lisp/erc/erc-speedbar.el @@ -139,9 +139,7 @@ This will add a speedbar major display mode." t)))) (defun erc-speedbar-expand-server (text server indent) - (cond ((if (>= emacs-major-version 28) - (string-search "+" text) - (string-match "\\+" text)) + (cond ((string-search "+" text) (speedbar-change-expand-button-char ?-) (if (speedbar-with-writable (save-excursion @@ -150,9 +148,7 @@ This will add a speedbar major display mode." (speedbar-change-expand-button-char ?-) (speedbar-change-expand-button-char ??))) (;; we have to contract this node - (if (>= emacs-major-version 28) - (string-search "-" text) - (string-match "-" text)) + (string-search "-" text) (speedbar-change-expand-button-char ?+) (speedbar-delete-subblock indent)) (t (error "Ooops... not sure what to do"))) @@ -189,9 +185,7 @@ This will add a speedbar major display mode." "For the line matching TEXT, in CHANNEL, expand or contract a line. INDENT is the current indentation level." (cond - ((if (>= emacs-major-version 28) - (string-search "+" text) - (string-match "\\+" text)) + ((string-search "+" text) (speedbar-change-expand-button-char ?-) (speedbar-with-writable (save-excursion @@ -240,9 +234,7 @@ INDENT is the current indentation level." (speedbar-with-writable (dolist (entry names) (erc-speedbar-insert-user entry ?+ (1+ indent)))))))))) - ((if (>= emacs-major-version 28) - (string-search "-" text) - (string-match "-" text)) + ((string-search "-" text) (speedbar-change-expand-button-char ?+) (speedbar-delete-subblock indent)) (t (error "Ooops... not sure what to do"))) @@ -293,9 +285,7 @@ The update is only done when the channel is actually expanded already." (erc-speedbar-expand-channel "+" buffer 1))))) (defun erc-speedbar-expand-user (text token indent) - (cond ((if (>= emacs-major-version 28) - (string-search "+" text) - (string-match "\\+" text)) + (cond ((string-search "+" text) (speedbar-change-expand-button-char ?-) (speedbar-with-writable (save-excursion @@ -318,9 +308,7 @@ The update is only done when the channel is actually expanded already." nil nil nil nil info nil nil nil (1+ indent))))))) - ((if (>= emacs-major-version 28) - (string-search "-" text) - (string-match "-" text)) + ((string-search "-" text) (speedbar-change-expand-button-char ?+) (speedbar-delete-subblock indent)) (t (error "Ooops... not sure what to do"))) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 4b852b39045..151d75e7ce1 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -13,7 +13,7 @@ ;; Michael Olson (mwolson@gnu.org) ;; Kelvin White (kwhite@gnu.org) ;; Version: 5.4.1 -;; Package-Requires: ((emacs "27.1")) +;; Package-Requires: ((emacs "27.1") (compat "28.1.2.0")) ;; Keywords: IRC, chat, client, Internet ;; URL: https://www.gnu.org/software/emacs/erc.html @@ -69,6 +69,8 @@ (require 'iso8601) (eval-when-compile (require 'subr-x)) +(require 'erc-compat) + (defconst erc-version "5.4.1" "This version of ERC.") @@ -3519,9 +3521,7 @@ Without SECRET, consult auth-source, possibly passing SERVER as the "Non-nil when channel is server-local on a network that allows them." (and-let* (((eq ?& (aref channel 0))) (chan-types (erc--get-isupport-entry 'CHANTYPES 'single)) - ((if (>= emacs-major-version 28) - (string-search "&" chan-types) - (string-match-p "&" chan-types)))))) + ((string-search "&" chan-types))))) (defun erc-cmd-JOIN (channel &optional key) "Join the channel given in CHANNEL, optionally with KEY. @@ -4654,8 +4654,9 @@ a new window, but not to select it. See the documentation for (const :tag "Use current buffer" buffer) (const :tag "Use current buffer" t))) -;; FIXME either retire this or put it to use or more clearly explain -;; what it's supposed to do. It's currently only used by the obsolete +;; FIXME either retire this or put it to use after determining how +;; it's meant to work. Clearly, the doc string does not describe +;; current behavior. It's currently only used by the obsolete ;; function `erc-auto-query'. (defcustom erc-query-on-unjoined-chan-privmsg t "If non-nil create query buffer on receiving any PRIVMSG at all. @@ -7004,21 +7005,12 @@ shortened server name instead." (fill-region (point-min) (point-max)) (buffer-string)))) (setq header-line-format - (if (>= emacs-major-version 28) - (string-replace - "%" - "%%" - (if face - (propertize header 'help-echo help-echo - 'face face) - (propertize header 'help-echo help-echo))) - (replace-regexp-in-string - "%" - "%%" - (if face - (propertize header 'help-echo help-echo - 'face face) - (propertize header 'help-echo help-echo))))))) + (string-replace + "%" + "%%" + (if face + (propertize header 'help-echo help-echo 'face face) + (propertize header 'help-echo help-echo)))))) (t (setq header-line-format (if face (propertize header 'face face) @@ -7303,9 +7295,7 @@ functions." nick user host channel (if (not (string= reason "")) (format ": %s" - (if (>= emacs-major-version 28) - (string-replace "%" "%%" reason) - (replace-regexp-in-string "%" "%%" reason))) + (string-replace "%" "%%" reason)) ""))))) diff --git a/lisp/faces.el b/lisp/faces.el index f04ea9115ee..0418cd4c05f 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -2496,18 +2496,9 @@ default." "Basic face for highlighting." :group 'basic-faces) -;; Region face: under NS, default to the system-defined selection -;; color (optimized for the fixed white background of other apps), -;; if background is light. (defface region '((((class color) (min-colors 88) (background dark)) :background "blue3" :extend t) - (((class color) (min-colors 88) (background light) (type gtk)) - :distant-foreground "gtk_selection_fg_color" - :background "gtk_selection_bg_color" :extend t) - (((class color) (min-colors 88) (background light) (type ns)) - :distant-foreground "ns_selection_fg_color" - :background "ns_selection_bg_color" :extend t) (((class color) (min-colors 88) (background light)) :background "lightgoldenrod2" :extend t) (((class color) (min-colors 16) (background dark)) diff --git a/lisp/ffap.el b/lisp/ffap.el index 9de0dd40d16..ffed9f9759d 100644 --- a/lisp/ffap.el +++ b/lisp/ffap.el @@ -24,10 +24,10 @@ ;;; Commentary: -;; -;; Command find-file-at-point replaces find-file. With a prefix, it -;; behaves exactly like find-file. Without a prefix, it first tries -;; to guess a default file or URL from the text around the point + +;; Command `find-file-at-point' replaces `find-file'. With a prefix, +;; it behaves exactly like find-file. Without a prefix, it first +;; tries to guess a default file or URL from the text around the point ;; (`ffap-require-prefix' swaps these behaviors). This is useful for ;; following references in situations such as mail or news buffers, ;; README's, MANIFEST's, and so on. Submit bugs or suggestions with @@ -68,29 +68,27 @@ ;; If you do not like these bindings, modify the variable ;; `ffap-bindings', or write your own. ;; -;; If you use ange-ftp, browse-url, complete, efs, it is best to load -;; or autoload them before ffap. If you use ff-paths, load it -;; afterwards. Try apropos {C-h a ffap RET} to get a list of the many -;; option variables. In particular, if ffap is slow, try these: +;; If you use ange-ftp, it is best to load or autoload it before ffap. +;; If you use ff-paths, load it afterwards. Try apropos {C-h a ffap +;; RET} to get a list of the many option variables. In particular, if +;; ffap is slow, try these: ;; ;; (setq ffap-alist nil) ; faster, dumber prompting -;; (setq ffap-machine-p-known 'accept) ; no pinging ;; (setq ffap-url-regexp nil) ; disable URL features in ffap ;; (setq ffap-shell-prompt-regexp nil) ; disable shell prompt stripping ;; (setq ffap-gopher-regexp nil) ; disable gopher bookmark matching ;; ;; ffap uses `browse-url' to fetch URLs. -;; For a hairier `ffap-url-fetcher', try ffap-url.el (same ftp site). ;; Also, you can add `ffap-menu-rescan' to various hooks to fontify ;; the file and URL references within a buffer. +;;; Code: + ;;; Change Log: -;; -;; The History and Contributors moved to ffap.LOG (same ftp site), +;; The History and Contributors moved to ffap.LOG, ;; which also has some old examples and commentary from ffap 1.5. - ;;; Todo list: ;; * let "/dir/file#key" jump to key (tag or regexp) in /dir/file ;; * find file of symbol if TAGS is loaded (like above) @@ -98,13 +96,10 @@ ;; * notice node in "(dired)Virtual Dired" (quotes, parentheses, whitespace) ;; * notice "machine.dom blah blah blah dir/file" (how?) ;; * regexp options for ffap-string-at-point, like font-lock (MCOOK) -;; * v19: could replace `ffap-locate-file' with a quieter `locate-library' +;; * could replace `ffap-locate-file' with a quieter `locate-library' ;; * handle "$(VAR)" in Makefiles ;; * use the font-lock machinery - -;;; Code: - (eval-when-compile (require 'cl-lib)) (require 'url-parse) (require 'thingatpt) @@ -173,7 +168,7 @@ well-formed, such as \"user@host\" or \"<user@host>\"." (defcustom ffap-ftp-default-user "anonymous" "User name in FTP file names generated by `ffap-host-to-filename'. Note this name may be omitted if it equals the default -\(either `efs-default-user' or `ange-ftp-default-user')." +(`ange-ftp-default-user')." :type 'string :group 'ffap) @@ -273,8 +268,7 @@ ffap most of the time." :risky t) (defcustom ffap-url-fetcher 'browse-url - "A function of one argument, called by ffap to fetch an URL. -For a fancy alternative, get `ffap-url.el'." + "A function of one argument, called by ffap to fetch an URL." :type '(choice (const browse-url) function) :group 'ffap @@ -433,13 +427,6 @@ Returned values: t means that HOST answered. `accept' means the relevant variable told us to accept. \"mesg\" means HOST exists, but does not respond for some reason." - ;; Try some (Emory local): - ;; (ffap-machine-p "ftp" nil nil 'ping) - ;; (ffap-machine-p "nonesuch" nil nil 'ping) - ;; (ffap-machine-p "ftp.mathcs.emory.edu" nil nil 'ping) - ;; (ffap-machine-p "mathcs" 5678 nil 'ping) - ;; (ffap-machine-p "foo.bonk" nil nil 'ping) - ;; (ffap-machine-p "foo.bonk.com" nil nil 'ping) (if (or (string-match "[^-[:alnum:].]" host) ; Invalid chars (?) (not (string-match "[^0-9]" host))) ; 1: a number? 2: quick reject nil @@ -495,16 +482,13 @@ Returned values: (defun ffap-replace-file-component (fullname name) "In remote FULLNAME, replace path with NAME. May return nil." - ;; Use efs if loaded, but do not load it otherwise. - (if (fboundp 'efs-replace-path-component) - (funcall 'efs-replace-path-component fullname name) - (and (stringp fullname) - (stringp name) - (concat (file-remote-p fullname) name)))) -;; (ffap-replace-file-component "/who@foo.com:/whatever" "/new") + (and (stringp fullname) + (stringp name) + (concat (file-remote-p fullname) name))) (defun ffap-file-suffix (file) "Return trailing `.foo' suffix of FILE, or nil if none." + (declare (obsolete file-name-extension "29.1")) (let ((pos (string-match "\\.[^./]*\\'" file))) (and pos (substring file pos nil)))) @@ -528,7 +512,7 @@ The optional NOMODIFY argument suppresses the extra search." ;; three reasons to suppress search: (nomodify nil) ((not (rassq 'jka-compr-handler file-name-handler-alist)) nil) - ((member (ffap-file-suffix file) ffap-compression-suffixes) nil) + ((member (file-name-extension file t) ffap-compression-suffixes) nil) (t ; ok, do the search (let ((list ffap-compression-suffixes) try ret) (while list @@ -539,9 +523,6 @@ The optional NOMODIFY argument suppresses the extra search." (defun ffap-file-remote-p (filename) "If FILENAME looks remote, return it (maybe slightly improved)." - ;; (ffap-file-remote-p "/user@foo.bar.com:/pub") - ;; (ffap-file-remote-p "/cssun.mathcs.emory.edu://dir") - ;; (ffap-file-remote-p "/ffap.el:80") (or (and ffap-ftp-regexp (string-match ffap-ftp-regexp filename) ;; Convert "/host.com://dir" to "/host:/dir", to handle a dying @@ -568,9 +549,8 @@ Looks at `ffap-ftp-default-user', returns \"\" for \"localhost\"." "" (let ((user ffap-ftp-default-user)) ;; Avoid including the user if it is same as default: - (if (or (equal user (ffap-symbol-value 'ange-ftp-default-user)) - (equal user (ffap-symbol-value 'efs-default-user))) - (setq user nil)) + (when (equal user (ffap-symbol-value 'ange-ftp-default-user)) + (setq user nil)) (concat "/" user (and user "@") host ":")))) (defun ffap-fixup-machine (mach) @@ -583,7 +563,7 @@ Looks at `ffap-ftp-default-user', returns \"\" for \"localhost\"." ;; www.ncsa.uiuc.edu ((and (string-match "\\`w\\(ww\\|eb\\)[-.]" mach)) (concat "http://" mach "/")) - ;; More cases? Maybe "telnet:" for archie? + ;; More cases? (ffap-ftp-regexp (ffap-host-to-filename mach)) )) @@ -643,18 +623,6 @@ Looks at `ffap-ftp-default-user', returns \"\" for \"localhost\"." ;;; File Name Handling: -;; -;; The upcoming ffap-alist actions need various utilities to prepare -;; and search directories. Too many features here. - -;; (defun ffap-last (l) (while (cdr l) (setq l (cdr l))) l) -;; (defun ffap-splice (func inlist) -;; "Equivalent to (apply 'nconc (mapcar FUNC INLIST)), but less consing." -;; (let* ((head (cons 17 nil)) (last head)) -;; (while inlist -;; (setcdr last (funcall func (car inlist))) -;; (setq last (ffap-last last) inlist (cdr inlist))) -;; (cdr head))) (defun ffap-list-env (env &optional empty) "Return a list of strings parsed from environment variable ENV. @@ -793,7 +761,6 @@ This uses `ffap-file-exists-string', which may try adding suffixes from ("\\.\\(tex\\|sty\\|doc\\|cls\\)\\'" . ffap-tex) ("\\.bib\\'" . ffap-bib) ; search ffap-bib-path ("\\`\\." . ffap-home) ; .emacs, .bashrc, .profile - ("\\`~/" . ffap-lcd) ; |~/misc/ffap.el.Z| ;; This used to have a blank, but ffap-string-at-point doesn't ;; handle blanks. ;; https://lists.gnu.org/r/emacs-devel/2008-01/msg01058.html @@ -1041,7 +1008,7 @@ out of NAME." ;; Maybe a "Lisp Code Directory" reference: (defun ffap-lcd (name) - ;; FIXME: Is this still in use? + (declare (obsolete nil "29.1")) (and (or ;; lisp-dir-apropos output buffer: diff --git a/lisp/files.el b/lisp/files.el index bc74dfa7381..bea0c13d25f 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -1428,7 +1428,7 @@ containing it, until no links are left at any level. ;; If these are equal, we have the (or a) root directory. (or (string= dir dirfile) (and (file-name-case-insensitive-p dir) - (eq (compare-strings dir 0 nil dirfile 0 nil t) t)) + (string-equal-ignore-case dir dirfile)) ;; If this is the same dir we last got the truename for, ;; save time--don't recalculate. (if (assoc dir (car prev-dirs)) @@ -5119,14 +5119,16 @@ extension, the value is \"\"." ""))))) (defun file-name-with-extension (filename extension) - "Set the EXTENSION of a FILENAME. + "Return FILENAME modified to have the specified EXTENSION. The extension (in a file name) is the part that begins with the last \".\". +This function removes any existing extension from FILENAME, and then +appends EXTENSION to it. -Trims a leading dot from the EXTENSION so that either \"foo\" or -\".foo\" can be given. +EXTENSION may include the leading dot; if it doesn't, this function +will provide it. -Errors if the FILENAME or EXTENSION are empty, or if the given -FILENAME has the format of a directory. +It is an error if FILENAME or EXTENSION is empty, or if FILENAME +is in the form of a directory name according to `directory-name-p'. See also `file-name-sans-extension'." (let ((extn (string-trim-left extension "[.]"))) @@ -5459,21 +5461,17 @@ on a DOS/Windows machine, it returns FILENAME in expanded form." ;; Test for different drive letters (not (eq t (compare-strings filename 0 2 directory 0 2 fold-case))) ;; Test for UNCs on different servers - (not (eq t (compare-strings - (progn - (if (string-match "\\`//\\([^:/]+\\)/" filename) - (match-string 1 filename) - ;; Windows file names cannot have ? in - ;; them, so use that to detect when - ;; neither FILENAME nor DIRECTORY is a - ;; UNC. - "?")) - 0 nil - (progn - (if (string-match "\\`//\\([^:/]+\\)/" directory) - (match-string 1 directory) - "?")) - 0 nil t))))) + (not (string-equal-ignore-case + (if (string-match "\\`//\\([^:/]+\\)/" filename) + (match-string 1 filename) + ;; Windows file names cannot have ? in + ;; them, so use that to detect when + ;; neither FILENAME nor DIRECTORY is a + ;; UNC. + "?") + (if (string-match "\\`//\\([^:/]+\\)/" directory) + (match-string 1 directory) + "?"))))) ;; Test for different remote file system identification (not (equal fremote dremote))) filename diff --git a/lisp/font-core.el b/lisp/font-core.el index f92d1e38306..f70c42bb03f 100644 --- a/lisp/font-core.el +++ b/lisp/font-core.el @@ -65,7 +65,7 @@ Other variables include that for syntactic keyword fontification, `font-lock-syntactic-keywords' and those for buffer-specialized fontification functions, `font-lock-fontify-buffer-function', `font-lock-unfontify-buffer-function', `font-lock-fontify-region-function', -`font-lock-unfontify-region-function', and `font-lock-inhibit-thing-lock'.") +`font-lock-unfontify-region-function'.") ;; Autoload if this file no longer dumped. ;;;###autoload (put 'font-lock-defaults 'risky-local-variable t) diff --git a/lisp/font-lock.el b/lisp/font-lock.el index d815a9c9c46..4ae84220a71 100644 --- a/lisp/font-lock.el +++ b/lisp/font-lock.el @@ -490,8 +490,7 @@ of the line, i.e., cause the MATCHER search to span lines. These regular expressions can match text which spans lines, although it is better to avoid it if possible since updating them while editing text is slower, and it is not guaranteed to be -always correct when using support modes like jit-lock or -lazy-lock. +always correct. This variable is set by major modes via the variable `font-lock-defaults'. Be careful when composing regexps for this @@ -623,11 +622,8 @@ fontified.") It should take two args, the beginning and end of the region. This is normally set via `font-lock-defaults'.") -(defvar font-lock-inhibit-thing-lock nil - "List of Font Lock mode related modes that should not be turned on. -Currently, valid mode names are `fast-lock-mode', `jit-lock-mode' and -`lazy-lock-mode'. This is normally set via `font-lock-defaults'.") -(make-obsolete-variable 'font-lock-inhibit-thing-lock nil "25.1") +(defvar font-lock-inhibit-thing-lock nil) +(make-obsolete-variable 'font-lock-inhibit-thing-lock "it does nothing." "25.1") (defvar-local font-lock-multiline nil "Whether font-lock should cater to multiline keywords. @@ -642,7 +638,6 @@ Major/minor modes can set this variable if they know which option applies.") (eval-when-compile ;; - ;; Borrowed from lazy-lock.el. ;; We use this to preserve or protect things when modifying text properties. (defmacro save-buffer-state (&rest body) "Bind variables according to VARLIST and eval BODY restoring buffer state." @@ -881,65 +876,17 @@ happens, so the major mode can be corrected." ;;; Font Lock Support mode. -;; This is the code used to interface font-lock.el with any of its add-on -;; packages, and provide the user interface. Packages that have their own -;; local buffer fontification functions (see below) may have to call -;; `font-lock-after-fontify-buffer' and/or `font-lock-after-unfontify-buffer' -;; themselves. - -(defcustom font-lock-support-mode 'jit-lock-mode +(defvar font-lock-support-mode #'jit-lock-mode "Support mode for Font Lock mode. -Support modes speed up Font Lock mode by being choosy about when fontification -occurs. The default support mode, Just-in-time Lock mode (symbol -`jit-lock-mode'), is recommended. - -Other, older support modes are Fast Lock mode (symbol `fast-lock-mode') and -Lazy Lock mode (symbol `lazy-lock-mode'). See those modes for more info. -However, they are no longer recommended, as Just-in-time Lock mode is better. - If nil, means support for Font Lock mode is never performed. -If a symbol, use that support mode. -If a list, each element should be of the form (MAJOR-MODE . SUPPORT-MODE), -where MAJOR-MODE is a symbol or t (meaning the default). For example: - ((c-mode . fast-lock-mode) (c++-mode . fast-lock-mode) (t . lazy-lock-mode)) -means that Fast Lock mode is used to support Font Lock mode for buffers in C or -C++ modes, and Lazy Lock mode is used to support Font Lock mode otherwise. - -The value of this variable is used when Font Lock mode is turned on." - :type '(choice (const :tag "none" nil) - (const :tag "fast lock" fast-lock-mode) - (const :tag "lazy lock" lazy-lock-mode) - (const :tag "jit lock" jit-lock-mode) - (repeat :menu-tag "mode specific" :tag "mode specific" - :value ((t . jit-lock-mode)) - (cons :tag "Instance" - (radio :tag "Mode" - (const :tag "all" t) - (symbol :tag "name")) - (radio :tag "Support" - (const :tag "none" nil) - (const :tag "fast lock" fast-lock-mode) - (const :tag "lazy lock" lazy-lock-mode) - (const :tag "JIT lock" jit-lock-mode))) - )) - :version "21.1" - :group 'font-lock) +This can be useful for debugging. -(defvar fast-lock-mode) -(defvar lazy-lock-mode) -(defvar jit-lock-mode) +The value of this variable is used when Font Lock mode is turned on.") -(declare-function fast-lock-after-fontify-buffer "fast-lock") -(declare-function fast-lock-after-unfontify-buffer "fast-lock") -(declare-function fast-lock-mode "fast-lock") -(declare-function lazy-lock-after-fontify-buffer "lazy-lock") -(declare-function lazy-lock-after-unfontify-buffer "lazy-lock") -(declare-function lazy-lock-mode "lazy-lock") +(defvar jit-lock-mode) (defun font-lock-turn-on-thing-lock () (pcase (font-lock-value-in-major-mode font-lock-support-mode) - ('fast-lock-mode (fast-lock-mode t)) - ('lazy-lock-mode (lazy-lock-mode t)) ('jit-lock-mode ;; Prepare for jit-lock (remove-hook 'after-change-functions @@ -962,39 +909,11 @@ The value of this variable is used when Font Lock mode is turned on." nil t)))) (defun font-lock-turn-off-thing-lock () - (cond ((bound-and-true-p fast-lock-mode) - (fast-lock-mode -1)) - ((bound-and-true-p jit-lock-mode) + (cond ((bound-and-true-p jit-lock-mode) (jit-lock-unregister 'font-lock-fontify-region) ;; Reset local vars to the non-jit-lock case. - (kill-local-variable 'font-lock-fontify-buffer-function)) - ((bound-and-true-p lazy-lock-mode) - (lazy-lock-mode -1)))) - -(defun font-lock-after-fontify-buffer () - (cond ((bound-and-true-p fast-lock-mode) - (fast-lock-after-fontify-buffer)) - ;; Useless now that jit-lock intercepts font-lock-fontify-buffer. -sm - ;; (jit-lock-mode - ;; (jit-lock-after-fontify-buffer)) - ((bound-and-true-p lazy-lock-mode) - (lazy-lock-after-fontify-buffer)))) - -(defun font-lock-after-unfontify-buffer () - (cond ((bound-and-true-p fast-lock-mode) - (fast-lock-after-unfontify-buffer)) - ;; Useless as well. It's only called when: - ;; - turning off font-lock: it does not matter if we leave spurious - ;; `fontified' text props around since jit-lock-mode is also off. - ;; - font-lock-default-fontify-buffer fails: this is not run - ;; any more anyway. -sm - ;; - ;; (jit-lock-mode - ;; (jit-lock-after-unfontify-buffer)) - ((bound-and-true-p lazy-lock-mode) - (lazy-lock-after-unfontify-buffer)))) - -;; End of Font Lock Support mode. + (kill-local-variable 'font-lock-fontify-buffer-function)))) + ;;; Fontification functions. @@ -1160,7 +1079,6 @@ Lock mode." (save-excursion (save-match-data (font-lock-fontify-region (point-min) (point-max) verbose) - (font-lock-after-fontify-buffer) (setq font-lock-fontified t))) ;; We don't restore the old fontification, so it's best to unfontify. (quit (font-lock-unfontify-buffer))))))) @@ -1171,7 +1089,6 @@ Lock mode." (save-restriction (widen) (font-lock-unfontify-region (point-min) (point-max)) - (font-lock-after-unfontify-buffer) (setq font-lock-fontified nil))) (defvar font-lock-dont-widen nil @@ -2395,6 +2312,10 @@ This should be an integer. Used in `cpp-font-lock-keywords'.") for C preprocessor directives. This definition is for the other modes in which C preprocessor directives are used, e.g. `asm-mode' and `ld-script-mode'.") + +(define-obsolete-function-alias 'font-lock-after-fontify-buffer #'ignore "29.1") +(define-obsolete-function-alias 'font-lock-after-unfontify-buffer #'ignore "29.1") + (provide 'font-lock) diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 4b68a54ce81..18baf982b2b 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -1939,8 +1939,8 @@ always hide." 'boring-headers))) ;; Hide boring Newsgroups header. ((eq elem 'newsgroups) - (when (gnus-string-equal - (gnus-fetch-field "newsgroups") + (when (string-equal-ignore-case + (or (gnus-fetch-field "newsgroups") "") (gnus-group-real-name (if (boundp 'gnus-newsgroup-name) gnus-newsgroup-name @@ -1954,7 +1954,7 @@ always hide." gnus-newsgroup-name "")))) (when (and to to-address (ignore-errors - (gnus-string-equal + (string-equal-ignore-case ;; only one address in To (nth 1 (mail-extract-address-components to)) to-address))) @@ -1967,7 +1967,7 @@ always hide." gnus-newsgroup-name "")))) (when (and to to-list (ignore-errors - (gnus-string-equal + (string-equal-ignore-case ;; only one address in To (nth 1 (mail-extract-address-components to)) to-list))) @@ -1980,15 +1980,15 @@ always hide." gnus-newsgroup-name "")))) (when (and cc to-list (ignore-errors - (gnus-string-equal + (string-equal-ignore-case ;; only one address in Cc (nth 1 (mail-extract-address-components cc)) to-list))) (gnus-article-hide-header "cc")))) ((eq elem 'followup-to) - (when (gnus-string-equal - (message-fetch-field "followup-to") - (message-fetch-field "newsgroups")) + (when (string-equal-ignore-case + (or (message-fetch-field "followup-to") "") + (or (message-fetch-field "newsgroups") "")) (gnus-article-hide-header "followup-to"))) ((eq elem 'reply-to) (if (gnus-group-find-parameter diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index 218a4d242b2..dda2b4ff5fc 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -1078,6 +1078,7 @@ ARG is passed to the first function." ;; (`string-equal' uses symbol print names.) (defun gnus-string-equal (x y) "Like `string-equal', except it compares case-insensitively." + (declare (obsolete string-equal-ignore-case "29.1")) (and (= (length x) (length y)) (or (string-equal x y) (string-equal (downcase x) (downcase y))))) diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el index 093e582ea7a..5cd57d2f801 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -980,13 +980,10 @@ type detected." (symbol-name type) value)))))) (defvar ange-ftp-name-format) -(defvar efs-path-regexp) (defun mml-parse-file-name (path) - (if (if (boundp 'efs-path-regexp) - (string-match efs-path-regexp path) - (if (boundp 'ange-ftp-name-format) - (string-match (car ange-ftp-name-format) path))) + (if (and (boundp 'ange-ftp-name-format) + (string-match (car ange-ftp-name-format) path)) (list (match-string 1 path) (match-string 2 path) (substring path (1+ (match-end 2)))) path)) @@ -1517,7 +1514,7 @@ BUFFER is the name of the buffer to attach. See (defun mml-attach-external (file &optional type description) "Attach an external file into the buffer. -FILE is an ange-ftp/efs specification of the part location. +FILE is an ange-ftp specification of the part location. TYPE is the MIME type to use." (interactive (let* ((file (mml-minibuffer-read-file "Attach external file: ")) diff --git a/lisp/gnus/nnheader.el b/lisp/gnus/nnheader.el index c1c5f00ff7f..ab57bd7eedd 100644 --- a/lisp/gnus/nnheader.el +++ b/lisp/gnus/nnheader.el @@ -918,15 +918,11 @@ first. Otherwise, find the newest one, though it may take a time." (car (sort results #'file-newer-than-file-p))))) (defvar ange-ftp-path-format) -(defvar efs-path-regexp) (defun nnheader-re-read-dir (path) "Re-read directory PATH if PATH is on a remote system." - (if (and (fboundp 'efs-re-read-dir) (boundp 'efs-path-regexp)) - (when (string-match efs-path-regexp path) - (efs-re-read-dir path)) - (when (and (fboundp 'ange-ftp-re-read-dir) (boundp 'ange-ftp-path-format)) - (when (string-match (car ange-ftp-path-format) path) - (ange-ftp-re-read-dir path))))) + (when (and (fboundp 'ange-ftp-re-read-dir) (boundp 'ange-ftp-path-format)) + (when (string-match (car ange-ftp-path-format) path) + (ange-ftp-re-read-dir path)))) (defun nnheader-insert-file-contents (filename &optional visit beg end replace) "Like `insert-file-contents', q.v., but only reads in the file. diff --git a/lisp/help-fns.el b/lisp/help-fns.el index dc64a09f3d8..768023b54c2 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -266,13 +266,9 @@ handling of autoloaded functions." (current-buffer))) (help-buffer-under-preparation t)) - (help-setup-xref - (list (lambda (function buffer) - (let ((describe-function-orig-buffer - (if (buffer-live-p buffer) buffer))) - (describe-function function))) - function describe-function-orig-buffer) - (called-interactively-p 'interactive)) + (help-setup-xref (list #'describe-function--helper + function describe-function-orig-buffer) + (called-interactively-p 'interactive)) (save-excursion (with-help-window (help-buffer) @@ -1030,7 +1026,7 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." (aliased (format-message "an alias for `%s'" real-def)) ((subr-native-elisp-p def) - (concat beg "native compiled Lisp function")) + (concat beg "native-compiled Lisp function")) ((subrp def) (concat beg (if (eq 'unevalled (cdr (subr-arity def))) "special form" @@ -1049,7 +1045,7 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." (macrop function)) (concat beg "Lisp macro")) ((byte-code-function-p def) - (concat beg "compiled Lisp function")) + (concat beg "byte-compiled Lisp function")) ((module-function-p def) (concat beg "module function")) ((eq (car-safe def) 'lambda) diff --git a/lisp/help-mode.el b/lisp/help-mode.el index e374f8e94de..f49d20270cf 100644 --- a/lisp/help-mode.el +++ b/lisp/help-mode.el @@ -384,8 +384,8 @@ The format is (FUNCTION ARGS...).") 'help-function (lambda (file pos) (if help-window-keep-selected - (view-buffer (find-file-noselect file)) - (view-buffer-other-window (find-file-noselect file))) + (view-file file) + (view-file-other-window file)) (goto-char pos)) 'help-echo (purecopy "mouse-2, RET: show corresponding NEWS announcement")) @@ -408,7 +408,7 @@ Commands: \\{help-mode-map}" (setq-local revert-buffer-function #'help-mode-revert-buffer) - (add-hook 'context-menu-functions 'help-mode-context-menu 5 t) + (add-hook 'context-menu-functions #'help-mode-context-menu 5 t) (setq-local tool-bar-map help-mode-tool-bar-map) (setq-local help-mode--current-data nil) @@ -678,9 +678,10 @@ that." (defun help-xref--navigation-buttons () (let ((inhibit-read-only t)) + (when (or help-xref-stack help-xref-forward-stack) + (ensure-empty-lines 1)) ;; Make a back-reference in this buffer if appropriate. (when help-xref-stack - (ensure-empty-lines 1) (help-insert-xref-button help-back-label 'help-back (current-buffer))) ;; Make a forward-reference in this buffer if appropriate. @@ -761,7 +762,7 @@ See `help-make-xrefs'." ;; Additional functions for (re-)creating types of help buffers. ;;;###autoload -(define-obsolete-function-alias 'help-xref-interned 'describe-symbol "25.1") +(define-obsolete-function-alias 'help-xref-interned #'describe-symbol "25.1") ;; Navigation/hyperlinking with xrefs @@ -831,7 +832,7 @@ The help buffers are divided into \"pages\" by the ^L character." (defun help-goto-previous-page () "Go to the previous page (if any) in the current buffer. -(If not at the start of a page, go to the start of the current page.) +\(If not at the start of a page, go to the start of the current page.) The help buffers are divided into \"pages\" by the ^L character." (interactive nil help-mode) diff --git a/lisp/help.el b/lisp/help.el index d9e553e4e10..1c1ce1618ca 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -606,7 +606,6 @@ or a buffer name." (setq-local outline-level (lambda () 1)) (setq-local outline-minor-mode-cycle t outline-minor-mode-highlight t) - (setq-local outline-minor-mode-use-buttons t) (outline-minor-mode 1) (save-excursion (goto-char (point-min)) @@ -906,6 +905,18 @@ Describe the following key, mouse click, or menu item: " ;; Defined in help-fns.el. (defvar describe-function-orig-buffer) +;; These two are named functions because lambda-functions cannot be +;; serialized in a native-compilation build, which breaks bookmark +;; support in help-mode.el. +(defun describe-key--helper (key-list buf) + (describe-key key-list + (if (buffer-live-p buf) buf))) + +(defun describe-function--helper (func buf) + (let ((describe-function-orig-buffer + (if (buffer-live-p buf) buf))) + (describe-function func))) + (defun describe-key (&optional key-list buffer up-event) "Display documentation of the function invoked by KEY-LIST. KEY-LIST can be any kind of a key sequence; it can include keyboard events, @@ -959,10 +970,7 @@ current buffer." `(,seq ,brief-desc ,defn ,locus))) key-list)) 2))) - (help-setup-xref (list (lambda (key-list buf) - (describe-key key-list - (if (buffer-live-p buf) buf))) - key-list buf) + (help-setup-xref (list #'describe-key--helper key-list buf) (called-interactively-p 'interactive)) (if (and (<= (length info-list) 1) (help--binding-undefined-p (nth 2 (car info-list)))) diff --git a/lisp/image-dired.el b/lisp/image-dired.el index 9ceaf1bf734..93cce33c2ba 100644 --- a/lisp/image-dired.el +++ b/lisp/image-dired.el @@ -913,7 +913,7 @@ Otherwise, delete overlays." (interactive) (setq image-dired-dired-disp-props (not image-dired-dired-disp-props)) - (message "Dired display properties %s." + (message "Dired display properties %s" (if image-dired-dired-disp-props "on" "off"))) @@ -1464,7 +1464,7 @@ Should be called from commands in `image-dired-thumbnail-mode'." `(let ((file-name (image-dired-original-file-name)) (dired-buf (image-dired-associated-dired-buffer))) (if (not (and dired-buf file-name)) - (message "No image, or image with correct properties, at point.") + (message "No image, or image with correct properties, at point") (with-current-buffer dired-buf (when (dired-goto-file file-name) ,@body @@ -2106,7 +2106,7 @@ default value at the prompt." (image-dired-set-exif-data file "ImageDescription" (read-string "Value of ImageDescription: " old-value))) - (message "Successfully wrote ImageDescription tag.") + (message "Successfully wrote ImageDescription tag") (error "Could not write ImageDescription tag"))))) (defun image-dired-set-exif-data (file tag-name tag-value) @@ -2295,7 +2295,7 @@ matching tag will be marked in the Dired buffer." (when (search-forward-regexp (format "\\s %s$" curr-file) nil t) (setq hits (+ hits 1)) (dired-mark 1)))) - (message "%d files with matching tag marked." hits))) + (message "%d files with matching tag marked" hits))) @@ -2728,14 +2728,14 @@ the operation by activating the Cancel button.\n\n") (lambda (&rest _ignore) (image-dired-save-information-from-widgets) (bury-buffer) - (message "Done.")) + (message "Done")) "Save") (widget-insert " ") (widget-create 'push-button :notify (lambda (&rest _ignore) (bury-buffer) - (message "Operation canceled.")) + (message "Operation canceled")) "Cancel") (widget-insert "\n") (use-local-map widget-keymap) @@ -2973,7 +2973,7 @@ Dired." (let ((file-name (image-dired-original-file-name)) (dired-buf (image-dired-associated-dired-buffer))) (if (not (and dired-buf file-name)) - (message "No image, or image with correct properties, at point.") + (message "No image, or image with correct properties, at point") (with-current-buffer dired-buf (message "%s" file-name) (when (dired-goto-file file-name) diff --git a/lisp/info.el b/lisp/info.el index fca40512246..7c1b34ed642 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -4520,7 +4520,7 @@ Advanced commands: ("java" . "ccmode") ("idl" . "ccmode") ("pike" . "ccmode") ("skeleton" . "autotype") ("auto-insert" . "autotype") ("copyright" . "autotype") ("executable" . "autotype") - ("time-stamp" . "autotype") ("quickurl" . "autotype") + ("time-stamp" . "autotype") ("tempo" . "autotype") ("hippie-expand" . "autotype") ("cvs" . "pcl-cvs") ("ada" . "ada-mode") "calc" ("calcAlg" . "calc") ("calcDigit" . "calc") ("calcVar" . "calc") diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index df1c06ec272..12896cc4b0e 100644 --- a/lisp/international/mule-cmds.el +++ b/lisp/international/mule-cmds.el @@ -2199,8 +2199,7 @@ See `set-language-info-alist' for use in programs." first nil)) (dolist (elt l) (when (or (eq input-method elt) - (eq t (compare-strings language-name nil nil - (nth 1 elt) nil nil t))) + (string-equal-ignore-case language-name (nth 1 elt))) (when first (insert "Input methods:\n") (setq first nil)) @@ -2599,7 +2598,7 @@ Matching is done ignoring case and any hyphens and underscores in the names. E.g. `ISO_8859-1' and `iso88591' both match `iso-8859-1'." (setq charset1 (replace-regexp-in-string "[-_]" "" charset1)) (setq charset2 (replace-regexp-in-string "[-_]" "" charset2)) - (eq t (compare-strings charset1 nil nil charset2 nil nil t))) + (string-equal-ignore-case charset1 charset2)) (defvar locale-charset-alist nil "Coding system alist keyed on locale-style charset name. diff --git a/lisp/mail/feedmail.el b/lisp/mail/feedmail.el index af12417f706..989a8b3cd67 100644 --- a/lisp/mail/feedmail.el +++ b/lisp/mail/feedmail.el @@ -211,14 +211,6 @@ ;; ;;;;;;;; ;; -;; I think the LCD is no longer being updated, but if it were, this -;; would be a proper LCD record. There is an old version of -;; feedmail.el in the LCD archive. It works but is missing a lot of -;; features. -;; -;; LCD record: -;; feedmail|WJCarpenter|bill-feedmail@carpenter.ORG|Outbound mail queue handling|01-??-??|11-beta-??|feedmail.el -;; ;; Change log: ;; original, 31 March 1991 ;; patchlevel 1, 5 April 1991 diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el index 71eda7cd2b0..4bfec22b3a9 100644 --- a/lisp/mail/rmail.el +++ b/lisp/mail/rmail.el @@ -1451,8 +1451,7 @@ If so restore the actual mbox message collection." (setq-local font-lock-defaults '(rmail-font-lock-keywords t t nil nil - (font-lock-dont-widen . t) - (font-lock-inhibit-thing-lock . (lazy-lock-mode fast-lock-mode)))) + (font-lock-dont-widen . t))) (setq-local require-final-newline nil) (setq-local version-control 'never) (add-hook 'kill-buffer-hook #'rmail-mode-kill-summary nil t) diff --git a/lisp/mail/supercite.el b/lisp/mail/supercite.el index f320246f2de..3f8a940382e 100644 --- a/lisp/mail/supercite.el +++ b/lisp/mail/supercite.el @@ -1,6 +1,6 @@ ;;; supercite.el --- minor mode for citing mail and news replies -*- lexical-binding: t; -*- -;; Copyright (C) 1993, 1997, 2001-2022 Free Software Foundation, Inc. +;; Copyright (C) 1993-2022 Free Software Foundation, Inc. ;; Author: 1993 Barry A. Warsaw <bwarsaw@python.org> ;; Maintainer: emacs-devel@gnu.org @@ -22,11 +22,6 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. -;; LCD Archive Entry -;; supercite|Barry A. Warsaw|supercite-help@python.org -;; |Mail and news reply citation package -;; |1993/09/22 18:58:46|3.1| - ;;; Commentary: ;;; Code: diff --git a/lisp/man.el b/lisp/man.el index 951e0ef9add..d66f63972ae 100644 --- a/lisp/man.el +++ b/lisp/man.el @@ -1241,8 +1241,7 @@ See the variable `Man-notify-method' for the different notification behaviors." (defun Man-softhyphen-to-minus () ;; \255 is SOFT HYPHEN in Latin-N. Versions of Debian man, at ;; least, emit it even when not in a Latin-N locale. - (unless (eq t (compare-strings "latin-" 0 nil - current-language-environment 0 6 t)) + (unless (string-prefix-p "latin-" current-language-environment t) (goto-char (point-min)) (while (search-forward "" nil t) (replace-match "-")))) diff --git a/lisp/mh-e/mh-mime.el b/lisp/mh-e/mh-mime.el index b93f7d8c412..865f817da5b 100644 --- a/lisp/mh-e/mh-mime.el +++ b/lisp/mh-e/mh-mime.el @@ -379,10 +379,8 @@ do the work." ((and (or prompt (equal t mh-mime-save-parts-default-directory)) mh-mime-save-parts-directory) - (read-directory-name (format-prompt - "Store in directory" - mh-mime-save-parts-directory) - "" mh-mime-save-parts-directory t "")) + (read-directory-name "Store in directory: " + mh-mime-save-parts-directory nil t)) ((stringp mh-mime-save-parts-default-directory) mh-mime-save-parts-default-directory) (t @@ -394,18 +392,19 @@ do the work." (if (equal nil mh-mime-save-parts-default-directory) (setq mh-mime-save-parts-directory directory)) (with-current-buffer (get-buffer-create mh-log-buffer) - (cd directory) - (setq mh-mime-save-parts-directory directory) - (let ((initial-size (mh-truncate-log-buffer))) - (apply #'call-process - (expand-file-name command mh-progs) nil t nil - (mh-list-to-string (list folder msg "-auto" - (if (not (mh-variant-p 'nmh)) - "-store")))) - (if (> (buffer-size) initial-size) - (save-window-excursion - (switch-to-buffer-other-window mh-log-buffer) - (sit-for 3)))))))) + (let (default-directory) + (cd directory) + (setq mh-mime-save-parts-directory directory) + (let ((initial-size (mh-truncate-log-buffer))) + (apply #'call-process + (expand-file-name command mh-progs) nil t nil + (mh-list-to-string (list folder msg "-auto" + (if (not (mh-variant-p 'nmh)) + "-store")))) + (if (> (buffer-size) initial-size) + (save-window-excursion + (switch-to-buffer-other-window mh-log-buffer) + (sit-for 3))))))))) ;;;###mh-autoload (defun mh-toggle-mh-decode-mime-flag () diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index d139e094eb2..3daab8a1e8d 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -634,9 +634,6 @@ for use at QPOS." (let ((qstr (funcall qfun completion))) (cons qstr (length qstr)))))) -(defun completion--string-equal-p (s1 s2) - (eq t (compare-strings s1 nil nil s2 nil nil 'ignore-case))) - (defun completion--twq-all (string ustring completions boundary _unquote requote) (when completions @@ -650,7 +647,7 @@ for use at QPOS." (qfullprefix (substring string 0 qfullpos)) ;; FIXME: This assertion can be wrong, e.g. in Cygwin, where ;; (unquote "c:\bin") => "/usr/bin" but (unquote "c:\") => "/". - ;;(cl-assert (completion--string-equal-p + ;;(cl-assert (string-equal-ignore-case ;; (funcall unquote qfullprefix) ;; (concat (substring ustring 0 boundary) prefix)) ;; t)) @@ -688,7 +685,7 @@ for use at QPOS." (let* ((rest (substring completion 0 (length prefix))) (qrest (funcall qfun rest))) - (if (completion--string-equal-p qprefix qrest) + (if (string-equal-ignore-case qprefix qrest) (propertize qrest 'face 'completions-common-part) qprefix)))) @@ -696,7 +693,7 @@ for use at QPOS." ;; FIXME: Similarly here, Cygwin's mapping trips this ;; assertion. ;;(cl-assert - ;; (completion--string-equal-p + ;; (string-equal-ignore-case ;; (funcall unquote ;; (concat (substring string 0 qboundary) ;; qcompletion)) @@ -1309,10 +1306,8 @@ when the buffer's text is already an exact match." ;; for appearance, the string is rewritten if the case changes. (let* ((comp-pos (cdr comp)) (completion (car comp)) - (completed (not (eq t (compare-strings completion nil nil - string nil nil t)))) - (unchanged (eq t (compare-strings completion nil nil - string nil nil nil)))) + (completed (not (string-equal-ignore-case completion string))) + (unchanged (string-equal completion string))) (if unchanged (goto-char end) ;; Insert in minibuffer the chars we got. @@ -2760,7 +2755,6 @@ The completion method is determined by `completion-at-point-functions'." (defvar-keymap minibuffer-local-must-match-map :doc "Local keymap for minibuffer input with completion, for exact match." :parent minibuffer-local-completion-map - "M-X" #'execute-extended-command-cycle "RET" #'minibuffer-complete-and-exit "C-j" #'minibuffer-complete-and-exit) diff --git a/lisp/misc.el b/lisp/misc.el index 28c5d6e07f5..a53571f4639 100644 --- a/lisp/misc.el +++ b/lisp/misc.el @@ -79,6 +79,43 @@ Also see the `copy-from-above-command' command." (dotimes (_ n) (insert line "\n"))))) +(declare-function rectangle--duplicate-right "rect" (n)) + +;; `duplicate-dwim' preserves an active region and changes the buffer +;; outside of it: disregard the region when immediately undoing the +;; actions of this command. +(put 'duplicate-dwim 'undo-inhibit-region t) + +;;;###autoload +(defun duplicate-dwim (&optional n) + "Duplicate the current line or region N times. +If the region is inactive, duplicate the current line (like `duplicate-line'). +Otherwise, duplicate the region, which remains active afterwards. +If the region is rectangular, duplicate on its right-hand side. +Interactively, N is the prefix numeric argument, and defaults to 1." + (interactive "p") + (unless n + (setq n 1)) + (cond + ;; Duplicate rectangle. + ((bound-and-true-p rectangle-mark-mode) + (rectangle--duplicate-right n) + (setq deactivate-mark nil)) + + ;; Duplicate (contiguous) region. + ((use-region-p) + (let* ((beg (region-beginning)) + (end (region-end)) + (text (buffer-substring beg end))) + (save-excursion + (goto-char end) + (dotimes (_ n) + (insert text)))) + (setq deactivate-mark nil)) + + ;; Duplicate line. + (t (duplicate-line n)))) + ;; Variation of `zap-to-char'. ;;;###autoload diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index a55aec76bfc..2d528c4862c 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -403,7 +403,7 @@ commands reverses the effect of this variable." Any substring of a filename matching one of the REGEXPs is replaced by the corresponding STRING using `replace-match', not treating STRING literally. All pairs are applied in the order given. The default -value converts ange-ftp/EFS-style file names into ftp URLs and prepends +value converts ange-ftp-style file names into ftp URLs and prepends `file:' to any file name beginning with `/'. For example, adding to the default a specific translation of an ange-ftp @@ -981,8 +981,7 @@ The optional NEW-WINDOW argument is not used." ;; quotes in the MAILTO URLs, so we prefer ;; to leave the URL with its embedded %nn ;; encoding intact. - (if (eq t (compare-strings url nil 7 - "file://" nil nil)) + (if (string-prefix-p "file://" url) (url-unhex-string url) url))))) diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 476c7017e6c..248faeb223c 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -1740,35 +1740,14 @@ BASE is the URL of the HTML being rendered." shr-cookie-policy))) (defun shr--preferred-image (dom) - (let ((srcset (dom-attr dom 'srcset)) - (frame-width (frame-pixel-width)) - (width (string-to-number (or (dom-attr dom 'width) "100"))) - candidate) - (when (> (length srcset) 0) - ;; srcset consist of a series of URL/size specifications - ;; separated by the ", " string. - (setq srcset - (sort (mapcar - (lambda (elem) - (let ((spec (split-string elem "[\t\n\r ]+"))) - (cond - ((= (length spec) 1) - ;; Make sure it's well formed. - (list (car spec) 0)) - ((string-match "\\([0-9]+\\)x\\'" (cadr spec)) - ;; If we have an "x" form, then use the width - ;; spec to compute the real width. - (list (car spec) - (* width (string-to-number - (match-string 1 (cadr spec)))))) - (t - (list (car spec) - (string-to-number (cadr spec))))))) - (split-string (replace-regexp-in-string - "\\`[\t\n\r ]+\\|[\t\n\r ]+\\'" "" srcset) - "[\t\n\r ]*,[\t\n\r ]*")) - (lambda (e1 e2) - (> (cadr e1) (cadr e2))))) + (let* ((srcset (and (dom-attr dom 'srcset) + (shr--parse-srcset (dom-attr dom 'srcset) + (and (dom-attr dom 'width) + (string-to-number + (dom-attr dom 'width)))))) + (frame-width (frame-pixel-width)) + candidate) + (when srcset ;; Choose the smallest picture that's bigger than the current ;; frame. (setq candidate (caar srcset)) @@ -1778,6 +1757,42 @@ BASE is the URL of the HTML being rendered." (pop srcset))) (or candidate (dom-attr dom 'src)))) +(defun shr--parse-srcset (srcset &optional width) + (setq srcset (string-trim srcset) + width (or width 100)) + (when (> (length srcset) 0) + ;; srcset consists of a series of URL/size specifications separated + ;; by the " ," string. + (sort (mapcar + (lambda (elem) + (let ((spec (split-string elem "[\t\n\r ]+"))) + (cond + ((= (length spec) 1) + ;; Make sure it's well formed. + (list (car spec) 0)) + ((string-match "\\([0-9]+\\)x\\'" (cadr spec)) + ;; If we have an "x" form, then use the width + ;; spec to compute the real width. + (list (car spec) + (* width (string-to-number + (match-string 1 (cadr spec)))))) + (t + (list (car spec) + (string-to-number (cadr spec))))))) + (with-temp-buffer + (insert srcset) + (goto-char (point-min)) + (let ((bits nil)) + (while (re-search-forward "[^\t\n\r ]+[\t\n\r ]+[^\t\n\r ,]+" + nil t) + (push (match-string 0) bits) + (if (looking-at "[\t\n\r ]*,[\t\n\r ]*") + (goto-char (match-end 0)) + (goto-char (point-max)))) + bits))) + (lambda (e1 e2) + (> (cadr e1) (cadr e2)))))) + (defun shr-string-number (string) (if (null string) nil diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index de558568308..3e780aa1a18 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -182,8 +182,8 @@ It is used for TCP/IP devices." (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) (tramp-get-home-directory . ignore) - (tramp-get-remote-gid . ignore) - (tramp-get-remote-uid . ignore) + (tramp-get-remote-gid . tramp-adb-handle-get-remote-gid) + (tramp-get-remote-uid . tramp-adb-handle-get-remote-uid) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) (unlock-file . tramp-handle-unlock-file) @@ -252,21 +252,19 @@ arguments to pass to the OPERATION." (defun tramp-adb-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." - (unless id-format (setq id-format 'integer)) - (ignore-errors - (with-parsed-tramp-file-name filename nil - (with-tramp-file-property - v localname (format "file-attributes-%s" id-format) - (and - (tramp-adb-send-command-and-check - v (format "%s -d -l %s" - (tramp-adb-get-ls-command v) - (tramp-shell-quote-argument localname))) - (with-current-buffer (tramp-get-buffer v) - (tramp-adb-sh-fix-ls-output) - (cdar (tramp-do-parse-file-attributes-with-ls v id-format)))))))) - -(defun tramp-do-parse-file-attributes-with-ls (vec &optional id-format) + ;; The result is cached in `tramp-convert-file-attributes'. + (with-parsed-tramp-file-name filename nil + (tramp-convert-file-attributes v localname id-format + (and + (tramp-adb-send-command-and-check + v (format "%s -d -l %s" + (tramp-adb-get-ls-command v) + (tramp-shell-quote-argument localname))) + (with-current-buffer (tramp-get-buffer v) + (tramp-adb-sh-fix-ls-output) + (cdar (tramp-do-parse-file-attributes-with-ls v))))))) + +(defun tramp-do-parse-file-attributes-with-ls (vec) "Parse `file-attributes' for Tramp files using the ls(1) command." (with-current-buffer (tramp-get-buffer vec) (goto-char (point-min)) @@ -290,8 +288,8 @@ arguments to pass to the OPERATION." (or is-dir symlink-target) 1 ;link-count ;; no way to handle numeric ids in Androids ash - (if (eq id-format 'integer) 0 uid) - (if (eq id-format 'integer) 0 gid) + (cons uid tramp-unknown-id-integer) + (cons gid tramp-unknown-id-integer) tramp-time-dont-know ; atime ;; `date-to-time' checks `iso8601-parse', which might fail. (let (signal-hook-function) @@ -308,54 +306,28 @@ arguments to pass to the OPERATION." (defun tramp-adb-handle-directory-files-and-attributes (directory &optional full match nosort id-format count) "Like `directory-files-and-attributes' for Tramp files." - (unless (file-exists-p directory) - (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) - (when (file-directory-p directory) - (with-parsed-tramp-file-name (expand-file-name directory) nil - (copy-tree - (with-tramp-file-property - v localname (format "directory-files-and-attributes-%s-%s-%s-%s-%s" - full match id-format nosort count) - (with-current-buffer (tramp-get-buffer v) - (when (tramp-adb-send-command-and-check - v (format "%s -a -l %s" - (tramp-adb-get-ls-command v) - (tramp-shell-quote-argument localname))) - ;; We insert also filename/. and filename/.., because "ls" doesn't. - ;; Looks like it does include them in toybox, since Android 6. - (unless (re-search-backward "\\.$" nil t) - (narrow-to-region (point-max) (point-max)) - (tramp-adb-send-command - v (format "%s -d -a -l %s %s" - (tramp-adb-get-ls-command v) - (tramp-shell-quote-argument - (tramp-compat-file-name-concat localname ".")) - (tramp-shell-quote-argument - (tramp-compat-file-name-concat localname "..")))) - (widen))) - (tramp-adb-sh-fix-ls-output) - (let ((result (tramp-do-parse-file-attributes-with-ls - v (or id-format 'integer)))) - (when full - (setq result - (mapcar - (lambda (x) - (cons (expand-file-name (car x) directory) (cdr x))) - result))) - (unless nosort - (setq result - (sort result (lambda (x y) (string< (car x) (car y)))))) - - (setq result (delq nil - (mapcar - (lambda (x) (if (or (not match) - (string-match-p - match (car x))) - x)) - result))) - (when (and (natnump count) (> count 0)) - (setq result (tramp-compat-ntake count result))) - result))))))) + (tramp-skeleton-directory-files-and-attributes + directory full match nosort id-format count + (with-current-buffer (tramp-get-buffer v) + (when (tramp-adb-send-command-and-check + v (format "%s -a -l %s" + (tramp-adb-get-ls-command v) + (tramp-shell-quote-argument localname))) + ;; We insert also filename/. and filename/.., because "ls" + ;; doesn't. Looks like it does include them in toybox, since + ;; Android 6. + (unless (re-search-backward "\\.$" nil t) + (narrow-to-region (point-max) (point-max)) + (tramp-adb-send-command + v (format "%s -d -a -l %s %s" + (tramp-adb-get-ls-command v) + (tramp-shell-quote-argument + (tramp-compat-file-name-concat localname ".")) + (tramp-shell-quote-argument + (tramp-compat-file-name-concat localname "..")))) + (widen))) + (tramp-adb-sh-fix-ls-output) + (tramp-do-parse-file-attributes-with-ls v)))) (defun tramp-adb-get-ls-command (vec) "Determine `ls' command and its arguments." @@ -502,22 +474,18 @@ Emacs dired can't find files." (defun tramp-adb-handle-file-local-copy (filename) "Like `file-local-copy' for Tramp files." - (with-parsed-tramp-file-name filename nil - (unless (file-exists-p (file-truename filename)) - (tramp-error v 'file-missing filename)) - (let ((tmpfile (tramp-compat-make-temp-file filename))) - (with-tramp-progress-reporter - v 3 (format "Fetching %s to tmp file %s" filename tmpfile) - ;; "adb pull ..." does not always return an error code. - (unless - (and (tramp-adb-execute-adb-command - v "pull" (tramp-compat-file-name-unquote localname) tmpfile) - (file-exists-p tmpfile)) - (ignore-errors (delete-file tmpfile)) - (tramp-error - v 'file-error "Cannot make local copy of file `%s'" filename)) - (set-file-modes tmpfile (logior (or (file-modes filename) 0) #o0400))) - tmpfile))) + (tramp-skeleton-file-local-copy filename + (with-tramp-progress-reporter + v 3 (format "Fetching %s to tmp file %s" filename tmpfile) + ;; "adb pull ..." does not always return an error code. + (unless + (and (tramp-adb-execute-adb-command + v "pull" (tramp-compat-file-name-unquote localname) tmpfile) + (file-exists-p tmpfile)) + (ignore-errors (delete-file tmpfile)) + (tramp-error + v 'file-error "Cannot make local copy of file `%s'" filename)) + (set-file-modes tmpfile (logior (or (file-modes filename) 0) #o0400))))) (defun tramp-adb-handle-file-executable-p (filename) "Like `file-executable-p' for Tramp files." @@ -617,62 +585,61 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; let-bind `jka-compr-inhibit' to t. (jka-compr-inhibit t)) (with-parsed-tramp-file-name (if t1 filename newname) nil - (unless (file-exists-p filename) - (tramp-error v 'file-missing filename)) - (when (and (not ok-if-already-exists) (file-exists-p newname)) - (tramp-error v 'file-already-exists newname)) - (when (and (file-directory-p newname) - (not (directory-name-p newname))) - (tramp-error v 'file-error "File is a directory %s" newname)) - - (with-tramp-progress-reporter - v 0 (format "Copying %s to %s" filename newname) - (if (and t1 t2 (tramp-equal-remote filename newname)) - (let ((l1 (tramp-file-local-name filename)) - (l2 (tramp-file-local-name newname))) - ;; We must also flush the cache of the directory, - ;; because `file-attributes' reads the values from - ;; there. - (tramp-flush-file-properties v l2) - ;; Short track. - (tramp-adb-barf-unless-okay - v (format - "cp -f %s %s" - (tramp-shell-quote-argument l1) - (tramp-shell-quote-argument l2)) - "Error copying %s to %s" filename newname)) - - (if-let ((tmpfile (file-local-copy filename))) - ;; Remote filename. - (condition-case err - (rename-file tmpfile newname ok-if-already-exists) - ((error quit) - (delete-file tmpfile) - (signal (car err) (cdr err)))) - - ;; Remote newname. - (when (and (file-directory-p newname) - (directory-name-p newname)) - (setq newname - (expand-file-name - (file-name-nondirectory filename) newname))) - - (with-parsed-tramp-file-name newname nil - (when (and (not ok-if-already-exists) - (file-exists-p newname)) - (tramp-error v 'file-already-exists newname)) - - ;; 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-adb-execute-adb-command - v "push" - (tramp-compat-file-name-unquote filename) - (tramp-compat-file-name-unquote localname)) - (tramp-error - v 'file-error - "Cannot copy `%s' `%s'" filename newname)))))))) + (tramp-barf-if-file-missing v filename + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) + (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) + + (with-tramp-progress-reporter + v 0 (format "Copying %s to %s" filename newname) + (if (and t1 t2 (tramp-equal-remote filename newname)) + (let ((l1 (tramp-file-local-name filename)) + (l2 (tramp-file-local-name newname))) + ;; We must also flush the cache of the directory, + ;; because `file-attributes' reads the values from + ;; there. + (tramp-flush-file-properties v l2) + ;; Short track. + (tramp-adb-barf-unless-okay + v (format + "cp -f %s %s" + (tramp-shell-quote-argument l1) + (tramp-shell-quote-argument l2)) + "Error copying %s to %s" filename newname)) + + (if-let ((tmpfile (file-local-copy filename))) + ;; Remote filename. + (condition-case err + (rename-file tmpfile newname ok-if-already-exists) + ((error quit) + (delete-file tmpfile) + (signal (car err) (cdr err)))) + + ;; Remote newname. + (when (and (file-directory-p newname) + (directory-name-p newname)) + (setq newname + (expand-file-name + (file-name-nondirectory filename) newname))) + + (with-parsed-tramp-file-name newname nil + (when (and (not ok-if-already-exists) + (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + + ;; 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-adb-execute-adb-command + v "push" + (tramp-compat-file-name-unquote filename) + (tramp-compat-file-name-unquote localname)) + (tramp-error + v 'file-error + "Cannot copy `%s' `%s'" filename newname))))))))) ;; KEEP-DATE handling. (when keep-date @@ -698,37 +665,38 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; let-bind `jka-compr-inhibit' to t. (jka-compr-inhibit t)) (with-parsed-tramp-file-name (if t1 filename newname) nil - (unless (file-exists-p filename) - (tramp-error v 'file-missing filename)) - (when (and (not ok-if-already-exists) (file-exists-p newname)) - (tramp-error v 'file-already-exists newname)) - (when (and (file-directory-p newname) - (not (directory-name-p newname))) - (tramp-error v 'file-error "File is a directory %s" newname)) - - (with-tramp-progress-reporter - v 0 (format "Renaming %s to %s" filename newname) - (if (and t1 t2 - (tramp-equal-remote filename newname) - (not (file-directory-p filename))) - (let ((l1 (tramp-file-local-name filename)) - (l2 (tramp-file-local-name newname))) - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v l1) - (tramp-flush-file-properties v l2) - ;; Short track. - (tramp-adb-barf-unless-okay - v (format - "mv -f %s %s" - (tramp-shell-quote-argument l1) - (tramp-shell-quote-argument l2)) - "Error renaming %s to %s" filename newname)) - - ;; Rename by copy. - (copy-file - filename newname ok-if-already-exists 'keep-time 'preserve-uid-gid) - (delete-file filename))))))) + (tramp-barf-if-file-missing v filename + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) + (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) + + (with-tramp-progress-reporter + v 0 (format "Renaming %s to %s" filename newname) + (if (and t1 t2 + (tramp-equal-remote filename newname) + (not (file-directory-p filename))) + (let ((l1 (tramp-file-local-name filename)) + (l2 (tramp-file-local-name newname))) + ;; We must also flush the cache of the directory, + ;; because `file-attributes' reads the values from + ;; there. + (tramp-flush-file-properties v l1) + (tramp-flush-file-properties v l2) + ;; Short track. + (tramp-adb-barf-unless-okay + v (format + "mv -f %s %s" + (tramp-shell-quote-argument l1) + (tramp-shell-quote-argument l2)) + "Error renaming %s to %s" filename newname)) + + ;; Rename by copy. + (copy-file + filename newname ok-if-already-exists + 'keep-time 'preserve-uid-gid) + (delete-file filename)))))))) (defun tramp-adb-get-signal-strings (vec) "Strings to return by `process-file' in case of signals." @@ -1067,6 +1035,36 @@ implementation will be used." ;; The equivalent to `exec-directory'. `(,(tramp-file-local-name (expand-file-name default-directory))))) +(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)))) + +(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)))) + (defun tramp-adb-get-device (vec) "Return full host name from VEC to be used in shell execution. E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\" diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index 119ac54dd29..4f106a6b593 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -227,7 +227,7 @@ It must be supported by libarchive(3).") (delete-file . tramp-archive-handle-not-implemented) ;; `diff-latest-backup-file' performed by default handler. (directory-file-name . tramp-archive-handle-directory-file-name) - (directory-files . tramp-handle-directory-files) + (directory-files . tramp-archive-handle-directory-files) (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) (dired-compress-file . tramp-archive-handle-not-implemented) @@ -348,6 +348,13 @@ arguments to pass to the OPERATION." (tramp-archive-run-real-handler #'file-directory-p (list archive))) (tramp-archive-run-real-handler operation args) + ;; The default directory of the Tramp connection buffer + ;; cannot be accessed. (Bug#56628) + ;; FIXME: It is superfluous to set it every single loop. + ;; But there is no place to set it when creating the buffer. + (with-current-buffer + (tramp-get-buffer (tramp-archive-dissect-file-name filename)) + (setq default-directory (file-name-as-directory archive))) ;; Now run the handler. (let ((tramp-methods (cons `(,tramp-archive-method) tramp-methods)) (tramp-gvfs-methods tramp-archive-all-gvfs-methods) @@ -605,6 +612,27 @@ offered." ;; example. So we return `directory'. directory))) +(defun tramp-archive-handle-directory-files + (directory &optional full match nosort count) + "Like `directory-files' for Tramp files." + (unless (file-exists-p directory) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) + (when (file-directory-p directory) + (setq directory (file-name-as-directory (expand-file-name directory))) + (let ((temp (nreverse (file-name-all-completions "" directory))) + result item) + + (while temp + (setq item (directory-file-name (pop temp))) + (when (or (null match) (string-match-p match item)) + (push (if full (concat directory item) item) + result))) + (unless nosort + (setq result (sort result #'string<))) + (when (and (natnump count) (> count 0)) + (setq result (tramp-compat-ntake count result))) + result))) + (defun tramp-archive-handle-dired-uncache (dir) "Like `dired-uncache' for file archives." (dired-uncache (tramp-archive-gvfs-file-name dir))) diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index dbebcad1a84..68f4fda4756 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -205,6 +205,12 @@ Return VALUE." (unintern var obarray)))) ;;;###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))) + +;;;###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. diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index bd2dbf4a1e0..5c8012e553b 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -46,7 +46,7 @@ SYNTAX can be one of the symbols `default' (default), (let ((input (completing-read "Enter Tramp syntax: " (tramp-syntax-values) nil t (symbol-name tramp-syntax)))) - (unless (string-equal input "") + (unless (string-empty-p input) (list (intern input))))) (when syntax (customize-set-variable 'tramp-syntax syntax))) diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 1286255c898..bc32044451c 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -294,6 +294,15 @@ CONDITION can also be a list of error conditions." (setq secret (funcall secret))) secret)))) +;; Function `take' is new in Emacs 29.1. +(defalias 'tramp-compat-take + (if (fboundp 'take) + #'take + (lambda (n list) + (when (and (natnump n) (> n 0)) + (if (>= n (length list)) + list (butlast list (- (length list) n))))))) + ;; Function `ntake' is new in Emacs 29.1. (defalias 'tramp-compat-ntake (if (fboundp 'ntake) @@ -303,6 +312,13 @@ CONDITION can also be a list of error conditions." (if (>= n (length list)) list (nbutlast list (- (length list) n))))))) +;; Function `string-equal-ignore-case' is new in Emacs 29.1. +(defalias 'tramp-compat-string-equal-ignore-case + (if (fboundp 'string-equal-ignore-case) + #'string-equal-ignore-case + (lambda (string1 string2) + (eq t (compare-strings string1 nil nil string2 nil nil t))))) + (dolist (elt (all-completions "tramp-compat-" obarray 'functionp)) (put (intern elt) 'tramp-suppress-trace t)) @@ -319,6 +335,6 @@ CONDITION can also be a list of error conditions." ;; parentheses with a backslash in docstrings anymore. ;; ;; * Starting with Emacs 27.1, there's `make-empty-file'. Could be -;; used instead of `write-region'. +;; used instead of `(write-region "" ...)'. ;;; tramp-compat.el ends here diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index 804d6e5bd14..4fcd132ab0a 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -600,62 +600,61 @@ absolute file names." (delete-directory filename 'recursive))) (with-parsed-tramp-file-name (if t1 filename newname) nil - (unless (file-exists-p filename) - (tramp-error v 'file-missing filename)) - (when (and (not ok-if-already-exists) (file-exists-p newname)) - (tramp-error v 'file-already-exists newname)) - (when (and (file-directory-p newname) - (not (directory-name-p newname))) - (tramp-error v 'file-error "File is a directory %s" newname)) - - (with-tramp-progress-reporter - v 0 (format "%s %s to %s" msg-operation filename newname) - (if (and t1 t2 (string-equal t1 t2)) - ;; Both files are on the same encrypted remote directory. - (let (tramp-crypt-enabled) - (if (eq op 'copy) - (copy-file - encrypt-filename encrypt-newname ok-if-already-exists - keep-date preserve-uid-gid preserve-extended-attributes) - (rename-file - encrypt-filename encrypt-newname ok-if-already-exists))) - - (let* ((tmpdir (tramp-compat-make-temp-file filename 'dir)) - (tmpfile1 - (expand-file-name - (file-name-nondirectory encrypt-filename) tmpdir)) - (tmpfile2 - (expand-file-name - (file-name-nondirectory encrypt-newname) tmpdir)) - tramp-crypt-enabled) - (cond - ;; Source and target file are on an encrypted remote directory. - ((and t1 t2) - (if (eq op 'copy) - (copy-file - encrypt-filename encrypt-newname ok-if-already-exists - keep-date preserve-uid-gid preserve-extended-attributes) - (rename-file - encrypt-filename encrypt-newname ok-if-already-exists))) - ;; Source file is on an encrypted remote directory. - (t1 - (if (eq op 'copy) - (copy-file - encrypt-filename tmpfile1 t keep-date preserve-uid-gid - preserve-extended-attributes) - (rename-file encrypt-filename tmpfile1 t)) - (tramp-crypt-decrypt-file t1 tmpfile1 tmpfile2) - (rename-file tmpfile2 newname ok-if-already-exists)) - ;; Target file is on an encrypted remote directory. - (t2 - (if (eq op 'copy) - (copy-file - filename tmpfile1 t keep-date preserve-uid-gid - preserve-extended-attributes) - (rename-file filename tmpfile1 t)) - (tramp-crypt-encrypt-file t2 tmpfile1 tmpfile2) - (rename-file tmpfile2 encrypt-newname ok-if-already-exists))) - (delete-directory tmpdir 'recursive)))))) + (tramp-barf-if-file-missing v filename + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) + (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) + + (with-tramp-progress-reporter + v 0 (format "%s %s to %s" msg-operation filename newname) + (if (and t1 t2 (string-equal t1 t2)) + ;; Both files are on the same encrypted remote directory. + (let (tramp-crypt-enabled) + (if (eq op 'copy) + (copy-file + encrypt-filename encrypt-newname ok-if-already-exists + keep-date preserve-uid-gid preserve-extended-attributes) + (rename-file + encrypt-filename encrypt-newname ok-if-already-exists))) + + (let* ((tmpdir (tramp-compat-make-temp-file filename 'dir)) + (tmpfile1 + (expand-file-name + (file-name-nondirectory encrypt-filename) tmpdir)) + (tmpfile2 + (expand-file-name + (file-name-nondirectory encrypt-newname) tmpdir)) + tramp-crypt-enabled) + (cond + ;; Source and target file are on an encrypted remote directory. + ((and t1 t2) + (if (eq op 'copy) + (copy-file + encrypt-filename encrypt-newname ok-if-already-exists + keep-date preserve-uid-gid preserve-extended-attributes) + (rename-file + encrypt-filename encrypt-newname ok-if-already-exists))) + ;; Source file is on an encrypted remote directory. + (t1 + (if (eq op 'copy) + (copy-file + encrypt-filename tmpfile1 t keep-date preserve-uid-gid + preserve-extended-attributes) + (rename-file encrypt-filename tmpfile1 t)) + (tramp-crypt-decrypt-file t1 tmpfile1 tmpfile2) + (rename-file tmpfile2 newname ok-if-already-exists)) + ;; Target file is on an encrypted remote directory. + (t2 + (if (eq op 'copy) + (copy-file + filename tmpfile1 t keep-date preserve-uid-gid + preserve-extended-attributes) + (rename-file filename tmpfile1 t)) + (tramp-crypt-encrypt-file t2 tmpfile1 tmpfile2) + (rename-file tmpfile2 encrypt-newname ok-if-already-exists))) + (delete-directory tmpdir 'recursive))))))) (when (and t1 (eq op 'rename)) (with-parsed-tramp-file-name filename v1 @@ -702,36 +701,14 @@ absolute file names." (defun tramp-crypt-handle-directory-files (directory &optional full match nosort count) "Like `directory-files' for Tramp files." - (unless (file-exists-p directory) - (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) - (when (file-directory-p directory) - (setq directory (file-name-as-directory (expand-file-name directory))) - (let* (tramp-crypt-enabled - (result - (directory-files (tramp-crypt-encrypt-file-name directory) 'full))) - (setq result - (mapcar (lambda (x) (tramp-crypt-decrypt-file-name x)) result)) - (when match - (setq result - (delq - nil - (mapcar - (lambda (x) - (when (string-match-p match (substring x (length directory))) - x)) - result)))) - (unless full - (setq result - (mapcar - (lambda (x) - (replace-regexp-in-string - (concat "^" (regexp-quote directory)) "" x)) - result))) - (unless nosort - (setq result (sort result #'string<))) - (when (and (natnump count) (> count 0)) - (setq result (tramp-compat-ntake count result))) - result))) + (tramp-skeleton-directory-files directory full match nosort count + (let (tramp-crypt-enabled) + (mapcar + (lambda (x) + (replace-regexp-in-string + (concat "^" (regexp-quote directory)) "" + (tramp-crypt-decrypt-file-name x))) + (directory-files (tramp-crypt-encrypt-file-name directory) 'full))))) (defun tramp-crypt-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." diff --git a/lisp/net/tramp-fuse.el b/lisp/net/tramp-fuse.el index 2ff106d6023..486a3cc57b7 100644 --- a/lisp/net/tramp-fuse.el +++ b/lisp/net/tramp-fuse.el @@ -58,36 +58,30 @@ (defun tramp-fuse-handle-directory-files (directory &optional full match nosort count) "Like `directory-files' for Tramp files." - (unless (file-exists-p directory) - (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) - (when (file-directory-p directory) - (setq directory (file-name-as-directory (expand-file-name directory))) - (with-parsed-tramp-file-name directory nil - (let ((result - (tramp-compat-directory-files - (tramp-fuse-local-file-name directory) full match nosort count))) + (let ((result + (tramp-skeleton-directory-files directory full match nosort count + ;; Some storage systems do not return "." and "..". + (delete-dups + (append + '("." "..") + (tramp-fuse-remove-hidden-files + (tramp-compat-directory-files + (tramp-fuse-local-file-name directory)))))))) + (if full ;; Massage the result. - (when full - (let ((local (concat "^" (regexp-quote (tramp-fuse-mount-point v)))) - (remote (directory-file-name - (funcall - (if (tramp-compat-file-name-quoted-p directory) - #'tramp-compat-file-name-quote #'identity) - (file-remote-p directory))))) - (setq result - (mapcar - (lambda (x) (replace-regexp-in-string local remote x)) - result)))) - ;; Some storage systems do not return "." and "..". - (dolist (item '(".." ".")) - (when (and (string-match-p (or match (regexp-quote item)) item) - (not - (member (if full (setq item (concat directory item)) item) - result))) - (setq result (cons item result)))) - ;; Return result. - (tramp-fuse-remove-hidden-files - (if nosort result (sort result #'string<))))))) + (let ((local (concat + "^" (regexp-quote + (tramp-fuse-mount-point + (tramp-dissect-file-name directory))))) + (remote (directory-file-name + (funcall + (if (tramp-compat-file-name-quoted-p directory) + #'tramp-compat-file-name-quote #'identity) + (file-remote-p directory))))) + (mapcar + (lambda (x) (replace-regexp-in-string local remote x)) + result)) + result))) (defun tramp-fuse-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 056237fd55c..2f97b2cb916 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -87,7 +87,7 @@ ;; For hostname completion, information is retrieved from the zeroconf ;; daemon (for the "afp", "dav", "davs", and "sftp" methods). The ;; zeroconf daemon is pre-configured to discover services in the -;; "local" domain. If another domain shall be used for discovering +;; "local" domain. If another domain should be used for discovering ;; services, the user option `tramp-gvfs-zeroconf-domain' can be set ;; accordingly. @@ -943,7 +943,7 @@ The call will be traced by Tramp with trace level 6." "Current Tramp file name to be used, as vector. It is needed when D-Bus signals or errors arrive, because there is no information where to trace the message. -Globally, the value shall always be nil; it is bound where needed.") +The global value will always be nil; it is bound where needed.") (defun tramp-gvfs-dbus-event-error (event err) "Called when a D-Bus error message arrives, see `dbus-event-error-functions'." @@ -1002,84 +1002,83 @@ file names." (msg-operation (if (eq op 'copy) "Copying" "Renaming"))) (with-parsed-tramp-file-name (if t1 filename newname) nil - (unless (file-exists-p filename) - (tramp-error v 'file-missing filename)) - (when (and (not ok-if-already-exists) (file-exists-p newname)) - (tramp-error v 'file-already-exists newname)) - (when (and (file-directory-p newname) - (not (directory-name-p newname))) - (tramp-error v 'file-error "File is a directory %s" newname)) - - (cond - ;; We cannot rename volatile files, as used by Google-drive. - ((and (not equal-remote) volatile) - (prog1 (copy-file - filename newname ok-if-already-exists keep-date - preserve-uid-gid preserve-extended-attributes) - (delete-file filename))) - - ;; We cannot copy or rename directly. - ((or (and equal-remote - (tramp-get-connection-property v "direct-copy-failed")) - (and t1 (not (tramp-gvfs-file-name-p filename))) - (and t2 (not (tramp-gvfs-file-name-p newname)))) - (let ((tmpfile (tramp-compat-make-temp-file filename))) - (if (eq op 'copy) - (copy-file - filename tmpfile t keep-date preserve-uid-gid - preserve-extended-attributes) - (rename-file filename tmpfile t)) - (rename-file tmpfile newname ok-if-already-exists))) - - ;; Direct action. - (t (with-tramp-progress-reporter - v 0 (format "%s %s to %s" msg-operation filename newname) - (unless - (and (apply - #'tramp-gvfs-send-command v gvfs-operation - (append - (and (eq op 'copy) (or keep-date preserve-uid-gid) - '("--preserve")) - (list - (tramp-gvfs-url-file-name filename) - (tramp-gvfs-url-file-name newname)))) - ;; Some backends do not return a proper error - ;; code in case of direct copy/move. Apply - ;; sanity checks. - (or (not equal-remote) - (tramp-gvfs-send-command - v "gvfs-info" (tramp-gvfs-url-file-name newname)) - (eq op 'copy) - (not (tramp-gvfs-send-command - v "gvfs-info" - (tramp-gvfs-url-file-name filename))))) - - (if (or (not equal-remote) - (and equal-remote - (tramp-get-connection-property - v "direct-copy-failed"))) - ;; Propagate the error. - (with-current-buffer (tramp-get-connection-buffer v) - (goto-char (point-min)) - (tramp-error-with-buffer - nil v 'file-error - "%s failed, see buffer `%s' for details." - msg-operation (buffer-name))) - - ;; Some WebDAV server, like the one from QNAP, do - ;; not support direct copy/move. Try a fallback. - (tramp-set-connection-property v "direct-copy-failed" t) - (tramp-gvfs-do-copy-or-rename-file - op filename newname ok-if-already-exists keep-date - preserve-uid-gid preserve-extended-attributes)))) - - (when (and t1 (eq op 'rename)) - (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v localname))) - - (when t2 - (with-parsed-tramp-file-name newname nil - (tramp-flush-file-properties v localname))))))))) + (tramp-barf-if-file-missing v filename + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) + (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) + + (cond + ;; We cannot rename volatile files, as used by Google-drive. + ((and (not equal-remote) volatile) + (prog1 (copy-file + filename newname ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + (delete-file filename))) + + ;; We cannot copy or rename directly. + ((or (and equal-remote + (tramp-get-connection-property v "direct-copy-failed")) + (and t1 (not (tramp-gvfs-file-name-p filename))) + (and t2 (not (tramp-gvfs-file-name-p newname)))) + (let ((tmpfile (tramp-compat-make-temp-file filename))) + (if (eq op 'copy) + (copy-file + filename tmpfile t keep-date preserve-uid-gid + preserve-extended-attributes) + (rename-file filename tmpfile t)) + (rename-file tmpfile newname ok-if-already-exists))) + + ;; Direct action. + (t (with-tramp-progress-reporter + v 0 (format "%s %s to %s" msg-operation filename newname) + (unless + (and (apply + #'tramp-gvfs-send-command v gvfs-operation + (append + (and (eq op 'copy) (or keep-date preserve-uid-gid) + '("--preserve")) + (list + (tramp-gvfs-url-file-name filename) + (tramp-gvfs-url-file-name newname)))) + ;; Some backends do not return a proper error + ;; code in case of direct copy/move. Apply + ;; sanity checks. + (or (not equal-remote) + (tramp-gvfs-send-command + v "gvfs-info" (tramp-gvfs-url-file-name newname)) + (eq op 'copy) + (not (tramp-gvfs-send-command + v "gvfs-info" + (tramp-gvfs-url-file-name filename))))) + + (if (or (not equal-remote) + (and equal-remote + (tramp-get-connection-property + v "direct-copy-failed"))) + ;; Propagate the error. + (with-current-buffer (tramp-get-connection-buffer v) + (goto-char (point-min)) + (tramp-error-with-buffer + nil v 'file-error + "%s failed, see buffer `%s' for details." + msg-operation (buffer-name))) + + ;; Some WebDAV server, like the one from QNAP, do + ;; not support direct copy/move. Try a fallback. + (tramp-set-connection-property v "direct-copy-failed" t) + (tramp-gvfs-do-copy-or-rename-file + op filename newname ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes)))) + + (when (and t1 (eq op 'rename)) + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-properties v localname))) + + (when t2 + (with-parsed-tramp-file-name newname nil + (tramp-flush-file-properties v localname)))))))))) (defun tramp-gvfs-handle-copy-file (filename newname &optional ok-if-already-exists keep-date @@ -1626,6 +1625,7 @@ VEC or USER, or if there is no home directory, return nil." (defun tramp-gvfs-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 'string) (tramp-file-name-user vec) (when-let ((localname @@ -1636,6 +1636,7 @@ ID-FORMAT valid values are `string' and `integer'." (defun tramp-gvfs-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'. (when-let ((localname (tramp-get-connection-property (tramp-get-process vec) "share"))) (file-attribute-group-id @@ -1795,7 +1796,8 @@ a downcased host name only." (progn (message "%s" message) 0) - (with-tramp-connection-property (tramp-get-process v) message + (with-tramp-connection-property + (tramp-get-process v) message ;; In theory, there can be several choices. ;; Until now, there is only the question ;; whether to accept an unknown host @@ -1887,7 +1889,7 @@ Their full names are \"org.gtk.vfs.MountTracker.mounted\" and v 6 "%s %s" signal-name (tramp-gvfs-stringify-dbus-message mount-info)) (tramp-flush-file-property v "/" "list-mounts") - (if (string-equal (downcase signal-name) "unmounted") + (if (tramp-compat-string-equal-ignore-case signal-name "unmounted") (tramp-flush-file-properties v "/") ;; Set mountpoint and location. (tramp-set-file-property v "/" "fuse-mountpoint" fuse-mountpoint) diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index bbc76851318..5bee5641bb1 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -225,46 +225,45 @@ file names." (msg-operation (if (eq op 'copy) "Copying" "Renaming"))) (with-parsed-tramp-file-name (if t1 filename newname) nil - (unless (file-exists-p filename) - (tramp-error v 'file-missing filename)) - (when (and (not ok-if-already-exists) (file-exists-p newname)) - (tramp-error v 'file-already-exists newname)) - (when (and (file-directory-p newname) - (not (directory-name-p newname))) - (tramp-error v 'file-error "File is a directory %s" newname)) - - (if (or (and t1 (not (tramp-rclone-file-name-p filename))) - (and t2 (not (tramp-rclone-file-name-p newname)))) - - ;; We cannot copy or rename directly. - (let ((tmpfile (tramp-compat-make-temp-file filename))) - (if (eq op 'copy) - (copy-file - filename tmpfile t keep-date preserve-uid-gid - preserve-extended-attributes) - (rename-file filename tmpfile t)) - (rename-file tmpfile newname ok-if-already-exists)) - - ;; Direct action. - (with-tramp-progress-reporter - v 0 (format "%s %s to %s" msg-operation filename newname) - (unless (zerop - (tramp-rclone-send-command - v rclone-operation - (tramp-rclone-remote-file-name filename) - (tramp-rclone-remote-file-name newname))) - (tramp-error - v 'file-error - "Error %s `%s' `%s'" msg-operation filename newname))) - - (when (and t1 (eq op 'rename)) - (while (file-exists-p filename) - (with-parsed-tramp-file-name filename v1 - (tramp-flush-file-properties v1 v1-localname)))) - - (when t2 - (with-parsed-tramp-file-name newname v2 - (tramp-flush-file-properties v2 v2-localname)))))))) + (tramp-barf-if-file-missing v filename + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) + (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) + + (if (or (and t1 (not (tramp-rclone-file-name-p filename))) + (and t2 (not (tramp-rclone-file-name-p newname)))) + + ;; We cannot copy or rename directly. + (let ((tmpfile (tramp-compat-make-temp-file filename))) + (if (eq op 'copy) + (copy-file + filename tmpfile t keep-date preserve-uid-gid + preserve-extended-attributes) + (rename-file filename tmpfile t)) + (rename-file tmpfile newname ok-if-already-exists)) + + ;; Direct action. + (with-tramp-progress-reporter + v 0 (format "%s %s to %s" msg-operation filename newname) + (unless (zerop + (tramp-rclone-send-command + v rclone-operation + (tramp-rclone-remote-file-name filename) + (tramp-rclone-remote-file-name newname))) + (tramp-error + v 'file-error + "Error %s `%s' `%s'" msg-operation filename newname))) + + (when (and t1 (eq op 'rename)) + (while (file-exists-p filename) + (with-parsed-tramp-file-name filename v1 + (tramp-flush-file-properties v1 v1-localname)))) + + (when t2 + (with-parsed-tramp-file-name newname v2 + (tramp-flush-file-properties v2 v2-localname))))))))) (defun tramp-rclone-handle-copy-file (filename newname &optional ok-if-already-exists keep-date diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index e772af9e0a1..172933859c1 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -666,14 +666,14 @@ else { $type = \"nil\" }; -$uid = ($ARGV[1] eq \"integer\") ? $stat[4] : \"\\\"\" . getpwuid($stat[4]) . \"\\\"\"; -$gid = ($ARGV[1] eq \"integer\") ? $stat[5] : \"\\\"\" . getgrgid($stat[5]) . \"\\\"\"; printf( - \"(%%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u %%u t %%u -1)\\n\", + \"(%%s %%u (%%s . %%u) (%%s . %%u) (%%u %%u) (%%u %%u) (%%u %%u) %%u %%u t %%u -1)\\n\", $type, $stat[3], - $uid, - $gid, + \"\\\"\" . getpwuid($stat[4]) . \"\\\"\", + $stat[4], + \"\\\"\" . getgrgid($stat[5]) . \"\\\"\", + $stat[5], $stat[8] >> 16 & 0xffff, $stat[8] & 0xffff, $stat[9] >> 16 & 0xffff, @@ -683,12 +683,29 @@ printf( $stat[7], $stat[2], $stat[1] -);' \"$1\" \"$2\" %n" +);' \"$1\" %n" "Perl script to produce output suitable for use with `file-attributes' on the remote file system. Format specifiers are replaced by `tramp-expand-script', percent characters need to be doubled.") +(defconst tramp-stat-file-attributes + (format + (concat + "(%%s -c" + " '((%s%%%%N%s) %%%%h (%s%%%%U%s . %%%%u) (%s%%%%G%s . %%%%g)" + " %%%%X %%%%Y %%%%Z %%%%s %s%%%%A%s t %%%%i -1)' \"$1\" %%n || echo nil) |" + " sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g'") + tramp-stat-marker tramp-stat-marker ; %%N + tramp-stat-marker tramp-stat-marker ; %%U + tramp-stat-marker tramp-stat-marker ; %%G + tramp-stat-marker tramp-stat-marker ; %%A + tramp-stat-quoted-marker) + "Shell function to produce output suitable for use with `file-attributes' +on the remote file system. +Format specifiers are replaced by `tramp-expand-script', percent +characters need to be doubled.") + (defconst tramp-perl-directory-files-and-attributes "%p -e ' chdir($ARGV[0]) or printf(\"\\\"Cannot change to $ARGV[0]: $''!''\\\"\\n\"), exit(); @@ -715,16 +732,16 @@ for($i = 0; $i < $n; $i++) { $type = \"nil\" }; - $uid = ($ARGV[1] eq \"integer\") ? $stat[4] : \"\\\"\" . getpwuid($stat[4]) . \"\\\"\"; - $gid = ($ARGV[1] eq \"integer\") ? $stat[5] : \"\\\"\" . getgrgid($stat[5]) . \"\\\"\"; $filename =~ s/\"/\\\\\"/g; printf( - \"(\\\"%%s\\\" %%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u %%u t %%u -1)\\n\", + \"(\\\"%%s\\\" %%s %%u (%%s . %%u) (%%s . %%u) (%%u %%u) (%%u %%u) (%%u %%u) %%u %%u t %%u -1)\\n\", $filename, $type, $stat[3], - $uid, - $gid, + \"\\\"\" . getpwuid($stat[4]) . \"\\\"\", + $stat[4], + \"\\\"\" . getgrgid($stat[5]) . \"\\\"\", + $stat[5], $stat[8] >> 16 & 0xffff, $stat[8] & 0xffff, $stat[9] >> 16 & 0xffff, @@ -735,12 +752,38 @@ for($i = 0; $i < $n; $i++) $stat[2], $stat[1]); } -printf(\")\\n\");' \"$1\" \"$2\" %n" +printf(\")\\n\");' \"$1\" %n" "Perl script implementing `directory-files-and-attributes' as Lisp `read'able output. Format specifiers are replaced by `tramp-expand-script', percent characters need to be doubled.") +(defconst tramp-stat-directory-files-and-attributes + (format + (concat + ;; We must care about file names with spaces, or starting with + ;; "-"; this would confuse xargs. "ls -aQ" might be a solution, + ;; but it does not work on all remote systems. Therefore, we use + ;; \000 as file separator. `tramp-sh--quoting-style-options' do + ;; not work for file names with spaces piped to "xargs". + ;; Apostrophes in the stat output are masked as + ;; `tramp-stat-marker', in order to make a proper shell escape of + ;; them in file names. + "cd \"$1\" && echo \"(\"; (%%l -a | tr '\\n\\r' '\\000\\000' |" + " xargs -0 %%s -c" + " '(%s%%%%n%s (%s%%%%N%s) %%%%h (%s%%%%U%s . %%%%u) (%s%%%%G%s . %%%%g) %%%%X %%%%Y %%%%Z %%%%s %s%%%%A%s t %%%%i -1)'" + " -- %%n | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g'); echo \")\"") + tramp-stat-marker tramp-stat-marker ; %n + tramp-stat-marker tramp-stat-marker ; %N + tramp-stat-marker tramp-stat-marker ; %U + tramp-stat-marker tramp-stat-marker ; %G + tramp-stat-marker tramp-stat-marker ; %A + tramp-stat-quoted-marker) + "Shell function implementing `directory-files-and-attributes' as Lisp +`read'able 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" @@ -1068,7 +1111,9 @@ component is used as the target of the symlink." (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))))) + (setq target (tramp-file-local-name (expand-file-name target)))) + ;; There could be a cyclic link. + (tramp-flush-file-properties v target)) ;; If TARGET is still remote, quote it. (if (tramp-tramp-file-p target) @@ -1130,36 +1175,32 @@ component is used as the target of the symlink." (tramp-make-tramp-file-name v (with-tramp-file-property v localname "file-truename" - (let (result) ; result steps in reverse order - (tramp-message v 4 "Finding true name for `%s'" filename) - (cond - ;; Use GNU readlink --canonicalize-missing where available. - ((tramp-get-remote-readlink v) - (tramp-send-command-and-check - v - (format "%s --canonicalize-missing %s" - (tramp-get-remote-readlink v) - (tramp-shell-quote-argument localname))) - (with-current-buffer (tramp-get-connection-buffer v) - (goto-char (point-min)) - (setq result (buffer-substring (point-min) (point-at-eol))))) - - ;; Use Perl implementation. - ((and (tramp-get-remote-perl v) - (tramp-get-connection-property v "perl-file-spec") - (tramp-get-connection-property v "perl-cwd-realpath")) - (tramp-maybe-send-script - v tramp-perl-file-truename "tramp_perl_file_truename") - (setq result - (tramp-send-command-and-read - v - (format "tramp_perl_file_truename %s" - (tramp-shell-quote-argument localname))))) - - ;; Do it yourself. - (t (setq - result - (tramp-file-local-name (tramp-handle-file-truename filename))))) + (tramp-message v 4 "Finding true name for `%s'" filename) + (let ((result + (cond + ;; Use GNU readlink --canonicalize-missing where available. + ((tramp-get-remote-readlink v) + (tramp-send-command-and-check + v (format "%s --canonicalize-missing %s" + (tramp-get-remote-readlink v) + (tramp-shell-quote-argument localname))) + (with-current-buffer (tramp-get-connection-buffer v) + (goto-char (point-min)) + (buffer-substring (point-min) (point-at-eol)))) + + ;; Use Perl implementation. + ((and (tramp-get-remote-perl v) + (tramp-get-connection-property v "perl-file-spec") + (tramp-get-connection-property v "perl-cwd-realpath")) + (tramp-maybe-send-script + v tramp-perl-file-truename "tramp_perl_file_truename") + (tramp-send-command-and-read + v (format "tramp_perl_file_truename %s" + (tramp-shell-quote-argument localname)))) + + ;; Do it yourself. + (t (tramp-file-local-name + (tramp-handle-file-truename filename)))))) ;; Detect cycle. (when (and (file-symlink-p filename) @@ -1184,37 +1225,28 @@ component is used as the target of the symlink." (when (tramp-connectable-p filename) (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname "file-exists-p" - (or (not (null (tramp-get-file-property - v localname "file-attributes-integer"))) - (not (null (tramp-get-file-property - v localname "file-attributes-string"))) - (tramp-send-command-and-check - v - (format - "%s %s" - (tramp-get-file-exists-command v) - (tramp-shell-quote-argument localname)))))))) + (if (tramp-file-property-p v localname "file-attributes") + (not (null (tramp-get-file-property v localname "file-attributes"))) + (tramp-send-command-and-check + v + (format + "%s %s" + (tramp-get-file-exists-command v) + (tramp-shell-quote-argument localname)))))))) (defun tramp-sh-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." - (unless id-format (setq id-format 'integer)) - (ignore-errors - ;; Don't modify `last-coding-system-used' by accident. - (let ((last-coding-system-used last-coding-system-used)) - (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-tramp-file-property - v localname (format "file-attributes-%s" id-format) - (tramp-convert-file-attributes - v - (or - (cond - ((tramp-get-remote-stat v) - (tramp-do-file-attributes-with-stat v localname id-format)) - ((tramp-get-remote-perl v) - (tramp-do-file-attributes-with-perl v localname id-format)) - (t nil)) - ;; The scripts could fail, for example with huge file size. - (tramp-do-file-attributes-with-ls v localname id-format)))))))) + ;; The result is cached in `tramp-convert-file-attributes'. + ;; Don't modify `last-coding-system-used' by accident. + (let ((last-coding-system-used last-coding-system-used)) + (with-parsed-tramp-file-name (expand-file-name filename) nil + (tramp-convert-file-attributes v localname id-format + (cond + ((tramp-get-remote-stat v) + (tramp-do-file-attributes-with-stat v localname)) + ((tramp-get-remote-perl v) + (tramp-do-file-attributes-with-perl v localname)) + (t (tramp-do-file-attributes-with-ls v localname))))))) (defconst tramp-sunos-unames (regexp-opt '("SunOS 5.10" "SunOS 5.11")) "Regexp to determine remote SunOS.") @@ -1230,29 +1262,40 @@ component is used as the target of the symlink." (tramp-get-ls-command-with vec "-w")) "")) -(defun tramp-do-file-attributes-with-ls (vec localname &optional id-format) +(defun tramp-do-file-attributes-with-ls (vec localname) "Implement `file-attributes' for Tramp files using the ls(1) command." (let (symlinkp dirp res-inode res-filemodes res-numlinks - res-uid res-gid res-size res-symlink-target) + res-uid-string res-gid-string res-uid-integer res-gid-integer + res-size res-symlink-target) (tramp-message vec 5 "file attributes with ls: %s" localname) ;; We cannot send all three commands combined, it could exceed ;; NAME_MAX or PATH_MAX. Happened on macOS, for example. - (when (or (tramp-send-command-and-check - vec - (format "%s %s" - (tramp-get-file-exists-command vec) - (tramp-shell-quote-argument localname))) - (tramp-send-command-and-check - vec - (format "%s -h %s" - (tramp-get-test-command vec) - (tramp-shell-quote-argument localname)))) + (when (tramp-send-command-and-check + vec + (format "cd %s && (%s %s || %s -h %s)" + (tramp-shell-quote-argument + (tramp-run-real-handler + #'file-name-directory (list localname))) + (tramp-get-file-exists-command vec) + (if (string-empty-p (file-name-nondirectory localname)) + "." + (tramp-shell-quote-argument + (file-name-nondirectory localname))) + (tramp-get-test-command vec) + (if (string-empty-p (file-name-nondirectory localname)) + "." + (tramp-shell-quote-argument + (file-name-nondirectory localname))))) (tramp-send-command vec - (format "%s %s %s %s" + (format "%s -ild %s %s; %s -lnd %s %s" + (tramp-get-ls-command vec) + ;; On systems which have no quoting style, file names + ;; with special characters could fail. + (tramp-sh--quoting-style-options vec) + (tramp-shell-quote-argument localname) (tramp-get-ls-command vec) - (if (eq id-format 'integer) "-ildn" "-ild") ;; On systems which have no quoting style, file names ;; with special characters could fail. (tramp-sh--quoting-style-options vec) @@ -1268,17 +1311,12 @@ component is used as the target of the symlink." ;; ... number links (setq res-numlinks (read (current-buffer))) ;; ... uid and gid - (setq res-uid (read (current-buffer))) - (setq res-gid (read (current-buffer))) - (if (eq id-format 'integer) - (progn - (unless (numberp res-uid) - (setq res-uid tramp-unknown-id-integer)) - (unless (numberp res-gid) - (setq res-gid tramp-unknown-id-integer))) - (progn - (unless (stringp res-uid) (setq res-uid (symbol-name res-uid))) - (unless (stringp res-gid) (setq res-gid (symbol-name res-gid))))) + (setq res-uid-string (read (current-buffer))) + (setq res-gid-string (read (current-buffer))) + (unless (stringp res-uid-string) + (setq res-uid-string (symbol-name res-uid-string))) + (unless (stringp res-gid-string) + (setq res-gid-string (symbol-name res-gid-string))) ;; ... size (setq res-size (read (current-buffer))) ;; From the file modes, figure out other stuff. @@ -1291,7 +1329,20 @@ component is used as the target of the symlink." (if (looking-at-p "\"") (read (current-buffer)) (buffer-substring (point) (point-at-eol))))) - ;; Return data gathered. + (forward-line) + ;; ... file mode flags + (read (current-buffer)) + ;; ... number links + (read (current-buffer)) + ;; ... uid and gid + (setq res-uid-integer (read (current-buffer))) + (setq res-gid-integer (read (current-buffer))) + (unless (numberp res-uid-integer) + (setq res-uid-integer tramp-unknown-id-integer)) + (unless (numberp res-gid-integer) + (setq res-gid-integer tramp-unknown-id-integer)) + + ;; Return data gathered. (list ;; 0. t for directory, string (name linked to) for symbolic ;; link, or nil. @@ -1299,9 +1350,9 @@ component is used as the target of the symlink." ;; 1. Number of links to file. res-numlinks ;; 2. File uid. - res-uid + (cons res-uid-string res-uid-integer) ;; 3. File gid. - res-gid + (cons res-gid-string res-gid-integer) ;; 4. Last access time. ;; 5. Last modification time. ;; 6. Last status change time. @@ -1318,42 +1369,23 @@ component is used as the target of the symlink." ;; 11. Device number. Will be replaced by a virtual device number. -1)))))) -(defun tramp-do-file-attributes-with-perl - (vec localname &optional id-format) +(defun tramp-do-file-attributes-with-perl (vec localname) "Implement `file-attributes' for Tramp files using a Perl script." (tramp-message vec 5 "file attributes with perl: %s" localname) (tramp-maybe-send-script vec tramp-perl-file-attributes "tramp_perl_file_attributes") (tramp-send-command-and-read - vec - (format "tramp_perl_file_attributes %s %s" - (tramp-shell-quote-argument localname) id-format))) + vec (format "tramp_perl_file_attributes %s" + (tramp-shell-quote-argument localname)))) -(defun tramp-do-file-attributes-with-stat - (vec localname &optional id-format) +(defun tramp-do-file-attributes-with-stat (vec localname) "Implement `file-attributes' for Tramp files using stat(1) command." (tramp-message vec 5 "file attributes with stat: %s" localname) + (tramp-maybe-send-script + vec tramp-stat-file-attributes "tramp_stat_file_attributes") (tramp-send-command-and-read - vec - (format - (concat - ;; Apostrophes in the stat output are masked as - ;; `tramp-stat-marker', in order to make a proper shell escape of - ;; them in file names. - "(%s -c '((%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' %s |" - " sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g')") - (tramp-get-remote-stat vec) - tramp-stat-marker tramp-stat-marker - (if (eq id-format 'integer) - "%u" - (eval-when-compile (concat tramp-stat-marker "%U" tramp-stat-marker))) - (if (eq id-format 'integer) - "%g" - (eval-when-compile (concat tramp-stat-marker "%G" tramp-stat-marker))) - tramp-stat-marker tramp-stat-marker - (tramp-shell-quote-argument localname) - tramp-stat-quoted-marker) - 'noerror)) + vec (format "tramp_stat_file_attributes %s" + (tramp-shell-quote-argument localname)))) (defun tramp-sh-handle-set-visited-file-modtime (&optional time-list) "Like `set-visited-file-modtime' for Tramp files." @@ -1486,6 +1518,7 @@ VEC or USER, or if there is no home directory, return nil." (defun tramp-sh-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'. (ignore-errors (cond ((tramp-get-remote-id vec) (tramp-get-remote-uid-with-id vec id-format)) @@ -1496,6 +1529,7 @@ ID-FORMAT valid values are `string' and `integer'." (defun tramp-sh-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'. (ignore-errors (cond ((tramp-get-remote-id vec) (tramp-get-remote-gid-with-id vec id-format)) @@ -1620,16 +1654,18 @@ ID-FORMAT valid values are `string' and `integer'." (with-tramp-file-property v localname "file-executable-p" ;; Examine `file-attributes' cache to see if request can be ;; satisfied without remote operation. - (or (tramp-check-cached-permissions v ?x) - (tramp-check-cached-permissions v ?s) - (tramp-run-test "-x" filename))))) + (if (tramp-file-property-p v localname "file-attributes") + (or (tramp-check-cached-permissions v ?x) + (tramp-check-cached-permissions v ?s)) + (tramp-run-test "-x" filename))))) (defun tramp-sh-handle-file-readable-p (filename) "Like `file-readable-p' for Tramp files." (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname "file-readable-p" - (or (tramp-handle-file-readable-p filename) - (tramp-run-test "-r" filename))))) + (if (tramp-file-property-p v localname "file-attributes") + (tramp-handle-file-readable-p filename) + (tramp-run-test "-r" filename))))) ;; Functions implemented using the basic functions above. @@ -1642,19 +1678,28 @@ ID-FORMAT valid values are `string' and `integer'." ;; be expected that this is always a directory. (or (zerop (length localname)) (with-tramp-file-property v localname "file-directory-p" - (tramp-run-test "-d" filename))))) + (if-let + ((truename (tramp-get-file-property v localname "file-truename")) + (attr-p (tramp-file-property-p + v (tramp-file-local-name truename) "file-attributes"))) + (eq (file-attribute-type + (tramp-get-file-property + v (tramp-file-local-name truename) "file-attributes")) + t) + (tramp-run-test "-d" filename)))))) (defun tramp-sh-handle-file-writable-p (filename) "Like `file-writable-p' for Tramp files." (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname "file-writable-p" (if (file-exists-p filename) - ;; Examine `file-attributes' cache to see if request can be - ;; satisfied without remote operation. - (or (tramp-check-cached-permissions v ?w) - (tramp-run-test "-w" filename)) + (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-run-test "-w" filename)) ;; If file doesn't exist, check if directory is writable. - (and (tramp-run-test "-d" (file-name-directory filename)) + (and (file-exists-p (file-name-directory filename)) (tramp-run-test "-w" (file-name-directory filename))))))) (defun tramp-sh-handle-file-ownership-preserved-p (filename &optional group) @@ -1683,51 +1728,18 @@ ID-FORMAT valid values are `string' and `integer'." (defun tramp-sh-handle-directory-files-and-attributes (directory &optional full match nosort id-format count) "Like `directory-files-and-attributes' for Tramp files." - (unless id-format (setq id-format 'integer)) - (unless (file-exists-p directory) - (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) - (when (file-directory-p directory) - (setq directory (expand-file-name directory)) - (let* ((temp - (copy-tree - (with-parsed-tramp-file-name directory nil - (with-tramp-file-property - v localname - (format "directory-files-and-attributes-%s" id-format) - (mapcar - (lambda (x) - (cons (car x) (tramp-convert-file-attributes v (cdr x)))) - (cond - ((tramp-get-remote-stat v) - (tramp-do-directory-files-and-attributes-with-stat - v localname id-format)) - ((tramp-get-remote-perl v) - (tramp-do-directory-files-and-attributes-with-perl - v localname id-format)) - (t nil))))))) - result item) - - (while temp - (setq item (pop temp)) - (when (or (null match) (string-match-p match (car item))) - (when full - (setcar item (expand-file-name (car item) directory))) - (push item result))) - - (unless nosort - (setq result (sort result (lambda (x y) (string< (car x) (car y)))))) - - (when (and (natnump count) (> count 0)) - (setq result (tramp-compat-ntake count result))) - - (or result - ;; The scripts could fail, for example with huge file size. - (tramp-handle-directory-files-and-attributes - directory full match nosort id-format count))))) + (tramp-skeleton-directory-files-and-attributes + directory full match nosort id-format count + (cond + ((tramp-get-remote-stat v) + (tramp-do-directory-files-and-attributes-with-stat + v localname)) + ((tramp-get-remote-perl v) + (tramp-do-directory-files-and-attributes-with-perl + v localname))))) ;; FIXME: Fix function to work with count parameter. -(defun tramp-do-directory-files-and-attributes-with-perl - (vec localname &optional id-format) +(defun tramp-do-directory-files-and-attributes-with-perl (vec localname) "Implement `directory-files-and-attributes' for Tramp files using a Perl script." (tramp-message vec 5 "directory-files-and-attributes with perl: %s" localname) (tramp-maybe-send-script @@ -1735,50 +1747,21 @@ ID-FORMAT valid values are `string' and `integer'." "tramp_perl_directory_files_and_attributes") (let ((object (tramp-send-command-and-read - vec - (format "tramp_perl_directory_files_and_attributes %s %s" - (tramp-shell-quote-argument localname) id-format)))) + vec (format "tramp_perl_directory_files_and_attributes %s" + (tramp-shell-quote-argument localname))))) (when (stringp object) (tramp-error vec 'file-error object)) object)) ;; FIXME: Fix function to work with count parameter. -(defun tramp-do-directory-files-and-attributes-with-stat - (vec localname &optional id-format) +(defun tramp-do-directory-files-and-attributes-with-stat (vec localname) "Implement `directory-files-and-attributes' for Tramp files with stat(1) command." (tramp-message vec 5 "directory-files-and-attributes with stat: %s" localname) + (tramp-maybe-send-script + vec tramp-stat-directory-files-and-attributes + "tramp_stat_directory_files_and_attributes") (tramp-send-command-and-read - vec - (format - (concat - ;; We must care about file names with spaces, or starting with - ;; "-"; this would confuse xargs. "ls -aQ" might be a solution, - ;; but it does not work on all remote systems. Therefore, we use - ;; \000 as file separator. `tramp-sh--quoting-style-options' do - ;; not work for file names with spaces piped to "xargs". - ;; Apostrophes in the stat output are masked as - ;; `tramp-stat-marker', in order to make a proper shell escape of - ;; them in file names. - "cd %s && echo \"(\"; (%s %s -a | tr '\\n\\r' '\\000\\000' | " - "xargs -0 %s -c " - "'(%s%%n%s (%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' " - "-- 2>%s | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g'); echo \")\"") - (tramp-shell-quote-argument localname) - (tramp-get-ls-command vec) - ;; On systems which have no quoting style, file names with special - ;; characters could fail. - (tramp-sh--quoting-style-options vec) - (tramp-get-remote-stat vec) - tramp-stat-marker tramp-stat-marker - tramp-stat-marker tramp-stat-marker - (if (eq id-format 'integer) - "%u" - (eval-when-compile (concat tramp-stat-marker "%U" tramp-stat-marker))) - (if (eq id-format 'integer) - "%g" - (eval-when-compile (concat tramp-stat-marker "%G" tramp-stat-marker))) - tramp-stat-marker tramp-stat-marker - (tramp-get-remote-null-device vec) - tramp-stat-quoted-marker))) + vec (format "tramp_stat_directory_files_and_attributes %s" + (tramp-shell-quote-argument localname)))) ;; This function should return "foo/" for directories and "bar" for ;; files. @@ -1900,59 +1883,62 @@ ID-FORMAT valid values are `string' and `integer'." (defun tramp-sh-handle-copy-directory (dirname newname &optional keep-date parents copy-contents) "Like `copy-directory' for Tramp files." - (let ((t1 (tramp-tramp-file-p dirname)) - (t2 (tramp-tramp-file-p newname)) - target) - (with-parsed-tramp-file-name (if t1 dirname newname) nil - (unless (file-exists-p dirname) - (tramp-error v 'file-missing dirname)) - - ;; `copy-directory-create-symlink' exists since Emacs 28.1. - (if (and (bound-and-true-p copy-directory-create-symlink) - (setq target (file-symlink-p dirname)) - (tramp-equal-remote dirname newname)) - (make-symbolic-link - target - (if (directory-name-p newname) - (concat newname (file-name-nondirectory dirname)) newname) - t) - - (if (and (not copy-contents) - (tramp-get-method-parameter v 'tramp-copy-recursive) - ;; When DIRNAME and NEWNAME are remote, they must - ;; have the same method. - (or (null t1) (null t2) - (string-equal - (tramp-file-name-method (tramp-dissect-file-name dirname)) - (tramp-file-name-method - (tramp-dissect-file-name newname))))) - ;; scp or rsync DTRT. - (progn - (when (and (file-directory-p newname) - (not (directory-name-p newname))) - (tramp-error v 'file-already-exists newname)) - (setq dirname (directory-file-name (expand-file-name dirname)) - newname (directory-file-name (expand-file-name newname))) - (when (and (file-directory-p newname) - (not (string-equal (file-name-nondirectory dirname) - (file-name-nondirectory newname)))) - (setq newname - (expand-file-name - (file-name-nondirectory dirname) newname))) - (unless (file-directory-p (file-name-directory newname)) - (make-directory (file-name-directory newname) parents)) - (tramp-do-copy-or-rename-file-out-of-band - 'copy dirname newname 'ok-if-already-exists keep-date)) - - ;; We must do it file-wise. - (tramp-run-real-handler - #'copy-directory - (list dirname newname keep-date parents copy-contents)))) - - ;; When newname did exist, we have wrong cached values. - (when t2 - (with-parsed-tramp-file-name newname nil - (tramp-flush-file-properties v localname)))))) + (tramp-skeleton-copy-directory + dirname newname keep-date parents copy-contents + (let ((t1 (tramp-tramp-file-p dirname)) + (t2 (tramp-tramp-file-p newname)) + target) + (with-parsed-tramp-file-name (if t1 dirname newname) nil + (unless (file-exists-p dirname) + (tramp-error v 'file-missing dirname)) + + ;; `copy-directory-create-symlink' exists since Emacs 28.1. + (if (and (bound-and-true-p copy-directory-create-symlink) + (setq target (file-symlink-p dirname)) + (tramp-equal-remote dirname newname)) + (make-symbolic-link + target + (if (directory-name-p newname) + (concat newname (file-name-nondirectory dirname)) newname) + t) + + (if (and (not copy-contents) + (tramp-get-method-parameter v 'tramp-copy-recursive) + ;; When DIRNAME and NEWNAME are remote, they must + ;; have the same method. + (or (null t1) (null t2) + (string-equal + (tramp-file-name-method + (tramp-dissect-file-name dirname)) + (tramp-file-name-method + (tramp-dissect-file-name newname))))) + ;; scp or rsync DTRT. + (progn + (when (and (file-directory-p newname) + (not (directory-name-p newname))) + (tramp-error v 'file-already-exists newname)) + (setq dirname (directory-file-name (expand-file-name dirname)) + newname (directory-file-name (expand-file-name newname))) + (when (and (file-directory-p newname) + (not (string-equal (file-name-nondirectory dirname) + (file-name-nondirectory newname)))) + (setq newname + (expand-file-name + (file-name-nondirectory dirname) newname))) + (unless (file-directory-p (file-name-directory newname)) + (make-directory (file-name-directory newname) parents)) + (tramp-do-copy-or-rename-file-out-of-band + 'copy dirname newname 'ok-if-already-exists keep-date)) + + ;; We must do it file-wise. + (tramp-run-real-handler + #'copy-directory + (list dirname newname keep-date parents copy-contents)))) + + ;; When newname did exist, we have wrong cached values. + (when t2 + (with-parsed-tramp-file-name newname nil + (tramp-flush-file-properties v localname))))))) (defun tramp-sh-handle-rename-file (filename newname &optional ok-if-already-exists) @@ -1997,98 +1983,101 @@ file names." (copy-directory filename newname keep-date t) (when (eq op 'rename) (delete-directory filename 'recursive))) + ;; FIXME: This should be optimized. Computing `file-attributes' + ;; checks already, whether the file exists. (let ((t1 (tramp-tramp-file-p filename)) (t2 (tramp-tramp-file-p newname)) (length (file-attribute-size (file-attributes (file-truename filename)))) - (attributes (and preserve-extended-attributes - (file-extended-attributes filename))) (msg-operation (if (eq op 'copy) "Copying" "Renaming"))) (with-parsed-tramp-file-name (if t1 filename newname) nil - (unless (file-exists-p filename) + (unless length (tramp-error v 'file-missing filename)) - (when (and (not ok-if-already-exists) (file-exists-p newname)) - (tramp-error v 'file-already-exists newname)) - (when (and (file-directory-p newname) - (not (directory-name-p newname))) - (tramp-error v 'file-error "File is a directory %s" newname)) + (tramp-barf-if-file-missing v filename + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) + (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) - (with-tramp-progress-reporter - v 0 (format "%s %s to %s" msg-operation filename newname) + (with-tramp-progress-reporter + v 0 (format "%s %s to %s" msg-operation filename newname) - (cond - ;; Both are Tramp files. - ((and t1 t2) - (with-parsed-tramp-file-name filename v1 - (with-parsed-tramp-file-name newname v2 - (cond - ;; Shortcut: if method, host, user are the same for - ;; both files, we invoke `cp' or `mv' on the remote - ;; host directly. - ((tramp-equal-remote filename newname) - (tramp-do-copy-or-rename-file-directly - op filename newname - ok-if-already-exists keep-date preserve-uid-gid)) - - ;; Try out-of-band operation. - ((and - (tramp-method-out-of-band-p v1 length) - (tramp-method-out-of-band-p v2 length)) - (tramp-do-copy-or-rename-file-out-of-band - op filename newname ok-if-already-exists keep-date)) - - ;; No shortcut was possible. So we copy the file - ;; first. If the operation was `rename', we go back - ;; and delete the original file (if the copy was - ;; successful). The approach is simple-minded: we - ;; create a new buffer, insert the contents of the - ;; source file into it, then write out the buffer to - ;; the target file. The advantage is that it doesn't - ;; matter which file name handlers are used for the - ;; source and target file. - (t - (tramp-do-copy-or-rename-file-via-buffer - op filename newname ok-if-already-exists keep-date)))))) - - ;; One file is a Tramp file, the other one is local. - ((or t1 t2) (cond - ;; Fast track on local machine. - ((tramp-local-host-p v) - (tramp-do-copy-or-rename-file-directly - op filename newname - ok-if-already-exists keep-date preserve-uid-gid)) - - ;; If the Tramp file has an out-of-band method, the - ;; corresponding copy-program can be invoked. - ((tramp-method-out-of-band-p v length) - (tramp-do-copy-or-rename-file-out-of-band - op filename newname ok-if-already-exists keep-date)) - - ;; Use the inline method via a Tramp buffer. - (t (tramp-do-copy-or-rename-file-via-buffer - op filename newname ok-if-already-exists keep-date)))) - - (t - ;; One of them must be a Tramp file. - (error "Tramp implementation says this cannot happen"))) - - ;; Handle `preserve-extended-attributes'. We ignore possible - ;; errors, because ACL strings could be incompatible. - (when attributes - (ignore-errors - (set-file-extended-attributes newname attributes))) - - ;; In case of `rename', we must flush the cache of the source file. - (when (and t1 (eq op 'rename)) - (with-parsed-tramp-file-name filename v1 - (tramp-flush-file-properties v1 v1-localname))) - - ;; When newname did exist, we have wrong cached values. - (when t2 - (with-parsed-tramp-file-name newname v2 - (tramp-flush-file-properties v2 v2-localname)))))))) + ;; Both are Tramp files. + ((and t1 t2) + (with-parsed-tramp-file-name filename v1 + (with-parsed-tramp-file-name newname v2 + (cond + ;; Shortcut: if method, host, user are the same for + ;; both files, we invoke `cp' or `mv' on the remote + ;; host directly. + ((tramp-equal-remote filename newname) + (tramp-do-copy-or-rename-file-directly + op filename newname + ok-if-already-exists keep-date preserve-uid-gid)) + + ;; Try out-of-band operation. + ((and + (tramp-method-out-of-band-p v1 length) + (tramp-method-out-of-band-p v2 length)) + (tramp-do-copy-or-rename-file-out-of-band + op filename newname ok-if-already-exists keep-date)) + + ;; No shortcut was possible. So we copy the file + ;; first. If the operation was `rename', we go + ;; back and delete the original file (if the copy + ;; was successful). The approach is simple-minded: + ;; we create a new buffer, insert the contents of + ;; the source file into it, then write out the + ;; buffer to the target file. The advantage is + ;; that it doesn't matter which file name handlers + ;; are used for the source and target file. + (t + (tramp-do-copy-or-rename-file-via-buffer + op filename newname ok-if-already-exists keep-date)))))) + + ;; One file is a Tramp file, the other one is local. + ((or t1 t2) + (cond + ;; Fast track on local machine. + ((tramp-local-host-p v) + (tramp-do-copy-or-rename-file-directly + op filename newname + ok-if-already-exists keep-date preserve-uid-gid)) + + ;; If the Tramp file has an out-of-band method, the + ;; corresponding copy-program can be invoked. + ((tramp-method-out-of-band-p v length) + (tramp-do-copy-or-rename-file-out-of-band + op filename newname ok-if-already-exists keep-date)) + + ;; Use the inline method via a Tramp buffer. + (t (tramp-do-copy-or-rename-file-via-buffer + op filename newname ok-if-already-exists keep-date)))) + + (t + ;; One of them must be a Tramp file. + (error "Tramp implementation says this cannot happen"))) + + ;; Handle `preserve-extended-attributes'. We ignore + ;; possible errors, because ACL strings could be + ;; incompatible. + (when-let ((attributes (and preserve-extended-attributes + (file-extended-attributes filename)))) + (ignore-errors + (set-file-extended-attributes newname attributes))) + + ;; In case of `rename', we must flush the cache of the source file. + (when (and t1 (eq op 'rename)) + (with-parsed-tramp-file-name filename v1 + (tramp-flush-file-properties v1 v1-localname))) + + ;; When newname did exist, we have wrong cached values. + (when t2 + (with-parsed-tramp-file-name newname v2 + (tramp-flush-file-properties v2 v2-localname))))))))) (defun tramp-do-copy-or-rename-file-via-buffer (op filename newname ok-if-already-exists keep-date) @@ -3126,7 +3115,7 @@ implementation will be used." (with-current-buffer (tramp-get-connection-buffer vec) (goto-char (point-min)) (buffer-substring (point-at-bol) (point-at-eol))))) - (if (string-equal res "") + (if (string-empty-p res) (format "Signal %d" i) res))) result)) @@ -3269,15 +3258,10 @@ implementation will be used." (defun tramp-sh-handle-file-local-copy (filename) "Like `file-local-copy' for Tramp files." - (with-parsed-tramp-file-name filename nil - (unless (file-exists-p (file-truename filename)) - (tramp-error v 'file-missing filename)) - - (let* ((size (file-attribute-size - (file-attributes (file-truename filename)))) - (rem-enc (tramp-get-inline-coding v "remote-encoding" size)) - (loc-dec (tramp-get-inline-coding v "local-decoding" size)) - (tmpfile (tramp-compat-make-temp-file filename))) + (tramp-skeleton-file-local-copy filename + (if-let ((size (file-attribute-size (file-attributes filename))) + (rem-enc (tramp-get-inline-coding v "remote-encoding" size)) + (loc-dec (tramp-get-inline-coding v "local-decoding" size))) (condition-case err (cond @@ -3308,7 +3292,7 @@ implementation will be used." (let (file-name-handler-alist (coding-system-for-write 'binary) (default-directory - tramp-compat-temporary-file-directory)) + tramp-compat-temporary-file-directory)) (with-temp-file tmpfile (set-buffer-multibyte nil) (insert-buffer-substring (tramp-get-buffer v)) @@ -3343,8 +3327,8 @@ implementation will be used." (delete-file tmpfile) (signal (car err) (cdr err)))) - (run-hooks 'tramp-handle-file-local-copy-hook) - tmpfile))) + ;; Impossible to copy. Trigger `file-missing' error. + (setq tmpfile nil)))) (defun tramp-sh-handle-write-region (start end filename &optional append visit lockname mustbenew) @@ -3490,16 +3474,14 @@ implementation will be used." filename rem-dec) (goto-char (point-max)) (unless (bolp) (newline)) - (tramp-send-command + (tramp-barf-unless-okay v (format (concat rem-dec " <<'%s'\n%s%s") (tramp-shell-quote-argument localname) tramp-end-of-heredoc (buffer-string) - tramp-end-of-heredoc)) - (tramp-barf-unless-okay - v nil + tramp-end-of-heredoc) "Couldn't write region to `%s', decode using `%s' failed" filename rem-dec) ;; When `file-precious-flag' is set, the region is @@ -3814,8 +3796,7 @@ Fall back to normal file name handler if no Tramp handler exists." (setq pos (match-end 0)) (cond ((getenv "EMACS_EMBA_CI") 'GInotifyFileMonitor) - ((eq system-type 'cygwin) 'GPollFileMonitor) - (t nil))) + ((eq system-type 'cygwin) 'GPollFileMonitor))) ;; TODO: What happens, if several monitor names are reported? ((string-match "\ Supported arguments for GIO_USE_FILE_MONITOR environment variable: @@ -3927,14 +3908,14 @@ Supported arguments for GIO_USE_FILE_MONITOR environment variable: (defun tramp-expand-script (vec script) "Expand SCRIPT with remote files or commands. -\"%a\", \"%h\", \"%o\" and \"%p\" format specifiers are replaced -by the respective `awk', `hexdump', `od' and `perl' 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 +\"%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." - (if (not (string-match-p "\\(^\\|[^%]\\)%[ahnopt]" script)) + (if (not (string-match-p "\\(^\\|[^%]\\)%[ahlnoprst]" script)) script (catch 'wont-work (let ((awk (when (string-match-p "\\(^\\|[^%]\\)%a" script) @@ -3952,6 +3933,11 @@ function returns nil." (if (eq system-type 'windows-nt) "" (concat "2>" null-device))) (throw 'wont-work nil)))) + (ls (when (string-match-p "\\(^\\|[^%]\\)%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 "\\(^\\|[^%]\\)%o" script) (or (if vec (tramp-get-remote-od vec) (executable-find "od")) (throw 'wont-work nil)))) @@ -3960,6 +3946,17 @@ function returns nil." (if vec (tramp-get-remote-perl vec) (executable-find "perl")) (throw 'wont-work nil)))) + (readlink (when (string-match-p "\\(^\\|[^%]\\)%r" script) + (or + (if vec + (tramp-get-remote-readlink vec) + (executable-find "readlink")) + (throw 'wont-work nil)))) + (stat (when (string-match-p "\\(^\\|[^%]\\)%s" script) + (or + (if vec + (tramp-get-remote-stat vec) (executable-find "stat")) + (throw 'wont-work nil)))) (tmp (when (string-match-p "\\(^\\|[^%]\\)%t" script) (or (if vec @@ -3968,7 +3965,9 @@ function returns nil." (throw 'wont-work nil))))) (format-spec script - (format-spec-make ?a awk ?h hdmp ?n dev ?o od ?p perl ?t tmp)))))) + (format-spec-make + ?a awk ?h hdmp ?l ls ?n dev ?o od ?p perl + ?r readlink ?s stat ?t tmp)))))) (defun tramp-maybe-send-script (vec script name) "Define in remote shell function NAME implemented as SCRIPT. @@ -4284,8 +4283,7 @@ seconds. If not, it produces an error message with the given ERROR-ARGS." "Set up an interactive shell. Mainly sets the prompt and the echo correctly. PROC is the shell process to set up. VEC specifies the connection." - (let ((tramp-end-of-output tramp-initial-end-of-output) - (case-fold-search t)) + (let ((case-fold-search t)) (tramp-open-shell vec (tramp-get-method-parameter vec 'tramp-remote-shell)) (tramp-message vec 5 "Setting up remote shell environment") @@ -4312,12 +4310,6 @@ process to set up. VEC specifies the connection." ;; width magic interferes with them. (tramp-send-command vec "stty icanon erase ^H cols 32767" t)))) - (tramp-message vec 5 "Setting shell prompt") - (tramp-send-command - vec (format "PS1=%s PS2='' PS3='' PROMPT_COMMAND=''" - (tramp-shell-quote-argument tramp-end-of-output)) - t) - ;; Check whether the output of "uname -sr" has been changed. If ;; yes, this is a strong indication that we must expire all ;; connection properties. We start again with @@ -4442,7 +4434,7 @@ process to set up. VEC specifies the connection." (copy-sequence tramp-remote-process-environment)))) (setq item (split-string item "=" 'omit)) (setcdr item (string-join (cdr item) "=")) - (if (and (stringp (cdr item)) (not (string-equal (cdr item) ""))) + (if (and (stringp (cdr item)) (not (string-empty-p (cdr item)))) (push (format "%s %s" (car item) (cdr item)) vars) (push (car item) unset))) (when vars @@ -5264,16 +5256,23 @@ executed in a subshell, ie surrounded by parentheses. If DONT-SUPPRESS-ERR is non-nil, stderr won't be sent to \"/dev/null\". Optional argument EXIT-STATUS, if non-nil, triggers the return of the exit status." - (tramp-send-command - vec - (concat (if subshell "( " "") - command - (if command - (if dont-suppress-err - "; " (format " 2>%s; " (tramp-get-remote-null-device vec))) - "") - "echo tramp_exit_status $?" - (if subshell " )" ""))) + (let (cmd data) + (if (and (stringp command) + (string-match (format ".*<<'%s'.*" tramp-end-of-heredoc) command)) + (setq cmd (match-string 0 command) + data (substring command (match-end 0))) + (setq cmd command)) + (tramp-send-command + vec + (concat (if subshell "( " "") + cmd + (if cmd + (if dont-suppress-err + "; " (format " 2>%s; " (tramp-get-remote-null-device vec))) + "") + "echo tramp_exit_status $?" + (if subshell " )" "") + data))) (with-current-buffer (tramp-get-connection-buffer vec) (unless (tramp-search-regexp "tramp_exit_status [[:digit:]]+") (tramp-error @@ -5328,94 +5327,6 @@ raises an error." "`%s' does not return a valid Lisp expression: `%s'" command (buffer-string)))))))) -;; FIXME: Move to tramp.el? -;;;###tramp-autoload -(defun tramp-convert-file-attributes (vec attr) - "Convert `file-attributes' ATTR generated by perl script, stat or ls. -Convert file mode bits to string and set virtual device number. -Return ATTR." - (when attr - (save-match-data - ;; Remove color escape sequences from symlink. - (when (stringp (car attr)) - (while (string-match tramp-display-escape-sequence-regexp (car attr)) - (setcar attr (replace-match "" nil nil (car attr))))) - ;; Convert uid and gid. Use `tramp-unknown-id-integer' as - ;; indication of unusable value. - (when (and (numberp (nth 2 attr)) (< (nth 2 attr) 0)) - (setcar (nthcdr 2 attr) tramp-unknown-id-integer)) - (when (and (floatp (nth 2 attr)) - (<= (nth 2 attr) most-positive-fixnum)) - (setcar (nthcdr 2 attr) (round (nth 2 attr)))) - (when (and (numberp (nth 3 attr)) (< (nth 3 attr) 0)) - (setcar (nthcdr 3 attr) tramp-unknown-id-integer)) - (when (and (floatp (nth 3 attr)) - (<= (nth 3 attr) most-positive-fixnum)) - (setcar (nthcdr 3 attr) (round (nth 3 attr)))) - ;; Convert last access time. - (unless (listp (nth 4 attr)) - (setcar (nthcdr 4 attr) (seconds-to-time (nth 4 attr)))) - ;; Convert last modification time. - (unless (listp (nth 5 attr)) - (setcar (nthcdr 5 attr) (seconds-to-time (nth 5 attr)))) - ;; Convert last status change time. - (unless (listp (nth 6 attr)) - (setcar (nthcdr 6 attr) (seconds-to-time (nth 6 attr)))) - ;; Convert file size. - (when (< (nth 7 attr) 0) - (setcar (nthcdr 7 attr) -1)) - (when (and (floatp (nth 7 attr)) - (<= (nth 7 attr) most-positive-fixnum)) - (setcar (nthcdr 7 attr) (round (nth 7 attr)))) - ;; Convert file mode bits to string. - (unless (stringp (nth 8 attr)) - (setcar (nthcdr 8 attr) (tramp-file-mode-from-int (nth 8 attr))) - (when (stringp (car attr)) - (aset (nth 8 attr) 0 ?l))) - ;; Convert directory indication bit. - (when (string-prefix-p "d" (nth 8 attr)) - (setcar attr t)) - ;; Convert symlink from `tramp-do-file-attributes-with-stat'. - ;; Decode also multibyte string. - (when (consp (car attr)) - (setcar attr - (and (stringp (caar attr)) - (string-match ".+ -> .\\(.+\\)." (caar attr)) - (decode-coding-string - (match-string 1 (caar attr)) 'utf-8)))) - ;; Set file's gid change bit. - (setcar (nthcdr 9 attr) - (if (numberp (nth 3 attr)) - (not (= (nth 3 attr) - (tramp-get-remote-gid vec 'integer))) - (not (string-equal - (nth 3 attr) - (tramp-get-remote-gid vec 'string))))) - ;; Convert inode. - (when (floatp (nth 10 attr)) - (setcar (nthcdr 10 attr) - (condition-case nil - (let ((high (nth 10 attr)) - middle low) - (if (<= high most-positive-fixnum) - (floor high) - ;; The low 16 bits. - (setq low (mod high #x10000) - high (/ high #x10000)) - (if (<= high most-positive-fixnum) - (cons (floor high) (floor low)) - ;; The middle 24 bits. - (setq middle (mod high #x1000000) - high (/ high #x1000000)) - (cons (floor high) - (cons (floor middle) (floor low)))))) - ;; Inodes can be incredible huge. We must hide this. - (error (tramp-get-inode vec))))) - ;; Set virtual device number. - (setcar (nthcdr 11 attr) - (tramp-get-device vec))) - attr)) - (defun tramp-shell-case-fold (string) "Convert STRING to shell glob pattern which ignores case." (mapconcat @@ -5797,18 +5708,25 @@ 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-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/\\$/\\\"/")))) + ;; `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." @@ -5825,7 +5743,6 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." (with-tramp-connection-property vec "python" (tramp-message vec 5 "Finding a suitable `python' command") (or (tramp-find-executable vec "python" (tramp-get-remote-path vec)) - (tramp-find-executable vec "python2" (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) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 5789b8f9474..29abdb575d3 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -232,7 +232,7 @@ See `tramp-actions-before-shell' for more info.") (delete-file . tramp-smb-handle-delete-file) ;; `diff-latest-backup-file' performed by default handler. (directory-file-name . tramp-handle-directory-file-name) - (directory-files . tramp-smb-handle-directory-files) + (directory-files . tramp-handle-directory-files) (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) (dired-compress-file . ignore) @@ -416,175 +416,181 @@ arguments to pass to the OPERATION." (defun tramp-smb-handle-copy-directory (dirname newname &optional keep-date parents copy-contents) "Like `copy-directory' for Tramp files." - (let ((t1 (tramp-tramp-file-p dirname)) - (t2 (tramp-tramp-file-p newname)) - target) - (with-parsed-tramp-file-name (if t1 dirname newname) nil - (unless (file-exists-p dirname) - (tramp-error v 'file-missing dirname)) - - ;; `copy-directory-create-symlink' exists since Emacs 28.1. - (if (and (bound-and-true-p copy-directory-create-symlink) - (setq target (file-symlink-p dirname)) - (tramp-equal-remote dirname newname)) - (make-symbolic-link - target - (if (directory-name-p newname) - (concat newname (file-name-nondirectory dirname)) newname) - t) - - (if copy-contents - ;; We must do it file-wise. - (tramp-run-real-handler - #'copy-directory - (list dirname newname keep-date parents copy-contents)) - - (setq dirname (expand-file-name dirname) - newname (expand-file-name newname)) - (with-tramp-progress-reporter - v 0 (format "Copying %s to %s" dirname newname) - (unless (file-exists-p dirname) - (tramp-error v 'file-missing dirname)) - (when (and (file-directory-p newname) - (not (directory-name-p newname))) - (tramp-error v 'file-already-exists newname)) - (cond - ;; We must use a local temporary directory. - ((and t1 t2) - (let ((tmpdir (tramp-compat-make-temp-name))) - (unwind-protect - (progn - (make-directory tmpdir) - (copy-directory - dirname (file-name-as-directory tmpdir) - keep-date 'parents) - (copy-directory - (expand-file-name (file-name-nondirectory dirname) tmpdir) - newname keep-date parents)) - (delete-directory tmpdir 'recursive)))) - - ;; We can copy recursively. - ;; TODO: Does not work reliably. - (nil ;(and (or t1 t2) (tramp-smb-get-cifs-capabilities v)) + (tramp-skeleton-copy-directory + dirname newname keep-date parents copy-contents + (let ((t1 (tramp-tramp-file-p dirname)) + (t2 (tramp-tramp-file-p newname)) + target) + (with-parsed-tramp-file-name (if t1 dirname newname) nil + (unless (file-exists-p dirname) + (tramp-error v 'file-missing dirname)) + + ;; `copy-directory-create-symlink' exists since Emacs 28.1. + (if (and (bound-and-true-p copy-directory-create-symlink) + (setq target (file-symlink-p dirname)) + (tramp-equal-remote dirname newname)) + (make-symbolic-link + target + (if (directory-name-p newname) + (concat newname (file-name-nondirectory dirname)) newname) + t) + + (if copy-contents + ;; We must do it file-wise. + (tramp-run-real-handler + #'copy-directory + (list dirname newname keep-date parents copy-contents)) + + (setq dirname (expand-file-name dirname) + newname (expand-file-name newname)) + (with-tramp-progress-reporter + v 0 (format "Copying %s to %s" dirname newname) (when (and (file-directory-p newname) - (not (string-equal (file-name-nondirectory dirname) - (file-name-nondirectory newname)))) - (setq newname - (expand-file-name - (file-name-nondirectory dirname) newname)) - (if t2 (setq v (tramp-dissect-file-name newname)))) - (if (not (file-directory-p newname)) - (make-directory newname parents)) - - (let* ((share (tramp-smb-get-share v)) - (localname (file-name-as-directory - (tramp-compat-string-replace - "\\" "/" (tramp-smb-get-localname v)))) - (tmpdir (tramp-compat-make-temp-name)) - (args (list (concat "//" host "/" share) "-E")) - (options tramp-smb-options)) - - (if (not (zerop (length user))) - (setq args (append args (list "-U" user))) - (setq args (append args (list "-N")))) - - (when domain (setq args (append args (list "-W" domain)))) - (when port (setq args (append args (list "-p" port)))) - (when tramp-smb-conf - (setq args (append args (list "-s" tramp-smb-conf)))) - (while options - (setq args - (append args `("--option" ,(format "%s" (car options)))) - options (cdr options))) - (setq args - (if t1 - ;; Source is remote. + (not (directory-name-p newname))) + (tramp-error v 'file-already-exists newname)) + (cond + ;; We must use a local temporary directory. + ((and t1 t2) + (let ((tmpdir (tramp-compat-make-temp-name))) + (unwind-protect + (progn + (make-directory tmpdir) + (copy-directory + dirname (file-name-as-directory tmpdir) + keep-date 'parents) + (copy-directory + (expand-file-name + (file-name-nondirectory dirname) tmpdir) + newname keep-date parents)) + (delete-directory tmpdir 'recursive)))) + + ;; We can copy recursively. + ;; FIXME: Does not work reliably. + (nil ;(and (or t1 t2) (tramp-smb-get-cifs-capabilities v)) + (when (and (file-directory-p newname) + (not (string-equal (file-name-nondirectory dirname) + (file-name-nondirectory newname)))) + (setq newname + (expand-file-name + (file-name-nondirectory dirname) newname)) + (if t2 (setq v (tramp-dissect-file-name newname)))) + (if (not (file-directory-p newname)) + (make-directory newname parents)) + + (let* ((share (tramp-smb-get-share v)) + (localname (file-name-as-directory + (tramp-compat-string-replace + "\\" "/" (tramp-smb-get-localname v)))) + (tmpdir (tramp-compat-make-temp-name)) + (args (list (concat "//" host "/" share) "-E")) + (options tramp-smb-options)) + + (if (not (zerop (length user))) + (setq args (append args (list "-U" user))) + (setq args (append args (list "-N")))) + + (when domain (setq args (append args (list "-W" domain)))) + (when port (setq args (append args (list "-p" port)))) + (when tramp-smb-conf + (setq args (append args (list "-s" tramp-smb-conf)))) + (while options + (setq args (append args + `("--option" ,(format "%s" (car options)))) + options (cdr options))) + (setq args + (if t1 + ;; Source is remote. + (append args + (list "-D" + (tramp-unquote-shell-quote-argument + localname) + "-c" + (tramp-unquote-shell-quote-argument + "tar qc - *") + "|" "tar" "xfC" "-" + (tramp-unquote-shell-quote-argument + tmpdir))) + ;; Target is remote. + (append (list + "tar" "cfC" "-" + (tramp-unquote-shell-quote-argument dirname) + "." "|") + args (list "-D" (tramp-unquote-shell-quote-argument localname) "-c" (tramp-unquote-shell-quote-argument - "tar qc - *") - "|" "tar" "xfC" "-" - (tramp-unquote-shell-quote-argument - tmpdir))) - ;; Target is remote. - (append (list - "tar" "cfC" "-" - (tramp-unquote-shell-quote-argument dirname) - "." "|") - args - (list "-D" (tramp-unquote-shell-quote-argument - localname) - "-c" (tramp-unquote-shell-quote-argument - "tar qx -"))))) - - (unwind-protect - (with-tramp-saved-connection-property v "process-name" - (with-tramp-saved-connection-property v "process-buffer" - (with-temp-buffer - ;; Set the transfer process properties. - (tramp-set-connection-property - v "process-name" (buffer-name (current-buffer))) - (tramp-set-connection-property - v "process-buffer" (current-buffer)) - - (when t1 - ;; The smbclient tar command creates - ;; always complete paths. We must emulate - ;; the directory structure, and symlink to - ;; the real target. - (make-directory - (expand-file-name - ".." (concat tmpdir localname)) - 'parents) - (make-symbolic-link - newname - (directory-file-name (concat tmpdir localname)))) - - ;; Use an asynchronous processes. By this, - ;; password can be handled. - (let* ((default-directory tmpdir) - (p (apply - #'start-process - (tramp-get-connection-name v) - (tramp-get-connection-buffer v) - tramp-smb-program args))) - - (tramp-message - v 6 "%s" (string-join (process-command p) " ")) - (process-put p 'vector v) - (process-put p 'adjust-window-size-function #'ignore) - (set-process-query-on-exit-flag p nil) - (tramp-process-actions - p v nil tramp-smb-actions-with-tar) - - (while (process-live-p p) - (sleep-for 0.1)) - (tramp-message v 6 "\n%s" (buffer-string)))))) - - ;; Save exit. - (when t1 (delete-directory tmpdir 'recursive)))) - - ;; Handle KEEP-DATE argument. - (when keep-date - (tramp-compat-set-file-times - newname - (file-attribute-modification-time (file-attributes dirname)) - (unless ok-if-already-exists 'nofollow))) - - ;; Set the mode. - (unless keep-date - (set-file-modes newname (tramp-default-file-modes dirname))) - - ;; When newname did exist, we have wrong cached values. - (when t2 - (with-parsed-tramp-file-name newname nil - (tramp-flush-file-properties v localname)))) - - ;; We must do it file-wise. - (t - (tramp-run-real-handler - #'copy-directory (list dirname newname keep-date parents)))))))))) + "tar qx -"))))) + + (unwind-protect + (with-tramp-saved-connection-property v "process-name" + (with-tramp-saved-connection-property v "process-buffer" + (with-temp-buffer + ;; Set the transfer process properties. + (tramp-set-connection-property + v "process-name" (buffer-name (current-buffer))) + (tramp-set-connection-property + v "process-buffer" (current-buffer)) + + (when t1 + ;; The smbclient tar command creates + ;; always complete paths. We must + ;; emulate the directory structure, and + ;; symlink to the real target. + (make-directory + (expand-file-name + ".." (concat tmpdir localname)) + 'parents) + (make-symbolic-link + newname + (directory-file-name (concat tmpdir localname)))) + + ;; Use an asynchronous processes. By + ;; this, password can be handled. + (let* ((default-directory tmpdir) + (p (apply + #'start-process + (tramp-get-connection-name v) + (tramp-get-connection-buffer v) + tramp-smb-program args))) + + (tramp-message + v 6 "%s" (string-join (process-command p) " ")) + (process-put p 'vector v) + (process-put + p 'adjust-window-size-function #'ignore) + (set-process-query-on-exit-flag p nil) + (tramp-process-actions + p v nil tramp-smb-actions-with-tar) + + (while (process-live-p p) + (sleep-for 0.1)) + (tramp-message v 6 "\n%s" (buffer-string)))))) + + ;; Save exit. + (when t1 (delete-directory tmpdir 'recursive)))) + + ;; Handle KEEP-DATE argument. + (when keep-date + (tramp-compat-set-file-times + newname + (file-attribute-modification-time (file-attributes dirname)) + (unless ok-if-already-exists 'nofollow))) + + ;; Set the mode. + (unless keep-date + (set-file-modes newname (tramp-default-file-modes dirname))) + + ;; When newname did exist, we have wrong cached values. + (when t2 + (with-parsed-tramp-file-name newname nil + (tramp-flush-file-properties v localname)))) + + ;; We must do it file-wise. + (t + (tramp-run-real-handler + #'copy-directory + (list dirname newname keep-date parents))))))))))) (defun tramp-smb-handle-copy-file (filename newname &optional ok-if-already-exists keep-date @@ -706,37 +712,6 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (search-forward-regexp tramp-smb-errors nil t) (tramp-error v 'file-error "%s `%s'" (match-string 0) filename))))))) -(defun tramp-smb-handle-directory-files - (directory &optional full match nosort count) - "Like `directory-files' for Tramp files." - (unless (file-exists-p directory) - (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) - (let ((result (mapcar #'directory-file-name - (file-name-all-completions "" directory)))) - ;; Discriminate with regexp. - (when match - (setq result - (delete nil - (mapcar (lambda (x) (when (string-match-p match x) x)) - result)))) - - ;; Sort them if necessary. - (unless nosort - (setq result (sort result #'string-lessp))) - - ;; Return count number of results. - (when (and (natnump count) (> count 0)) - (setq result (tramp-compat-ntake count result))) - - ;; Prepend directory. - (when full - (setq result - (mapcar - (lambda (x) (format "%s/%s" (directory-file-name directory) x)) - result))) - - result)) - (defun tramp-smb-handle-expand-file-name (name &optional dir) "Like `expand-file-name' for Tramp files." ;; If DIR is not given, use DEFAULT-DIRECTORY or "/". @@ -852,24 +827,21 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (defun tramp-smb-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." - (unless id-format (setq id-format 'integer)) - (ignore-errors - (with-parsed-tramp-file-name filename nil - (with-tramp-file-property - v localname (format "file-attributes-%s" id-format) + ;; The result is cached in `tramp-convert-file-attributes'. + (with-parsed-tramp-file-name filename nil + (tramp-convert-file-attributes v localname id-format + (ignore-errors (if (tramp-smb-get-stat-capability v) - (tramp-smb-do-file-attributes-with-stat v id-format) - ;; Reading just the filename entry via "dir localname" is not - ;; possible, because when filename is a directory, some - ;; smbclient versions return the content of the directory, and - ;; other versions don't. Therefore, the whole content of the - ;; upper directory is retrieved, and the entry of the filename - ;; is extracted from. + (tramp-smb-do-file-attributes-with-stat v) + ;; Reading just the filename entry via "dir localname" is + ;; not possible, because when filename is a directory, some + ;; smbclient versions return the content of the directory, + ;; and other versions don't. Therefore, the whole content + ;; of the upper directory is retrieved, and the entry of the + ;; filename is extracted from. (let* ((entries (tramp-smb-get-file-entries (file-name-directory filename))) (entry (assoc (file-name-nondirectory filename) entries)) - (uid (if (equal id-format 'string) "nobody" -1)) - (gid (if (equal id-format 'string) "nogroup" -1)) (inode (tramp-get-inode v)) (device (tramp-get-device v))) @@ -877,19 +849,21 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when entry (list (and (tramp-compat-string-search "d" (nth 1 entry)) t) ;0 file type - -1 ;1 link count - uid ;2 uid - gid ;3 gid + -1 ;1 link count + (cons + tramp-unknown-id-string tramp-unknown-id-integer) ;2 uid + (cons + tramp-unknown-id-string tramp-unknown-id-integer) ;3 gid tramp-time-dont-know ;4 atime (nth 3 entry) ;5 mtime tramp-time-dont-know ;6 ctime (nth 2 entry) ;7 size (nth 1 entry) ;8 mode - nil ;9 gid weird - inode ;10 inode number + nil ;9 gid weird + inode ;10 inode number device)))))))) ;11 file system number -(defun tramp-smb-do-file-attributes-with-stat (vec &optional id-format) +(defun tramp-smb-do-file-attributes-with-stat (vec) "Implement `file-attributes' for Tramp files using `stat' command." (tramp-message vec 5 "file attributes with stat: %s" (tramp-file-name-localname vec)) @@ -920,10 +894,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." "Uid:\\s-+\\([[:digit:]]+\\)\\s-+" "Gid:\\s-+\\([[:digit:]]+\\)")) (setq mode (match-string 1) - uid (if (equal id-format 'string) (match-string 2) - (string-to-number (match-string 2))) - gid (if (equal id-format 'string) (match-string 3) - (string-to-number (match-string 3))))) + uid (match-string 2) + gid (match-string 3))) ((looking-at (concat "Access:\\s-+" @@ -977,26 +949,23 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Return the result. (when (or id link uid gid atime mtime ctime size mode inode) - (list id link uid gid atime mtime ctime size mode nil inode - (tramp-get-device vec)))))))) + (list id link (cons uid (string-to-number uid)) + (cons gid (string-to-number gid)) gid atime mtime ctime size + mode nil inode (tramp-get-device vec)))))))) (defun tramp-smb-handle-file-local-copy (filename) "Like `file-local-copy' for Tramp files." - (with-parsed-tramp-file-name (file-truename filename) nil - (unless (file-exists-p (file-truename filename)) - (tramp-error v 'file-missing filename)) - (let ((tmpfile (tramp-compat-make-temp-file filename))) - (with-tramp-progress-reporter - v 3 (format "Fetching %s to tmp file %s" filename tmpfile) - (unless (tramp-smb-send-command - v (format "get %s %s" - (tramp-smb-shell-quote-localname v) - (tramp-smb-shell-quote-argument tmpfile))) - ;; Oops, an error. We shall cleanup. - (delete-file tmpfile) - (tramp-error - v 'file-error "Cannot make local copy of file `%s'" filename))) - tmpfile))) + (tramp-skeleton-file-local-copy filename + (with-tramp-progress-reporter + v 3 (format "Fetching %s to tmp file %s" filename tmpfile) + (unless (tramp-smb-send-command + v (format "get %s %s" + (tramp-smb-shell-quote-localname v) + (tramp-smb-shell-quote-argument tmpfile))) + ;; Oops, an error. We shall cleanup. + (delete-file tmpfile) + (tramp-error + v 'file-error "Cannot make local copy of file `%s'" filename))))) ;; This function should return "foo/" for directories and "bar" for ;; files. @@ -2060,24 +2029,6 @@ If ARGUMENT is non-nil, use it as argument for tramp-smb-actions-with-share tramp-smb-actions-without-share)) - ;; Check server version. - ;; FIXME: With recent smbclient versions, this - ;; information isn't printed anymore. - ;; (unless argument - ;; (with-current-buffer (tramp-get-connection-buffer vec) - ;; (goto-char (point-min)) - ;; (search-forward-regexp tramp-smb-server-version nil t) - ;; (let ((smbserver-version (match-string 0))) - ;; (unless - ;; (string-equal - ;; smbserver-version - ;; (tramp-get-connection-property - ;; vec "smbserver-version" smbserver-version)) - ;; (tramp-flush-directory-properties vec "") - ;; (tramp-flush-connection-properties vec)) - ;; (tramp-set-connection-property - ;; vec "smbserver-version" smbserver-version)))) - ;; Set chunksize to 1. smbclient reads its input ;; character by character; if we send the string ;; at once, it is read painfully slow. diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 420a593644f..5ec68e904e7 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -241,6 +241,8 @@ absolute file names." (copy-directory filename newname keep-date t) (when (eq op 'rename) (delete-directory filename 'recursive))) + ;; FIXME: This should be optimized. Computing `file-attributes' + ;; checks already, whether the file exists. (let ((t1 (tramp-sudoedit-file-name-p filename)) (t2 (tramp-sudoedit-file-name-p newname)) (file-times (file-attribute-modification-time @@ -256,62 +258,61 @@ absolute file names." (msg-operation (if (eq op 'copy) "Copying" "Renaming"))) (with-parsed-tramp-file-name (if t1 filename newname) nil - (unless (file-exists-p filename) - (tramp-error v 'file-missing filename)) - (when (and (not ok-if-already-exists) (file-exists-p newname)) - (tramp-error v 'file-already-exists newname)) - (when (and (file-directory-p newname) - (not (directory-name-p newname))) - (tramp-error v 'file-error "File is a directory %s" newname)) - - (if (or (and (file-remote-p filename) (not t1)) - (and (file-remote-p newname) (not t2))) - ;; We cannot copy or rename directly. - (let ((tmpfile (tramp-compat-make-temp-file filename))) - (if (eq op 'copy) - (copy-file filename tmpfile t) - (rename-file filename tmpfile t)) - (rename-file tmpfile newname ok-if-already-exists)) - - ;; Direct action. - (with-tramp-progress-reporter - v 0 (format "%s %s to %s" msg-operation filename newname) - (unless (tramp-sudoedit-send-command - v sudoedit-operation - (tramp-unquote-file-local-name filename) - (tramp-unquote-file-local-name newname)) - (tramp-error - v 'file-error - "Error %s `%s' `%s'" msg-operation filename newname)))) - - ;; When `newname' is local, we must change the ownership to - ;; the local user. - (unless (file-remote-p newname) - (tramp-set-file-uid-gid - (concat (file-remote-p filename) newname) - (tramp-get-local-uid 'integer) - (tramp-get-local-gid 'integer))) - - ;; Set the time and mode. Mask possible errors. - (when keep-date - (ignore-errors - (tramp-compat-set-file-times - newname file-times (unless ok-if-already-exists 'nofollow)) - (set-file-modes newname file-modes))) - - ;; Handle `preserve-extended-attributes'. We ignore possible - ;; errors, because ACL strings could be incompatible. - (when attributes - (ignore-errors - (set-file-extended-attributes newname attributes))) - - (when (and t1 (eq op 'rename)) - (with-parsed-tramp-file-name filename v1 - (tramp-flush-file-properties v1 v1-localname))) - - (when t2 - (with-parsed-tramp-file-name newname v2 - (tramp-flush-file-properties v2 v2-localname))))))) + (tramp-barf-if-file-missing v filename + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) + (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) + + (if (or (and (file-remote-p filename) (not t1)) + (and (file-remote-p newname) (not t2))) + ;; We cannot copy or rename directly. + (let ((tmpfile (tramp-compat-make-temp-file filename))) + (if (eq op 'copy) + (copy-file filename tmpfile t) + (rename-file filename tmpfile t)) + (rename-file tmpfile newname ok-if-already-exists)) + + ;; Direct action. + (with-tramp-progress-reporter + v 0 (format "%s %s to %s" msg-operation filename newname) + (unless (tramp-sudoedit-send-command + v sudoedit-operation + (tramp-unquote-file-local-name filename) + (tramp-unquote-file-local-name newname)) + (tramp-error + v 'file-error + "Error %s `%s' `%s'" msg-operation filename newname)))) + + ;; When `newname' is local, we must change the ownership to + ;; the local user. + (unless (file-remote-p newname) + (tramp-set-file-uid-gid + (concat (file-remote-p filename) newname) + (tramp-get-local-uid 'integer) + (tramp-get-local-gid 'integer))) + + ;; Set the time and mode. Mask possible errors. + (when keep-date + (ignore-errors + (tramp-compat-set-file-times + newname file-times (unless ok-if-already-exists 'nofollow)) + (set-file-modes newname file-modes))) + + ;; Handle `preserve-extended-attributes'. We ignore possible + ;; errors, because ACL strings could be incompatible. + (when attributes + (ignore-errors + (set-file-extended-attributes newname attributes))) + + (when (and t1 (eq op 'rename)) + (with-parsed-tramp-file-name filename v1 + (tramp-flush-file-properties v1 v1-localname))) + + (when t2 + (with-parsed-tramp-file-name newname v2 + (tramp-flush-file-properties v2 v2-localname)))))))) (defun tramp-sudoedit-handle-copy-file (filename newname &optional ok-if-already-exists keep-date @@ -407,34 +408,30 @@ the result will be a local, non-Tramp, file name." ;; provided by `tramp-sudoedit-send-command-string'. Add it. (and (stringp result) (concat result "\n")))))) +(defconst tramp-sudoedit-file-attributes + (format + ;; Apostrophes in the stat output are masked as + ;; `tramp-stat-marker', in order to make a proper shell escape of + ;; them in file names. They are replaced in + ;; `tramp-sudoedit-send-command-and-read'. + (concat "((%s%%N%s) %%h (%s%%U%s . %%u) (%s%%G%s . %%g)" + " %%X %%Y %%Z %%s %s%%A%s t %%i -1)") + tramp-stat-marker tramp-stat-marker ; %%N + tramp-stat-marker tramp-stat-marker ; %%U + tramp-stat-marker tramp-stat-marker ; %%G + tramp-stat-marker tramp-stat-marker) ; %%A + "stat format string to produce output suitable for use with +`file-attributes' on the remote file system.") + (defun tramp-sudoedit-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." - (unless id-format (setq id-format 'integer)) + ;; The result is cached in `tramp-convert-file-attributes'. (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-tramp-file-property - v localname (format "file-attributes-%s" id-format) - (tramp-message v 5 "file attributes: %s" localname) - (ignore-errors - (tramp-convert-file-attributes - v - (tramp-sudoedit-send-command-and-read - v "env" "QUOTING_STYLE=locale" "stat" "-c" - (format - ;; Apostrophes in the stat output are masked as - ;; `tramp-stat-marker', in order to make a proper shell - ;; escape of them in file names. - "((%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)" - tramp-stat-marker tramp-stat-marker - (if (eq id-format 'integer) - "%u" - (eval-when-compile - (concat tramp-stat-marker "%U" tramp-stat-marker))) - (if (eq id-format 'integer) - "%g" - (eval-when-compile - (concat tramp-stat-marker "%G" tramp-stat-marker))) - tramp-stat-marker tramp-stat-marker) - (tramp-compat-file-name-unquote localname))))))) + (tramp-convert-file-attributes v localname id-format + (tramp-sudoedit-send-command-and-read + v "env" "QUOTING_STYLE=locale" "stat" "-c" + tramp-sudoedit-file-attributes + (tramp-compat-file-name-unquote localname))))) (defun tramp-sudoedit-handle-file-executable-p (filename) "Like `file-executable-p' for Tramp files." @@ -718,6 +715,7 @@ 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"))) @@ -725,6 +723,7 @@ ID-FORMAT valid values are `string' and `integer'." (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"))) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index b11fd293ccb..faf3182d4aa 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -1558,7 +1558,7 @@ of `process-file', `start-file-process', or `shell-command'." This is METHOD, if non-nil. Otherwise, do a lookup in `tramp-default-method-alist' and `tramp-default-method'." (when (and method - (or (string-equal method "") + (or (string-empty-p method) (string-equal method tramp-default-method-marker))) (setq method nil)) (let ((result @@ -1957,7 +1957,8 @@ The outline level is equal to the verbosity of the Tramp message." They are completed by \"M-x TAB\" only in Tramp debug buffers." (with-current-buffer buffer (string-equal - (buffer-substring (point-min) (min (+ (point-min) 10) (point-max))) ";; Emacs:"))) + (buffer-substring (point-min) (min (+ (point-min) 10) (point-max))) + ";; Emacs:"))) (put #'tramp-debug-buffer-command-completion-p 'tramp-suppress-trace t) @@ -1984,6 +1985,7 @@ They are completed by \"M-x TAB\" only in Tramp debug buffers." ,(eval tramp-debug-font-lock-keywords t))) ;; Do not edit the debug buffer. (use-local-map special-mode-map) + (set-buffer-modified-p nil) ;; For debugging purposes. (local-set-key "\M-n" 'clone-buffer) (add-hook 'clone-buffer-hook #'tramp-setup-debug-buffer nil 'local)) @@ -2272,6 +2274,24 @@ the resulting error message." (put #'tramp-with-demoted-errors 'tramp-suppress-trace t) +;; This macro shall optimize the cases where an `file-exists-p' call +;; is invoked first. Often, the file exists, so the remote command is +;; superfluous. +(defmacro tramp-barf-if-file-missing (vec filename &rest body) + "Execute BODY and return the result. +In case if an error, raise a `file-missing' error if FILENAME +does not exist, otherwise propagate the error." + (declare (indent 2) (debug (symbolp form body))) + (let ((err (make-symbol "err"))) + `(condition-case ,err + (progn ,@body) + (error + (if (not (file-exists-p ,filename)) + (tramp-error ,vec 'file-missing ,filename) + (signal (car ,err) (cdr ,err))))))) + +(put #'tramp-barf-if-file-missing 'tramp-suppress-trace t) + (defun tramp-test-message (fmt-string &rest arguments) "Emit a Tramp message according `default-directory'." (cond @@ -3375,6 +3395,22 @@ User is always nil." ;;; Skeleton macros for file name handler functions. +(defmacro tramp-skeleton-copy-directory + (directory _newname &optional _keep-date _parents _copy-contents &rest body) + "Skeleton for `tramp-*-handle-copy-directory'. +BODY is the backend specific code." + (declare (indent 5) (debug t)) + ;; `copy-directory' creates NEWNAME before running this check. So + ;; we do it ourselves. Therefore, we cannot also run + ;; `tramp-barf-if-file-missing'. + `(progn + (unless (file-exists-p ,directory) + (tramp-error + (tramp-dissect-file-name ,directory) 'file-missing ,directory)) + ,@body)) + +(put #'tramp-skeleton-copy-directory 'tramp-suppress-trace t) + (defmacro tramp-skeleton-delete-directory (directory recursive trash &rest body) "Skeleton for `tramp-*-handle-delete-directory'. BODY is the backend specific code." @@ -3392,6 +3428,106 @@ BODY is the backend specific code." (put #'tramp-skeleton-delete-directory 'tramp-suppress-trace t) +(defmacro tramp-skeleton-directory-files + (directory &optional full match nosort count &rest body) + "Skeleton for `tramp-*-handle-directory-files'. +BODY is the backend specific code." + (declare (indent 5) (debug t)) + `(or + (with-parsed-tramp-file-name ,directory nil + (tramp-barf-if-file-missing v ,directory + (when (file-directory-p ,directory) + (setq ,directory + (file-name-as-directory (expand-file-name ,directory))) + (let ((temp + (with-tramp-file-property v localname "directory-files" ,@body)) + result item) + (while temp + (setq item (directory-file-name (pop temp))) + (when (or (null ,match) (string-match-p ,match item)) + (push (if ,full (concat ,directory item) item) + result))) + (unless ,nosort + (setq result (sort result #'string<))) + (when (and (natnump ,count) (> ,count 0)) + (setq result (tramp-compat-ntake ,count result))) + result)))) + + ;; Error handling. + (if (not (file-exists-p ,directory)) + (tramp-error + (tramp-dissect-file-name ,directory) 'file-missing ,directory) + nil))) + +(put #'tramp-skeleton-directory-files 'tramp-suppress-trace t) + +(defmacro tramp-skeleton-directory-files-and-attributes + (directory &optional full match nosort id-format count &rest body) + "Skeleton for `tramp-*-handle-directory-files-and-attributes'. +BODY is the backend specific code." + (declare (indent 6) (debug t)) + `(or + (with-parsed-tramp-file-name ,directory nil + (tramp-barf-if-file-missing v ,directory + (when (file-directory-p ,directory) + (setq ,directory (expand-file-name ,directory)) + (let ((temp + (copy-tree + (mapcar + (lambda (x) + (cons + (car x) + (tramp-convert-file-attributes + v (car x) ,id-format (cdr x)))) + (with-tramp-file-property + v localname ",directory-files-and-attributes" + ,@body)))) + result item) + + (while temp + (setq item (pop temp)) + (when (or (null ,match) (string-match-p ,match (car item))) + (when ,full + (setcar item (expand-file-name (car item) ,directory))) + (push item result))) + + (unless ,nosort + (setq result + (sort result (lambda (x y) (string< (car x) (car y)))))) + + (when (and (natnump ,count) (> ,count 0)) + (setq result (tramp-compat-ntake ,count result))) + + (or result + ;; The scripts could fail, for example with huge file size. + (tramp-handle-directory-files-and-attributes + ,directory ,full ,match ,nosort ,id-format ,count)))))) + + ;; Error handling. + (if (not (file-exists-p ,directory)) + (tramp-error + (tramp-dissect-file-name ,directory) 'file-missing ,directory) + nil))) + +(put #'tramp-skeleton-directory-files-and-attributes 'tramp-suppress-trace t) + +(defmacro tramp-skeleton-file-local-copy (filename &rest body) + "Skeleton for `tramp-*-handle-file-local-copy-files'. +BODY is the backend specific code." + (declare (indent 1) (debug t)) + `(with-parsed-tramp-file-name (file-truename ,filename) nil + (tramp-barf-if-file-missing v ,filename + (or + (let ((tmpfile (tramp-compat-make-temp-file ,filename))) + ,@body + (run-hooks 'tramp-handle-file-local-copy-hook) + tmpfile) + + ;; Trigger the `file-missing' error. + (signal 'error nil))))) + +(put #'tramp-skeleton-file-local-copy 'tramp-suppress-trace t) + (defmacro tramp-skeleton-write-region (start end filename append visit lockname mustbenew &rest body) "Skeleton for `tramp-*-handle-write-region'. @@ -3585,14 +3721,12 @@ Let-bind it when necessary.") (defun tramp-handle-copy-directory (directory newname &optional keep-date parents copy-contents) "Like `copy-directory' for Tramp files." - ;; `copy-directory' creates NEWNAME before running this check. So - ;; we do it ourselves. - (unless (file-exists-p directory) - (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) - ;; We must do it file-wise. - (tramp-run-real-handler - #'copy-directory - (list directory newname keep-date parents copy-contents))) + (tramp-skeleton-copy-directory + directory newname keep-date parents copy-contents + ;; We must do it file-wise. + (tramp-run-real-handler + #'copy-directory + (list directory newname keep-date parents copy-contents)))) (defun tramp-handle-directory-file-name (directory) "Like `directory-file-name' for Tramp files." @@ -3608,23 +3742,8 @@ Let-bind it when necessary.") (defun tramp-handle-directory-files (directory &optional full match nosort count) "Like `directory-files' for Tramp files." - (unless (file-exists-p directory) - (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) - (when (file-directory-p directory) - (setq directory (file-name-as-directory (expand-file-name directory))) - (let ((temp (nreverse (file-name-all-completions "" directory))) - result item) - - (while temp - (setq item (directory-file-name (pop temp))) - (when (or (null match) (string-match-p match item)) - (push (if full (concat directory item) item) - result))) - (unless nosort - (setq result (sort result #'string<))) - (when (and (natnump count) (> count 0)) - (setq result (tramp-compat-ntake count result))) - result))) + (tramp-skeleton-directory-files directory full match nosort count + (nreverse (file-name-all-completions "" directory)))) (defun tramp-handle-directory-files-and-attributes (directory &optional full match nosort id-format count) @@ -3722,12 +3841,8 @@ Let-bind it when necessary.") (defun tramp-handle-file-local-copy (filename) "Like `file-local-copy' for Tramp files." - (with-parsed-tramp-file-name filename nil - (unless (file-exists-p filename) - (tramp-error v 'file-missing filename)) - (let ((tmpfile (tramp-compat-make-temp-file filename))) - (copy-file filename tmpfile 'ok-if-already-exists 'keep-time) - tmpfile))) + (tramp-skeleton-file-local-copy filename + (copy-file filename tmpfile 'ok-if-already-exists 'keep-time))) (defun tramp-handle-file-modes (filename &optional flag) "Like `file-modes' for Tramp files." @@ -4048,13 +4163,10 @@ Let-bind it when necessary.") (let (result local-copy remote-copy) (with-parsed-tramp-file-name filename nil (unwind-protect - (if (not (file-exists-p filename)) - (let ((tramp-verbose (if visit 0 tramp-verbose))) - (tramp-error v 'file-missing filename)) - - (with-tramp-progress-reporter - v 3 (format-message "Inserting `%s'" filename) - (condition-case err + (condition-case err + (tramp-barf-if-file-missing v filename + (with-tramp-progress-reporter + v 3 (format-message "Inserting `%s'" filename) (if (and (tramp-local-host-p v) (let (file-name-handler-alist) (file-readable-p localname))) @@ -4067,7 +4179,7 @@ Let-bind it when necessary.") ;; When we shall insert only a part of the file, we ;; copy this part. This works only for the shell file - ;; name handlers. It doesn't work for encrypted files. + ;; name handlers. It doesn't work for encrypted files. (when (and (or beg end) (tramp-sh-file-name-handler-p v) (null tramp-crypt-enabled)) @@ -4131,12 +4243,16 @@ Let-bind it when necessary.") filename local-copy))) (setq result (insert-file-contents - local-copy visit beg end replace)))) - (error - (add-hook 'find-file-not-found-functions - `(lambda () (signal ',(car err) ',(cdr err))) - nil t) - (signal (car err) (cdr err)))))) + local-copy visit beg end replace)))))) + + (file-error + (let ((tramp-verbose (if visit 0 tramp-verbose))) + (tramp-error v 'file-missing filename))) + (error + (add-hook 'find-file-not-found-functions + `(lambda () (signal ',(car err) ',(cdr err))) + nil t) + (signal (car err) (cdr err)))) ;; Save exit. (when visit @@ -4288,8 +4404,7 @@ It is not guaranteed, that all process attributes as described in (funcall (cdr elt))) ((null (cdr elt)) (search-forward-regexp "\\s-+") - (buffer-substring (point) (line-end-position))) - (t nil))) + (buffer-substring (point) (line-end-position))))) res)) ;; `nice' could be `-'. (setq res (rassq-delete-all '- res)) @@ -4822,11 +4937,7 @@ support symbolic links." ;; Run the process. (setq p (start-file-process-shell-command (buffer-name output-buffer) buffer command)) - ;; Insert error messages if they were separated. - (when error-file - (with-current-buffer error-buffer - (insert-file-contents-literally error-file))) - (if (process-live-p p) + (when (process-live-p p) ;; Display output. (with-current-buffer output-buffer (setq mode-line-process '(":%s")) @@ -4842,11 +4953,15 @@ support symbolic links." (insert-file-contents-literally error-file nil nil nil 'replace)) (delete-file error-file)))) - (display-buffer output-buffer '(nil (allow-no-window . t)))) + (display-buffer output-buffer '(nil (allow-no-window . t))))) - (when error-file - (delete-file error-file))))) + ;; Insert error messages if they were separated. + (when (and error-file (not (process-live-p p))) + (with-current-buffer error-buffer + (insert-file-contents-literally error-file)) + (delete-file error-file)))) + ;; Synchronous case. (prog1 ;; Run the process. (process-file-shell-command command nil buffer) @@ -5199,8 +5314,7 @@ Wait, until the connection buffer changes." (tramp-message vec 3 "Process has finished.") (throw 'tramp-action 'ok)) (tramp-message vec 3 "Process has died.") - (throw 'tramp-action 'out-of-band-failed)))) - (t nil))) + (throw 'tramp-action 'out-of-band-failed)))))) ;;; Functions for processing the actions: @@ -5711,51 +5825,140 @@ VEC is used for tracing." "Check `file-attributes' caches for VEC. Return t if according to the cache access type ACCESS is known to be granted." - (let (result - (offset (cond - ((eq ?r access) 1) - ((eq ?w access) 2) - ((eq ?x access) 3) - ((eq ?s access) 3)))) - (dolist (suffix '("string" "integer") result) - (setq - result - (or - result - (let ((file-attr - (or - (tramp-get-file-property - vec (tramp-file-name-localname vec) - (concat "file-attributes-" suffix) nil) - (file-attributes - (tramp-make-tramp-file-name vec) (intern suffix)))) - (remote-uid (tramp-get-remote-uid vec (intern suffix))) - (remote-gid (tramp-get-remote-gid vec (intern suffix))) - (unknown-id - (if (string-equal suffix "string") - tramp-unknown-id-string tramp-unknown-id-integer))) - (and - file-attr - (or - ;; Not a symlink. - (eq t (file-attribute-type file-attr)) - (null (file-attribute-type file-attr))) - (or - ;; World accessible. - (eq access (aref (file-attribute-modes file-attr) (+ offset 6))) - ;; User accessible and owned by user. - (and - (eq access (aref (file-attribute-modes file-attr) offset)) - (or (equal remote-uid unknown-id) - (equal remote-uid (file-attribute-user-id file-attr)) - (equal unknown-id (file-attribute-user-id file-attr)))) - ;; Group accessible and owned by user's principal group. - (and - (eq access - (aref (file-attribute-modes file-attr) (+ offset 3))) - (or (equal remote-gid unknown-id) - (equal remote-gid (file-attribute-group-id file-attr)) - (equal unknown-id (file-attribute-group-id file-attr)))))))))))) + (when-let ((offset (cond + ((eq ?r access) 1) + ((eq ?w access) 2) + ((eq ?x access) 3) + ((eq ?s access) 3))) + (file-attr (file-attributes (tramp-make-tramp-file-name vec))) + (remote-uid (tramp-get-remote-uid vec 'integer)) + (remote-gid (tramp-get-remote-gid vec 'integer))) + (or + ;; Not a symlink. + (eq t (file-attribute-type file-attr)) + (null (file-attribute-type file-attr))) + (or + ;; World accessible. + (eq access (aref (file-attribute-modes file-attr) (+ offset 6))) + ;; User accessible and owned by user. + (and + (eq access (aref (file-attribute-modes file-attr) offset)) + (or (equal remote-uid tramp-unknown-id-integer) + (equal remote-uid (file-attribute-user-id file-attr)) + (equal tramp-unknown-id-integer (file-attribute-user-id file-attr)))) + ;; Group accessible and owned by user's principal group. + (and + (eq access + (aref (file-attribute-modes file-attr) (+ offset 3))) + (or (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))))))) + +(defmacro tramp-convert-file-attributes (vec localname id-format attr) + "Convert `file-attributes' ATTR generated Tramp backend functions. +Convert file mode bits to string and set virtual device number. +Set file uid and gid according to ID-FORMAT. LOCALNAME is used +to cache the result. Return the modified ATTR." + (declare (indent 3) (debug t)) + `(with-tramp-file-property + ,vec ,localname (format "file-attributes-%s" (or ,id-format 'integer)) + (when-let + ((result + (with-tramp-file-property ,vec ,localname "file-attributes" + (when-let ((attr ,attr)) + (save-match-data + ;; Remove color escape sequences from symlink. + (when (stringp (car attr)) + (while (string-match + tramp-display-escape-sequence-regexp (car attr)) + (setcar attr (replace-match "" nil nil (car attr))))) + ;; Convert uid and gid. Use `tramp-unknown-id-integer' + ;; as indication of unusable value. + (when (consp (nth 2 attr)) + (when (and (numberp (cdr (nth 2 attr))) + (< (cdr (nth 2 attr)) 0)) + (setcdr (car (nthcdr 2 attr)) tramp-unknown-id-integer)) + (when (and (floatp (cdr (nth 2 attr))) + (<= (cdr (nth 2 attr)) most-positive-fixnum)) + (setcdr (car (nthcdr 2 attr)) (round (cdr (nth 2 attr)))))) + (when (consp (nth 3 attr)) + (when (and (numberp (cdr (nth 3 attr))) + (< (cdr (nth 3 attr)) 0)) + (setcdr (car (nthcdr 3 attr)) tramp-unknown-id-integer)) + (when (and (floatp (cdr (nth 3 attr))) + (<= (cdr (nth 3 attr)) most-positive-fixnum)) + (setcdr (car (nthcdr 3 attr)) (round (cdr (nth 3 attr)))))) + ;; Convert last access time. + (unless (listp (nth 4 attr)) + (setcar (nthcdr 4 attr) (seconds-to-time (nth 4 attr)))) + ;; Convert last modification time. + (unless (listp (nth 5 attr)) + (setcar (nthcdr 5 attr) (seconds-to-time (nth 5 attr)))) + ;; Convert last status change time. + (unless (listp (nth 6 attr)) + (setcar (nthcdr 6 attr) (seconds-to-time (nth 6 attr)))) + ;; Convert file size. + (when (< (nth 7 attr) 0) + (setcar (nthcdr 7 attr) -1)) + (when (and (floatp (nth 7 attr)) + (<= (nth 7 attr) most-positive-fixnum)) + (setcar (nthcdr 7 attr) (round (nth 7 attr)))) + ;; Convert file mode bits to string. + (unless (stringp (nth 8 attr)) + (setcar (nthcdr 8 attr) + (tramp-file-mode-from-int (nth 8 attr))) + (when (stringp (car attr)) + (aset (nth 8 attr) 0 ?l))) + ;; Convert directory indication bit. + (when (string-prefix-p "d" (nth 8 attr)) + (setcar attr t)) + ;; Convert symlink from `tramp-do-file-attributes-with-stat'. + ;; Decode also multibyte string. + (when (consp (car attr)) + (setcar attr + (and (stringp (caar attr)) + (string-match ".+ -> .\\(.+\\)." (caar attr)) + (decode-coding-string + (match-string 1 (caar attr)) 'utf-8)))) + ;; Set file's gid change bit. + (setcar + (nthcdr 9 attr) + (not (= (cdr (nth 3 attr)) + (or (tramp-get-remote-gid ,vec 'integer) + tramp-unknown-id-integer)))) + ;; Convert inode. + (when (floatp (nth 10 attr)) + (setcar (nthcdr 10 attr) + (condition-case nil + (let ((high (nth 10 attr)) + middle low) + (if (<= high most-positive-fixnum) + (floor high) + ;; The low 16 bits. + (setq low (mod high #x10000) + high (/ high #x10000)) + (if (<= high most-positive-fixnum) + (cons (floor high) (floor low)) + ;; The middle 24 bits. + (setq middle (mod high #x1000000) + high (/ high #x1000000)) + (cons (floor high) + (cons (floor middle) (floor low)))))) + ;; Inodes can be incredible huge. We + ;; must hide this. + (error (tramp-get-inode ,vec))))) + ;; Set virtual device number. + (setcar (nthcdr 11 attr) + (tramp-get-device ,vec)) + attr))))) + + ;; Return normalized result. + (append (tramp-compat-take 2 result) + (if (eq ,id-format 'string) + (list (car (nth 2 result)) (car (nth 3 result))) + (list (cdr (nth 2 result)) (cdr (nth 3 result)))) + (nthcdr 4 result))))) (defun tramp-get-home-directory (vec &optional user) "The remote home directory for connection VEC as local file name. @@ -5828,21 +6031,15 @@ This handles also chrooted environments, which are not regarded as local." (defun tramp-make-tramp-temp-file (vec) "Create a temporary file on the remote host identified by VEC. Return the local name of the temporary file." - (let (result) - (while (not result) - ;; `make-temp-file' would be the natural choice for - ;; implementation. But it calls `write-region' internally, - ;; which also needs a temporary file - we would end in an - ;; infinite loop. - (setq result (tramp-make-tramp-temp-name vec)) - (if (file-exists-p result) - (setq result nil) - ;; This creates the file by side effect. - (set-file-times result) - (set-file-modes result #o0700))) - - ;; Return the local part. - (tramp-file-local-name result))) + (let (create-lockfiles) + (cl-letf (((symbol-function 'tramp-remote-acl-p) #'ignore) + ((symbol-function 'tramp-remote-selinux-p) #'ignore) + ((symbol-function 'tramp-sudoedit-remote-acl-p) #'ignore) + ((symbol-function 'tramp-sudoedit-remote-selinux-p) #'ignore)) + (tramp-file-local-name + (make-temp-file + (expand-file-name + tramp-temp-name-prefix (tramp-get-remote-tmpdir vec))))))) (defun tramp-delete-temp-file-function () "Remove temporary files related to current buffer." diff --git a/lisp/obsolete/fast-lock.el b/lisp/obsolete/fast-lock.el deleted file mode 100644 index 1614935f03a..00000000000 --- a/lisp/obsolete/fast-lock.el +++ /dev/null @@ -1,730 +0,0 @@ -;;; fast-lock.el --- automagic text properties caching for fast Font Lock mode -*- lexical-binding: t; -*- - -;; Copyright (C) 1994-1998, 2001-2022 Free Software Foundation, Inc. - -;; Author: Simon Marshall <simon@gnu.org> -;; Maintainer: emacs-devel@gnu.org -;; Keywords: faces files -;; Version: 3.14 -;; Obsolete-since: 22.1 - -;; 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: - -;; Fast Lock mode is a Font Lock support mode. -;; It makes visiting a file in Font Lock mode faster by restoring its face text -;; properties from automatically saved associated Font Lock cache files. -;; -;; See caveats and feedback below. -;; See also the lazy-lock package. (But don't use the two at the same time!) - -;; Installation: -;; -;; Put in your ~/.emacs: -;; -;; (setq font-lock-support-mode 'fast-lock-mode) -;; -;; Start up a new Emacs and use font-lock as usual (except that you can use the -;; so-called "gaudier" fontification regexps on big files without frustration). -;; -;; When you visit a file (which has `font-lock-mode' enabled) that has a -;; corresponding Font Lock cache file associated with it, the Font Lock cache -;; will be loaded from that file instead of being generated by Font Lock code. - -;; Caveats: -;; -;; A cache will be saved when visiting a compressed file using crypt++, but not -;; be read. This is a "feature"/"consequence"/"bug" of crypt++. -;; -;; Version control packages are likely to stamp all over file modification -;; times. Therefore the act of checking out may invalidate a cache. - -;; History: -;; -;; 0.02--1.00: -;; - Changed name from turbo-prop to fast-lock. Automagic for font-lock only -;; - Made `fast-lock-mode' a minor mode, like G. Dinesh Dutt's fss-mode -;; 1.00--1.01: -;; - Turn on `fast-lock-mode' only if `buffer-file-name' or `interactive-p' -;; - Made `fast-lock-file-name' use `buffer-name' if `buffer-file-name' is nil -;; - Moved save-all conditions to `fast-lock-save-cache' -;; - Added `fast-lock-save-text-properties' to `kill-buffer-hook' -;; 1.01--2.00: complete rewrite---not worth the space to document -;; - Changed structure of text properties cache and threw out file mod checks -;; 2.00--2.01: -;; - Made `condition-case' forms understand `quit'. -;; - Made `fast-lock' require `font-lock' -;; - Made `fast-lock-cache-name' chase links (from Ben Liblit) -;; 2.01--3.00: -;; - Changed structure of cache to include `font-lock-keywords' (from rms) -;; - Changed `fast-lock-cache-mechanisms' to `fast-lock-cache-directories' -;; - Removed `fast-lock-read-others' -;; - Made `fast-lock-read-cache' ignore cache owner -;; - Made `fast-lock-save-cache-external' create cache directory -;; - Made `fast-lock-save-cache-external' save `font-lock-keywords' -;; - Made `fast-lock-cache-data' check `font-lock-keywords' -;; 3.00--3.01: incorporated port of 2.00 to Lucid, made by Barry Warsaw -;; - Package now provides itself -;; - Lucid: Use `font-lock-any-extents-p' for `font-lock-any-properties-p' -;; - Lucid: Use `list-faces' for `face-list' -;; - Lucid: Added `set-text-properties' -;; - Lucid: Made `turn-on-fast-lock' pass 1 not t to `fast-lock-mode' -;; - Removed test for `fast-lock-mode' from `fast-lock-read-cache' -;; - Lucid: Added Lucid-specific `fast-lock-get-face-properties' -;; 3.01--3.02: now works with Lucid Emacs, thanks to Barry Warsaw -;; - Made `fast-lock-cache-name' map ":" to ";" for OS/2 (from Serganova Vera) -;; - Made `fast-lock-cache-name' use abbreviated file name (from Barry Warsaw) -;; - Lucid: Separated handlers for `error' and `quit' for `condition-case' -;; 3.02--3.03: -;; - Changed `fast-lock-save-cache-external' to `fast-lock-save-cache-data' -;; - Lucid: Added Lucid-specific `fast-lock-set-face-properties' -;; 3.03--3.04: -;; - Corrected `subrp' test of Lucid code -;; - Replaced `font-lock-any-properties-p' with `text-property-not-all' -;; - Lucid: Made `fast-lock-set-face-properties' put `text-prop' on extents -;; - Made `fast-lock-cache-directories' a regexp alist (from Colin Rafferty) -;; - Made `fast-lock-cache-directory' to return a usable cache file directory -;; 3.04--3.05: -;; - Lucid: Fix for XEmacs 19.11 `text-property-not-all' -;; - Replaced `subrp' test of Lucid code with `emacs-version' `string-match' -;; - Made `byte-compile-warnings' omit `unresolved' on compilation -;; - Made `fast-lock-save-cache-data' use a buffer (from Rick Sladkey) -;; - Reverted to old `fast-lock-get-face-properties' (from Rick Sladkey) -;; 3.05--3.06: incorporated hack of 3.03, made by Jonathan Stigelman (Stig) -;; - Reverted to 3.04 version of `fast-lock-get-face-properties' -;; - XEmacs: Removed `list-faces' `defalias' -;; - Made `fast-lock-mode' and `turn-on-fast-lock' succeed `autoload' cookies -;; - Added `fast-lock-submit-bug-report' -;; - Renamed `fast-lock-save-size' to `fast-lock-minimum-size' -;; - Made `fast-lock-save-cache' output a message if no save ever attempted -;; - Made `fast-lock-save-cache-data' output a message if save attempted -;; - Made `fast-lock-cache-data' output a message if load attempted -;; - Made `fast-lock-save-cache-data' do `condition-case' not `unwind-protect' -;; - Made `fast-lock-save-cache' and `fast-lock-read-cache' return nothing -;; - Made `fast-lock-save-cache' check `buffer-modified-p' (Stig) -;; - Added `fast-lock-save-events' -;; - Added `fast-lock-after-save-hook' to `after-save-hook' (Stig) -;; - Added `fast-lock-kill-buffer-hook' to `kill-buffer-hook' -;; - Changed `fast-lock-save-caches' to `fast-lock-kill-emacs-hook' -;; - Added `fast-lock-kill-emacs-hook' to `kill-emacs-hook' -;; - Made `fast-lock-save-cache' check `verify-visited-file-modtime' (Stig) -;; - Made `visited-file-modtime' be the basis of the timestamp (Stig) -;; - Made `fast-lock-save-cache-1' and `fast-lock-cache-data' use/reformat it -;; - Added `fast-lock-cache-filename' to keep track of the cache file name -;; - Added `fast-lock-after-fontify-buffer' -;; - Added `fast-lock-save-faces' list of faces to save (idea from Stig/Tibor) -;; - Made `fast-lock-get-face-properties' functions use it -;; - XEmacs: Made `fast-lock-set-face-properties' do extents the Font Lock way -;; - XEmacs: Removed fix for `text-property-not-all' (19.11 support dropped) -;; - Made `fast-lock-mode' ensure `font-lock-mode' is on -;; - Made `fast-lock-save-cache' do `cdr-safe' not `cdr' (from Dave Foster) -;; - Made `fast-lock-save-cache' do `set-buffer' first (from Dave Foster) -;; - Made `fast-lock-save-cache' loop until saved or quit (from Georg Nikodym) -;; - Made `fast-lock-cache-data' check `buffer-modified-p' -;; - Made `fast-lock-cache-data' do `font-lock-compile-keywords' if necessary -;; - XEmacs: Made `font-lock-compile-keywords' `defalias' -;; 3.06--3.07: -;; - XEmacs: Add `fast-lock-after-fontify-buffer' to the Font Lock hook -;; - Made `fast-lock-cache-name' explain the use of `directory-abbrev-alist' -;; - Made `fast-lock-mode' use `buffer-file-truename' not `buffer-file-name' -;; 3.07--3.08: -;; - Made `fast-lock-read-cache' set `fast-lock-cache-filename' -;; 3.08--3.09: -;; - Made `fast-lock-save-cache' cope if `fast-lock-minimum-size' is a list -;; - Made `fast-lock-mode' respect the value of `font-lock-inhibit-thing-lock' -;; - Added `fast-lock-after-unfontify-buffer' -;; 3.09--3.10: -;; - Rewrite for Common Lisp macros -;; - Made fast-lock.el barf on a crap 8+3 pseudo-OS (Eli Zaretskii help) -;; - XEmacs: Made `add-minor-mode' succeed `autoload' cookie -;; - XEmacs: Made `fast-lock-save-faces' default to `font-lock-face-list' -;; - Made `fast-lock-save-cache' use `font-lock-value-in-major-mode' -;; - Wrap with `save-buffer-state' (Ray Van Tassle report) -;; - Made `fast-lock-mode' wrap `font-lock-support-mode' -;; 3.10--3.11: -;; - Made `fast-lock-get-face-properties' cope with face lists -;; - Added `fast-lock-verbose' -;; - XEmacs: Add `font-lock-value-in-major-mode' if necessary -;; - Removed `fast-lock-submit-bug-report' and bade farewell -;; 3.11--3.12: -;; - Added Custom support (Hrvoje Nikšić help) -;; - Made `save-buffer-state' wrap `inhibit-point-motion-hooks' -;; - Made `fast-lock-cache-data' simplify calls of `font-lock-compile-keywords' -;; 3.12--3.13: -;; - Removed `byte-*' variables from `eval-when-compile' (Erik Naggum hint) -;; - Changed structure of cache to include `font-lock-syntactic-keywords' -;; - Made `fast-lock-save-cache-1' save syntactic fontification data -;; - Made `fast-lock-cache-data' take syntactic fontification data -;; - Added `fast-lock-get-syntactic-properties' -;; - Renamed `fast-lock-set-face-properties' to `fast-lock-add-properties' -;; - Made `fast-lock-add-properties' add syntactic and face fontification data -;; 3.13--3.14: -;; - Made `fast-lock-cache-name' cope with `windowsnt' (Geoff Voelker fix) -;; - Made `fast-lock-verbose' use `other' widget (Andreas Schwab fix) -;; - Used `with-temp-message' where possible to make messages temporary. - -;;; Code: - -(require 'font-lock) - -(declare-function msdos-long-file-names "msdos.c") - -;; Make sure fast-lock.el is supported. -(if (and (eq system-type 'ms-dos) (not (msdos-long-file-names))) - (error "`fast-lock' was written for long file name systems")) - -(defvar font-lock-face-list) - -(eval-when-compile - ;; - ;; We use this to verify that a face should be saved. - (defmacro fast-lock-save-facep (face) - "Return non-nil if FACE is one of `fast-lock-save-faces'." - `(or (null fast-lock-save-faces) - (if (symbolp ,face) - (memq ,face fast-lock-save-faces) - (let ((faces ,face)) - (while (unless (memq (car faces) fast-lock-save-faces) - (setq faces (cdr faces)))) - faces))))) - -(defgroup fast-lock nil - "Font Lock support mode to cache fontification." - :load 'fast-lock - :group 'font-lock) - -(defvar fast-lock-mode nil) ; Whether we are turned on. -(defvar fast-lock-cache-timestamp nil) ; For saving/reading. -(defvar fast-lock-cache-filename nil) ; For deleting. - -;; User Variables: - -(defcustom fast-lock-minimum-size 25600 - "Minimum size of a buffer for cached fontification. -Only buffers more than this can have associated Font Lock cache files saved. -If nil, means cache files are never created. -If a list, each element should be a cons pair of the form (MAJOR-MODE . SIZE), -where MAJOR-MODE is a symbol or t (meaning the default). For example: - ((c-mode . 25600) (c++-mode . 25600) (rmail-mode . 1048576)) -means that the minimum size is 25K for buffers in C or C++ modes, one megabyte -for buffers in Rmail mode, and size is irrelevant otherwise." - :type '(choice (const :tag "none" nil) - (integer :tag "size") - (repeat :menu-tag "mode specific" :tag "mode specific" - :value ((t . nil)) - (cons :tag "Instance" - (radio :tag "Mode" - (const :tag "all" t) - (symbol :tag "name")) - (radio :tag "Size" - (const :tag "none" nil) - (integer :tag "size")))))) - -(defcustom fast-lock-cache-directories '("~/.emacs-flc") -; - `internal', keep each file's Font Lock cache file in the same file. -; - `external', keep each file's Font Lock cache file in the same directory. - "Directories in which Font Lock cache files are saved and read. -Each item should be either DIR or a cons pair of the form (REGEXP . DIR) where -DIR is a directory name (relative or absolute) and REGEXP is a regexp. - -An attempt will be made to save or read Font Lock cache files using these items -until one succeeds (i.e., until a readable or writable one is found). If an -item contains REGEXP, DIR is used only if the buffer file name matches REGEXP. -For example: - - (let ((home (expand-file-name (abbreviate-file-name (file-truename \"~/\"))))) - (list (cons (concat \"^\" (regexp-quote home)) \".\") \"~/.emacs-flc\")) - => - ((\"^/your/true/home/directory/\" . \".\") \"~/.emacs-flc\") - -would cause a file's current directory to be used if the file is under your -home directory hierarchy, or otherwise the absolute directory `~/.emacs-flc'. -For security reasons, it is not advisable to use the file's current directory -to avoid the possibility of using the cache of another user." - :type '(repeat (radio (directory :tag "directory") - (cons :tag "Matching" - (regexp :tag "regexp") - (directory :tag "directory"))))) -(put 'fast-lock-cache-directories 'risky-local-variable t) - -(defcustom fast-lock-save-events '(kill-buffer kill-emacs) - "Events under which caches will be saved. -Valid events are `save-buffer', `kill-buffer' and `kill-emacs'. -If concurrent editing sessions use the same associated cache file for a file's -buffer, then you should add `save-buffer' to this list." - :type '(set (const :tag "buffer saving" save-buffer) - (const :tag "buffer killing" kill-buffer) - (const :tag "emacs killing" kill-emacs))) - -(defcustom fast-lock-save-others t - "If non-nil, save Font Lock cache files irrespective of file owner. -If nil, means only buffer files known to be owned by you can have associated -Font Lock cache files saved. Ownership may be unknown for networked files." - :type 'boolean) - -(defcustom fast-lock-verbose font-lock-verbose - "If non-nil, means show status messages for cache processing. -If a number, only buffers greater than this size have processing messages." - :type '(choice (const :tag "never" nil) - (other :tag "always" t) - (integer :tag "size"))) - -(defvar fast-lock-save-faces nil - "Faces that will be saved in a Font Lock cache file. -If nil, means information for all faces will be saved.") - -;; User Functions: - -;;;###autoload -(defun fast-lock-mode (&optional arg) - "Toggle Fast Lock mode. -With arg, turn Fast Lock mode on if and only if arg is positive and the buffer -is associated with a file. Enable it automatically in your `~/.emacs' by: - - (setq font-lock-support-mode \\='fast-lock-mode) - -If Fast Lock mode is enabled, and the current buffer does not contain any text -properties, any associated Font Lock cache is used if its timestamp matches the -buffer's file, and its `font-lock-keywords' match those that you are using. - -Font Lock caches may be saved: -- When you save the file's buffer. -- When you kill an unmodified file's buffer. -- When you exit Emacs, for all unmodified or saved buffers. -Depending on the value of `fast-lock-save-events'. -See also the commands `fast-lock-read-cache' and `fast-lock-save-cache'. - -Use \\[font-lock-fontify-buffer] to fontify the buffer if the cache is bad. - -Various methods of control are provided for the Font Lock cache. In general, -see variable `fast-lock-cache-directories' and function `fast-lock-cache-name'. -For saving, see variables `fast-lock-minimum-size', `fast-lock-save-events', -`fast-lock-save-others' and `fast-lock-save-faces'." - (interactive "P") - ;; Only turn on if we are visiting a file. We could use `buffer-file-name', - ;; but many packages temporarily wrap that to nil when doing their own thing. - (set (make-local-variable 'fast-lock-mode) - (and buffer-file-truename - (not (memq 'fast-lock-mode font-lock-inhibit-thing-lock)) - (if arg (> (prefix-numeric-value arg) 0) (not fast-lock-mode)))) - (if (and fast-lock-mode (not font-lock-mode)) - ;; Turned on `fast-lock-mode' rather than `font-lock-mode'. - (progn - (message "Use font-lock-support-mode rather than calling fast-lock-mode") - (sit-for 2)) - ;; Let's get down to business. - (set (make-local-variable 'fast-lock-cache-timestamp) nil) - (set (make-local-variable 'fast-lock-cache-filename) nil) - (when (and fast-lock-mode (not font-lock-fontified)) - (fast-lock-read-cache)))) - -(defun fast-lock-read-cache () - "Read the Font Lock cache for the current buffer. - -The following criteria must be met for a Font Lock cache file to be read: -- Fast Lock mode must be turned on in the buffer. -- The buffer must not be modified. -- The buffer's `font-lock-keywords' must match the cache's. -- The buffer file's timestamp must match the cache's. -- Criteria imposed by `fast-lock-cache-directories'. - -See `fast-lock-mode'." - (interactive) - (let ((directories fast-lock-cache-directories) - (modified (buffer-modified-p)) (inhibit-read-only t) - (fontified font-lock-fontified)) - (set (make-local-variable 'font-lock-fontified) nil) - ;; Keep trying directories until fontification is turned off. - (while (and directories (not font-lock-fontified)) - (let ((directory (fast-lock-cache-directory (car directories) nil))) - (condition-case nil - (when directory - (setq fast-lock-cache-filename (fast-lock-cache-name directory)) - (when (file-readable-p fast-lock-cache-filename) - (load fast-lock-cache-filename t t t))) - (error nil) (quit nil)) - (setq directories (cdr directories)))) - ;; Unset `fast-lock-cache-filename', and restore `font-lock-fontified', if - ;; we don't use a cache. (Note that `fast-lock-cache-data' sets the value - ;; of `fast-lock-cache-timestamp'.) - (set-buffer-modified-p modified) - (unless font-lock-fontified - (setq fast-lock-cache-filename nil font-lock-fontified fontified)))) - -(defun fast-lock-save-cache (&optional buffer) - "Save the Font Lock cache of BUFFER or the current buffer. - -The following criteria must be met for a Font Lock cache file to be saved: -- Fast Lock mode must be turned on in the buffer. -- The event must be one of `fast-lock-save-events'. -- The buffer must be at least `fast-lock-minimum-size' bytes long. -- The buffer file must be owned by you, or `fast-lock-save-others' must be t. -- The buffer must contain at least one `face' text property. -- The buffer must not be modified. -- The buffer file's timestamp must be the same as the file's on disk. -- The on disk file's timestamp must be different than the buffer's cache. -- Criteria imposed by `fast-lock-cache-directories'. - -See `fast-lock-mode'." - (interactive) - (save-excursion - (when buffer - (set-buffer buffer)) - (let ((min-size (font-lock-value-in-major-mode fast-lock-minimum-size)) - (file-timestamp (visited-file-modtime)) (saved nil)) - (when (and fast-lock-mode - ;; - ;; "Only save if the buffer matches the file, the file has - ;; changed, and it was changed by the current emacs session." - ;; - ;; Only save if the buffer is not modified, - ;; (i.e., so we don't save for something not on disk) - (not (buffer-modified-p)) - ;; and the file's timestamp is the same as the buffer's, - ;; (i.e., someone else hasn't written the file in the meantime) - (verify-visited-file-modtime (current-buffer)) - ;; and the file's timestamp is different from the cache's. - ;; (i.e., a save has occurred since the cache was read) - (not (equal fast-lock-cache-timestamp file-timestamp)) - ;; - ;; Only save if user's restrictions are satisfied. - (and min-size (>= (buffer-size) min-size)) - (or fast-lock-save-others - (eq (user-uid) (file-attribute-user-id - (file-attributes buffer-file-name)))) - ;; - ;; Only save if there are `face' properties to save. - (text-property-not-all (point-min) (point-max) 'face nil)) - ;; - ;; Try each directory until we manage to save or the user quits. - (let ((directories fast-lock-cache-directories)) - (while (and directories (memq saved '(nil error))) - (let* ((dir (fast-lock-cache-directory (car directories) t)) - (file (and dir (fast-lock-cache-name dir)))) - (when (and file (file-writable-p file)) - (setq saved (fast-lock-save-cache-1 file file-timestamp))) - (setq directories (cdr directories))))))))) - -;;;###autoload -(defun turn-on-fast-lock () - "Unconditionally turn on Fast Lock mode." - (fast-lock-mode t)) - -;;; API Functions: - -(defun fast-lock-after-fontify-buffer () - ;; Delete the Font Lock cache file used to restore fontification, if any. - (when fast-lock-cache-filename - (if (file-writable-p fast-lock-cache-filename) - (delete-file fast-lock-cache-filename) - (message "File %s font lock cache cannot be deleted" (buffer-name)))) - ;; Flag so that a cache will be saved later even if the file is never saved. - (setq fast-lock-cache-timestamp nil)) - -(defalias 'fast-lock-after-unfontify-buffer #'ignore) - -;; Miscellaneous Functions: - -(defun fast-lock-save-cache-after-save-file () - ;; Do `fast-lock-save-cache' if `save-buffer' is on `fast-lock-save-events'. - (when (memq 'save-buffer fast-lock-save-events) - (fast-lock-save-cache))) - -(defun fast-lock-save-cache-before-kill-buffer () - ;; Do `fast-lock-save-cache' if `kill-buffer' is on `fast-lock-save-events'. - (when (memq 'kill-buffer fast-lock-save-events) - (fast-lock-save-cache))) - -(defun fast-lock-save-caches-before-kill-emacs () - ;; Do `fast-lock-save-cache's if `kill-emacs' is on `fast-lock-save-events'. - (when (memq 'kill-emacs fast-lock-save-events) - (mapcar #'fast-lock-save-cache (buffer-list)))) - -(defun fast-lock-cache-directory (directory create) - "Return usable directory based on DIRECTORY. -Returns nil if the directory does not exist, or, if CREATE non-nil, cannot be -created. DIRECTORY may be a string or a cons pair of the form (REGEXP . DIR). -See `fast-lock-cache-directories'." - (let ((dir - (cond ((not buffer-file-name) - ;; Should never be nil, but `crypt++' screws it up. - nil) - ((stringp directory) - ;; Just a directory. - directory) - (t - ;; A directory if the file name matches the regexp. - (let ((bufile (expand-file-name buffer-file-truename)) - (case-fold-search nil)) - (when (save-match-data (string-match (car directory) bufile)) - (cdr directory))))))) - (cond ((not dir) - nil) - ((file-accessible-directory-p dir) - dir) - (create - (condition-case nil - (progn (make-directory dir t) dir) - (error nil)))))) - -;; If you are wondering why we only hash if the directory is not ".", rather -;; than if `file-name-absolute-p', it is because if we just appended ".flc" for -;; relative cache directories (that are not ".") then it is possible that more -;; than one file would have the same cache name in that directory, if the luser -;; made a link from one relative cache directory to another. (Phew!) -(defun fast-lock-cache-name (directory) - "Return full cache file name using caching DIRECTORY. -If DIRECTORY is `.', the file name is the buffer file name appended with `.flc'. -Otherwise, the file name is constructed from DIRECTORY and the buffer's true -abbreviated file name, with all `/' characters in the name replaced with `#' -characters, and appended with `.flc'. - -If the same file has different cache file names when edited on different -machines, e.g., on one machine the cache file name has the prefix `#home', -perhaps due to automount, try putting in your `~/.emacs' something like: - - (setq directory-abbrev-alist (cons \\='(\"^/home/\" . \"/\") directory-abbrev-alist)) - -Emacs automagically removes the common `/tmp_mnt' automount prefix by default. - -See `fast-lock-cache-directory'." - (if (string-equal directory ".") - (concat buffer-file-name ".flc") - (let* ((bufile (expand-file-name buffer-file-truename)) - (chars-alist - (if (memq system-type '(windows-nt cygwin)) - '((?/ . (?#)) (?# . (?# ?#)) (?: . (?\;)) (?\; . (?\; ?\;))) - '((?/ . (?#)) (?# . (?# ?#))))) - (mapchars - (function (lambda (c) (or (cdr (assq c chars-alist)) (list c)))))) - (concat - (file-name-as-directory (expand-file-name directory)) - (mapconcat #'char-to-string (apply #'append (mapcar mapchars bufile)) "") - ".flc")))) - -;; Font Lock Cache Processing Functions: - -;; The version 3 format of the cache is: -;; -;; (fast-lock-cache-data VERSION TIMESTAMP -;; font-lock-syntactic-keywords SYNTACTIC-PROPERTIES -;; font-lock-keywords FACE-PROPERTIES) - -(defun fast-lock-save-cache-1 (file timestamp) - ;; Save the FILE with the TIMESTAMP plus fontification data. - ;; Returns non-nil if a save was attempted to a writable cache file. - (let ((tpbuf (generate-new-buffer " *fast-lock*")) - (verbose (if (numberp fast-lock-verbose) - (> (buffer-size) fast-lock-verbose) - fast-lock-verbose)) - (saved t)) - (with-temp-message - (when verbose - (format "Saving %s font lock cache..." (buffer-name))) - (condition-case nil - (save-excursion - (print (list 'fast-lock-cache-data 3 - (list 'quote timestamp) - (list 'quote font-lock-syntactic-keywords) - (list 'quote (fast-lock-get-syntactic-properties)) - (list 'quote font-lock-keywords) - (list 'quote (fast-lock-get-face-properties))) - tpbuf) - (set-buffer tpbuf) - (write-region (point-min) (point-max) file nil 'quietly) - (setq fast-lock-cache-timestamp timestamp - fast-lock-cache-filename file)) - (error (setq saved 'error)) (quit (setq saved 'quit))) - (kill-buffer tpbuf)) - (cond ((eq saved 'quit) - (message "Saving %s font lock cache...quit" (buffer-name))) - ((eq saved 'error) - (message "Saving %s font lock cache...failed" (buffer-name)))) - ;; We return non-nil regardless of whether a failure occurred. - saved)) - -(defun fast-lock-cache-data (version timestamp - syntactic-keywords syntactic-properties - keywords face-properties - &rest _ignored) - ;; Find value of syntactic keywords in case it is a symbol. - (setq font-lock-syntactic-keywords (font-lock-eval-keywords - font-lock-syntactic-keywords)) - ;; Compile all keywords in case some are and some aren't. - (when font-lock-syntactic-keywords - (setq font-lock-syntactic-keywords (font-lock-compile-keywords - font-lock-syntactic-keywords t))) - (when syntactic-keywords - (setq syntactic-keywords (font-lock-compile-keywords syntactic-keywords t))) - (setq font-lock-keywords (font-lock-compile-keywords font-lock-keywords) - keywords (font-lock-compile-keywords keywords)) - ;; Use the Font Lock cache SYNTACTIC-PROPERTIES and FACE-PROPERTIES if we're - ;; using cache VERSION format 3, the current buffer's file timestamp matches - ;; the TIMESTAMP, the current buffer's `font-lock-syntactic-keywords' are the - ;; same as SYNTACTIC-KEYWORDS, and the current buffer's `font-lock-keywords' - ;; are the same as KEYWORDS. - (let ((buf-timestamp (visited-file-modtime)) - (verbose (if (numberp fast-lock-verbose) - (> (buffer-size) fast-lock-verbose) - fast-lock-verbose)) - (loaded t)) - (if (or (/= version 3) - (buffer-modified-p) - (not (equal timestamp buf-timestamp)) - (not (equal syntactic-keywords font-lock-syntactic-keywords)) - (not (equal keywords font-lock-keywords))) - (setq loaded nil) - (with-temp-message - (when verbose - (format "Loading %s font lock cache..." (buffer-name))) - (condition-case nil - (fast-lock-add-properties syntactic-properties face-properties) - (error (setq loaded 'error)) (quit (setq loaded 'quit)))) - (cond ((eq loaded 'quit) - (message "Loading %s font lock cache...quit" (buffer-name))) - ((eq loaded 'error) - (message "Loading %s font lock cache...failed" (buffer-name))))) - (setq font-lock-fontified (eq loaded t) - fast-lock-cache-timestamp (and (eq loaded t) timestamp)))) - -;; Text Properties Processing Functions: - -;; This is fast, but fails if adjacent characters have different `face' text -;; properties. Maybe that's why I dropped it in the first place? -;(defun fast-lock-get-face-properties () -; "Return a list of `face' text properties in the current buffer. -;Each element of the list is of the form (VALUE START1 END1 START2 END2 ...) -;where VALUE is a `face' property value and STARTx and ENDx are positions." -; (save-restriction -; (widen) -; (let ((start (text-property-not-all (point-min) (point-max) 'face nil)) -; (limit (point-max)) end properties value cell) -; (while start -; (setq end (next-single-property-change start 'face nil limit) -; value (get-text-property start 'face)) -; ;; Make, or add to existing, list of regions with same `face'. -; (if (setq cell (assq value properties)) -; (setcdr cell (cons start (cons end (cdr cell)))) -; (setq properties (cons (list value start end) properties))) -; (setq start (next-single-property-change end 'face))) -; properties))) - -;; This is slow, but copes if adjacent characters have different `face' text -;; properties, but fails if they are lists. -;(defun fast-lock-get-face-properties () -; "Return a list of `face' text properties in the current buffer. -;Each element of the list is of the form (VALUE START1 END1 START2 END2 ...) -;where VALUE is a `face' property value and STARTx and ENDx are positions. -;Only those `face' VALUEs in `fast-lock-save-faces' are returned." -; (save-restriction -; (widen) -; (let ((faces (or fast-lock-save-faces (face-list))) (limit (point-max)) -; properties regions face start end) -; (while faces -; (setq face (car faces) faces (cdr faces) regions () end (point-min)) -; ;; Make a list of start/end regions with `face' property face. -; (while (setq start (text-property-any end limit 'face face)) -; (setq end (or (text-property-not-all start limit 'face face) limit) -; regions (cons start (cons end regions)))) -; ;; Add `face' face's regions, if any, to properties. -; (when regions -; (push (cons face regions) properties))) -; properties))) - -(defun fast-lock-get-face-properties () - "Return a list of `face' text properties in the current buffer. -Each element of the list is of the form (VALUE START1 END1 START2 END2 ...) -where VALUE is a `face' property value and STARTx and ENDx are positions." - (save-restriction - (widen) - (let ((start (text-property-not-all (point-min) (point-max) 'face nil)) - end properties value cell) - (while start - (setq end (next-single-property-change start 'face nil (point-max)) - value (get-text-property start 'face)) - ;; Make, or add to existing, list of regions with same `face'. - (cond ((setq cell (assoc value properties)) - (setcdr cell (cons start (cons end (cdr cell))))) - ((fast-lock-save-facep value) - (push (list value start end) properties))) - (setq start (text-property-not-all end (point-max) 'face nil))) - properties))) - -(defun fast-lock-get-syntactic-properties () - "Return a list of `syntax-table' text properties in the current buffer. -See `fast-lock-get-face-properties'." - (save-restriction - (widen) - (let ((start (text-property-not-all (point-min) (point-max) 'syntax-table - nil)) - end properties value cell) - (while start - (setq end (next-single-property-change start 'syntax-table nil - (point-max)) - value (get-text-property start 'syntax-table)) - ;; Make, or add to existing, list of regions with same `syntax-table'. - (if (setq cell (assoc value properties)) - (setcdr cell (cons start (cons end (cdr cell)))) - (push (list value start end) properties)) - (setq start (text-property-not-all end (point-max) 'syntax-table nil))) - properties))) - -(defun fast-lock-add-properties (syntactic-properties face-properties) - "Add `syntax-table' and `face' text properties to the current buffer. -Any existing `syntax-table' and `face' text properties are removed first. -See `fast-lock-get-face-properties'." - (with-silent-modifications - (let ((inhibit-point-motion-hooks t)) - (save-restriction - (widen) - (font-lock-unfontify-region (point-min) (point-max)) - ;; - ;; Set the `syntax-table' property for each start/end region. - (pcase-dolist (`(,plist . ,regions) syntactic-properties) - (while regions - (add-text-properties (nth 0 regions) (nth 1 regions) plist) - (setq regions (nthcdr 2 regions)))) - ;; - ;; Set the `face' property for each start/end region. - (pcase-dolist (`(,plist . ,regions) face-properties) - (while regions - (add-text-properties (nth 0 regions) (nth 1 regions) plist) - (setq regions (nthcdr 2 regions)))))))) - - -;; Install ourselves: - -(add-hook 'after-save-hook #'fast-lock-save-cache-after-save-file) -(add-hook 'kill-buffer-hook #'fast-lock-save-cache-before-kill-buffer) -(unless noninteractive - (add-hook 'kill-emacs-hook #'fast-lock-save-caches-before-kill-emacs)) - -;;;###autoload -(when (fboundp 'add-minor-mode) - (defvar fast-lock-mode nil) - (add-minor-mode 'fast-lock-mode nil)) -;;;###dont-autoload -(unless (assq 'fast-lock-mode minor-mode-alist) - (setq minor-mode-alist (append minor-mode-alist '((fast-lock-mode nil))))) - -(provide 'fast-lock) - -;;; fast-lock.el ends here - -;; Local Variables: -;; byte-compile-warnings: (not obsolete) -;; End: diff --git a/lisp/obsolete/lazy-lock.el b/lisp/obsolete/lazy-lock.el deleted file mode 100644 index 5c35cb32124..00000000000 --- a/lisp/obsolete/lazy-lock.el +++ /dev/null @@ -1,1025 +0,0 @@ -;;; lazy-lock.el --- lazy demand-driven fontification for fast Font Lock mode -*- lexical-binding: t; -*- - -;; Copyright (C) 1994-1998, 2001-2022 Free Software Foundation, Inc. - -;; Author: Simon Marshall <simon@gnu.org> -;; Maintainer: emacs-devel@gnu.org -;; Keywords: faces files -;; Version: 2.11 -;; Obsolete-since: 22.1 - -;; 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: - -;; Purpose: -;; -;; Lazy Lock mode is a Font Lock support mode. -;; It makes visiting buffers in Font Lock mode faster by making fontification -;; be demand-driven, deferred and stealthy, so that fontification only occurs -;; when, and where, necessary. -;; -;; See caveats and feedback below. -;; See also the fast-lock package. (But don't use them at the same time!) - -;; Installation: -;; -;; Put in your ~/.emacs: -;; -;; (setq font-lock-support-mode 'lazy-lock-mode) -;; -;; Start up a new Emacs and use font-lock as usual (except that you can use the -;; so-called "gaudier" fontification regexps on big files without frustration). -;; -;; In a buffer (which has `font-lock-mode' enabled) which is at least -;; `lazy-lock-minimum-size' characters long, buffer fontification will not -;; occur and only the visible portion of the buffer will be fontified. Motion -;; around the buffer will fontify those visible portions not previously -;; fontified. If stealth fontification is enabled, buffer fontification will -;; occur in invisible parts of the buffer after `lazy-lock-stealth-time' -;; seconds of idle time. If on-the-fly fontification is deferred, on-the-fly -;; fontification will occur after `lazy-lock-defer-time' seconds of idle time. - -;; User-visible differences with version 1: -;; -;; - Version 2 can defer on-the-fly fontification. Therefore you need not, and -;; should not, use defer-lock.el with this version of lazy-lock.el. -;; -;; A number of variables have changed meaning: -;; -;; - A value of nil for the variable `lazy-lock-minimum-size' means never turn -;; on demand-driven fontification. In version 1 this meant always turn on -;; demand-driven fontification. If you really want demand-driven fontification -;; regardless of buffer size, set this variable to 0. -;; -;; - The variable `lazy-lock-stealth-lines' cannot have a nil value. In -;; version 1 this meant use `window-height' as the maximum number of lines to -;; fontify as a stealth chunk. This makes no sense; stealth fontification is -;; of a buffer, not a window. - -;; Implementation differences with version 1: -;; -;; - Version 1 of lazy-lock.el is a bit of a hack. Version 1 demand-driven -;; fontification, the core feature of lazy-lock.el, is implemented by placing a -;; function on `post-command-hook'. This function fontifies where necessary, -;; i.e., where a window scroll has occurred. However, there are a number of -;; problems with using `post-command-hook': -;; -;; (a) As the name suggests, `post-command-hook' is run after every command, -;; i.e., frequently and regardless of whether scrolling has occurred. -;; (b) Scrolling can occur during a command, when `post-command-hook' is not -;; run, i.e., it is not necessarily run after scrolling has occurred. -;; (c) When `post-command-hook' is run, there is nothing to suggest where -;; scrolling might have occurred, i.e., which windows have scrolled. -;; -;; Thus lazy-lock.el's function is called almost as often as possible, usually -;; when it need not be called, yet it is not always called when it is needed. -;; Also, lazy-lock.el's function must check each window to see if a scroll has -;; occurred there. Worse still, lazy-lock.el's function must fontify a region -;; twice as large as necessary to make sure the window is completely fontified. -;; Basically, `post-command-hook' is completely inappropriate for lazy-lock.el. -;; -;; Ideally, we want to attach lazy-lock.el's function to a hook that is run -;; only when scrolling occurs, e.g., `window-start' has changed, and tells us -;; as much information as we need, i.e., the window and its new buffer region. -;; Richard Stallman implemented a `window-scroll-functions' for Emacs 19.30. -;; Functions on it are run when `window-start' has changed, and are supplied -;; with the window and the window's new `window-start' position. (It would be -;; better if it also supplied the window's new `window-end' position, but that -;; is calculated as part of the redisplay process, and the functions on -;; `window-scroll-functions' are run before redisplay has finished.) Thus, the -;; hook deals with the above problems (a), (b) and (c). -;; -;; If only life was that easy. Version 2 demand-driven fontification is mostly -;; implemented by placing a function on `window-scroll-functions'. However, -;; not all scrolling occurs when `window-start' has changed. A change in -;; window size, e.g., via C-x 1, or a significant deletion, e.g., of a number -;; of lines, causes text previously invisible (i.e., after `window-end') to -;; become visible without changing `window-start'. Arguably, these events are -;; not scrolling events, but fontification must occur for lazy-lock.el to work. -;; Hooks `window-size-change-functions' and `redisplay-end-trigger-functions' -;; were added for these circumstances. -;; -;; (Ben Wing thinks these hooks are "horribly horribly kludgy", and implemented -;; a `pre-idle-hook', a `mother-of-all-post-command-hooks', for XEmacs 19.14. -;; He then hacked up a version 1 lazy-lock.el to use `pre-idle-hook' rather -;; than `post-command-hook'. Whereas functions on `post-command-hook' are -;; called almost as often as possible, functions on `pre-idle-hook' really are -;; called as often as possible, even when the mouse moves and, on some systems, -;; while XEmacs is idle. Thus, the hook deals with the above problem (b), but -;; unfortunately it makes (a) worse and does not address (c) at all. -;; -;; I freely admit that `redisplay-end-trigger-functions' and, to a much lesser -;; extent, `window-size-change-functions' are not pretty. However, I feel that -;; a `window-scroll-functions' feature is cleaner than a `pre-idle-hook', and -;; the result is faster and smaller, less intrusive and more targeted, code. -;; Since `pre-idle-hook' is pretty much like `post-command-hook', there is no -;; point in making this version of lazy-lock.el work with it. Anyway, that's -;; Lit 30 of my humble opinion. -;; -;; - Version 1 stealth fontification is also implemented by placing a function -;; on `post-command-hook'. This function waits for a given amount of time, -;; and, if Emacs remains idle, fontifies where necessary. Again, there are a -;; number of problems with using `post-command-hook': -;; -;; (a) Functions on `post-command-hook' are run sequentially, so this function -;; can interfere with other functions on the hook, and vice versa. -;; (b) This function waits for a given amount of time, so it can interfere with -;; various features that are dealt with by Emacs after a command, e.g., -;; region highlighting, asynchronous updating and keystroke echoing. -;; (c) Fontification may be required during a command, when `post-command-hook' -;; is not run. (Version 2 deferred fontification only.) -;; -;; Again, `post-command-hook' is completely inappropriate for lazy-lock.el. -;; Richard Stallman and Morten Welinder implemented internal Timers and Idle -;; Timers for Emacs 19.31. Functions can be run independently at given times -;; or after given amounts of idle time. Thus, the feature deals with the above -;; problems (a), (b) and (c). Version 2 deferral and stealth are implemented -;; by functions on Idle Timers. (A function on XEmacs' `pre-idle-hook' is -;; similar to an Emacs Idle Timer function with a fixed zero second timeout.) - -;; - Version 1 has the following problems (relative to version 2): -;; -;; (a) It is slow when it does its job. -;; (b) It does not always do its job when it should. -;; (c) It slows all interaction (when it doesn't need to do its job). -;; (d) It interferes with other package functions on `post-command-hook'. -;; (e) It interferes with Emacs things within the read-eval loop. -;; -;; Ben's hacked-up lazy-lock.el 1.14 almost solved (b) but made (c) worse. -;; -;; - Version 2 has the following additional features (relative to version 1): -;; -;; (a) It can defer fontification (both on-the-fly and on-scrolling). -;; (b) It can fontify contextually (syntactically true on-the-fly). - -;; Caveats: -;; -;; Lazy Lock mode does not work efficiently with Outline mode. -;; This is because when in Outline mode, although text may be not visible to -;; you in the window, the text is visible to Emacs Lisp code (not surprisingly) -;; and Lazy Lock fontifies it mercilessly. Maybe it will be fixed one day. -;; -;; Because buffer text is not necessarily fontified, other packages that expect -;; buffer text to be fontified in Font Lock mode either might not work as -;; expected, or might not display buffer text as expected. An example of the -;; latter is `occur', which copies lines of buffer text into another buffer. -;; -;; In Emacs 19.30, Lazy Lock mode does not ensure that an existing buffer is -;; fontified if it is made visible via a minibuffer-less command that replaces -;; an existing window's buffer (e.g., via the Buffers menu). Upgrade! -;; -;; In Emacs 19.30, Lazy Lock mode does not work well with Transient Mark mode -;; or modes based on Comint mode (e.g., Shell mode), and also interferes with -;; the echoing of keystrokes in the minibuffer. This is because of the way -;; deferral and stealth have to be implemented for Emacs 19.30. Upgrade! -;; -;; Currently XEmacs does not have the features to support this version of -;; lazy-lock.el. Maybe it will one day. - -;; History: -;; -;; 1.15--2.00: -;; - Rewrite for Emacs 19.30 and the features rms added to support lazy-lock.el -;; so that it could work correctly and efficiently. -;; - Many thanks to those who reported bugs, fixed bugs, made suggestions or -;; otherwise contributed in the version 1 cycle; Jari Aalto, Kevin Broadey, -;; Ulrik Dickow, Bill Dubuque, Bob Glickstein, Boris Goldowsky, -;; Jonas Jarnestrom, David Karr, Michael Kifer, Erik Naggum, Rick Sladkey, -;; Jim Thompson, Ben Wing, Ilya Zakharevich, and Richard Stallman. -;; 2.00--2.01: -;; - Made `lazy-lock-fontify-after-command' always `sit-for' and so redisplay -;; - Use `buffer-name' not `buffer-live-p' (Bill Dubuque hint) -;; - Made `lazy-lock-install' do `add-to-list' not `setq' of `current-buffer' -;; - Made `lazy-lock-fontify-after-install' loop over buffer list -;; - Made `lazy-lock-arrange-before-change' to arrange `window-end' triggering -;; - Made `lazy-lock-let-buffer-state' wrap both `befter-change-functions' -;; - Made `lazy-lock-fontify-region' do `condition-case' (Hyman Rosen report) -;; 2.01--2.02: -;; - Use `buffer-live-p' as `buffer-name' can barf (Richard Stanton report) -;; - Made `lazy-lock-install' set `font-lock-fontified' (Kevin Davidson report) -;; - Made `lazy-lock-install' add hooks only if needed -;; - Made `lazy-lock-unstall' add `font-lock-after-change-function' if needed -;; 2.02--2.03: -;; - Made `lazy-lock-fontify-region' do `condition-case' for `quit' too -;; - Made `lazy-lock-mode' respect the value of `font-lock-inhibit-thing-lock' -;; - Added `lazy-lock-after-unfontify-buffer' -;; - Removed `lazy-lock-fontify-after-install' hack -;; - Made `lazy-lock-fontify-after-scroll' not `set-buffer' to `window-buffer' -;; - Made `lazy-lock-fontify-after-trigger' not `set-buffer' to `window-buffer' -;; - Made `lazy-lock-fontify-after-idle' be interruptible (Scott Burson hint) -;; 2.03--2.04: -;; - Rewrite for Emacs 19.31 idle timers -;; - Renamed `buffer-windows' to `get-buffer-window-list' -;; - Removed `buffer-live-p' -;; - Made `lazy-lock-defer-after-change' always save `current-buffer' -;; - Made `lazy-lock-fontify-after-defer' just process buffers -;; - Made `lazy-lock-install-hooks' add hooks correctly (Kevin Broadey report) -;; - Made `lazy-lock-install' cope if `lazy-lock-defer-time' is a list -;; 2.04--2.05: -;; - Rewrite for Common Lisp macros -;; - Added `do-while' macro -;; - Renamed `lazy-lock-let-buffer-state' macro to `save-buffer-state' -;; - Returned `lazy-lock-fontify-after-install' hack (Darren Hall hint) -;; - Added `lazy-lock-defer-on-scrolling' functionality (Scott Byer hint) -;; - Made `lazy-lock-mode' wrap `font-lock-support-mode' -;; 2.05--2.06: -;; - Made `lazy-lock-fontify-after-defer' swap correctly (Scott Byer report) -;; 2.06--2.07: -;; - Added `lazy-lock-stealth-load' functionality (Rob Hooft hint) -;; - Made `lazy-lock-unstall' call `lazy-lock-fontify-region' if needed -;; - Made `lazy-lock-mode' call `lazy-lock-unstall' only if needed -;; - Made `lazy-lock-defer-after-scroll' do `set-window-redisplay-end-trigger' -;; - Added `lazy-lock-defer-contextually' functionality -;; - Added `lazy-lock-defer-on-the-fly' from `lazy-lock-defer-time' -;; - Renamed `lazy-lock-defer-driven' to `lazy-lock-defer-on-scrolling' -;; - Removed `lazy-lock-submit-bug-report' and bade farewell -;; 2.07--2.08: -;; - Made `lazy-lock-fontify-conservatively' fontify around `window-point' -;; - Made `save-buffer-state' wrap `inhibit-point-motion-hooks' -;; - Added Custom support -;; 2.08--2.09: -;; - Removed `byte-*' variables from `eval-when-compile' (Erik Naggum hint) -;; - Made various wrapping `inhibit-point-motion-hooks' (Vinicius Latorre hint) -;; - Made `lazy-lock-fontify-after-idle' wrap `minibuffer-auto-raise' -;; - Made `lazy-lock-fontify-after-defer' paranoid about deferred buffers -;; 2.09--2.10: -;; - Use `window-end' UPDATE arg for Emacs 20.4 and later. -;; - Made deferral `widen' before unfontifying (Dan Nicolaescu report) -;; - Use `lazy-lock-fontify-after-visage' for hideshow.el (Dan Nicolaescu hint) -;; - Use `other' widget where possible (Andreas Schwab fix) -;; 2.10--2.11: -;; - Used `with-temp-message' where possible to make messages temporary. - -;;; Code: - -(require 'font-lock) -(eval-when-compile (require 'cl-lib)) - -(eval-when-compile - ;; - ;; We use this for clarity and speed. Naughty but nice. - (defmacro do-while (test &rest body) - "(do-while TEST BODY...): eval BODY... and repeat if TEST yields non-nil. -The order of execution is thus BODY, TEST, BODY, TEST and so on -until TEST returns nil." - (declare (indent 1) (debug t)) - `(while (progn ,@body ,test)))) - -(defgroup lazy-lock nil - "Font Lock support mode to fontify lazily." - :group 'font-lock) - -(defvar lazy-lock-mode nil) ; Whether we are turned on. -(defvar lazy-lock-buffers nil) ; For deferral. -(defvar lazy-lock-timers (cons nil nil)) ; For deferral and stealth. - -;; User Variables: - -(defcustom lazy-lock-minimum-size 25600 - "Minimum size of a buffer for demand-driven fontification. -On-demand fontification occurs if the buffer size is greater than this value. -If nil, means demand-driven fontification is never performed. -If a list, each element should be a cons pair of the form (MAJOR-MODE . SIZE), -where MAJOR-MODE is a symbol or t (meaning the default). For example: - ((c-mode . 25600) (c++-mode . 25600) (rmail-mode . 1048576)) -means that the minimum size is 25K for buffers in C or C++ modes, one megabyte -for buffers in Rmail mode, and size is irrelevant otherwise. - -The value of this variable is used when Lazy Lock mode is turned on." - :type '(choice (const :tag "none" nil) - (integer :tag "size") - (repeat :menu-tag "mode specific" :tag "mode specific" - :value ((t . nil)) - (cons :tag "Instance" - (radio :tag "Mode" - (const :tag "all" t) - (symbol :tag "name")) - (radio :tag "Size" - (const :tag "none" nil) - (integer :tag "size")))))) - -(defcustom lazy-lock-defer-on-the-fly t - "If non-nil, means fontification after a change should be deferred. -If nil, means on-the-fly fontification is performed. This means when changes -occur in the buffer, those areas are immediately fontified. -If a list, it should be a list of `major-mode' symbol names for which deferred -fontification should occur. The sense of the list is negated if it begins with -`not'. For example: - (c-mode c++-mode) -means that on-the-fly fontification is deferred for buffers in C and C++ modes -only, and deferral does not occur otherwise. - -The value of this variable is used when Lazy Lock mode is turned on." - :type '(choice (const :tag "never" nil) - (const :tag "always" t) - (set :menu-tag "mode specific" :tag "modes" - :value (not) - (const :tag "Except" not) - (repeat :inline t (symbol :tag "mode"))))) - -(defcustom lazy-lock-defer-on-scrolling nil - "If non-nil, means fontification after a scroll should be deferred. -If nil, means demand-driven fontification is performed. This means when -scrolling into unfontified areas of the buffer, those areas are immediately -fontified. Thus scrolling never presents unfontified areas. However, since -fontification occurs during scrolling, scrolling may be slow. -If t, means defer-driven fontification is performed. This means fontification -of those areas is deferred. Thus scrolling may present momentarily unfontified -areas. However, since fontification does not occur during scrolling, scrolling -will be faster than demand-driven fontification. -If any other value, e.g., `eventually', means demand-driven fontification is -performed until the buffer is fontified, then buffer fontification becomes -defer-driven. Thus scrolling never presents unfontified areas until the buffer -is first fontified, after which subsequent scrolling may present future buffer -insertions momentarily unfontified. However, since fontification does not -occur during scrolling after the buffer is first fontified, scrolling will -become faster. (But, since contextual changes continually occur, such a value -makes little sense if `lazy-lock-defer-contextually' is non-nil.) - -The value of this variable is used when Lazy Lock mode is turned on." - :type '(choice (const :tag "never" nil) - (const :tag "always" t) - (other :tag "eventually" eventually))) - -(defcustom lazy-lock-defer-contextually 'syntax-driven - "If non-nil, means deferred fontification should be syntactically true. -If nil, means deferred fontification occurs only on those lines modified. This -means where modification on a line causes syntactic change on subsequent lines, -those subsequent lines are not refontified to reflect their new context. -If t, means deferred fontification occurs on those lines modified and all -subsequent lines. This means those subsequent lines are refontified to reflect -their new syntactic context, either immediately or when scrolling into them. -If any other value, e.g., `syntax-driven', means deferred syntactically true -fontification occurs only if syntactic fontification is performed using the -buffer mode's syntax table, i.e., only if `font-lock-keywords-only' is nil. - -The value of this variable is used when Lazy Lock mode is turned on." - :type '(choice (const :tag "never" nil) - (const :tag "always" t) - (other :tag "syntax-driven" syntax-driven))) - -(defcustom lazy-lock-defer-time 0.25 - "Time in seconds to delay before beginning deferred fontification. -Deferred fontification occurs if there is no input within this time. -If nil, means fontification is never deferred, regardless of the values of the -variables `lazy-lock-defer-on-the-fly', `lazy-lock-defer-on-scrolling' and -`lazy-lock-defer-contextually'. - -The value of this variable is used when Lazy Lock mode is turned on." - :type '(choice (const :tag "never" nil) - (number :tag "seconds"))) - -(defcustom lazy-lock-stealth-time 30 - "Time in seconds to delay before beginning stealth fontification. -Stealth fontification occurs if there is no input within this time. -If nil, means stealth fontification is never performed. - -The value of this variable is used when Lazy Lock mode is turned on." - :type '(choice (const :tag "never" nil) - (number :tag "seconds"))) - -(defcustom lazy-lock-stealth-lines (if font-lock-maximum-decoration 100 250) - "Maximum size of a chunk of stealth fontification. -Each iteration of stealth fontification can fontify this number of lines. -To speed up input response during stealth fontification, at the cost of stealth -taking longer to fontify, you could reduce the value of this variable." - :type '(integer :tag "lines")) - -(defcustom lazy-lock-stealth-load - (if (condition-case nil (load-average) (error)) 200) - "Load in percentage above which stealth fontification is suspended. -Stealth fontification pauses when the system short-term load average (as -returned by the function `load-average' if supported) goes above this level, -thus reducing the demand that stealth fontification makes on the system. -If nil, means stealth fontification is never suspended. -To reduce machine load during stealth fontification, at the cost of stealth -taking longer to fontify, you could reduce the value of this variable. -See also `lazy-lock-stealth-nice'." - :type (if (condition-case nil (load-average) (error)) - '(choice (const :tag "never" nil) - (integer :tag "load")) - '(const :format "%t: unsupported\n" nil))) - -(defcustom lazy-lock-stealth-nice 0.125 - "Time in seconds to pause between chunks of stealth fontification. -Each iteration of stealth fontification is separated by this amount of time, -thus reducing the demand that stealth fontification makes on the system. -If nil, means stealth fontification is never paused. -To reduce machine load during stealth fontification, at the cost of stealth -taking longer to fontify, you could increase the value of this variable. -See also `lazy-lock-stealth-load'." - :type '(choice (const :tag "never" nil) - (number :tag "seconds"))) - -(defcustom lazy-lock-stealth-verbose - (and (not lazy-lock-defer-contextually) (not (null font-lock-verbose))) - "If non-nil, means stealth fontification should show status messages." - :type 'boolean) - -;; User Functions: - -;;;###autoload -(defun lazy-lock-mode (&optional arg) - "Toggle Lazy Lock mode. -With arg, turn Lazy Lock mode on if and only if arg is positive. Enable it -automatically in your `~/.emacs' by: - - (setq font-lock-support-mode \\='lazy-lock-mode) - -For a newer font-lock support mode with similar functionality, see -`jit-lock-mode'. Eventually, Lazy Lock mode will be deprecated in -JIT Lock's favor. - -When Lazy Lock mode is enabled, fontification can be lazy in a number of ways: - -- Demand-driven buffer fontification if `lazy-lock-minimum-size' is non-nil. - This means initial fontification does not occur if the buffer is greater than - `lazy-lock-minimum-size' characters in length. Instead, fontification occurs - when necessary, such as when scrolling through the buffer would otherwise - reveal unfontified areas. This is useful if buffer fontification is too slow - for large buffers. - -- Deferred scroll fontification if `lazy-lock-defer-on-scrolling' is non-nil. - This means demand-driven fontification does not occur as you scroll. - Instead, fontification is deferred until after `lazy-lock-defer-time' seconds - of Emacs idle time, while Emacs remains idle. This is useful if - fontification is too slow to keep up with scrolling. - -- Deferred on-the-fly fontification if `lazy-lock-defer-on-the-fly' is non-nil. - This means on-the-fly fontification does not occur as you type. Instead, - fontification is deferred until after `lazy-lock-defer-time' seconds of Emacs - idle time, while Emacs remains idle. This is useful if fontification is too - slow to keep up with your typing. - -- Deferred context fontification if `lazy-lock-defer-contextually' is non-nil. - This means fontification updates the buffer corresponding to true syntactic - context, after `lazy-lock-defer-time' seconds of Emacs idle time, while Emacs - remains idle. Otherwise, fontification occurs on modified lines only, and - subsequent lines can remain fontified corresponding to previous syntactic - contexts. This is useful where strings or comments span lines. - -- Stealthy buffer fontification if `lazy-lock-stealth-time' is non-nil. - This means remaining unfontified areas of buffers are fontified if Emacs has - been idle for `lazy-lock-stealth-time' seconds, while Emacs remains idle. - This is useful if any buffer has any deferred fontification. - -Basic Font Lock mode on-the-fly fontification behavior fontifies modified -lines only. Thus, if `lazy-lock-defer-contextually' is non-nil, Lazy Lock mode -on-the-fly fontification may fontify differently, albeit correctly. In any -event, to refontify some lines you can use \\[font-lock-fontify-block]. - -Stealth fontification only occurs while the system remains unloaded. -If the system load rises above `lazy-lock-stealth-load' percent, stealth -fontification is suspended. Stealth fontification intensity is controlled via -the variable `lazy-lock-stealth-nice' and `lazy-lock-stealth-lines', and -verbosity is controlled via the variable `lazy-lock-stealth-verbose'." - (interactive "P") - (let* ((was-on lazy-lock-mode) - (now-on (unless (memq 'lazy-lock-mode font-lock-inhibit-thing-lock) - (if arg (> (prefix-numeric-value arg) 0) (not was-on))))) - (cond ((and now-on (not font-lock-mode)) - ;; Turned on `lazy-lock-mode' rather than `font-lock-mode'. - (message "Use font-lock-support-mode rather than calling lazy-lock-mode") - (sit-for 2)) - (now-on - ;; Turn ourselves on. - (set (make-local-variable 'lazy-lock-mode) t) - (lazy-lock-install)) - (was-on - ;; Turn ourselves off. - (set (make-local-variable 'lazy-lock-mode) nil) - (lazy-lock-unstall))))) - -;;;###autoload -(defun turn-on-lazy-lock () - "Unconditionally turn on Lazy Lock mode." - (lazy-lock-mode t)) - -(defun lazy-lock-install () - (let ((min-size (font-lock-value-in-major-mode lazy-lock-minimum-size)) - (defer-change (and lazy-lock-defer-time lazy-lock-defer-on-the-fly)) - (defer-scroll (and lazy-lock-defer-time lazy-lock-defer-on-scrolling)) - (defer-context (and lazy-lock-defer-time lazy-lock-defer-contextually - (or (eq lazy-lock-defer-contextually t) - (null font-lock-keywords-only))))) - ;; - ;; Tell Font Lock whether Lazy Lock will do fontification. - (make-local-variable 'font-lock-fontified) - (setq font-lock-fontified (and min-size (>= (buffer-size) min-size))) - ;; - ;; Add the text properties and fontify. - (if (not font-lock-fontified) - (lazy-lock-after-fontify-buffer) - ;; Make sure we fontify in any existing windows showing the buffer. - (let ((windows (get-buffer-window-list (current-buffer) 'nomini t))) - (lazy-lock-after-unfontify-buffer) - (while windows - (lazy-lock-fontify-conservatively (car windows)) - (setq windows (cdr windows))))) - ;; - ;; Add the fontification hooks. - (lazy-lock-install-hooks - font-lock-fontified - (cond ((eq (car-safe defer-change) 'not) - (not (memq major-mode (cdr defer-change)))) - ((listp defer-change) - (memq major-mode defer-change)) - (t - defer-change)) - (eq defer-scroll t) - defer-context) - ;; - ;; Add the fontification timers. - (lazy-lock-install-timers - (if (or defer-change defer-scroll defer-context) lazy-lock-defer-time) - lazy-lock-stealth-time))) - -(defun lazy-lock-install-hooks (fontifying - defer-change defer-scroll defer-context) - ;; - ;; Add hook if lazy-lock.el is fontifying on scrolling or is deferring. - (when (or fontifying defer-change defer-scroll defer-context) - (add-hook 'window-scroll-functions (if defer-scroll - #'lazy-lock-defer-after-scroll - #'lazy-lock-fontify-after-scroll) - nil t)) - ;; - ;; Add hook if lazy-lock.el is fontifying and is not deferring changes. - (when (and fontifying (not defer-change) (not defer-context)) - (add-hook 'before-change-functions #'lazy-lock-arrange-before-change nil t)) - ;; - ;; Replace Font Lock mode hook. - (remove-hook 'after-change-functions #'font-lock-after-change-function t) - (add-hook 'after-change-functions - (cond ((and defer-change defer-context) - #'lazy-lock-defer-rest-after-change) - (defer-change - #'lazy-lock-defer-line-after-change) - (defer-context - #'lazy-lock-fontify-rest-after-change) - (t - #'lazy-lock-fontify-line-after-change)) - nil t) - ;; - ;; Add package-specific hook. - (add-hook 'outline-view-change-hook #'lazy-lock-fontify-after-visage nil t) - (add-hook 'hs-hide-hook #'lazy-lock-fontify-after-visage nil t)) - -(defun lazy-lock-install-timers (dtime stime) - ;; Schedule or re-schedule the deferral and stealth timers. - ;; The layout of `lazy-lock-timers' is: - ;; ((DEFER-TIME . DEFER-TIMER) (STEALTH-TIME . STEALTH-TIMER) - ;; If an idle timeout has changed, cancel the existing idle timer (if there - ;; is one) and schedule a new one (if the new idle timeout is non-nil). - (unless (eq dtime (car (car lazy-lock-timers))) - (let ((defer (car lazy-lock-timers))) - (when (cdr defer) - (cancel-timer (cdr defer))) - (setcar lazy-lock-timers (cons dtime (and dtime - (run-with-idle-timer dtime t #'lazy-lock-fontify-after-defer)))))) - (unless (eq stime (car (cdr lazy-lock-timers))) - (let ((stealth (cdr lazy-lock-timers))) - (when (cdr stealth) - (cancel-timer (cdr stealth))) - (setcdr lazy-lock-timers (cons stime (and stime - (run-with-idle-timer stime t #'lazy-lock-fontify-after-idle))))))) - -(defun lazy-lock-unstall () - ;; - ;; If Font Lock mode is still enabled, make sure that the buffer is - ;; fontified, and reinstall its hook. We must do this first. - (when font-lock-mode - (when (lazy-lock-unfontified-p) - (let ((verbose (if (numberp font-lock-verbose) - (> (buffer-size) font-lock-verbose) - font-lock-verbose))) - (with-temp-message - (when verbose - (format "Fontifying %s..." (buffer-name))) - ;; Make sure we fontify etc. in the whole buffer. - (save-restriction - (widen) - (lazy-lock-fontify-region (point-min) (point-max)))))) - (add-hook 'after-change-functions #'font-lock-after-change-function nil t)) - ;; - ;; Remove the text properties. - (lazy-lock-after-unfontify-buffer) - ;; - ;; Remove the fontification hooks. - (remove-hook 'window-scroll-functions #'lazy-lock-fontify-after-scroll t) - (remove-hook 'window-scroll-functions #'lazy-lock-defer-after-scroll t) - (remove-hook 'before-change-functions #'lazy-lock-arrange-before-change t) - (remove-hook 'after-change-functions #'lazy-lock-fontify-line-after-change t) - (remove-hook 'after-change-functions #'lazy-lock-fontify-rest-after-change t) - (remove-hook 'after-change-functions #'lazy-lock-defer-line-after-change t) - (remove-hook 'after-change-functions #'lazy-lock-defer-rest-after-change t) - (remove-hook 'outline-view-change-hook #'lazy-lock-fontify-after-visage t) - (remove-hook 'hs-hide-hook #'lazy-lock-fontify-after-visage t)) - -;; Hook functions. - -;; Lazy Lock mode intervenes when (1) a previously invisible buffer region -;; becomes visible, i.e., for demand- or defer-driven on-the-scroll -;; fontification, (2) a buffer modification occurs, i.e., for defer-driven -;; on-the-fly fontification, (3) Emacs becomes idle, i.e., for fontification of -;; deferred fontification and stealth fontification, and (4) other special -;; occasions. - -;; 1. There are three ways whereby this can happen. -;; -;; (a) Scrolling the window, either explicitly (e.g., `scroll-up') or -;; implicitly (e.g., `search-forward'). Here, `window-start' changes. -;; Fontification occurs by adding `lazy-lock-fontify-after-scroll' (for -;; demand-driven fontification) or `lazy-lock-defer-after-scroll' (for -;; defer-driven fontification) to the hook `window-scroll-functions'. - -(defun lazy-lock-fontify-after-scroll (window window-start) - ;; Called from `window-scroll-functions'. - ;; Fontify WINDOW from WINDOW-START following the scroll. - (let ((inhibit-point-motion-hooks t)) - (lazy-lock-fontify-region window-start (window-end window t))) - ;; A prior deletion that did not cause scrolling, followed by a scroll, would - ;; result in an unnecessary trigger after this if we did not cancel it now. - (set-window-redisplay-end-trigger window nil)) - -(defun lazy-lock-defer-after-scroll (window _window-start) - ;; Called from `window-scroll-functions'. - ;; Defer fontification following the scroll. Save the current buffer so that - ;; we subsequently fontify in all windows showing the buffer. - (unless (memq (current-buffer) lazy-lock-buffers) - (push (current-buffer) lazy-lock-buffers)) - ;; A prior deletion that did not cause scrolling, followed by a scroll, would - ;; result in an unnecessary trigger after this if we did not cancel it now. - (set-window-redisplay-end-trigger window nil)) - -;; (b) Resizing the window, either explicitly (e.g., `enlarge-window') or -;; implicitly (e.g., `delete-other-windows'). Here, `window-end' changes. -;; Fontification occurs by adding `lazy-lock-fontify-after-resize' to the -;; hook `window-size-change-functions'. - -(defun lazy-lock-fontify-after-resize (frame) - ;; Called from `window-size-change-functions'. - ;; Fontify windows in FRAME following the resize. We cannot use - ;; `window-start' or `window-end' so we fontify conservatively. - (save-excursion - (save-selected-window - (select-frame frame) - (walk-windows (function (lambda (window) - (set-buffer (window-buffer window)) - (when lazy-lock-mode - (lazy-lock-fontify-conservatively window)) - (set-window-redisplay-end-trigger window nil))) - 'nomini frame)))) - -;; (c) Deletion in the buffer. Here, a `window-end' marker can become visible. -;; Fontification occurs by adding `lazy-lock-arrange-before-change' to -;; `before-change-functions' and `lazy-lock-fontify-after-trigger' to the -;; hook `redisplay-end-trigger-functions'. Before every deletion, the -;; marker `window-redisplay-end-trigger' position is set to the soon-to-be -;; changed `window-end' position. If the marker becomes visible, -;; `lazy-lock-fontify-after-trigger' gets called. Ouch. Note that we only -;; have to deal with this eventuality if there is no on-the-fly deferral. - -(defun lazy-lock-arrange-before-change (beg end) - ;; Called from `before-change-functions'. - ;; Arrange that if text becomes visible it will be fontified (if a deletion - ;; is pending, text might become visible at the bottom). - (unless (eq beg end) - (let ((windows (get-buffer-window-list (current-buffer) 'nomini t)) window) - (while windows - (setq window (car windows)) - (unless (markerp (window-redisplay-end-trigger window)) - (set-window-redisplay-end-trigger window (make-marker))) - (set-marker (window-redisplay-end-trigger window) (window-end window)) - (setq windows (cdr windows)))))) - -(defun lazy-lock-fontify-after-trigger (window trigger-point) - ;; Called from `redisplay-end-trigger-functions'. - ;; Fontify WINDOW from TRIGGER-POINT following the redisplay. - ;; We could probably just use `lazy-lock-fontify-after-scroll' without loss: - ;; (inline (lazy-lock-fontify-after-scroll window (window-start window))) - (let ((inhibit-point-motion-hooks t)) - (lazy-lock-fontify-region trigger-point (window-end window t)))) - -;; 2. Modified text must be marked as unfontified so it can be identified and -;; fontified later when Emacs is idle. Deferral occurs by adding one of -;; `lazy-lock-fontify-*-after-change' (for on-the-fly fontification) or -;; `lazy-lock-defer-*-after-change' (for deferred fontification) to the -;; hook `after-change-functions'. - -(defalias 'lazy-lock-fontify-line-after-change - ;; Called from `after-change-functions'. - ;; Fontify the current change. - #'font-lock-after-change-function) - -(defun lazy-lock-fontify-rest-after-change (beg end old-len) - ;; Called from `after-change-functions'. - ;; Fontify the current change and defer fontification of the rest of the - ;; buffer. Save the current buffer so that we subsequently fontify in all - ;; windows showing the buffer. - (lazy-lock-fontify-line-after-change beg end old-len) - (with-silent-modifications - (unless (memq (current-buffer) lazy-lock-buffers) - (push (current-buffer) lazy-lock-buffers)) - (save-restriction - (widen) - (remove-text-properties end (point-max) '(lazy-lock nil))))) - -(defun lazy-lock-defer-line-after-change (beg end _old-len) - ;; Called from `after-change-functions'. - ;; Defer fontification of the current change. Save the current buffer so - ;; that we subsequently fontify in all windows showing the buffer. - (with-silent-modifications - (unless (memq (current-buffer) lazy-lock-buffers) - (push (current-buffer) lazy-lock-buffers)) - (remove-text-properties (max (1- beg) (point-min)) - (min (1+ end) (point-max)) - '(lazy-lock nil)))) - -(defun lazy-lock-defer-rest-after-change (beg _end _old-len) - ;; Called from `after-change-functions'. - ;; Defer fontification of the rest of the buffer. Save the current buffer so - ;; that we subsequently fontify in all windows showing the buffer. - (with-silent-modifications - (unless (memq (current-buffer) lazy-lock-buffers) - (push (current-buffer) lazy-lock-buffers)) - (save-restriction - (widen) - (remove-text-properties (max (1- beg) (point-min)) - (point-max) - '(lazy-lock nil))))) - -;; 3. Deferred fontification and stealth fontification are done from these two -;; functions. They are set up as Idle Timers. - -(defun lazy-lock-fontify-after-defer () - ;; Called from `timer-idle-list'. - ;; Fontify all windows where deferral has occurred for its buffer. - (save-excursion - (while (and lazy-lock-buffers (not (input-pending-p))) - (let ((buffer (car lazy-lock-buffers)) windows) - ;; Paranoia: check that the buffer is still live and Lazy Lock mode on. - (when (buffer-live-p buffer) - (set-buffer buffer) - (when lazy-lock-mode - (setq windows (get-buffer-window-list buffer 'nomini t)) - (while windows - (lazy-lock-fontify-window (car windows)) - (setq windows (cdr windows))))) - (setq lazy-lock-buffers (cdr lazy-lock-buffers))))) - ;; Add hook if fontification should now be defer-driven in this buffer. - (when (and lazy-lock-mode lazy-lock-defer-on-scrolling - (memq #'lazy-lock-fontify-after-scroll window-scroll-functions) - (not (or (input-pending-p) (lazy-lock-unfontified-p)))) - (remove-hook 'window-scroll-functions #'lazy-lock-fontify-after-scroll t) - (add-hook 'window-scroll-functions #'lazy-lock-defer-after-scroll nil t))) - -(defun lazy-lock-fontify-after-idle () - ;; Called from `timer-idle-list'. - ;; Fontify all buffers that need it, stealthily while idle. - (unless (or executing-kbd-macro (window-minibuffer-p (selected-window))) - ;; Loop over all buffers, fontify stealthily for each if necessary. - (let ((buffers (buffer-list)) (continue t) - message message-log-max minibuffer-auto-raise) - (save-excursion - (do-while (and buffers continue) - (set-buffer (car buffers)) - (if (not (and lazy-lock-mode (lazy-lock-unfontified-p))) - (setq continue (not (input-pending-p))) - ;; Fontify regions in this buffer while there is no input. - (with-temp-message - (when lazy-lock-stealth-verbose - "Fontifying stealthily...") - (do-while (and (lazy-lock-unfontified-p) continue) - (if (and lazy-lock-stealth-load - (> (car (load-average)) lazy-lock-stealth-load)) - ;; Wait a while before continuing with the loop. - (progn - (when message - (message "Fontifying stealthily...suspended") - (setq message nil)) - (setq continue (sit-for (or lazy-lock-stealth-time 30)))) - ;; Fontify a chunk. - (when lazy-lock-stealth-verbose - (if message - (message "Fontifying stealthily... %2d%% of %s" - (lazy-lock-percent-fontified) (buffer-name)) - (message "Fontifying stealthily...") - (setq message t))) - ;; Current buffer may have changed during `sit-for'. - (set-buffer (car buffers)) - (lazy-lock-fontify-chunk) - (setq continue (sit-for (or lazy-lock-stealth-nice 0))))))) - (setq buffers (cdr buffers))))))) - -;; 4. Special circumstances. - -(defun lazy-lock-fontify-after-visage () - ;; Called from `outline-view-change-hook' and `hs-hide-hook'. - ;; Fontify windows showing the current buffer, as its visibility has changed. - ;; This is a conspiracy hack between lazy-lock.el, outline.el and - ;; hideshow.el. - (let ((windows (get-buffer-window-list (current-buffer) 'nomini t))) - (while windows - (lazy-lock-fontify-conservatively (car windows)) - (setq windows (cdr windows))))) - -(defun lazy-lock-after-fontify-buffer () - ;; Called from `font-lock-after-fontify-buffer'. - ;; Mark the current buffer as fontified. - ;; This is a conspiracy hack between lazy-lock.el and font-lock.el. - (with-silent-modifications - (add-text-properties (point-min) (point-max) '(lazy-lock t)))) - -(defun lazy-lock-after-unfontify-buffer () - ;; Called from `font-lock-after-unfontify-buffer'. - ;; Mark the current buffer as unfontified. - ;; This is a conspiracy hack between lazy-lock.el and font-lock.el. - (with-silent-modifications - (remove-text-properties (point-min) (point-max) '(lazy-lock nil)))) - -;; Fontification functions. - -;; If packages want to ensure that some region of the buffer is fontified, they -;; should use this function. For an example, see ps-print.el. -(defun lazy-lock-fontify-region (beg end) - ;; Fontify between BEG and END, where necessary, in the current buffer. - (save-restriction - (widen) - (when (setq beg (text-property-any beg end 'lazy-lock nil)) - (save-excursion - (with-silent-modifications - (let ((inhibit-point-motion-hooks t)) - ;; Find successive unfontified regions between BEG and END. - (condition-case data - (do-while beg - (let ((next (or (text-property-any beg end 'lazy-lock t) - end))) - ;; Make sure the region end points are at beginning of line. - (goto-char beg) - (unless (bolp) - (beginning-of-line) - (setq beg (point))) - (goto-char next) - (unless (bolp) - (forward-line) - (setq next (point))) - ;; Fontify the region, then flag it as fontified. - (font-lock-fontify-region beg next) - (add-text-properties beg next '(lazy-lock t)) - (setq beg (text-property-any next end 'lazy-lock nil)))) - ((error quit) (message "Fontifying region...%s" data))))))))) - -(defun lazy-lock-fontify-chunk () - ;; Fontify the nearest chunk, for stealth, in the current buffer. - (let ((inhibit-point-motion-hooks t)) - (save-excursion - (save-restriction - (widen) - ;; Move to end of line in case the character at point is not fontified. - (end-of-line) - ;; Find where the previous (next) unfontified regions end (begin). - (let ((prev (previous-single-property-change (point) 'lazy-lock)) - (next (text-property-any (point) (point-max) 'lazy-lock nil))) - ;; Fontify from the nearest unfontified position. - (if (or (null prev) (and next (< (- next (point)) (- (point) prev)))) - ;; The next, or neither, region is the nearest not fontified. - (lazy-lock-fontify-region - (progn (goto-char (or next (point-min))) - (beginning-of-line) - (point)) - (progn (goto-char (or next (point-min))) - (forward-line lazy-lock-stealth-lines) - (point))) - ;; The previous region is the nearest not fontified. - (lazy-lock-fontify-region - (progn (goto-char prev) - (forward-line (- lazy-lock-stealth-lines)) - (point)) - (progn (goto-char prev) - (forward-line) - (point))))))))) - -(defun lazy-lock-fontify-window (window) - ;; Fontify in WINDOW between `window-start' and `window-end'. - ;; We can only do this when we can use `window-start' and `window-end'. - (with-current-buffer (window-buffer window) - (lazy-lock-fontify-region (window-start window) (window-end window)))) - -(defun lazy-lock-fontify-conservatively (window) - ;; Fontify in WINDOW conservatively around point. - ;; Where we cannot use `window-start' and `window-end' we do `window-height' - ;; lines around point. That way we guarantee to have done enough. - (with-current-buffer (window-buffer window) - (let ((inhibit-point-motion-hooks t)) - (lazy-lock-fontify-region - (save-excursion - (goto-char (window-point window)) - (vertical-motion (- (window-height window)) window) (point)) - (save-excursion - (goto-char (window-point window)) - (vertical-motion (window-height window) window) (point)))))) - -(defun lazy-lock-unfontified-p () - ;; Return non-nil if there is anywhere still to be fontified. - (save-restriction - (widen) - (text-property-any (point-min) (point-max) 'lazy-lock nil))) - -(defun lazy-lock-percent-fontified () - ;; Return the percentage (of characters) of the buffer that are fontified. - (save-restriction - (widen) - (let ((beg (point-min)) (size 0) next) - ;; Find where the next fontified region begins. - (while (setq beg (text-property-any beg (point-max) 'lazy-lock t)) - (setq next (or (text-property-any beg (point-max) 'lazy-lock nil) - (point-max))) - (cl-incf size (- next beg)) - (setq beg next)) - ;; Float because using integer multiplication will frequently overflow. - (truncate (* (/ (float size) (point-max)) 100))))) - -;; Version dependent workarounds and fixes. - -(when (consp lazy-lock-defer-time) - ;; - ;; In 2.06.04 and below, `lazy-lock-defer-time' could specify modes and time. - (with-output-to-temp-buffer "*Help*" - (princ "The value of the variable `lazy-lock-defer-time' was\n ") - (princ lazy-lock-defer-time) - (princ "\n") - (princ "This variable cannot now be a list of modes and time,\n") - (princ "so instead use ") - (princ (substitute-command-keys "\\[customize-option]")) - (princ " to modify the variables, or put the forms:\n") - (princ " (setq lazy-lock-defer-time ") - (princ (cdr lazy-lock-defer-time)) - (princ ")\n") - (princ " (setq lazy-lock-defer-on-the-fly '") - (princ (car lazy-lock-defer-time)) - (princ ")\n") - (princ "in your ~/.emacs. ") - (princ "The above forms have been evaluated for this editor session,\n") - (princ "but you should use ") - (princ (substitute-command-keys "\\[customize-option]")) - (princ " or change your ~/.emacs now.")) - (setq lazy-lock-defer-on-the-fly (car lazy-lock-defer-time) - lazy-lock-defer-time (cdr lazy-lock-defer-time))) - -(when (boundp 'lazy-lock-defer-driven) - ;; - ;; In 2.06.04 and below, `lazy-lock-defer-driven' was the variable name. - (with-output-to-temp-buffer "*Help*" - (princ "The value of the variable `lazy-lock-defer-driven' is set to ") - (if (memq lazy-lock-defer-driven '(nil t)) - (princ lazy-lock-defer-driven) - (princ "`") - (princ lazy-lock-defer-driven) - (princ "'")) - (princ ".\n") - (princ "This variable is now called `lazy-lock-defer-on-scrolling',\n") - (princ "so instead use ") - (princ (substitute-command-keys "\\[customize-option]")) - (princ " to modify the variable, or put the form:\n") - (princ " (setq lazy-lock-defer-on-scrolling ") - (unless (memq lazy-lock-defer-driven '(nil t)) - (princ "'")) - (princ lazy-lock-defer-driven) - (princ ")\n") - (princ "in your ~/.emacs. ") - (princ "The above form has been evaluated for this editor session,\n") - (princ "but you should use ") - (princ (substitute-command-keys "\\[customize-option]")) - (princ " or change your ~/.emacs now.")) - (setq lazy-lock-defer-on-scrolling lazy-lock-defer-driven)) - -;; Install ourselves: - -(add-hook 'window-size-change-functions #'lazy-lock-fontify-after-resize) -(add-hook 'redisplay-end-trigger-functions #'lazy-lock-fontify-after-trigger) - -(unless (assq 'lazy-lock-mode minor-mode-alist) - (setq minor-mode-alist (append minor-mode-alist '((lazy-lock-mode nil))))) - -(provide 'lazy-lock) - -;; Local Variables: -;; byte-compile-warnings: (not obsolete) -;; End: - -;;; lazy-lock.el ends here diff --git a/lisp/net/quickurl.el b/lisp/obsolete/quickurl.el index 61cae43a88a..5ac10323d18 100644 --- a/lisp/net/quickurl.el +++ b/lisp/obsolete/quickurl.el @@ -5,6 +5,7 @@ ;; Author: Dave Pearson <davep@davep.org> ;; Created: 1999-05-28 ;; Keywords: hypermedia +;; Obsolete-since: 29.1 ;; This file is part of GNU Emacs. diff --git a/lisp/obsolete/rcompile.el b/lisp/obsolete/rcompile.el index fbfc0c6bbca..ceffb072cb4 100644 --- a/lisp/obsolete/rcompile.el +++ b/lisp/obsolete/rcompile.el @@ -167,7 +167,7 @@ See \\[compile]." (compilation-start compile-command) ;; Set comint-file-name-prefix in the compilation buffer so ;; compilation-parse-errors will find referenced files by Tramp. - (with-current-buffer compilation-last-buffer + (with-current-buffer next-error-last-buffer (when (fboundp 'tramp-make-tramp-file-name) (set (make-local-variable 'comint-file-name-prefix) (funcall diff --git a/lisp/org/ob-core.el b/lisp/org/ob-core.el index 04af84d2e44..3d159ed38a9 100644 --- a/lisp/org/ob-core.el +++ b/lisp/org/ob-core.el @@ -136,8 +136,7 @@ used." :type 'string :safe (lambda (v) (and (stringp v) - (eq (compare-strings "RESULTS" nil nil v nil nil t) - t)))) + (string-equal-ignore-case "RESULTS" v)))) (defcustom org-babel-noweb-wrap-start "<<" "String used to begin a noweb reference in a code block. @@ -2435,7 +2434,7 @@ INFO may provide the values of these header arguments (in the ;; Escape contents from "export" wrap. Wrap ;; inline results within an export snippet with ;; appropriate value. - ((eq t (compare-strings type nil nil "export" nil nil t)) + ((string-equal-ignore-case type "export") (let ((backend (pcase split (`(,_) "none") (`(,_ ,b . ,_) b)))) @@ -2446,14 +2445,14 @@ INFO may provide the values of these header arguments (in the backend) "@@)}}}"))) ;; Escape contents from "example" wrap. Mark ;; inline results as verbatim. - ((eq t (compare-strings type nil nil "example" nil nil t)) + ((string-equal-ignore-case type "example") (funcall wrap opening-line closing-line nil nil "{{{results(=" "=)}}}")) ;; Escape contents from "src" wrap. Mark ;; inline results as inline source code. - ((eq t (compare-strings type nil nil "src" nil nil t)) + ((string-equal-ignore-case type "src") (let ((inline-open (pcase split (`(,_) diff --git a/lisp/org/ob-tangle.el b/lisp/org/ob-tangle.el index 566258eba4a..525d27bc070 100644 --- a/lisp/org/ob-tangle.el +++ b/lisp/org/ob-tangle.el @@ -581,7 +581,10 @@ which enable the original code blocks to be found." (error "Not in tangled code")) (setq body (buffer-substring body-start end))) ;; Go to the beginning of the relative block in Org file. - (org-link-open-from-string link) + ;; Explicitly allow fuzzy search even if user customized + ;; otherwise. + (let (org-link-search-must-match-exact-headline) + (org-link-open-from-string link)) (setq target-buffer (current-buffer)) (if (string-match "[^ \t\n\r]:\\([[:digit:]]+\\)" block-name) (let ((n (string-to-number (match-string 1 block-name)))) diff --git a/lisp/org/oc-basic.el b/lisp/org/oc-basic.el index 9ed1b810fab..8c76e200e4f 100644 --- a/lisp/org/oc-basic.el +++ b/lisp/org/oc-basic.el @@ -73,6 +73,7 @@ (require 'seq) (declare-function org-open-at-point "org" (&optional arg)) +(declare-function org-open-file "org" (path &optional in-emacs line search)) (declare-function org-element-interpret-data "org-element" (data)) (declare-function org-element-property "org-element" (property element)) diff --git a/lisp/org/org-compat.el b/lisp/org/org-compat.el index 3e394fbab1c..085e32d6774 100644 --- a/lisp/org/org-compat.el +++ b/lisp/org/org-compat.el @@ -113,6 +113,11 @@ the symbol of the calling function, for example." ;;; Emacs < 27.1 compatibility +(if (version< emacs-version "27.1") + (defsubst org-replace-buffer-contents (source &optional _max-secs _max-costs) + (replace-buffer-contents source)) + (defalias 'org-replace-buffer-contents #'replace-buffer-contents)) + (unless (fboundp 'proper-list-p) ;; `proper-list-p' was added in Emacs 27.1. The function below is ;; taken from Emacs subr.el 200195e824b^. @@ -929,6 +934,14 @@ Implements `define-error' for older emacsen." (put name 'error-conditions (copy-sequence (cons name (get 'error 'error-conditions)))))) +(unless (fboundp 'string-equal-ignore-case) + ;; From Emacs subr.el. + (defun string-equal-ignore-case (string1 string2) + "Like `string-equal', but case-insensitive. +Upper-case and lower-case letters are treated as equal. +Unibyte strings are converted to multibyte for comparison." + (eq t (compare-strings string1 0 nil string2 0 nil t)))) + (unless (fboundp 'string-suffix-p) ;; From Emacs subr.el. (defun string-suffix-p (suffix string &optional ignore-case) @@ -1120,10 +1133,8 @@ ELEMENT is the element at point." (and log (let ((drawer (org-element-lineage element '(drawer)))) (and drawer - (eq (compare-strings - log nil nil - (org-element-property :drawer-name drawer) nil nil t) - t))))) + (string-equal-ignore-case + log (org-element-property :drawer-name drawer)))))) nil) (t (cl-case (org-element-type element) diff --git a/lisp/org/org-lint.el b/lisp/org/org-lint.el index 83c2d08a907..6d8cf3f2374 100644 --- a/lisp/org/org-lint.el +++ b/lisp/org/org-lint.el @@ -334,10 +334,8 @@ called with one argument, the key used for comparison." ast 'node-property (lambda (property) - (and (eq (compare-strings "CUSTOM_ID" nil nil - (org-element-property :key property) nil nil - t) - t) + (and (string-equal-ignore-case + "CUSTOM_ID" (org-element-property :key property)) (org-element-property :value property))) (lambda (property _) (org-element-property :begin property)) (lambda (key) (format "Duplicate CUSTOM_ID property \"%s\"" key)))) diff --git a/lisp/org/org-plot.el b/lisp/org/org-plot.el index 7cce678a81b..c2da24266ab 100644 --- a/lisp/org/org-plot.el +++ b/lisp/org/org-plot.el @@ -682,9 +682,10 @@ line directly before or after the table." (looking-at "[[:space:]]*#\\+")) (setf params (org-plot/collect-options params)))) ;; Dump table to datafile - (if-let ((dump-func (plist-get type :data-dump))) - (funcall dump-func table data-file num-cols params) - (org-plot/gnuplot-to-data table data-file params)) + (let ((dump-func (plist-get type :data-dump))) + (if dump-func + (funcall dump-func table data-file num-cols params) + (org-plot/gnuplot-to-data table data-file params))) ;; Check type of ind column (timestamp? text?) (when (plist-get params :check-ind-type) (let* ((ind (1- (plist-get params :ind))) diff --git a/lisp/org/org-src.el b/lisp/org/org-src.el index 54f901252f2..89d0c28a432 100644 --- a/lisp/org/org-src.el +++ b/lisp/org/org-src.el @@ -1235,7 +1235,7 @@ Throw an error if there is no such buffer." (insert (with-current-buffer write-back-buf (buffer-string)))) (save-restriction (narrow-to-region beg end) - (replace-buffer-contents write-back-buf 0.1 nil) + (org-replace-buffer-contents write-back-buf 0.1 nil) (goto-char (point-max)))) (when (and expecting-bol (not (bolp))) (insert "\n"))) (kill-buffer write-back-buf) @@ -1283,7 +1283,7 @@ Throw an error if there is no such buffer." (buffer-string)))) (save-restriction (narrow-to-region beg end) - (replace-buffer-contents write-back-buf 0.1 nil) + (org-replace-buffer-contents write-back-buf 0.1 nil) (goto-char (point-max)))) (when (and expecting-bol (not (bolp))) (insert "\n"))))) (when write-back-buf (kill-buffer write-back-buf)) diff --git a/lisp/org/org-version.el b/lisp/org/org-version.el index 2a500fe5106..915c3f63c7d 100644 --- a/lisp/org/org-version.el +++ b/lisp/org/org-version.el @@ -11,7 +11,7 @@ Inserted by installing Org mode or when a release is made." (defun org-git-version () "The Git version of Org mode. Inserted by installing Org or when a release is made." - (let ((org-git-version "release_9.5.4-3-g6dc785")) + (let ((org-git-version "release_9.5.4-17-g6e991f")) org-git-version)) (provide 'org-version) diff --git a/lisp/org/org.el b/lisp/org/org.el index 008230500d7..7ab1801cfaa 100644 --- a/lisp/org/org.el +++ b/lisp/org/org.el @@ -1357,7 +1357,7 @@ Possible values for the file identifier are: to open [[file:document.pdf::5]] with evince at page 5. `directory' Matches a directory - `remote' Matches a remote file, accessible through tramp or efs. + `remote' Matches a remote file, accessible through tramp. Remote files most likely should be visited through Emacs because external applications cannot handle such paths. `auto-mode' Matches files that are matched by any entry in `auto-mode-alist', @@ -1694,7 +1694,7 @@ OK to kill that hidden subtree. When nil, kill without remorse." (const :tag "Never kill a hidden subtree with C-k" error))) (defcustom org-special-ctrl-o t - "Non-nil means, make `C-o' insert a row in tables." + "Non-nil means, make `open-line' (\\[open-line]) insert a row in tables." :group 'org-edit-structure :type 'boolean) diff --git a/lisp/org/ox-ascii.el b/lisp/org/ox-ascii.el index 38b2a5772c1..76a1a71fabe 100644 --- a/lisp/org/ox-ascii.el +++ b/lisp/org/ox-ascii.el @@ -948,12 +948,18 @@ channel." (when description (let ((dest (if (equal type "fuzzy") (org-export-resolve-fuzzy-link link info) - (org-export-resolve-id-link link info)))) - (concat - (org-ascii--fill-string - (format "[%s] %s" anchor (org-ascii--describe-datum dest info)) - width info) - "\n\n")))) + ;; Ignore broken links. On broken link, + ;; `org-export-resolve-id-link' will throw an + ;; error and we will return nil. + (condition-case nil + (org-export-resolve-id-link link info) + (org-link-broken nil))))) + (when dest + (concat + (org-ascii--fill-string + (format "[%s] %s" anchor (org-ascii--describe-datum dest info)) + width info) + "\n\n"))))) ;; Do not add a link that cannot be resolved and doesn't have ;; any description: destination is already visible in the ;; paragraph. diff --git a/lisp/org/ox-md.el b/lisp/org/ox-md.el index ad684d80333..3551e4184e5 100644 --- a/lisp/org/ox-md.el +++ b/lisp/org/ox-md.el @@ -193,11 +193,11 @@ of contents can refer to headlines." ;; A link refers internally to HEADLINE. (org-element-map (plist-get info :parse-tree) 'link (lambda (link) - (eq headline - (pcase (org-element-property :type link) - ((or "custom-id" "id") (org-export-resolve-id-link link info)) - ("fuzzy" (org-export-resolve-fuzzy-link link info)) - (_ nil)))) + (equal headline + ;; Ignore broken links. + (condition-case nil + (org-export-resolve-id-link link info) + (org-link-broken nil)))) info t)))) (defun org-md--headline-title (style level title &optional anchor tags) diff --git a/lisp/org/ox.el b/lisp/org/ox.el index ae7e41e576b..1bdf4dead89 100644 --- a/lisp/org/ox.el +++ b/lisp/org/ox.el @@ -80,6 +80,7 @@ (require 'org-element) (require 'org-macro) (require 'tabulated-list) +(require 'subr-x) (declare-function org-src-coderef-format "org-src" (&optional element)) (declare-function org-src-coderef-regexp "org-src" (fmt &optional label)) @@ -1908,8 +1909,10 @@ Return a string." (org-element-property :archivedp data))) (let ((transcoder (org-export-transcoder data info))) (or (and (functionp transcoder) - (broken-link-handler - (funcall transcoder data nil info))) + (if (eq type 'link) + (broken-link-handler + (funcall transcoder data nil info)) + (funcall transcoder data nil info))) ;; Export snippets never return a nil value so ;; that white spaces following them are never ;; ignored. @@ -4434,15 +4437,12 @@ INFO is a plist used as a communication channel. Return value can be a radio-target object or nil. Assume LINK has type \"radio\"." - (let ((path (replace-regexp-in-string - "[ \r\t\n]+" " " (org-element-property :path link)))) + (let ((path (string-clean-whitespace (org-element-property :path link)))) (org-element-map (plist-get info :parse-tree) 'radio-target (lambda (radio) - (and (eq (compare-strings - (replace-regexp-in-string - "[ \r\t\n]+" " " (org-element-property :value radio)) - nil nil path nil nil t) - t) + (and (string-equal-ignore-case + (string-clean-whitespace (org-element-property :value radio)) + path) radio)) info 'first-match))) diff --git a/lisp/outline.el b/lisp/outline.el index 38a37fb74d3..dd5df4c8966 100644 --- a/lisp/outline.el +++ b/lisp/outline.el @@ -35,6 +35,7 @@ ;;; Code: (eval-when-compile (require 'cl-lib)) +(require 'icons) (defgroup outlines nil "Support for hierarchical outlining." @@ -280,23 +281,33 @@ This option is only in effect when `outline-minor-mode-cycle' is non-nil." [outline-1 outline-2 outline-3 outline-4 outline-5 outline-6 outline-7 outline-8]) -(defcustom outline-minor-mode-use-buttons nil - "If non-nil, use clickable buttons on the headings. -Note that this feature is not meant to be used in editing -buffers (yet) -- that will be amended in a future version. +(defcustom outline-minor-mode-use-buttons '(derived-mode . special-mode) + "Whether to display clickable buttons on the headings. +The value should be a `buffer-match-p' condition, or nil to +disable in all buffers and t to enable in all buffers. -The `outline-minor-mode-buttons' variable specifies how the -buttons should look." +These buttons can be used to hide and show the body under the heading. +Note that this feature is not meant to be used in editing +buffers (yet) -- that will be amended in a future version." :type 'boolean :safe #'booleanp :version "29.1") -(defcustom outline-minor-mode-buttons - '(("▶️" "🔽" outline--valid-emoji-p) - ("▶" "▼" outline--valid-char-p)) - "List of close/open pairs to use if using buttons." - :type 'sexp - :version "29.1") +(define-icon outline-open button + '((emoji "▶️") + (symbol " ▶ ") + (text " open ")) + "Icon used for buttons for opening a section in outline buffers." + :version "29.1" + :help-echo "Open this section") + +(define-icon outline-close button + '((emoji "🔽") + (symbol " ▼ ") + (text " close ")) + "Icon used for buttons for closing a section in outline buffers." + :version "29.1" + :help-echo "Close this section") (defvar outline-level #'outline-level @@ -423,7 +434,10 @@ outline font-lock faces to those of major mode." (goto-char (match-beginning 0)) (not (get-text-property (point) 'face)))) (overlay-put overlay 'face (outline-font-lock-face))) - (when outline-minor-mode-use-buttons + (when (and outline-minor-mode-use-buttons + (or (eq outline-minor-mode-use-buttons t) + (buffer-match-p outline-minor-mode-use-buttons + (current-buffer)))) (outline--insert-open-button))) (goto-char (match-end 0)))))) @@ -972,22 +986,6 @@ If non-nil, EVENT should be a mouse event." (outline--insert-close-button)) (outline-flag-subtree t)) -(defun outline--make-button (type) - (cl-loop for (close open test) in outline-minor-mode-buttons - when (and (funcall test close) (funcall test open)) - return (concat (if (eq type 'close) - close - open) - " " (buffer-substring (point) (1+ (point)))))) - -(defun outline--valid-emoji-p (string) - (when-let ((font (and (display-multi-font-p) - (car (internal-char-font nil ?😀))))) - (font-has-char-p font (aref string 0)))) - -(defun outline--valid-char-p (string) - (char-displayable-p (aref string 0))) - (defun outline--make-button-overlay (type) (let ((o (seq-find (lambda (o) (overlay-get o 'outline-button)) @@ -997,12 +995,27 @@ If non-nil, EVENT should be a mouse event." (overlay-put o 'follow-link 'mouse-face) (overlay-put o 'mouse-face 'highlight) (overlay-put o 'outline-button t)) - (overlay-put o 'display (outline--make-button type)) + (let ((icon + (icon-elements (if (eq type 'close) 'outline-close 'outline-open))) + (inhibit-read-only t)) + ;; In editing buffers we use overlays only, but in other buffers + ;; we use a mix of text properties, text and overlays to make + ;; movement commands work more logically. + (when (derived-mode-p 'special-mode) + (put-text-property (point) (1+ (point)) 'face (plist-get icon 'face))) + (when-let ((image (plist-get icon 'image))) + (overlay-put o 'display image)) + (overlay-put o 'display (plist-get icon 'string)) + (overlay-put o 'face (plist-get icon 'face))) o)) (defun outline--insert-open-button () (save-excursion (beginning-of-line) + (when (derived-mode-p 'special-mode) + (let ((inhibit-read-only t)) + (insert " ") + (beginning-of-line))) (let ((o (outline--make-button-overlay 'open))) (overlay-put o 'help-echo "Click to hide") (overlay-put o 'keymap @@ -1013,6 +1026,10 @@ If non-nil, EVENT should be a mouse event." (defun outline--insert-close-button () (save-excursion (beginning-of-line) + (when (derived-mode-p 'special-mode) + (let ((inhibit-read-only t)) + (insert " ") + (beginning-of-line))) (let ((o (outline--make-button-overlay 'close))) (overlay-put o 'help-echo "Click to show") (overlay-put o 'keymap diff --git a/lisp/pgtk-dnd.el b/lisp/pgtk-dnd.el index f9532269d62..b37bf9ba60a 100644 --- a/lisp/pgtk-dnd.el +++ b/lisp/pgtk-dnd.el @@ -336,18 +336,32 @@ Currently XDND, Motif and old KDE 1.x protocols are recognized." (declare-function pgtk-update-drop-status "pgtkselect.c") (declare-function pgtk-drop-finish "pgtkselect.c") +(defvar pgtk-dnd-clear-data-on-motion nil + "Whether or not to obtain the new list of targets upon the next drag motion. +For more details, see the function `pgtk-dnd-handle-gdk'.") + (defun pgtk-dnd-handle-gdk (event frame window client-message) "Handle drag-n-drop EVENT on FRAME. WINDOW should be the window the event happened on top of. CLIENT-MESSAGE is the detailed description of the drag-and-drop message." (cond - ;; We can't handle `drag-leave' here, since that signal is also - ;; sent right before `drag-drop', and there is no reliable way to - ;; distinguish the two. + ;; We can't handle `drag-leave' immediately, since that signal is + ;; also sent right before `drag-drop', and there is no reliable way + ;; to distinguish a signal sent because the source left from one + ;; sent prior to a drop. Instead, set a flag that tells Emacs to + ;; clear the drag-and-drop state if anything other than a drop is + ;; received. + ((not client-message) ; drag-leave + (setq pgtk-dnd-clear-data-on-motion t)) ((eq (car client-message) 'lambda) ; drag-motion (let ((state (pgtk-dnd-get-state-for-frame frame))) - (unless (aref state 0) ;; This is actually an entry. + (unless (and (aref state 0) ;; This is actually an entry. + (not pgtk-dnd-clear-data-on-motion)) + (setq pgtk-dnd-clear-data-on-motion nil) + ;; Forget the drop first, or else the list of targets will not + ;; be cleared if it is nil. + (pgtk-dnd-forget-drop window) (pgtk-dnd-save-state window nil nil (pgtk-get-selection-internal (nth 1 client-message) 'TARGETS) diff --git a/lisp/progmodes/cc-defs.el b/lisp/progmodes/cc-defs.el index 9edaf465346..04f519dd0a5 100644 --- a/lisp/progmodes/cc-defs.el +++ b/lisp/progmodes/cc-defs.el @@ -425,23 +425,6 @@ to it is returned. This function does not modify the point or the mark." (defvar lookup-syntax-properties) ;XEmacs. -(eval-and-compile - ;; Constant to decide at compilation time whether to use category - ;; properties. Currently (2010-03) they're available only on GNU Emacs. - (defconst c-use-category - (with-temp-buffer - (let ((parse-sexp-lookup-properties t) - (lookup-syntax-properties t)) - (set-syntax-table (make-syntax-table)) - (insert "<()>") - (put-text-property (point-min) (1+ (point-min)) - 'category 'c-<-as-paren-syntax) - (put-text-property (+ 3 (point-min)) (+ 4 (point-min)) - 'category 'c->-as-paren-syntax) - (goto-char (point-min)) - (forward-sexp) - (= (point) (+ 4 (point-min))))))) - (defmacro c-is-escaped (pos) ;; Are there an odd number of backslashes before POS? (declare (debug t)) @@ -1147,11 +1130,13 @@ MODE is either a mode symbol or a list of mode symbols." (cc-bytecomp-fboundp 'delete-extent) (cc-bytecomp-fboundp 'map-extents)))) -(defconst c-<-as-paren-syntax '(4 . ?>)) -(put 'c-<-as-paren-syntax 'syntax-table c-<-as-paren-syntax) +(eval-and-compile + (defconst c-<-as-paren-syntax '(4 . ?>)) + (put 'c-<-as-paren-syntax 'syntax-table c-<-as-paren-syntax)) -(defconst c->-as-paren-syntax '(5 . ?<)) -(put 'c->-as-paren-syntax 'syntax-table c->-as-paren-syntax) +(eval-and-compile + (defconst c->-as-paren-syntax '(5 . ?<)) + (put 'c->-as-paren-syntax 'syntax-table c->-as-paren-syntax)) ;; `c-put-char-property' is complex enough in XEmacs and Emacs < 21 to ;; make it a function. @@ -1210,6 +1195,26 @@ MODE is either a mode symbol or a list of mode symbols." `((setq c-syntax-table-hwm (min c-syntax-table-hwm -pos-)))) (put-text-property -pos- (1+ -pos-) ',property ,value)))) +(eval-and-compile + ;; Constant to decide at compilation time whether to use category + ;; properties. Currently (2010-03) they're available only on GNU + ;; Emacs. This defconst must follow the declarations of + ;; `c-<-as-paren-syntax' and `c->-as-paren-syntax'. + (defconst c-use-category + (eval-when-compile + (with-temp-buffer + (let ((parse-sexp-lookup-properties t) + (lookup-syntax-properties t)) + (set-syntax-table (make-syntax-table)) + (insert "<()>") + (put-text-property (point-min) (1+ (point-min)) + 'category 'c-<-as-paren-syntax) + (put-text-property (+ 3 (point-min)) (+ 4 (point-min)) + 'category 'c->-as-paren-syntax) + (goto-char (point-min)) + (forward-sexp) + (= (point) (+ 4 (point-min)))))))) + (defmacro c-get-char-property (pos property) ;; Get the value of the given property on the character at POS if ;; it's been put there by `c-put-char-property'. PROPERTY is @@ -1646,7 +1651,7 @@ with value CHAR in the region [FROM to)." ;; toggle the property in all template brackets simultaneously and ;; cheaply. We use this, for instance, in `c-parse-state'. (declare (debug t)) - (if c-use-category + (if (eval-when-compile c-use-category) `(c-put-char-property ,pos 'category 'c-<-as-paren-syntax) `(c-put-char-property ,pos 'syntax-table c-<-as-paren-syntax))) @@ -1661,7 +1666,7 @@ with value CHAR in the region [FROM to)." ;; toggle the property in all template brackets simultaneously and ;; cheaply. We use this, for instance, in `c-parse-state'. (declare (debug t)) - (if c-use-category + (if (eval-when-compile c-use-category) `(c-put-char-property ,pos 'category 'c->-as-paren-syntax) `(c-put-char-property ,pos 'syntax-table c->-as-paren-syntax))) @@ -1675,7 +1680,9 @@ with value CHAR in the region [FROM to)." ;; toggle the property in all template brackets simultaneously and ;; cheaply. We use this, for instance, in `c-parse-state'. (declare (debug t)) - `(c-clear-char-property ,pos ,(if c-use-category ''category ''syntax-table))) + `(c-clear-char-property ,pos ,(if (eval-when-compile c-use-category) + ''category + ''syntax-table))) (defsubst c-suppress-<->-as-parens () ;; Suppress the syntactic effect of all marked < and > as parens. Note @@ -1755,7 +1762,7 @@ with value CHAR in the region [FROM to)." (defmacro c-sc-scan-lists (from count depth) (declare (debug t)) - (if c-use-category + (if (eval-when-compile c-use-category) `(scan-lists ,from ,count ,depth) (cond ((and (eq count 1) (eq depth 1)) @@ -1803,7 +1810,7 @@ with value CHAR in the region [FROM to)." (defmacro c-sc-parse-partial-sexp (from to &optional targetdepth stopbefore oldstate) (declare (debug t)) - (if c-use-category + (if (eval-when-compile c-use-category) `(parse-partial-sexp ,from ,to ,targetdepth ,stopbefore ,oldstate) `(c-sc-parse-partial-sexp-no-category ,from ,to ,targetdepth ,stopbefore ,oldstate))) diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index 9f33186d8b1..a665fccc733 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -979,11 +979,6 @@ Faces `compilation-error-face', `compilation-warning-face', (defvar compilation-leave-directory-face 'font-lock-builtin-face "Face name to use for leaving directory messages.") -;; Used for compatibility with the old compile.el. -(defvar compilation-parse-errors-function nil) -(make-obsolete-variable 'compilation-parse-errors-function - 'compilation-error-regexp-alist "24.1") - (defcustom compilation-auto-jump-to-first-error nil "If non-nil, automatically jump to the first error during compilation." :type '(choice (const :tag "Never" nil) @@ -1519,34 +1514,28 @@ RULE is the name (symbol) of the rule used or nil if anonymous. (and proc (memq (process-status proc) '(run open)))) (setq end (line-beginning-position)))) (compilation--remove-properties start end) - (if compilation-parse-errors-function - ;; An old package! Try the compatibility code. - (progn - (goto-char start) - (compilation--compat-parse-errors end)) - - ;; compilation-directory-matcher is the only part that really needs to be - ;; parsed sequentially. So we could split it out, handle directories - ;; like syntax-propertize, and the rest as font-lock-keywords. But since - ;; we want to have it work even when font-lock is off, we'd then need to - ;; use our own compilation-parsed text-property to keep track of the parts - ;; that have already been parsed. - (goto-char start) - (while (re-search-forward (car compilation-directory-matcher) - end t) - (compilation--flush-directory-cache (match-beginning 0) (match-end 0)) - (when compilation-debug - (font-lock-append-text-property - (match-beginning 0) (match-end 0) - 'compilation-debug - (vector 'directory compilation-directory-matcher))) - (dolist (elt (cdr compilation-directory-matcher)) - (add-text-properties (match-beginning (car elt)) - (match-end (car elt)) - (compilation-directory-properties - (car elt) (cdr elt))))) - - (compilation-parse-errors start end))) + ;; compilation-directory-matcher is the only part that really needs to be + ;; parsed sequentially. So we could split it out, handle directories + ;; like syntax-propertize, and the rest as font-lock-keywords. But since + ;; we want to have it work even when font-lock is off, we'd then need to + ;; use our own compilation-parsed text-property to keep track of the parts + ;; that have already been parsed. + (goto-char start) + (while (re-search-forward (car compilation-directory-matcher) + end t) + (compilation--flush-directory-cache (match-beginning 0) (match-end 0)) + (when compilation-debug + (font-lock-append-text-property + (match-beginning 0) (match-end 0) + 'compilation-debug + (vector 'directory compilation-directory-matcher))) + (dolist (elt (cdr compilation-directory-matcher)) + (add-text-properties (match-beginning (car elt)) + (match-end (car elt)) + (compilation-directory-properties + (car elt) (cdr elt))))) + + (compilation-parse-errors start end)) (defun compilation--note-type (type) "Note that a new message with severity TYPE was seen. @@ -2475,22 +2464,23 @@ commands of Compilation major mode are available. See (defun compilation-sentinel (proc msg) "Sentinel for compilation buffers." (if (memq (process-status proc) '(exit signal)) - (let ((buffer (process-buffer proc))) - (if (null (buffer-name buffer)) - ;; buffer killed - (set-process-buffer proc nil) - (with-current-buffer buffer - ;; Write something in the compilation buffer - ;; and hack its mode line. - (compilation-handle-exit (process-status proc) - (process-exit-status proc) - msg) - ;; Since the buffer and mode line will show that the - ;; process is dead, we can delete it now. Otherwise it - ;; will stay around until M-x list-processes. - (delete-process proc))) + (unwind-protect + (let ((buffer (process-buffer proc))) + (if (null (buffer-name buffer)) + ;; buffer killed + (set-process-buffer proc nil) + (with-current-buffer buffer + ;; Write something in the compilation buffer + ;; and hack its mode line. + (compilation-handle-exit (process-status proc) + (process-exit-status proc) + msg)))) (setq compilation-in-progress (delq proc compilation-in-progress)) - (compilation--update-in-progress-mode-line)))) + (compilation--update-in-progress-mode-line) + ;; Since the buffer and mode line will show that the + ;; process is dead, we can delete it now. Otherwise it + ;; will stay around until M-x list-processes. + (delete-process proc)))) (defun compilation-filter (proc string) "Process filter for compilation buffers. @@ -3259,73 +3249,11 @@ TRUE-DIRNAME is the `file-truename' of DIRNAME, if given." (if (eq v fs) (remhash k compilation-locs))) compilation-locs))) -;;; Compatibility with the old compile.el. - -(defvaralias 'compilation-last-buffer 'next-error-last-buffer) -(defvar compilation-parsing-end (make-marker)) -(defvar compilation-error-list nil) -(defvar compilation-old-error-list nil) - -(defun compilation--compat-parse-errors (limit) - (when compilation-parse-errors-function - ;; FIXME: We should remove the rest of the compilation keywords - ;; but we can't do that from here because font-lock is using - ;; the value right now. --Stef - (save-excursion - (setq compilation-error-list nil) - ;; Reset compilation-parsing-end each time because font-lock - ;; might force us the re-parse many times (typically because - ;; some code adds some text-property to the output that we - ;; already parsed). You might say "why reparse", well: - ;; because font-lock has just removed the `compilation-message' property - ;; so have to do it all over again. - (if compilation-parsing-end - (set-marker compilation-parsing-end (point)) - (setq compilation-parsing-end (point-marker))) - (condition-case nil - ;; Ignore any error: we're calling this function earlier than - ;; in the old compile.el so things might not all be setup yet. - (funcall compilation-parse-errors-function limit nil) - (error nil)) - (dolist (err (if (listp compilation-error-list) compilation-error-list)) - (let* ((src (car err)) - (dst (cdr err)) - (loc (cond ((markerp dst) - (cons nil - (compilation--make-cdrloc nil nil dst))) - ((consp dst) - (cons (nth 2 dst) - (compilation--make-cdrloc - (nth 1 dst) - (cons (cdar dst) (caar dst)) - nil)))))) - (when loc - (goto-char src) - ;; (put-text-property src (line-end-position) - ;; 'font-lock-face 'font-lock-warning-face) - (put-text-property src (line-end-position) - 'compilation-message - (compilation--make-message loc 2 nil nil))))))) - (goto-char limit) - nil) - -;; Beware! this is not only compatibility code. New code also uses it. --Stef (defun compilation-forget-errors () ;; In case we hit the same file/line specs, we want to recompute a new ;; marker for them, so flush our cache. (clrhash compilation-locs) (setq compilation-gcpro nil) - ;; FIXME: the old code reset the directory-stack, so maybe we should - ;; put a `directory change' marker of some sort, but where? -stef - ;; - ;; FIXME: The old code moved compilation-current-error (which was - ;; virtually represented by a mix of compilation-parsing-end and - ;; compilation-error-list) to point-min, but that was only meaningful for - ;; the internal uses of compilation-forget-errors: all calls from external - ;; packages seem to be followed by a move of compilation-parsing-end to - ;; something equivalent to point-max. So we heuristically move - ;; compilation-current-error to point-max (since the external package - ;; won't know that it should do it). --Stef (setq compilation-current-error nil) (let* ((proc (get-buffer-process (current-buffer))) (mark (if proc (process-mark proc))) @@ -3344,6 +3272,10 @@ TRUE-DIRNAME is the `file-truename' of DIRNAME, if given." (or compilation-auto-jump-to-first-error (eq compilation-scroll-output 'first-error)))) +(define-obsolete-variable-alias 'compilation-last-buffer + ;; Sadly, we forgot to declare this obsolete back then :-( + 'next-error-last-buffer "29.1 (tho really since 22.1)") + (provide 'compile) ;;; compile.el ends here diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index f51d2fcb115..ab70d574c5b 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -32,11 +32,6 @@ ;; the MooseX::Declare CPAN module, as well as Perl 5.10 keyword ;; support. -;; The latest version is available from -;; https://github.com/jrockway/cperl-mode -;; -;; (perhaps in the moosex-declare branch) - ;; You can either fine-tune the bells and whistles of this mode or ;; bulk enable them by putting diff --git a/lisp/progmodes/flymake-proc.el b/lisp/progmodes/flymake-proc.el index 4ab16831bc1..249ae9dff2f 100644 --- a/lisp/progmodes/flymake-proc.el +++ b/lisp/progmodes/flymake-proc.el @@ -399,10 +399,7 @@ instead of reading master file from disk." (not (string-match (format "\\.%s\\'" source-file-extension) inc-name)) (setq inc-name (concat inc-name "." source-file-extension))) - (when (eq t (compare-strings - source-file-nondir nil nil - inc-name (- (length inc-name) - (length source-file-nondir)) nil)) + (when (string-suffix-p source-file-nondir inc-name) (flymake-log 3 "inc-name=%s" inc-name) (when (flymake-proc--check-include source-file-name inc-name include-dirs) diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el index 423de7d5818..c01d7e997ec 100644 --- a/lisp/progmodes/grep.el +++ b/lisp/progmodes/grep.el @@ -345,12 +345,12 @@ See `compilation-error-screen-columns'." (defalias 'kill-grep #'kill-compilation) -;; override compilation-last-buffer +;; override next-error-last-buffer (defvar grep-last-buffer nil "The most recent grep buffer. A grep buffer becomes most recent when you select Grep mode in it. Notice that using \\[next-error] or \\[compile-goto-error] modifies -`compilation-last-buffer' rather than `grep-last-buffer'.") +`next-error-last-buffer' rather than `grep-last-buffer'.") (defvar grep-match-face 'match "Face name to use for grep matches.") diff --git a/lisp/progmodes/idlwave.el b/lisp/progmodes/idlwave.el index a2061fde762..b3dc3cac763 100644 --- a/lisp/progmodes/idlwave.el +++ b/lisp/progmodes/idlwave.el @@ -7528,7 +7528,7 @@ associated TAG, if any." (setq cl (pop sclasses)) (let ((tags (idlwave-class-tags cl))) (while tags - (if (eq t (compare-strings tag 0 nil (car tags) 0 nil t)) + (if (string-equal-ignore-case tag (car tags)) (throw 'exit cl)) (setq tags (cdr tags)))))))) diff --git a/lisp/progmodes/prolog.el b/lisp/progmodes/prolog.el index 5aba95d4c79..e3ddf28bbbe 100644 --- a/lisp/progmodes/prolog.el +++ b/lisp/progmodes/prolog.el @@ -1620,8 +1620,6 @@ Used for temporary files.") (defvar prolog-consult-compile-real-file nil "The file name of the buffer to compile/consult.") -(defvar compilation-parse-errors-function) - (defun prolog-consult-compile (compilep file &optional first-line) "Consult/compile FILE. If COMPILEP is non-nil, perform compilation, otherwise perform CONSULTING. @@ -1647,14 +1645,14 @@ This function must be called from the source code buffer." ;; Setting up font-locking for this buffer (setq-local font-lock-defaults '(prolog-font-lock-keywords nil nil ((?_ . "w")))) - (if (eq prolog-system 'sicstus) - ;; FIXME: This looks really problematic: not only is this using - ;; the old compilation-parse-errors-function, but - ;; prolog-parse-sicstus-compilation-errors only accepts one argument - ;; whereas compile.el calls it with 2 (and did so at least since - ;; Emacs-20). - (setq-local compilation-parse-errors-function - 'prolog-parse-sicstus-compilation-errors)) + ;; (if (eq prolog-system 'sicstus) + ;; ;; FIXME: This looks really problematic: not only is this using + ;; ;; the old compilation-parse-errors-function, but + ;; ;; prolog-parse-sicstus-compilation-errors only accepts one + ;; ;; argument whereas compile.el calls it with 2 (and did so at + ;; ;; least since Emacs-20). + ;; (setq-local compilation-parse-errors-function + ;; #'prolog-parse-sicstus-compilation-errors)) (setq buffer-read-only nil) (insert command-string "\n")) (display-buffer buffer) @@ -1685,40 +1683,41 @@ This function must be called from the source code buffer." (defvar compilation-error-list) -(defun prolog-parse-sicstus-compilation-errors (limit) - "Parse the prolog compilation buffer for errors. -Argument LIMIT is a buffer position limiting searching. -For use with the `compilation-parse-errors-function' variable." - (setq compilation-error-list nil) - (message "Parsing SICStus error messages...") - (let (filepath dir file errorline) - (while - (re-search-backward - "{\\([a-zA-Z ]* ERROR\\|Warning\\):.* in line[s ]*\\([0-9]+\\)" - limit t) - (setq errorline (string-to-number (match-string 2))) - (save-excursion - (re-search-backward - "{\\(consulting\\|compiling\\|processing\\) \\(.*\\)\\.\\.\\.}" - limit t) - (setq filepath (match-string 2))) - - ;; ###### Does this work with SICStus under Windows - ;; (i.e. backslashes and stuff?) - (if (string-match "\\(.*/\\)\\([^/]*\\)$" filepath) - (progn - (setq dir (match-string 1 filepath)) - (setq file (match-string 2 filepath)))) - - (setq compilation-error-list - (cons - (cons (save-excursion - (beginning-of-line) - (point-marker)) - (list (list file dir) errorline)) - compilation-error-list) - )) - )) +;; FIXME: This has been obsolete since Emacs-20! +;; (defun prolog-parse-sicstus-compilation-errors (limit) +;; "Parse the prolog compilation buffer for errors. +;; Argument LIMIT is a buffer position limiting searching. +;; For use with the `compilation-parse-errors-function' variable." +;; (setq compilation-error-list nil) +;; (message "Parsing SICStus error messages...") +;; (let (filepath dir file errorline) +;; (while +;; (re-search-backward +;; "{\\([a-zA-Z ]* ERROR\\|Warning\\):.* in line[s ]*\\([0-9]+\\)" +;; limit t) +;; (setq errorline (string-to-number (match-string 2))) +;; (save-excursion +;; (re-search-backward +;; "{\\(consulting\\|compiling\\|processing\\) \\(.*\\)\\.\\.\\.}" +;; limit t) +;; (setq filepath (match-string 2))) + +;; ;; ###### Does this work with SICStus under Windows +;; ;; (i.e. backslashes and stuff?) +;; (if (string-match "\\(.*/\\)\\([^/]*\\)$" filepath) +;; (progn +;; (setq dir (match-string 1 filepath)) +;; (setq file (match-string 2 filepath)))) + +;; (setq compilation-error-list +;; (cons +;; (cons (save-excursion +;; (beginning-of-line) +;; (point-marker)) +;; (list (list file dir) errorline)) +;; compilation-error-list) +;; )) +;; )) (defun prolog-consult-compile-filter (process output) "Filter function for Prolog compilation PROCESS. diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index f31832fec9c..b8fc7d4c546 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -1459,8 +1459,11 @@ With positive ARG search backwards, else search forwards." (current-indentation))) (body-indentation (and (> arg 0) - (or (and (python-info-looking-at-beginning-of-defun) - (+ (current-indentation) python-indent-offset)) + (or (and (python-info-looking-at-beginning-of-defun nil t) + (+ (save-excursion + (python-nav-beginning-of-statement) + (current-indentation)) + python-indent-offset)) (save-excursion (while (and @@ -5168,7 +5171,8 @@ likely an invalid python file." (while (and (< (point) cur-line) (setq no-back-indent (or (> (current-indentation) indentation) - (python-info-current-line-empty-p)))) + (python-info-current-line-empty-p) + (python-info-current-line-comment-p)))) (forward-line))) no-back-indent))) (setq collected-indentations diff --git a/lisp/progmodes/verilog-mode.el b/lisp/progmodes/verilog-mode.el index 31d50a1882e..f063fb5a7ca 100644 --- a/lisp/progmodes/verilog-mode.el +++ b/lisp/progmodes/verilog-mode.el @@ -5458,9 +5458,11 @@ For example: becomes: // surefire lint_line_off UDDONX" (interactive) - (let ((buff (if (boundp 'next-error-last-buffer) + (let ((buff (if (boundp 'next-error-last-buffer) ;Added to Emacs-22.1 next-error-last-buffer - compilation-last-buffer))) + (verilog--suppressed-warnings + ((obsolete compilation-last-buffer)) + compilation-last-buffer)))) (when (buffer-live-p buff) (save-excursion (switch-to-buffer buff) @@ -10878,10 +10880,10 @@ This repairs those mis-inserted by an AUTOARG." (setq out (replace-match (concat (match-string 1 out) (if (equal (match-string 3 out) ">>") - (int-to-string (lsh (string-to-number (match-string 2 out)) + (int-to-string (ash (string-to-number (match-string 2 out)) (* -1 (string-to-number (match-string 4 out)))))) (if (equal (match-string 3 out) "<<") - (int-to-string (lsh (string-to-number (match-string 2 out)) + (int-to-string (ash (string-to-number (match-string 2 out)) (string-to-number (match-string 4 out))))) (if (equal (match-string 3 out) ">>>") (int-to-string (ash (string-to-number (match-string 2 out)) diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index 0213ab3cc58..f3db971bcf2 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.4.1 +;; Version: 1.5.0 ;; Package-Requires: ((emacs "26.1")) ;; This is a GNU ELPA :core package. Avoid functionality that is not @@ -1821,7 +1821,8 @@ to control which program to use when looking for matches." (when (and (/= (point-min) (point-max)) (not (looking-at grep-re)) ;; TODO: Show these matches as well somehow? - (not (looking-at "Binary file .* matches"))) + ;; Matching both Grep's and Ripgrep 13's messages. + (not (looking-at ".*[bB]inary file.* matches"))) (user-error "Search failed with status %d: %s" status (buffer-substring (point-min) (line-end-position)))) (while (re-search-forward grep-re nil t) diff --git a/lisp/rect.el b/lisp/rect.el index 47df95b04e4..eebbf999d40 100644 --- a/lisp/rect.el +++ b/lisp/rect.el @@ -930,6 +930,27 @@ Ignores `line-move-visual'." (mapc #'delete-overlay (nthcdr 5 rol)) (setcar (cdr rol) nil))) +(defun rectangle--duplicate-right (n) + "Duplicate the rectangular region N times on the right-hand side." + (let ((cols (rectangle--pos-cols (point) (mark)))) + (apply-on-rectangle + (lambda (startcol endcol) + (let ((lines (list nil))) + (extract-rectangle-line startcol endcol lines) + (move-to-column endcol t) + (dotimes (_ n) + (insert (cadr lines))))) + (region-beginning) (region-end)) + ;; Recompute the rectangle state; no crutches should be needed now. + (let ((p (point)) + (m (mark))) + (rectangle--reset-crutches) + (goto-char m) + (move-to-column (cdr cols) t) + (set-mark (point)) + (goto-char p) + (move-to-column (car cols) t)))) + (provide 'rect) ;;; rect.el ends here diff --git a/lisp/select.el b/lisp/select.el index 2d501f207f1..019be9cb23b 100644 --- a/lisp/select.el +++ b/lisp/select.el @@ -829,7 +829,8 @@ This function returns the string \"emacs\"." (concat value [0])))) (defun xselect-uri-list-available-p (selection _type value) - "Return whether or not `text/uri-list' is a valid target for SELECTION. + "Return non-nil if `text/uri-list' is a valid target for SELECTION. +Return nil otherwise. VALUE is the local selection value of SELECTION." (and (eq selection 'XdndSelection) (or (stringp value) @@ -839,13 +840,20 @@ VALUE is the local selection value of SELECTION." "") (defun xselect-dt-netfile-available-p (selection _type value) - "Return whether or not `_DT_NETFILE' is a valid target for SELECTION. + "Return non-nil if `_DT_NETFILE' is a valid target for SELECTION. +Return nil otherwise. VALUE is SELECTION's local selection value." (and (eq selection 'XdndSelection) (stringp value) (file-exists-p value) (not (file-remote-p value)))) +(defun xselect-dnd-target-available-p (selection _type _value) + "Return non-nil if TYPE is a valid target for SELECTION. +Return nil otherwise. +VALUE is SELECTION's local selection value." + (eq selection 'XdndSelection)) + (defun xselect-tt-net-file (file) "Get the canonical ToolTalk filename for FILE. FILE must be a local file, or otherwise the conversion will fail. @@ -890,7 +898,8 @@ VALUE should be SELECTION's local value." (text/plain\;charset=utf-8 . xselect-convert-to-string) (text/uri-list . (xselect-uri-list-available-p . xselect-convert-to-text-uri-list)) - (text/x-xdnd-username . xselect-convert-to-username) + (text/x-xdnd-username . (xselect-dnd-target-available-p + . xselect-convert-to-username)) (FILE . (xselect-uri-list-available-p . xselect-convert-to-xm-file)) (TARGETS . xselect-convert-to-targets) @@ -909,8 +918,10 @@ VALUE should be SELECTION's local value." (INTEGER . xselect-convert-to-integer) (SAVE_TARGETS . xselect-convert-to-save-targets) (_EMACS_INTERNAL . xselect-convert-to-identity) - (XmTRANSFER_SUCCESS . xselect-convert-xm-special) - (XmTRANSFER_FAILURE . xselect-convert-xm-special) + (XmTRANSFER_SUCCESS . (xselect-dnd-target-available-p + . xselect-convert-xm-special)) + (XmTRANSFER_FAILURE . (xselect-dnd-target-available-p + . xselect-convert-xm-special)) (_DT_NETFILE . (xselect-dt-netfile-available-p . xselect-convert-to-dt-netfile)))) diff --git a/lisp/simple.el b/lisp/simple.el index 5443d961e13..2ef8a3cf003 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -2229,9 +2229,20 @@ See `extended-command-versions'." "Alist of prompts and what the extended command predicate should be. This is used by the \\<minibuffer-local-must-match-map>\\[execute-extended-command-cycle] command when reading an extended command.") +(defvar-keymap read-extended-command-mode-map + :doc "Local keymap added to the current map when reading an extended command." + "M-X" #'execute-extended-command-cycle) + +(define-minor-mode read-extended-command-mode + "Minor mode used for completion in `read-extended-command'.") + (defun read-extended-command (&optional prompt) - "Read command name to invoke in `execute-extended-command'. -This function uses the `read-extended-command-predicate' user option." + "Read command name to invoke via `execute-extended-command'. +Use `read-extended-command-predicate' to determine which commands +to include among completion candidates. + +This function activates the `read-extended-command-mode' minor +mode when reading the command name." (let ((default-predicate read-extended-command-predicate) (read-extended-command-predicate read-extended-command-predicate) already-typed ret) @@ -2270,6 +2281,8 @@ This function uses the `read-extended-command-predicate' user option." (setq execute-extended-command--last-typed (minibuffer-contents))) nil 'local) + ;; This is so that we define the `M-X' toggling command. + (read-extended-command-mode) (setq-local minibuffer-default-add-function (lambda () ;; Get a command name at point in the original buffer diff --git a/lisp/speedbar.el b/lisp/speedbar.el index 9184d6c5254..e74d6fd80a9 100644 --- a/lisp/speedbar.el +++ b/lisp/speedbar.el @@ -2789,15 +2789,7 @@ to add more types of version control systems." (not (or (and (featurep 'ange-ftp) (string-match (car (symbol-value 'ange-ftp-name-format)) - (expand-file-name default-directory))) - ;; efs support: Bob Weiner - (and (featurep 'efs) - (string-match - (let ((reg (symbol-value 'efs-directory-regexp))) - (if (stringp reg) - reg - (car reg))) - (expand-file-name default-directory)))))) + (expand-file-name default-directory)))))) (setq speedbar-vc-to-do-point 0)) (if (numberp speedbar-vc-to-do-point) (progn diff --git a/lisp/subr.el b/lisp/subr.el index 510a77dbc8d..6b121a314a9 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -528,6 +528,10 @@ i.e., subtract 2 * `most-negative-fixnum' from VALUE before shifting it. This function is provided for compatibility. In new code, use `ash' instead." + (declare (compiler-macro + (lambda (form) + (macroexp-warn-and-return "avoid `lsh'; use `ash' instead" + form '(suspicious lsh) t form)))) (when (and (< value 0) (< count 0)) (when (< value most-negative-fixnum) (signal 'args-out-of-range (list value count))) @@ -729,11 +733,6 @@ If N is omitted or nil, remove the last element." (if (> n 0) (setcdr (nthcdr (- (1- m) n) list) nil)) list)))) -;; The function's definition was moved to fns.c, -;; but it's easier to set properties here. -(put 'proper-list-p 'pure t) -(put 'proper-list-p 'side-effect-free 'error-free) - (defun delete-dups (list) "Destructively remove `equal' duplicates from LIST. Store the result in LIST and return it. LIST must be a proper list. @@ -864,7 +863,7 @@ Non-strings in LIST are ignored." (declare (side-effect-free t)) (while (and list (not (and (stringp (car list)) - (eq t (compare-strings elt 0 nil (car list) 0 nil t))))) + (string-equal-ignore-case elt (car list))))) (setq list (cdr list))) list) @@ -5298,10 +5297,18 @@ and replace a sub-expression, e.g. (setq matches (cons (substring string start l) matches)) ; leftover (apply #'concat (nreverse matches))))) +(defsubst string-equal-ignore-case (string1 string2) + "Like `string-equal', but case-insensitive. +Upper-case and lower-case letters are treated as equal. +Unibyte strings are converted to multibyte for comparison." + (declare (pure t) (side-effect-free t)) + (eq t (compare-strings string1 0 nil string2 0 nil t))) + (defun string-prefix-p (prefix string &optional ignore-case) "Return non-nil if PREFIX is a prefix of STRING. If IGNORE-CASE is non-nil, the comparison is done without paying attention to case differences." + (declare (pure t) (side-effect-free t)) (let ((prefix-length (length prefix))) (if (> prefix-length (length string)) nil (eq t (compare-strings prefix 0 prefix-length string @@ -5311,6 +5318,7 @@ to case differences." "Return non-nil if SUFFIX is a suffix of STRING. If IGNORE-CASE is non-nil, the comparison is done without paying attention to case differences." + (declare (pure t) (side-effect-free t)) (let ((start-pos (- (length string) (length suffix)))) (and (>= start-pos 0) (eq t (compare-strings suffix nil nil diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index 1a3f35891ef..cf5ae09a247 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -2411,7 +2411,7 @@ When `switch-to-buffer-obey-display-actions' is non-nil, (keymap-set tab-prefix-map "M" #'tab-move-to) (keymap-set tab-prefix-map "G" #'tab-group) (keymap-set tab-prefix-map "r" #'tab-rename) -(keymap-set tab-prefix-map "r" #'tab-switch) +(keymap-set tab-prefix-map "RET" #'tab-switch) (keymap-set tab-prefix-map "b" #'switch-to-buffer-other-tab) (keymap-set tab-prefix-map "f" #'find-file-other-tab) (keymap-set tab-prefix-map "C-f" #'find-file-other-tab) diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el index 9d9c31970dc..a16169d477f 100644 --- a/lisp/term/haiku-win.el +++ b/lisp/term/haiku-win.el @@ -489,19 +489,56 @@ Return the number of clicks that were made in quick succession." (defvar haiku-drag-wheel-function) -(defun haiku-handle-drag-wheel (frame x y horizontal up) +(defun haiku-dnd-modifier-mask (mods) + "Return the internal modifier mask for the Emacs modifier state MODS. +MODS is a single symbol, or a list of symbols such as `shift' or +`control'." + (let ((mask 0)) + (unless (consp mods) + (setq mods (list mods))) + (dolist (modifier mods) + (cond ((eq modifier 'shift) + (setq mask (logior mask ?\S-\0))) + ((eq modifier 'control) + (setq mask (logior mask ?\C-\0))) + ((eq modifier 'meta) + (setq mask (logior mask ?\M-\0))) + ((eq modifier 'hyper) + (setq mask (logior mask ?\H-\0))) + ((eq modifier 'super) + (setq mask (logior mask ?\s-\0))) + ((eq modifier 'alt) + (setq mask (logior mask ?\A-\0))))) + mask)) + +(defun haiku-dnd-wheel-modifier-type (flags) + "Return the modifier type of an internal modifier mask. +FLAGS is the internal modifier mask of a turn of the mouse wheel." + (let ((modifiers (logior ?\M-\0 ?\C-\0 ?\S-\0 + ?\H-\0 ?\s-\0 ?\A-\0))) + (catch 'type + (dolist (modifier mouse-wheel-scroll-amount) + (when (and (consp modifier) + (eq (haiku-dnd-modifier-mask (car modifier)) + (logand flags modifiers))) + (throw 'type (cdr modifier)))) + nil))) + +(defun haiku-handle-drag-wheel (frame x y horizontal up modifiers) "Handle wheel movement during drag-and-drop. FRAME is the frame on top of which the wheel moved. X and Y are the frame-relative coordinates of the wheel movement. HORIZONTAL is whether or not the wheel movement was horizontal. -UP is whether or not the wheel moved up (or left)." +UP is whether or not the wheel moved up (or left). +MODIFIERS is the internal modifier mask of the wheel movement." (when (not (equal haiku-last-wheel-direction (cons horizontal up))) (setq haiku-last-wheel-direction (cons horizontal up)) (when (consp haiku-dnd-wheel-count) (setcar haiku-dnd-wheel-count 0))) - (let ((function (cond + (let ((type (haiku-dnd-wheel-modifier-type modifiers)) + (function (cond ((and (not horizontal) (not up)) mwheel-scroll-up-function) ((not horizontal) @@ -512,14 +549,27 @@ UP is whether or not the wheel moved up (or left)." (t (if mouse-wheel-flip-direction mwheel-scroll-left-function mwheel-scroll-right-function)))) - (timestamp (time-convert nil 1000))) + (timestamp (time-convert nil 1000)) + (amt 1)) + (cond ((and (eq type 'hscroll) + (not horizontal)) + (setq function (if (not up) + mwheel-scroll-left-function + mwheel-scroll-right-function))) + ((and (eq type 'global-text-scale)) + (setq function 'global-text-scale-adjust + amt (if up 1 -1))) + ((and (eq type 'text-scale)) + (setq function 'text-scale-adjust + amt (if up 1 -1)))) (when function (let ((posn (posn-at-x-y x y frame))) (when (windowp (posn-window posn)) (with-selected-window (posn-window posn) (funcall function - (or (and (not mouse-wheel-progressive-speed) 1) - (haiku-note-wheel-click (car timestamp)))))))))) + (* amt + (or (and (not mouse-wheel-progressive-speed) 1) + (haiku-note-wheel-click (car timestamp))))))))))) (setq haiku-drag-wheel-function #'haiku-handle-drag-wheel) diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el index 333cfa51695..8135d40d261 100644 --- a/lisp/textmodes/bibtex.el +++ b/lisp/textmodes/bibtex.el @@ -2215,6 +2215,7 @@ Point must be at beginning of preamble. Do not move point." (defsubst bibtex-string= (str1 str2) "Return t if STR1 and STR2 are equal, ignoring case." + (declare (obsolete string-equal-ignore-case "29.1")) (eq t (compare-strings str1 0 nil str2 0 nil t))) (defun bibtex-delete-whitespace () @@ -2657,7 +2658,7 @@ Formats current entry according to variable `bibtex-entry-format'." ;; update page dashes (if (and (memq 'page-dashes format) - (bibtex-string= field-name "pages") + (string-equal-ignore-case field-name "pages") (progn (goto-char beg-text) (looking-at "\\([\"{][0-9]+\\)[ \t\n]*--?[ \t\n]*\\([0-9]+[\"}]\\)"))) @@ -2710,7 +2711,7 @@ Formats current entry according to variable `bibtex-entry-format'." ;; use book title of crossref'd entry (if (and (memq 'inherit-booktitle format) empty-field - (bibtex-string= field-name "booktitle") + (string-equal-ignore-case field-name "booktitle") crossref-key) (let ((title (save-excursion (save-restriction @@ -3503,7 +3504,7 @@ If NO-BUTTON is non-nil do not generate buttons." (let ((lst bibtex-generate-url-list) url) (while (and (not found) (setq url (car (pop lst)))) (goto-char start) - (setq found (and (bibtex-string= name (car url)) + (setq found (and (string-equal-ignore-case name (car url)) (re-search-forward (cdr url) end t)))))) (unless found (goto-char end))) (if (and found (not no-button)) @@ -3954,7 +3955,7 @@ entry (for example, the year parts of the keys)." (goto-char (1- (match-beginning 0))) (bibtex-beginning-of-entry) (if (and (looking-at bibtex-entry-head) - (bibtex-string= type (bibtex-type-in-head)) + (string-equal-ignore-case type (bibtex-type-in-head)) ;; In case we found ourselves :-( (not (equal key (setq tmp (bibtex-key-in-head))))) (setq other-key tmp @@ -3963,7 +3964,7 @@ entry (for example, the year parts of the keys)." (bibtex-end-of-entry) (bibtex-skip-to-valid-entry) (if (and (looking-at bibtex-entry-head) - (bibtex-string= type (bibtex-type-in-head)) + (string-equal-ignore-case type (bibtex-type-in-head)) ;; In case we found ourselves :-( (not (equal key (setq tmp (bibtex-key-in-head)))) (or (not other-key) @@ -4004,9 +4005,9 @@ interactive calls." (interactive (list nil t)) (unless field (setq field (car (bibtex-find-text-internal nil nil comma)))) (if (string-search "@" field) - (cond ((bibtex-string= field "@string") + (cond ((string-equal-ignore-case field "@string") (message "String definition")) - ((bibtex-string= field "@preamble") + ((string-equal-ignore-case field "@preamble") (message "Preamble definition")) (t (message "Entry key"))) (let* ((case-fold-search t) @@ -4588,7 +4589,7 @@ Return t if test was successful, nil otherwise." bounds field idx) (while (setq bounds (bibtex-parse-field)) (let ((field-name (bibtex-name-in-field bounds))) - (if (and (bibtex-string= field-name "month") + (if (and (string-equal-ignore-case field-name "month") ;; Check only abbreviated month fields. (let ((month (bibtex-text-in-field-bounds bounds))) (not (or (string-match "\\`[\"{].+[\"}]\\'" month) @@ -4669,7 +4670,7 @@ Return t if test was successful, nil otherwise." (while (re-search-forward bibtex-entry-head nil t) (setq entry-type (bibtex-type-in-head) key (bibtex-key-in-head)) - (if (or (and strings (bibtex-string= entry-type "string")) + (if (or (and strings (string-equal-ignore-case entry-type "string")) (assoc-string entry-type bibtex-entry-alist t)) (if (member key key-list) (push (format-message @@ -5046,10 +5047,10 @@ At end of the cleaning process, the functions in (user-error "Not inside a BibTeX entry"))) (entry-type (bibtex-type-in-head)) (key (bibtex-key-in-head))) - (cond ((bibtex-string= entry-type "preamble") + (cond ((string-equal-ignore-case entry-type "preamble") ;; (bibtex-format-preamble) (user-error "No clean up of @Preamble entries")) - ((bibtex-string= entry-type "string") + ((string-equal-ignore-case entry-type "string") (setq entry-type 'string)) ;; (bibtex-format-string) (t (bibtex-format-entry))) @@ -5326,10 +5327,10 @@ entries from minibuffer." (>= pnt (bibtex-start-of-text-in-field bounds)) (<= pnt (bibtex-end-of-text-in-field bounds))) (setq name (bibtex-name-in-field bounds t) - compl (cond ((bibtex-string= name "crossref") + compl (cond ((string-equal-ignore-case name "crossref") ;; point is in crossref field 'crossref-key) - ((bibtex-string= name "month") + ((string-equal-ignore-case name "month") ;; point is in month field bibtex-predefined-month-strings) ;; point is in other field @@ -5488,7 +5489,7 @@ Return the URL or nil if none can be generated." (while (and (not url) (setq scheme (pop lst))) ;; Verify the match of `bibtex-font-lock-url' by ;; comparing with TEXT. - (when (and (bibtex-string= (caar scheme) name) + (when (and (string-equal-ignore-case (caar scheme) name) (string-match (cdar scheme) text)) (setq url t scheme (cdr scheme))))))) diff --git a/lisp/textmodes/sgml-mode.el b/lisp/textmodes/sgml-mode.el index 8f9b603ef5f..ba0a94b4a1f 100644 --- a/lisp/textmodes/sgml-mode.el +++ b/lisp/textmodes/sgml-mode.el @@ -1536,8 +1536,7 @@ not the case, the first tag returned is the one inside which we are." ;; [ Well, actually it depends, but we don't have the info about ;; when it doesn't and when it does. --Stef ] (setq ignore nil))) - ((eq t (compare-strings (sgml-tag-name tag-info) nil nil - (car stack) nil nil t)) + ((string-equal-ignore-case (sgml-tag-name tag-info) (car stack)) (setq stack (cdr stack))) (t ;; The open and close tags don't match. @@ -1549,9 +1548,8 @@ not the case, the first tag returned is the one inside which we are." ;; but it's a bad assumption when tags *are* closed but ;; not properly nested. (while (and (cdr tmp) - (not (eq t (compare-strings - (sgml-tag-name tag-info) nil nil - (cadr tmp) nil nil t)))) + (not (string-equal-ignore-case + (sgml-tag-name tag-info) (cadr tmp)))) (setq tmp (cdr tmp))) (if (cdr tmp) (setcdr tmp (cddr tmp))))) (message "Unmatched tags <%s> and </%s>" @@ -1701,9 +1699,8 @@ LCON is the lexical context, if any." (there (point))) ;; Ignore previous unclosed start-tag in context. (while (and context unclosed - (eq t (compare-strings - (sgml-tag-name (car context)) nil nil - unclosed nil nil t))) + (string-equal-ignore-case + (sgml-tag-name (car context)) unclosed)) (setq context (cdr context))) ;; Indent to reflect nesting. (cond diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el index d34133f8564..e6c0f8c28c0 100644 --- a/lisp/textmodes/tex-mode.el +++ b/lisp/textmodes/tex-mode.el @@ -2496,10 +2496,8 @@ Only applies the FSPEC to the args part of FORMAT." (let (shell-dirtrack-verbose) (tex-send-command tex-shell-cd-command dir))) (with-current-buffer (process-buffer (tex-send-command cmd)) - (setq compilation-last-buffer (current-buffer)) - (compilation-forget-errors) - ;; Don't parse previous compilations. - (set-marker compilation-parsing-end (1- (point-max)))) + (setq next-error-last-buffer (current-buffer)) + (compilation-forget-errors)) (tex-display-shell) (setq tex-last-buffer-texed (current-buffer))) diff --git a/lisp/url/url-file.el b/lisp/url/url-file.el index 3863ac99144..99e62d9b7a2 100644 --- a/lisp/url/url-file.el +++ b/lisp/url/url-file.el @@ -42,10 +42,10 @@ src=\"/ssh:host...\"> element, which can be disturbing.") (defun url-file-find-possibly-compressed-file (fname &rest _) "Find the exact file referenced by `fname'. This tries the common compression extensions, because things like -ange-ftp and efs are not quite smart enough to realize when a server -can do automatic decompression for them, and won't find `foo' if -`foo.gz' exists, even though the FTP server would happily serve it up -to them." +ange-ftp is not quite smart enough to realize when a server can +do automatic decompression for them, and won't find `foo' if +`foo.gz' exists, even though the FTP server would happily serve +it up to them." (let ((scratch nil) (compressed-extensions '("" ".gz" ".z" ".Z" ".bz2" ".xz")) (found nil)) diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 30ba4153a9e..aa426446d73 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -147,6 +147,12 @@ and hunk-based syntax highlighting otherwise as a fallback." (const :tag "Highlight syntax" t) (const :tag "Allow hunk-based fallback" hunk-also))) +(defcustom diff-whitespace-style '(face trailing) + "Specify `whitespace-style' variable for `diff-mode' buffers." + :require 'whitespace + :type (get 'whitespace-style 'custom-type) + :version "29.1") + (defvar diff-vc-backend nil "The VC backend that created the current Diff buffer, if any.") @@ -1476,9 +1482,6 @@ See `after-change-functions' for the meaning of BEG, END and LEN." ;; Added when diff--font-lock-prettify is non-nil! (cl-pushnew 'display font-lock-extra-managed-props))) -(defvar whitespace-style) -(defvar whitespace-trailing-regexp) - (defvar-local diff-mode-read-only nil "Non-nil when read-only diff buffer uses short keys.") @@ -1487,6 +1490,9 @@ See `after-change-functions' for the meaning of BEG, END and LEN." (nconc minor-mode-map-alist (list (cons 'diff-mode-read-only diff-mode-shared-map)))) +(defvar whitespace-style) +(defvar whitespace-trailing-regexp) + ;;;###autoload (define-derived-mode diff-mode fundamental-mode "Diff" "Major mode for viewing/editing context diffs. @@ -1572,7 +1578,7 @@ a diff with \\[diff-reverse-direction]. This sets `whitespace-style' and `whitespace-trailing-regexp' so that Whitespace mode shows trailing whitespace problems on the modified lines of the diff." - (setq-local whitespace-style '(face trailing)) + (setq-local whitespace-style diff-whitespace-style) (let ((style (save-excursion (goto-char (point-min)) ;; FIXME: For buffers filled from async processes, this search diff --git a/lisp/vc/vc-dispatcher.el b/lisp/vc/vc-dispatcher.el index 5c664d58f1a..e2a490092b5 100644 --- a/lisp/vc/vc-dispatcher.el +++ b/lisp/vc/vc-dispatcher.el @@ -636,23 +636,23 @@ NOT-URGENT means it is ok to continue if the user says not to save." (and (local-variable-p 'vc-log-fileset) (not (equal vc-log-fileset fileset)))) `((log-edit-listfun - . (lambda () - ;; FIXME: When fileset includes directories, and - ;; there are relevant ChangeLog files inside their - ;; children, we don't find them. Either handle it - ;; in `log-edit-insert-changelog-entries' by - ;; walking down the file trees, or somehow pass - ;; `fileset-only-files' from `vc-next-action' - ;; through to this function. - (let ((root (vc-root-dir))) - ;; Returns paths relative to the root, so that - ;; `log-edit-changelog-insert-entries' - ;; substitutes them in correctly later, even when - ;; `vc-checkin' was called from a file buffer, or - ;; a non-root VC-Dir buffer. - (mapcar - (lambda (file) (file-relative-name file root)) - ',fileset)))) + . ,(lambda () + ;; FIXME: When fileset includes directories, and + ;; there are relevant ChangeLog files inside their + ;; children, we don't find them. Either handle it + ;; in `log-edit-insert-changelog-entries' by + ;; walking down the file trees, or somehow pass + ;; `fileset-only-files' from `vc-next-action' + ;; through to this function. + (let ((root (vc-root-dir))) + ;; Returns paths relative to the root, so that + ;; `log-edit-changelog-insert-entries' + ;; substitutes them in correctly later, even when + ;; `vc-checkin' was called from a file buffer, or + ;; a non-root VC-Dir buffer. + (mapcar + (lambda (file) (file-relative-name file root)) + fileset)))) (log-edit-diff-function . vc-diff) (log-edit-vc-backend . ,backend) (vc-log-fileset . ,fileset)) @@ -761,8 +761,7 @@ the buffer contents as a comment." ;; (while (and (not member) fileset) ;; (let ((elem (pop fileset))) ;; (if (if (file-directory-p elem) -;; (eq t (compare-strings buffer-file-name nil (length elem) -;; elem nil nil)) +;; (string-prefix-p elem buffer-file-name) ;; (eq (current-buffer) (get-file-buffer elem))) ;; (setq member t)))) ;; member)) diff --git a/lisp/wid-browse.el b/lisp/wid-browse.el index e71e8cd4935..7fc476e5dfd 100644 --- a/lisp/wid-browse.el +++ b/lisp/wid-browse.el @@ -1,6 +1,6 @@ ;;; wid-browse.el --- functions for browsing widgets -*- lexical-binding: t -*- -;; Copyright (C) 1997, 2001-2022 Free Software Foundation, Inc. +;; Copyright (C) 1997-2022 Free Software Foundation, Inc. ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> ;; Keywords: extensions @@ -118,13 +118,6 @@ The following commands are available: (switch-to-buffer (get-buffer-create "*Browse Widget*"))) (widget-browse-mode) - ;; Quick way to get out. -;; (widget-create 'push-button -;; :action (lambda (widget &optional event) -;; (bury-buffer)) -;; "Quit") -;; (widget-insert "\n") - ;; Top text indicating whether it is a class or object browser. (if (listp widget) (widget-insert "Widget object browser.\n\nClass: ") diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el index a06563946c6..bdfe444bc1d 100644 --- a/lisp/x-dnd.el +++ b/lisp/x-dnd.el @@ -194,7 +194,8 @@ any protocol specific data.") (defun x-dnd-init-frame (&optional frame) "Setup drag and drop for FRAME (i.e. create appropriate properties)." - (when (eq 'x (window-system frame)) + (when (and (eq 'x (window-system frame)) + (not (frame-parameter frame 'tooltip))) (let ((x-fast-protocol-requests (not x-dnd-debug-errors))) (x-register-dnd-atom "DndProtocol" frame) (x-register-dnd-atom "_MOTIF_DRAG_AND_DROP_MESSAGE" frame) @@ -707,7 +708,6 @@ MODS is a single symbol, or a list of symbols such as `shift' or (unless (consp mods) (setq mods (list mods))) (dolist (modifier mods) - ;; TODO: handle virtual modifiers such as Meta and Hyper. (cond ((eq modifier 'shift) (setq mask (logior mask 1))) ; ShiftMask ((eq modifier 'control) @@ -722,15 +722,27 @@ MODS is a single symbol, or a list of symbols such as `shift' or (setq mask (nth 2 virtual-modifiers))))) mask)) -(defun x-dnd-hscroll-flags () - "Return the event state of a button press that should result in hscroll. -Value is a mask of all the X modifier states that would normally -cause a button press event to perform horizontal scrolling." - (let ((i 0)) - (dolist (modifier mouse-wheel-scroll-amount) - (when (eq (cdr-safe modifier) 'hscroll) - (setq i (logior i (x-dnd-modifier-mask (car modifier)))))) - i)) +(defun x-dnd-get-modifiers () + "Obtain an X modifier mask containing all modifiers. +Value is an X modifier mask containing all modifiers that can +modify an Emacs keyboard or mouse event." + (let ((mods (x-get-modifier-masks)) + (mask 5)) ; ShiftMask | ControlMask + (dolist (mod mods) + (setq mask (logior mask mod))) + mask)) + +(defun x-dnd-wheel-modifier-type (flags) + "Return the modifier type of an X modifier mask. +FLAGS is the X modifier mask of a turn of the mouse wheel." + (let ((modifiers (x-dnd-get-modifiers))) + (catch 'type + (dolist (modifier mouse-wheel-scroll-amount) + (when (and (consp modifier) + (eq (x-dnd-modifier-mask (car modifier)) + (logand flags modifiers))) + (throw 'type (cdr modifier)))) + nil))) (defvar x-dnd-click-count nil "Alist of button numbers to click counters during drag-and-drop. @@ -760,19 +772,23 @@ Use MODIFIERS, an X modifier mask, to determine if any alternative operation (such as scrolling horizontally) should be taken. COUNT is the number of times in quick succession BUTTON has been pressed." - (let ((hscroll (not (zerop (logand modifiers - (x-dnd-hscroll-flags))))) - (amt (or (and (not mouse-wheel-progressive-speed) 1) - (* 1 count)))) + (let* ((type (x-dnd-wheel-modifier-type modifiers)) + (hscroll (eq type 'hscroll)) + (amt (or (and (not mouse-wheel-progressive-speed) 1) + (* 1 count)))) (unless (and (not mouse-wheel-tilt-scroll) (or (eq button 6) (eq button 7))) - (let ((function (cond ((eq button 4) + (let ((function (cond ((eq type 'text-scale) + #'text-scale-adjust) + ((eq type 'global-text-scale) + #'global-text-scale-adjust) + ((eq button 4) (if hscroll - mwheel-scroll-left-function + mwheel-scroll-right-function mwheel-scroll-down-function)) ((eq button 5) (if hscroll - mwheel-scroll-right-function + mwheel-scroll-left-function mwheel-scroll-up-function)) ((eq button 6) (if mouse-wheel-flip-direction @@ -782,9 +798,17 @@ has been pressed." (if mouse-wheel-flip-direction mwheel-scroll-left-function mwheel-scroll-right-function))))) + ;; Button5 should decrease the text scale, not increase it. + (when (and (memq type '(text-scale global-text-scale)) + (eq button 5)) + (setq amt (- amt))) (when function (condition-case nil - (funcall function amt) + ;; Don't overwrite any echo-area message that might + ;; already be shown, since this can be called from + ;; `x-begin-drag'. + (let ((inhibit-message t)) + (funcall function amt)) ;; Do not error at buffer limits. Show a message instead. ;; This is especially important here because signalling an ;; error will mess up the drag-and-drop operation. @@ -1417,6 +1441,11 @@ ACTION is the action given to `x-begin-drag'." (defvar x-dnd-disable-motif-protocol) (defvar x-dnd-use-unsupported-drop) +(defvar x-dnd-xds-testing nil + "Whether or not XDS is being tested from ERT. +When non-nil, throw errors from the `XdndDirectSave0' converters +instead of returning \"E\".") + (defun x-dnd-handle-direct-save (_selection _type _value) "Handle a selection request for `XdndDirectSave'." (setq x-dnd-xds-performed t) @@ -1431,15 +1460,24 @@ ACTION is the action given to `x-begin-drag'." (dnd-get-local-file-name local-file-uri)))) (if (not local-name) '(STRING . "F") - (condition-case nil - (progn + ;; We want errors to be signalled immediately during ERT + ;; testing, instead of being silently handled. (bug#56712) + (if x-dnd-xds-testing + (prog1 '(STRING . "S") (copy-file x-dnd-xds-current-file local-name t) (when (equal x-dnd-xds-current-file dnd-last-dragged-remote-file) (dnd-remove-last-dragged-remote-file))) - (:success '(STRING . "S")) - (error '(STRING . "E")))))) + (condition-case nil + (progn + (copy-file x-dnd-xds-current-file + local-name t) + (when (equal x-dnd-xds-current-file + dnd-last-dragged-remote-file) + (dnd-remove-last-dragged-remote-file))) + (:success '(STRING . "S")) + (error '(STRING . "E"))))))) (defun x-dnd-handle-octet-stream (_selection _type _value) "Handle a selecton request for `application/octet-stream'. diff --git a/src/buffer.c b/src/buffer.c index a55af906e26..a07194aef72 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -6430,11 +6430,13 @@ will run for `clone-indirect-buffer' calls as well. */); Vclone_indirect_buffer_hook = Qnil; DEFVAR_LISP ("long-line-threshold", Vlong_line_threshold, - doc: /* Line length above which specific display optimizations are used. -Display optimizations for long lines will automatically be enabled in -buffers which contain one or more lines whose length is above that -threshold. -When nil, these display optimizations are disabled. */); + doc: /* Line length above which to use redisplay shortcuts. +The value should be a positive integer or nil. +If the value is an integer, shortcuts in the display code intended +to speed up redisplay for long lines will automatically be enabled +in buffers which contain one or more lines whose length is above +this threshold. +If nil, these display shortcuts will always remain disabled. */); XSETFASTINT (Vlong_line_threshold, 10000); defsubr (&Sbuffer_live_p); diff --git a/src/haiku_support.cc b/src/haiku_support.cc index 098739cd98b..b7590f68a48 100644 --- a/src/haiku_support.cc +++ b/src/haiku_support.cc @@ -1496,7 +1496,6 @@ public: class EmacsView : public BView { public: - uint32_t previous_buttons; int looper_locked_count; BRegion sb_region; BRegion invalid_region; @@ -1512,10 +1511,10 @@ public: #endif BMessage *wait_for_release_message; + int64 grabbed_buttons; EmacsView () : BView (BRect (0, 0, 0, 0), "Emacs", B_FOLLOW_NONE, B_WILL_DRAW), - previous_buttons (0), looper_locked_count (0), offscreen_draw_view (NULL), offscreen_draw_bitmap_1 (NULL), @@ -1524,7 +1523,8 @@ public: cr_surface (NULL), cr_context (NULL), #endif - wait_for_release_message (NULL) + wait_for_release_message (NULL), + grabbed_buttons (0) { } @@ -1826,42 +1826,51 @@ public: } void - BasicMouseDown (BPoint point, BView *scroll_bar) + BasicMouseDown (BPoint point, BView *scroll_bar, BMessage *message) { struct haiku_button_event rq; - uint32 mods, buttons; + int64 when; + int32 mods, buttons, button; - this->GetMouse (&point, &buttons, false); + if (message->FindInt64 ("when", &when) != B_OK + || message->FindInt32 ("modifiers", &mods) != B_OK + || message->FindInt32 ("buttons", &buttons) != B_OK) + return; - if (!grab_view_locker.Lock ()) - gui_abort ("Couldn't lock grab view locker"); - if (buttons) - grab_view = this; - grab_view_locker.Unlock (); + /* Find which button was pressed by comparing the previous button + mask to the current one. This assumes that B_MOUSE_DOWN will + be sent for each button press. */ + button = buttons & ~grabbed_buttons; + grabbed_buttons = buttons; + + if (!scroll_bar) + { + if (!grab_view_locker.Lock ()) + gui_abort ("Couldn't lock grab view locker"); + grab_view = this; + grab_view_locker.Unlock (); + } rq.window = this->Window (); rq.scroll_bar = scroll_bar; - if (!(previous_buttons & B_PRIMARY_MOUSE_BUTTON) - && (buttons & B_PRIMARY_MOUSE_BUTTON)) + if (button == B_PRIMARY_MOUSE_BUTTON) rq.btn_no = 0; - else if (!(previous_buttons & B_SECONDARY_MOUSE_BUTTON) - && (buttons & B_SECONDARY_MOUSE_BUTTON)) + else if (button == B_SECONDARY_MOUSE_BUTTON) rq.btn_no = 2; - else if (!(previous_buttons & B_TERTIARY_MOUSE_BUTTON) - && (buttons & B_TERTIARY_MOUSE_BUTTON)) + else if (button == B_TERTIARY_MOUSE_BUTTON) rq.btn_no = 1; else + /* We don't know which button was pressed. This usually happens + when a B_MOUSE_UP is sent to a view that didn't receive a + corresponding B_MOUSE_DOWN event, so simply ignore the + message. */ return; - previous_buttons = buttons; - rq.x = point.x; rq.y = point.y; - - mods = modifiers (); - rq.modifiers = 0; + if (mods & B_SHIFT_KEY) rq.modifiers |= HAIKU_MODIFIER_SHIFT; @@ -1878,62 +1887,76 @@ public: SetMouseEventMask (B_POINTER_EVENTS, (B_LOCK_WINDOW_FOCUS | B_NO_POINTER_HISTORY)); - rq.time = system_time (); + rq.time = when; haiku_write (BUTTON_DOWN, &rq); } void MouseDown (BPoint point) { - BasicMouseDown (point, NULL); + BMessage *msg; + BLooper *looper; + + looper = Looper (); + msg = (looper + ? looper->CurrentMessage () + : NULL); + + if (msg) + BasicMouseDown (point, NULL, msg); } void - BasicMouseUp (BPoint point, BView *scroll_bar) + BasicMouseUp (BPoint point, BView *scroll_bar, BMessage *message) { struct haiku_button_event rq; - uint32 buttons, mods; + int64 when; + int32 mods, button, buttons; - this->GetMouse (&point, &buttons, false); + if (message->FindInt64 ("when", &when) != B_OK + || message->FindInt32 ("modifiers", &mods) != B_OK + || message->FindInt32 ("buttons", &buttons) != B_OK) + return; - if (!grab_view_locker.Lock ()) - gui_abort ("Couldn't lock grab view locker"); - if (!buttons) - grab_view = NULL; - grab_view_locker.Unlock (); + if (!scroll_bar) + { + if (!grab_view_locker.Lock ()) + gui_abort ("Couldn't lock grab view locker"); + if (!buttons) + grab_view = NULL; + grab_view_locker.Unlock (); + } - if (!buttons && wait_for_release_message) + button = (grabbed_buttons & ~buttons); + grabbed_buttons = buttons; + + if (wait_for_release_message) { - wait_for_release_message->SendReply (wait_for_release_message); - delete wait_for_release_message; - wait_for_release_message = NULL; + if (!grabbed_buttons) + { + wait_for_release_message->SendReply (wait_for_release_message); + delete wait_for_release_message; + wait_for_release_message = NULL; + } - previous_buttons = buttons; return; } rq.window = this->Window (); rq.scroll_bar = scroll_bar; - if ((previous_buttons & B_PRIMARY_MOUSE_BUTTON) - && !(buttons & B_PRIMARY_MOUSE_BUTTON)) + if (button == B_PRIMARY_MOUSE_BUTTON) rq.btn_no = 0; - else if ((previous_buttons & B_SECONDARY_MOUSE_BUTTON) - && !(buttons & B_SECONDARY_MOUSE_BUTTON)) + else if (button == B_SECONDARY_MOUSE_BUTTON) rq.btn_no = 2; - else if ((previous_buttons & B_TERTIARY_MOUSE_BUTTON) - && !(buttons & B_TERTIARY_MOUSE_BUTTON)) + else if (button == B_TERTIARY_MOUSE_BUTTON) rq.btn_no = 1; else return; - previous_buttons = buttons; - rq.x = point.x; rq.y = point.y; - mods = modifiers (); - rq.modifiers = 0; if (mods & B_SHIFT_KEY) rq.modifiers |= HAIKU_MODIFIER_SHIFT; @@ -1947,14 +1970,23 @@ public: if (mods & B_OPTION_KEY) rq.modifiers |= HAIKU_MODIFIER_SUPER; - rq.time = system_time (); + rq.time = when; haiku_write (BUTTON_UP, &rq); } void MouseUp (BPoint point) { - BasicMouseUp (point, NULL); + BMessage *msg; + BLooper *looper; + + looper = Looper (); + msg = (looper + ? looper->CurrentMessage () + : NULL); + + if (msg) + BasicMouseUp (point, NULL, msg); } }; @@ -1967,8 +1999,9 @@ public: float old_value; scroll_bar_info info; - /* True if button events should be passed to the parent. */ - bool handle_button; + /* How many button events were passed to the parent without + release. */ + int handle_button_count; bool in_overscroll; bool can_overscroll; bool maybe_overscroll; @@ -1984,7 +2017,7 @@ public: : BScrollBar (BRect (x, y, x1, y1), NULL, NULL, 0, 0, horizontal_p ? B_HORIZONTAL : B_VERTICAL), dragging (0), - handle_button (false), + handle_button_count (0), in_overscroll (false), can_overscroll (false), maybe_overscroll (false), @@ -2208,10 +2241,10 @@ public: && mods & B_CONTROL_KEY) { /* Allow C-mouse-3 to split the window on a scroll bar. */ - handle_button = true; + handle_button_count += 1; SetMouseEventMask (B_POINTER_EVENTS, (B_SUSPEND_VIEW_FOCUS | B_LOCK_WINDOW_FOCUS)); - parent->BasicMouseDown (ConvertToParent (pt), this); + parent->BasicMouseDown (ConvertToParent (pt), this, message); return; } @@ -2274,14 +2307,23 @@ public: MouseUp (BPoint pt) { struct haiku_scroll_bar_drag_event rq; + BMessage *msg; + BLooper *looper; in_overscroll = false; maybe_overscroll = false; - if (handle_button) + if (handle_button_count) { - handle_button = false; - parent->BasicMouseUp (ConvertToParent (pt), this); + handle_button_count--; + looper = Looper (); + msg = (looper + ? looper->CurrentMessage () + : NULL); + + if (msg) + parent->BasicMouseUp (ConvertToParent (pt), + this, msg); return; } @@ -5418,3 +5460,17 @@ be_get_explicit_workarea (int *x, int *y, int *width, int *height) return true; } + +/* Clear the grab view. This has to be called manually from some + places, since we don't get B_MOUSE_UP messages after a popup menu + is run. */ + +void +be_clear_grab_view (void) +{ + if (grab_view_locker.Lock ()) + { + grab_view = NULL; + grab_view_locker.Unlock (); + } +} diff --git a/src/haiku_support.h b/src/haiku_support.h index 5577d2f151f..76fe071f2c9 100644 --- a/src/haiku_support.h +++ b/src/haiku_support.h @@ -727,6 +727,7 @@ extern void be_set_window_fullscreen_mode (void *, enum haiku_fullscreen_mode); extern void be_lock_window (void *); extern void be_unlock_window (void *); extern bool be_get_explicit_workarea (int *, int *, int *, int *); +extern void be_clear_grab_view (void); #ifdef __cplusplus } diff --git a/src/haikufns.c b/src/haikufns.c index 67f79a31669..f3667ac2f9d 100644 --- a/src/haikufns.c +++ b/src/haikufns.c @@ -2405,7 +2405,6 @@ DEFUN ("x-show-tip", Fx_show_tip, Sx_show_tip, 1, 6, 0, if (!NILP (tip_frame) && FRAME_LIVE_P (XFRAME (tip_frame))) { if (FRAME_VISIBLE_P (XFRAME (tip_frame)) - && EQ (frame, tip_last_frame) && !NILP (Fequal_including_properties (tip_last_string, string)) && !NILP (Fequal (tip_last_parms, parms))) { diff --git a/src/haikumenu.c b/src/haikumenu.c index 929ed952105..69bb56c124e 100644 --- a/src/haikumenu.c +++ b/src/haikumenu.c @@ -432,6 +432,11 @@ haiku_menu_show (struct frame *f, int x, int y, int menuflags, FRAME_DISPLAY_INFO (f)->grabbed = 0; + /* Clear the grab view manually. There is a race condition here if + the window thread receives a button press between here and the + end of BMenu_run. */ + be_clear_grab_view (); + if (menu_item_selection) { prefix = entry = Qnil; diff --git a/src/haikuselect.c b/src/haikuselect.c index 268d8b1ec92..7eb93a2754d 100644 --- a/src/haikuselect.c +++ b/src/haikuselect.c @@ -1062,8 +1062,9 @@ haiku_note_drag_wheel (struct input_event *ie) if (!NILP (Vhaiku_drag_wheel_function) && (haiku_dnd_allow_same_frame || XFRAME (ie->frame_or_window) != haiku_dnd_frame)) - safe_call (6, Vhaiku_drag_wheel_function, ie->frame_or_window, - ie->x, ie->y, horizontal ? Qt : Qnil, up ? Qt : Qnil); + safe_call (7, Vhaiku_drag_wheel_function, ie->frame_or_window, + ie->x, ie->y, horizontal ? Qt : Qnil, up ? Qt : Qnil, + make_int (ie->modifiers)); redisplay_preserve_echo_area (35); } @@ -1149,12 +1150,12 @@ These are only called if a connection to the Haiku display was opened. */); DEFVAR_LISP ("haiku-drag-wheel-function", Vhaiku_drag_wheel_function, doc: /* Function called upon wheel movement while dragging a message. -If non-nil, it is called with 5 arguments when the mouse wheel moves +If non-nil, it is called with 6 arguments when the mouse wheel moves while a drag-and-drop operation is in progress: the frame where the mouse moved, the frame-relative X and Y positions where the mouse -moved, whether or not the wheel movement was horizontal, and whether -or not the wheel moved up (or left, if the movement was -horizontal). */); +moved, whether or not the wheel movement was horizontal, whether or +not the wheel moved up (or left, if the movement was horizontal), and +keyboard modifiers currently held down. */); Vhaiku_drag_wheel_function = Qnil; DEFSYM (QSECONDARY, "SECONDARY"); diff --git a/src/haikuterm.c b/src/haikuterm.c index 7630d9c103c..f2bee1263d3 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -3365,6 +3365,7 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) if (b->just_exited_p) { Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (f); + if (f == hlinfo->mouse_face_mouse_frame) { /* If we move outside the frame, then we're @@ -3375,6 +3376,9 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) haiku_flush_dirty_back_buffer_on (f); } + if (f == x_display_list->last_mouse_glyph_frame) + x_display_list->last_mouse_glyph_frame = NULL; + if (f->auto_lower && !popup_activated_p /* Don't do this if the mouse entered a scroll bar. */ && !BView_inside_scroll_bar (FRAME_HAIKU_VIEW (f), diff --git a/src/lisp.h b/src/lisp.h index 2afe135674d..8fcc9b6e75a 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3146,7 +3146,7 @@ CHECK_NUMBER (Lisp_Object x) INLINE void CHECK_INTEGER (Lisp_Object x) { - CHECK_TYPE (INTEGERP (x), Qnumberp, x); + CHECK_TYPE (INTEGERP (x), Qintegerp, x); } INLINE void diff --git a/src/nsfns.m b/src/nsfns.m index b0b779bd41c..433df059610 100644 --- a/src/nsfns.m +++ b/src/nsfns.m @@ -3292,7 +3292,6 @@ DEFUN ("x-show-tip", Fx_show_tip, Sx_show_tip, 1, 6, 0, if (!NILP (tip_frame) && FRAME_LIVE_P (XFRAME (tip_frame))) { if (FRAME_VISIBLE_P (XFRAME (tip_frame)) - && EQ (frame, tip_last_frame) && !NILP (Fequal_including_properties (tip_last_string, string)) && !NILP (Fequal (tip_last_parms, parms))) { diff --git a/src/nsterm.m b/src/nsterm.m index 57f1f44de26..e3f47eb905e 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -3108,14 +3108,9 @@ ns_draw_window_cursor (struct window *w, struct glyph_row *glyph_row, ns_focus (f, &r, 1); break; case HOLLOW_BOX_CURSOR: - [ctx restoreGraphicsState]; - ns_unfocus (f); - draw_phys_cursor_glyph (w, glyph_row, DRAW_NORMAL_TEXT); - ns_focus (f, &r, 1); - [FRAME_CURSOR_COLOR (f) set]; - /* This works like it does in PostScript, not X Windows. */ [NSBezierPath strokeRect: NSInsetRect (r, 0.5, 0.5)]; + [ctx restoreGraphicsState]; break; case HBAR_CURSOR: NSRectFill (r); @@ -3998,42 +3993,104 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r) static void -ns_dumpglyphs_stretch (struct glyph_string *s) +ns_draw_stretch_glyph_string (struct glyph_string *s) { - NSRect glyphRect; - struct face *face = s->face; - NSColor *fgCol, *bgCol; + struct face *face; - if (!s->background_filled_p) + if (s->hl == DRAW_CURSOR + && !x_stretch_cursor_p) { + /* If `x-stretch-cursor' is nil, don't draw a block cursor as + wide as the stretch glyph. */ + int width, background_width = s->background_width; + int x = s->x; - face = s->face; + if (!s->row->reversed_p) + { + int left_x = window_box_left_offset (s->w, TEXT_AREA); - bgCol = [NSColor colorWithUnsignedLong:NS_FACE_BACKGROUND (face)]; - fgCol = [NSColor colorWithUnsignedLong:NS_FACE_FOREGROUND (face)]; + if (x < left_x) + { + background_width -= left_x - x; + x = left_x; + } + } + else + { + /* In R2L rows, draw the cursor on the right edge of the + stretch glyph. */ + int right_x = window_box_right (s->w, TEXT_AREA); + + if (x + background_width > right_x) + background_width -= x - right_x; + x += background_width; + } + + width = min (FRAME_COLUMN_WIDTH (s->f), background_width); + if (s->row->reversed_p) + x -= width; if (s->hl == DRAW_CURSOR) + [FRAME_CURSOR_COLOR (s->f) set]; + else + [[NSColor colorWithUnsignedLong: s->face->foreground] set]; + + NSRectFill (NSMakeRect (x, s->y, width, s->height)); + + /* Clear rest using the GC of the original non-cursor face. */ + if (width < background_width) { - fgCol = bgCol; - bgCol = FRAME_CURSOR_COLOR (s->f); - } + int y = s->y; + int w = background_width - width, h = s->height; - glyphRect = NSMakeRect (s->x, s->y, s->background_width, s->height); + if (!s->row->reversed_p) + x += width; + else + x = s->x; - [bgCol set]; + if (s->row->mouse_face_p + && cursor_in_mouse_face_p (s->w)) + { + face = FACE_FROM_ID_OR_NULL (s->f, + MOUSE_HL_INFO (s->f)->mouse_face_face_id); + + if (!s->face) + face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); + prepare_face_for_display (s->f, face); - NSRectFill (glyphRect); + [[NSColor colorWithUnsignedLong: face->background] set]; + } + else + [[NSColor colorWithUnsignedLong: s->face->background] set]; + NSRectFill (NSMakeRect (x, y, w, h)); + } + } + else if (!s->background_filled_p) + { + int background_width = s->background_width; + int x = s->x, text_left_x = window_box_left (s->w, TEXT_AREA); - /* Draw overlining, etc. on the stretch glyph (or the part of - the stretch glyph after the cursor). If the glyph has a box, - then decorations will be drawn after drawing the box in - ns_draw_glyph_string, in order to prevent them from being - overwritten by the box. */ - if (s->face->box == FACE_NO_BOX) - ns_draw_text_decoration (s, face, fgCol, NSWidth (glyphRect), - NSMinX (glyphRect)); + /* Don't draw into left fringe or scrollbar area except for + header line and mode line. */ + if (s->area == TEXT_AREA + && x < text_left_x && !s->row->mode_line_p) + { + background_width -= text_left_x - x; + x = text_left_x; + } - s->background_filled_p = 1; + if (!s->row->stipple_p) + s->row->stipple_p = s->stippled_p; + + if (background_width > 0) + { + if (s->hl == DRAW_CURSOR) + [FRAME_CURSOR_COLOR (s->f) set]; + else + [[NSColor colorWithUnsignedLong: s->face->background] set]; + + NSRectFill (NSMakeRect (x, s->y, background_width, s->height)); + } } } @@ -4255,13 +4312,9 @@ ns_draw_glyph_string (struct glyph_string *s) n = ns_get_glyph_string_clip_rect (s->next, r); ns_focus (s->f, r, n); if (next->first_glyph->type != STRETCH_GLYPH) - { - ns_maybe_dumpglyphs_background (s->next, 1); - } - else - { - ns_dumpglyphs_stretch (s->next); - } + ns_maybe_dumpglyphs_background (s->next, 1); + else + ns_draw_stretch_glyph_string (s->next); ns_unfocus (s->f); next->num_clips = 0; } @@ -4301,7 +4354,7 @@ ns_draw_glyph_string (struct glyph_string *s) break; case STRETCH_GLYPH: - ns_dumpglyphs_stretch (s); + ns_draw_stretch_glyph_string (s); break; case CHAR_GLYPH: diff --git a/src/pdumper.c b/src/pdumper.c index af451920eb6..33cb804dbae 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2701,7 +2701,7 @@ dump_hash_table (struct dump_context *ctx, static dump_off dump_buffer (struct dump_context *ctx, const struct buffer *in_buffer) { -#if CHECK_STRUCTS && !defined HASH_buffer_F8FE65D42F +#if CHECK_STRUCTS && !defined HASH_buffer_AA373AEE10 # error "buffer changed. See CHECK_STRUCTS comment in config.h." #endif struct buffer munged_buffer = *in_buffer; @@ -2813,6 +2813,7 @@ dump_buffer (struct dump_context *ctx, const struct buffer *in_buffer) DUMP_FIELD_COPY (out, buffer, prevent_redisplay_optimizations_p); DUMP_FIELD_COPY (out, buffer, clip_changed); DUMP_FIELD_COPY (out, buffer, inhibit_buffer_hooks); + DUMP_FIELD_COPY (out, buffer, long_line_optimizations_p); dump_field_lv_rawptr (ctx, out, buffer, &buffer->overlays_before, Lisp_Vectorlike, WEIGHT_NORMAL); diff --git a/src/print.c b/src/print.c index b5a621f80aa..7303e847aa2 100644 --- a/src/print.c +++ b/src/print.c @@ -98,14 +98,14 @@ bool print_output_debug_flag EXTERNALLY_VISIBLE = 1; or call strout to output a block of characters. */ #define PRINTPREPARE \ - struct buffer *old = current_buffer; \ ptrdiff_t old_point = -1, start_point = -1; \ ptrdiff_t old_point_byte = -1, start_point_byte = -1; \ specpdl_ref specpdl_count = SPECPDL_INDEX (); \ - bool free_print_buffer = 0; \ bool multibyte \ = !NILP (BVAR (current_buffer, enable_multibyte_characters)); \ Lisp_Object original = printcharfun; \ + record_unwind_current_buffer (); \ + specbind(Qprint__unreadable_callback_buffer, Fcurrent_buffer ()); \ if (NILP (printcharfun)) printcharfun = Qt; \ if (BUFFERP (printcharfun)) \ { \ @@ -153,7 +153,7 @@ bool print_output_debug_flag EXTERNALLY_VISIBLE = 1; int new_size = 1000; \ print_buffer = xmalloc (new_size); \ print_buffer_size = new_size; \ - free_print_buffer = 1; \ + record_unwind_protect_void (print_free_buffer); \ } \ print_buffer_pos = 0; \ print_buffer_pos_byte = 0; \ @@ -180,20 +180,24 @@ bool print_output_debug_flag EXTERNALLY_VISIBLE = 1; print_buffer_pos_byte, 0, 1, 0); \ signal_after_change (PT - print_buffer_pos, 0, print_buffer_pos);\ } \ - if (free_print_buffer) \ - { \ - xfree (print_buffer); \ - print_buffer = 0; \ - } \ - unbind_to (specpdl_count, Qnil); \ if (MARKERP (original)) \ set_marker_both (original, Qnil, PT, PT_BYTE); \ if (old_point >= 0) \ SET_PT_BOTH (old_point + (old_point >= start_point \ ? PT - start_point : 0), \ old_point_byte + (old_point_byte >= start_point_byte \ - ? PT_BYTE - start_point_byte : 0)); \ - set_buffer_internal (old); + ? PT_BYTE - start_point_byte : 0)); \ + unbind_to (specpdl_count, Qnil); \ + +/* This is used to free the print buffer; we don't simply record xfree + since print_buffer can be reallocated during the printing. */ + +static void +print_free_buffer (void) +{ + xfree (print_buffer); + print_buffer = NULL; +} /* This is used to restore the saved contents of print_buffer when there is a recursive call to print. */ @@ -1652,6 +1656,17 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, infinite recursion in the function called. */ Lisp_Object func = Vprint_unreadable_function; specbind (Qprint_unreadable_function, Qnil); + + /* If we're being called from `prin1-to-string' or the like, + we're now in the secret " prin1" buffer. This can lead to + problems if, for instance, the callback function switches a + window to this buffer -- this will make Emacs segfault. */ + if (!NILP (Vprint__unreadable_callback_buffer) + && !NILP (Fbuffer_live_p (Vprint__unreadable_callback_buffer))) + { + record_unwind_current_buffer (); + set_buffer_internal (XBUFFER (Vprint__unreadable_callback_buffer)); + } Lisp_Object result = CALLN (Ffuncall, func, obj, escapeflag? Qt: Qnil); unbind_to (count, Qnil); @@ -2910,6 +2925,15 @@ be printed. */); Vprint_unreadable_function = Qnil; DEFSYM (Qprint_unreadable_function, "print-unreadable-function"); + DEFVAR_LISP ("print--unreadable-callback-buffer", + Vprint__unreadable_callback_buffer, + doc: /* Dynamically bound to indicate current buffer. */); + Vprint__unreadable_callback_buffer = Qnil; + DEFSYM (Qprint__unreadable_callback_buffer, + "print--unreadable-callback-buffer"); + /* Don't export this variable to Elisp. */ + Funintern (Qprint__unreadable_callback_buffer, Qnil); + defsubr (&Sflush_standard_output); /* Initialized in print_create_variable_mapping. */ diff --git a/src/process.c b/src/process.c index 444265a1bcb..a15efa39bd1 100644 --- a/src/process.c +++ b/src/process.c @@ -4641,15 +4641,20 @@ network_lookup_address_info_1 (Lisp_Object host, const char *service, } DEFUN ("network-lookup-address-info", Fnetwork_lookup_address_info, - Snetwork_lookup_address_info, 1, 2, 0, + Snetwork_lookup_address_info, 1, 3, 0, doc: /* Look up Internet Protocol (IP) address info of NAME. -Optional parameter FAMILY controls whether to look up IPv4 or IPv6 +Optional argument FAMILY controls whether to look up IPv4 or IPv6 addresses. The default of nil means both, symbol `ipv4' means IPv4 -only, symbol `ipv6' means IPv6 only. Returns a list of addresses, or -nil if none were found. Each address is a vector of integers, as per -the description of ADDRESS in `make-network-process'. In case of -error displays the error message. */) - (Lisp_Object name, Lisp_Object family) +only, symbol `ipv6' means IPv6 only. +Optional argument HINTS allows specifying the hints passed to the +underlying library call. The only supported value is `numeric', which +means treat NAME as a numeric IP address. This also suppresses DNS +traffic. +Return a list of addresses, or nil if none were found. Each address +is a vector of integers, as per the description of ADDRESS in +`make-network-process'. In case of error log the error message +returned from the lookup. */) + (Lisp_Object name, Lisp_Object family, Lisp_Object hint) { Lisp_Object addresses = Qnil; Lisp_Object msg = Qnil; @@ -4667,9 +4672,14 @@ error displays the error message. */) hints.ai_family = AF_INET6; #endif else - error ("Unsupported lookup type"); + error ("Unsupported family"); hints.ai_socktype = SOCK_DGRAM; + if (EQ (hint, Qnumeric)) + hints.ai_flags = AI_NUMERICHOST; + else if (!NILP (hint)) + error ("Unsupported hints value"); + msg = network_lookup_address_info_1 (name, NULL, &hints, &res); if (!EQ (msg, Qt)) message ("%s", SSDATA(msg)); @@ -8515,6 +8525,7 @@ syms_of_process (void) #ifdef AF_INET6 DEFSYM (Qipv6, "ipv6"); #endif + DEFSYM (Qnumeric, "numeric"); DEFSYM (Qdatagram, "datagram"); DEFSYM (Qseqpacket, "seqpacket"); diff --git a/src/terminal.c b/src/terminal.c index dcde8e9f557..d366e9d2438 100644 --- a/src/terminal.c +++ b/src/terminal.c @@ -402,7 +402,7 @@ but if the second argument FORCE is non-nil, you may do so. */) DEFUN ("frame-terminal", Fframe_terminal, Sframe_terminal, 0, 1, 0, doc: /* Return the terminal that FRAME is displayed on. -If FRAME is nil, the selected frame is used. +If FRAME is nil, use the selected frame. The terminal device is represented by its integer identifier. */) (Lisp_Object frame) @@ -421,10 +421,12 @@ The terminal device is represented by its integer identifier. */) DEFUN ("terminal-live-p", Fterminal_live_p, Sterminal_live_p, 1, 1, 0, doc: /* Return non-nil if OBJECT is a terminal which has not been deleted. -Value is nil if OBJECT is not a live display terminal. -If object is a live display terminal, the return value indicates what -sort of output terminal it uses. See the documentation of `framep' for -possible return values. */) +Return nil if OBJECT is not a live display terminal. +OBJECT may be a terminal object, a frame, or nil (meaning the +selected frame's terminal). +If OBJECT is a live display terminal, return what sort of output +terminal it uses. See the documentation of `framep' for possible +return values. */) (Lisp_Object object) { struct terminal *t = decode_terminal (object); diff --git a/src/window.c b/src/window.c index 8f889585582..33a1b8a4bf4 100644 --- a/src/window.c +++ b/src/window.c @@ -1275,7 +1275,10 @@ set_window_hscroll (struct window *w, EMACS_INT hscroll) /* Prevent redisplay shortcuts when changing the hscroll. */ if (w->hscroll != new_hscroll) - XBUFFER (w->contents)->prevent_redisplay_optimizations_p = true; + { + XBUFFER (w->contents)->prevent_redisplay_optimizations_p = true; + wset_redisplay (w); + } w->hscroll = new_hscroll; w->suspend_auto_hscroll = true; @@ -6684,7 +6687,7 @@ and redisplay normally--don't erase and redraw the frame. */) considered to be part of the visible height of the line. */ h += extra_line_spacing; - while (-it.current_y > h) + while (-it.current_y > h && it.what != IT_EOB) move_it_by_lines (&it, 1); charpos = IT_CHARPOS (it); diff --git a/src/xdisp.c b/src/xdisp.c index e13d68eab9d..2c889586cd6 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -19101,7 +19101,10 @@ set_vertical_scroll_bar (struct window *w) && NILP (echo_area_buffer[0]))) { struct buffer *buf = XBUFFER (w->contents); - ptrdiff_t window_end_pos = w->window_end_pos; + + whole = BUF_ZV (buf) - BUF_BEGV (buf); + start = marker_position (w->start) - BUF_BEGV (buf); + end = BUF_Z (buf) - w->window_end_pos - BUF_BEGV (buf); /* If w->window_end_pos cannot be trusted, recompute it "the hard way". But don't bother to be too accurate when @@ -19110,18 +19113,19 @@ set_vertical_scroll_bar (struct window *w) { struct it it; struct text_pos start_pos; - + struct buffer *obuf = current_buffer; + /* When we display the scroll bar of a mini-window, + current_buffer is not guaranteed to be the mini-window's + buffer, see the beginning of redisplay_window. */ + set_buffer_internal_1 (XBUFFER (w->contents)); SET_TEXT_POS_FROM_MARKER (start_pos, w->start); start_display (&it, w, start_pos); move_it_to (&it, -1, it.last_visible_x, window_box_height (w), -1, MOVE_TO_X | MOVE_TO_Y); - window_end_pos = BUF_Z (buf) - IT_CHARPOS (it); + end -= (BUF_Z (buf) - IT_CHARPOS (it)) - w->window_end_pos; + set_buffer_internal_1 (obuf); } - whole = BUF_ZV (buf) - BUF_BEGV (buf); - start = marker_position (w->start) - BUF_BEGV (buf); - end = BUF_Z (buf) - window_end_pos - BUF_BEGV (buf); - if (end < start) end = start; if (whole < (end - start)) diff --git a/src/xfns.c b/src/xfns.c index ce867c1619c..076cd97875a 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -8681,7 +8681,8 @@ Text larger than the specified size is clipped. */) if (!NILP (tip_frame) && FRAME_LIVE_P (XFRAME (tip_frame))) { if (FRAME_VISIBLE_P (XFRAME (tip_frame)) - && BASE_EQ (frame, tip_last_frame) + && (FRAME_X_DISPLAY (XFRAME (frame)) + == FRAME_X_DISPLAY (XFRAME (tip_last_frame))) && !NILP (Fequal_including_properties (tip_last_string, string)) && !NILP (Fequal (tip_last_parms, parms))) { diff --git a/src/xterm.c b/src/xterm.c index 1e9161c7ab0..e9db4b364fb 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_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) ATOM_REFS_INIT ("_NET_WM_USER_TIME_WINDOW", Xatom_net_wm_user_time_window) ATOM_REFS_INIT ("_NET_CLIENT_LIST_STACKING", Xatom_net_client_list_stacking) @@ -1390,6 +1391,12 @@ static int x_dnd_recursion_depth; initiating Motif drag-and-drop for the first time. */ static Lisp_Object x_dnd_selection_alias_cell; +/* The last known position of the tooltip window. */ +static int x_dnd_last_tooltip_x, x_dnd_last_tooltip_y; + +/* Whether or not those values are actually known yet. */ +static bool x_dnd_last_tooltip_valid; + /* Structure describing a single window that can be the target of drag-and-drop operations. */ struct x_client_list_window @@ -2931,7 +2938,7 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) Window *toplevels; int format, rc; unsigned long nitems, bytes_after; - unsigned long i; + unsigned long i, real_nitems; unsigned char *data = NULL; int frame_extents[4]; @@ -2995,6 +3002,16 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo) toplevels = (Window *) data; + for (i = 0, real_nitems = 0; i < nitems; ++i) + { + /* Some window managers with built in compositors end up putting + tooltips in the client list, which is silly. */ + if (!x_tooltip_window_to_frame (dpyinfo, toplevels[i], NULL)) + toplevels[real_nitems++] = toplevels[i]; + } + + nitems = real_nitems; + #ifdef USE_XCB USE_SAFE_ALLOCA; @@ -5357,12 +5374,16 @@ xi_populate_device_from_info (struct xi_device_t *xi_device, #endif } -/* The code below handles the tracking of scroll valuators on XInput - 2, in order to support scroll wheels that report information more - granular than a screen line. +/* Populate our client-side record of all devices, which includes + basic information about the device and also touchscreen tracking + information and scroll valuators. - On X, when the XInput 2 extension is being utilized, the states of - the mouse wheels in each axis are stored as absolute values inside + Keeping track of scroll valuators is required in order to support + scroll wheels that report information in a fashion more detailed + than a single turn of a "step" in the wheel. + + When the input extension is being utilized, the states of the mouse + wheels on each axis are stored as absolute values inside "valuators" attached to each mouse device. To obtain the delta of the scroll wheel from a motion event (which is used to report that some valuator has changed), it is necessary to iterate over every @@ -5376,20 +5397,13 @@ xi_populate_device_from_info (struct xi_device_t *xi_device, This delta however is still intermediate, to make driver implementations easier. The XInput developers recommend (and most programs use) the following algorithm to convert from scroll unit - deltas to pixel deltas: + deltas to pixel deltas by which the display must actually be + scrolled: pixels_scrolled = pow (window_height, 2.0 / 3.0) * delta; */ -/* Setup valuator tracking for XI2 master devices on - DPYINFO->display. */ - -/* This function's name is a misnomer: these days, it keeps a - client-side record of all devices, which includes basic information - about the device and also touchscreen tracking information, instead - of just scroll valuators. */ - static void -x_init_master_valuators (struct x_display_info *dpyinfo) +x_cache_xi_devices (struct x_display_info *dpyinfo) { int ndevices, actual_devices; XIDeviceInfo *infos; @@ -6582,6 +6596,82 @@ x_set_frame_alpha (struct frame *f) Starting and ending an update ***********************************************************************/ +#if defined HAVE_XSYNC && !defined USE_GTK +/* Tell the compositing manager to postpone updates of F until a frame + has finished drawing. */ + +static void +x_sync_update_begin (struct frame *f) +{ + XSyncValue value, add; + Bool overflow; + + if (FRAME_X_EXTENDED_COUNTER (f) == None) + return; + + value = FRAME_X_COUNTER_VALUE (f); + + /* Since a frame is already in progress, there is no point in + continuing. */ + if (XSyncValueLow32 (value) % 2) + return; + + /* Since Emacs needs a non-urgent redraw, ensure that value % 4 == + 0. */ + if (XSyncValueLow32 (value) % 4 == 2) + XSyncIntToValue (&add, 3); + else + XSyncIntToValue (&add, 1); + + XSyncValueAdd (&FRAME_X_COUNTER_VALUE (f), + value, add, &overflow); + + if (XSyncValueLow32 (FRAME_X_COUNTER_VALUE (f)) % 4 != 1) + emacs_abort (); + + if (overflow) + XSyncIntToValue (&FRAME_X_COUNTER_VALUE (f), 1); + + XSyncSetCounter (FRAME_X_DISPLAY (f), + FRAME_X_EXTENDED_COUNTER (f), + FRAME_X_COUNTER_VALUE (f)); +} + +/* Tell the compositing manager that FRAME has been drawn and can be + updated. */ + +static void +x_sync_update_finish (struct frame *f) +{ + XSyncValue value, add; + Bool overflow; + + if (FRAME_X_EXTENDED_COUNTER (f) == None) + return; + + if (FRAME_X_OUTPUT (f)->ext_sync_end_pending_p) + return; + + value = FRAME_X_COUNTER_VALUE (f); + + if (!(XSyncValueLow32 (value) % 2)) + return; + + XSyncIntToValue (&add, 1); + XSyncValueAdd (&FRAME_X_COUNTER_VALUE (f), + value, add, &overflow); + + if (overflow) + XSyncIntToValue (&FRAME_X_COUNTER_VALUE (f), 0); + + XSyncSetCounter (FRAME_X_DISPLAY (f), + FRAME_X_EXTENDED_COUNTER (f), + FRAME_X_COUNTER_VALUE (f)); + + /* TODO: implement sync fences. */ +} +#endif + /* Start an update of frame F. This function is installed as a hook for update_begin, i.e. it is called when update_begin is called. This function is called prior to calls to gui_update_window_begin for @@ -6591,7 +6681,11 @@ x_set_frame_alpha (struct frame *f) static void x_update_begin (struct frame *f) { +#if defined HAVE_XSYNC && !defined USE_GTK + x_sync_update_begin (f); +#else /* Nothing to do. */ +#endif } /* Draw a vertical window border from (x,y0) to (x,y1) */ @@ -6720,7 +6814,10 @@ x_flip_and_flush (struct frame *f) block_input (); #ifdef HAVE_XDBE if (FRAME_X_NEED_BUFFER_FLIP (f)) - show_back_buffer (f); + { + show_back_buffer (f); + x_sync_update_finish (f); + } #endif x_flush (f); unblock_input (); @@ -6737,17 +6834,17 @@ x_update_end (struct frame *f) #ifdef USE_CAIRO if (!FRAME_X_DOUBLE_BUFFERED_P (f) && FRAME_CR_CONTEXT (f)) - { - block_input (); - cairo_surface_flush (cairo_get_target (FRAME_CR_CONTEXT (f))); - unblock_input (); - } + cairo_surface_flush (cairo_get_target (FRAME_CR_CONTEXT (f))); #endif -#ifndef XFlush - block_input (); - XFlush (FRAME_X_DISPLAY (f)); - unblock_input (); + /* If double buffering is disabled, finish the update here. + Otherwise, finish the update when the back buffer is next + displayed. */ +#if defined HAVE_XSYNC && !defined USE_GTK +#ifdef HAVE_XDBE + if (!FRAME_X_DOUBLE_BUFFERED_P (f)) +#endif + x_sync_update_finish (f); #endif } @@ -6775,6 +6872,11 @@ XTframe_up_to_date (struct frame *f) if (!buffer_flipping_blocked_p () && FRAME_X_NEED_BUFFER_FLIP (f)) show_back_buffer (f); + +#if defined HAVE_XSYNC && !defined USE_GTK + if (FRAME_X_DOUBLE_BUFFERED_P (f)) + x_sync_update_finish (f); +#endif #endif #ifdef HAVE_XSYNC @@ -6791,14 +6893,14 @@ XTframe_up_to_date (struct frame *f) if (FRAME_X_OUTPUT (f)->ext_sync_end_pending_p && FRAME_X_EXTENDED_COUNTER (f) != None) { - current = FRAME_X_OUTPUT (f)->current_extended_counter_value; + current = FRAME_X_COUNTER_VALUE (f); if (XSyncValueLow32 (current) % 2) XSyncIntToValue (&add, 1); else XSyncIntToValue (&add, 2); - XSyncValueAdd (&FRAME_X_OUTPUT (f)->current_extended_counter_value, + XSyncValueAdd (&FRAME_X_COUNTER_VALUE (f), current, add, &overflow_p); if (overflow_p) @@ -6806,7 +6908,7 @@ XTframe_up_to_date (struct frame *f) XSyncSetCounter (FRAME_X_DISPLAY (f), FRAME_X_EXTENDED_COUNTER (f), - FRAME_X_OUTPUT (f)->current_extended_counter_value); + FRAME_X_COUNTER_VALUE (f)); FRAME_X_OUTPUT (f)->ext_sync_end_pending_p = false; } @@ -11066,7 +11168,8 @@ x_tooltip_window_to_frame (struct x_display_info *dpyinfo, GdkWindow *tooltip_window; #endif - *unrelated_tooltip_p = false; + if (unrelated_tooltip_p) + *unrelated_tooltip_p = false; FOR_EACH_FRAME (tail, frame) { @@ -11095,14 +11198,16 @@ x_tooltip_window_to_frame (struct x_display_info *dpyinfo, if (tooltip_window && (gdk_x11_window_get_xid (tooltip_window) == wdesc)) { - *unrelated_tooltip_p = true; + if (unrelated_tooltip_p) + *unrelated_tooltip_p = true; break; } #else if (tooltip_window && (GDK_WINDOW_XID (tooltip_window) == wdesc)) { - *unrelated_tooltip_p = true; + if (unrelated_tooltip_p) + *unrelated_tooltip_p = true; break; } #endif @@ -11670,6 +11775,7 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, x_dnd_run_unsupported_drop_function = false; x_dnd_use_toplevels = x_wm_supports (f, FRAME_DISPLAY_INFO (f)->Xatom_net_client_list_stacking); + x_dnd_last_tooltip_valid = false; x_dnd_toplevels = NULL; x_dnd_allow_current_frame = allow_current_frame; x_dnd_movement_frame = NULL; @@ -13054,15 +13160,26 @@ static void x_send_scroll_bar_event (Lisp_Object, enum scroll_bar_part, static Lisp_Object window_being_scrolled; -/* Whether this is an Xaw with arrow-scrollbars. This should imply - that movements of 1/20 of the screen size are mapped to up/down. */ +static Time +x_get_last_toolkit_time (struct x_display_info *dpyinfo) +{ +#ifdef USE_X_TOOLKIT + return XtLastTimestampProcessed (dpyinfo->display); +#else + return dpyinfo->last_user_time; +#endif +} #ifndef USE_GTK -/* Id of action hook installed for scroll bars. */ +/* Id of action hook installed for scroll bars and horizontal scroll + bars. */ static XtActionHookId action_hook_id; static XtActionHookId horizontal_action_hook_id; +/* Whether this is an Xaw with arrow-scrollbars. This should imply + that movements of 1/20 of the screen size are mapped to up/down. */ + static Boolean xaw3d_arrow_scroll; /* Whether the drag scrolling maintains the mouse at the top of the @@ -13273,12 +13390,8 @@ x_scroll_bar_to_input_event (const XEvent *event, ievent->kind = SCROLL_BAR_CLICK_EVENT; ievent->frame_or_window = window; ievent->arg = Qnil; -#ifdef USE_GTK - ievent->timestamp = CurrentTime; -#else - ievent->timestamp = - XtLastTimestampProcessed (FRAME_X_DISPLAY (XFRAME (w->frame))); -#endif + ievent->timestamp + = x_get_last_toolkit_time (FRAME_DISPLAY_INFO (XFRAME (w->frame))); ievent->code = 0; ievent->part = ev->data.l[2]; ievent->x = make_fixnum (ev->data.l[3]); @@ -13308,12 +13421,8 @@ x_horizontal_scroll_bar_to_input_event (const XEvent *event, ievent->kind = HORIZONTAL_SCROLL_BAR_CLICK_EVENT; ievent->frame_or_window = window; ievent->arg = Qnil; -#ifdef USE_GTK - ievent->timestamp = CurrentTime; -#else - ievent->timestamp = - XtLastTimestampProcessed (FRAME_X_DISPLAY (XFRAME (w->frame))); -#endif + ievent->timestamp + = x_get_last_toolkit_time (FRAME_DISPLAY_INFO (XFRAME (w->frame))); ievent->code = 0; ievent->part = ev->data.l[2]; ievent->x = make_fixnum (ev->data.l[3]); @@ -13417,19 +13526,31 @@ xm_scroll_callback (Widget widget, XtPointer client_data, XtPointer call_data) bar widget. DATA is a pointer to the scroll_bar structure. */ static gboolean -xg_scroll_callback (GtkRange *range, - GtkScrollType scroll, - gdouble value, - gpointer user_data) +xg_scroll_callback (GtkRange *range, GtkScrollType scroll, + gdouble value, gpointer user_data) { - int whole = 0, portion = 0; - struct scroll_bar *bar = user_data; - enum scroll_bar_part part = scroll_bar_nowhere; - GtkAdjustment *adj = GTK_ADJUSTMENT (gtk_range_get_adjustment (range)); - struct frame *f = g_object_get_data (G_OBJECT (range), XG_FRAME_DATA); + int whole, portion; + struct scroll_bar *bar; + enum scroll_bar_part part; + GtkAdjustment *adj; + struct frame *f; + guint32 time; + struct x_display_info *dpyinfo; if (xg_ignore_gtk_scrollbar) return false; + whole = 0; + portion = 0; + bar = user_data; + part = scroll_bar_nowhere; + adj = GTK_ADJUSTMENT (gtk_range_get_adjustment (range)); + f = g_object_get_data (G_OBJECT (range), XG_FRAME_DATA); + time = gtk_get_current_event_time (); + dpyinfo = FRAME_DISPLAY_INFO (f); + + if (time != GDK_CURRENT_TIME) + x_display_set_last_user_time (dpyinfo, time, true); + switch (scroll) { case GTK_SCROLL_JUMP: @@ -13496,8 +13617,11 @@ xg_end_scroll_callback (GtkWidget *widget, GdkEventButton *event, gpointer user_data) { - struct scroll_bar *bar = user_data; + struct scroll_bar *bar; + + bar = user_data; bar->dragging = -1; + if (WINDOWP (window_being_scrolled)) { x_send_scroll_bar_event (window_being_scrolled, @@ -15910,6 +16034,15 @@ x_dnd_update_tooltip_position (int root_x, int root_y) x_dnd_compute_tip_xy (&root_x, &root_y, x_dnd_monitors); + if (x_dnd_last_tooltip_valid + && root_x == x_dnd_last_tooltip_x + && root_y == x_dnd_last_tooltip_y) + return; + + x_dnd_last_tooltip_x = root_x; + x_dnd_last_tooltip_y = root_y; + x_dnd_last_tooltip_valid = true; + XMoveWindow (FRAME_X_DISPLAY (x_dnd_frame), tip_window, root_x, root_y); } @@ -16817,8 +16950,9 @@ handle_one_xevent (struct x_display_info *dpyinfo, } else if (event->xclient.data.l[4] == 1) { - XSyncIntsToValue (&FRAME_X_OUTPUT (f)->current_extended_counter_value, - event->xclient.data.l[2], event->xclient.data.l[3]); + XSyncIntsToValue (&FRAME_X_COUNTER_VALUE (f), + event->xclient.data.l[2], + event->xclient.data.l[3]); FRAME_X_OUTPUT (f)->ext_sync_end_pending_p = true; } @@ -16935,10 +17069,19 @@ handle_one_xevent (struct x_display_info *dpyinfo, goto done; } +#if defined HAVE_XSYNC && !defined USE_GTK + /* These messages are sent by the compositing manager after a + frame is drawn under extended synchronization. */ + if (event->xclient.message_type == dpyinfo->Xatom_net_wm_frame_drawn + || event->xclient.message_type == dpyinfo->Xatom_net_wm_frame_timings) + goto done; +#endif + xft_settings_event (dpyinfo, event); f = any; - if (!f) + /* We don't want to ever leak tooltip frames to Lisp code. */ + if (!f || FRAME_TOOLTIP_P (f)) goto OTHER; /* These values are always used initialized, but GCC doesn't @@ -17711,7 +17854,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, /* `xkey' will be modified, but it's not important to modify `event' itself. */ XKeyEvent xkey = event->xkey; - int i; + #ifdef HAVE_XINPUT2 Time pending_keystroke_time; struct xi_device_t *source; @@ -17761,27 +17904,6 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (modifiers & dpyinfo->meta_mod_mask) memset (&compose_status, 0, sizeof (compose_status)); -#ifdef HAVE_XKB - if (dpyinfo->xkb_desc) - { - XkbDescRec *rec = dpyinfo->xkb_desc; - - if (rec->map->modmap && rec->map->modmap[xkey.keycode]) - goto done_keysym; - } - else -#endif - { - if (dpyinfo->modmap) - { - for (i = 0; i < 8 * dpyinfo->modmap->max_keypermod; i++) - { - if (xkey.keycode == dpyinfo->modmap->modifiermap[i]) - goto done_keysym; - } - } - } - #ifdef HAVE_X_I18N if (FRAME_XIC (f)) { @@ -18258,6 +18380,19 @@ handle_one_xevent (struct x_display_info *dpyinfo, #endif if (f) { + /* Now clear dpyinfo->last_mouse_motion_frame, or + gui_redo_mouse_highlight will end up highlighting the + last known poisition of the mouse if a tooltip frame is + later unmapped. */ + + if (f == dpyinfo->last_mouse_motion_frame) + dpyinfo->last_mouse_motion_frame = NULL; + + /* Something similar applies to + dpyinfo->last_mouse_glyph_frame. */ + if (f == dpyinfo->last_mouse_glyph_frame) + dpyinfo->last_mouse_glyph_frame = NULL; + if (f == hlinfo->mouse_face_mouse_frame) { /* If we move outside the frame, then we're @@ -19004,10 +19139,11 @@ handle_one_xevent (struct x_display_info *dpyinfo, dpyinfo->grabbed |= (1 << event->xbutton.button); dpyinfo->last_mouse_frame = f; - if (f && !tab_bar_p) + + if (f) f->last_tab_bar_item = -1; #if ! defined (USE_GTK) - if (f && !tool_bar_p) + if (f) f->last_tool_bar_item = -1; #endif /* not USE_GTK */ } @@ -19708,8 +19844,22 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (!f) f = x_top_window_to_frame (dpyinfo, leave->event); #endif + if (f) { + /* Now clear dpyinfo->last_mouse_motion_frame, or + gui_redo_mouse_highlight will end up highlighting + the last known poisition of the mouse if a + tooltip frame is later unmapped. */ + + if (f == dpyinfo->last_mouse_motion_frame) + dpyinfo->last_mouse_motion_frame = NULL; + + /* Something similar applies to + dpyinfo->last_mouse_glyph_frame. */ + if (f == dpyinfo->last_mouse_glyph_frame) + dpyinfo->last_mouse_glyph_frame = NULL; + if (f == hlinfo->mouse_face_mouse_frame) { /* If we move outside the frame, then we're @@ -19799,9 +19949,9 @@ handle_one_xevent (struct x_display_info *dpyinfo, bar = NULL; - /* See the comment on top of - x_init_master_valuators for more details on how - scroll wheel movement is reported on XInput 2. */ + /* See the comment on top of x_cache_xi_devices + for more details on how scroll wheel movement + is reported on XInput 2. */ delta = x_get_scroll_valuator_delta (dpyinfo, device, i, *values, &val); values++; @@ -20407,10 +20557,10 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (device) device->grab |= (1 << xev->detail); - if (f && !tab_bar_p) + if (f) f->last_tab_bar_item = -1; #if ! defined (USE_GTK) - if (f && !tool_bar_p) + if (f) f->last_tool_bar_item = -1; #endif /* not USE_GTK */ } @@ -21090,27 +21240,6 @@ handle_one_xevent (struct x_display_info *dpyinfo, #ifdef HAVE_XKB if (dpyinfo->xkb_desc) { - XkbDescRec *rec = dpyinfo->xkb_desc; - - if (rec->map->modmap && rec->map->modmap[xev->detail]) - goto xi_done_keysym; - } - else -#endif - { - if (dpyinfo->modmap) - { - for (i = 0; i < 8 * dpyinfo->modmap->max_keypermod; i++) - { - if (xev->detail == dpyinfo->modmap->modifiermap[i]) - goto xi_done_keysym; - } - } - } - -#ifdef HAVE_XKB - if (dpyinfo->xkb_desc) - { uint xkb_state = state; xkb_state &= ~(1 << 13 | 1 << 14); xkb_state |= xev->group.effective << 13; @@ -21663,7 +21792,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (!device) { /* An existing device might have been enabled. */ - x_init_master_valuators (dpyinfo); + x_cache_xi_devices (dpyinfo); /* Now try to find the device again, in case it was just enabled. */ @@ -21795,7 +21924,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (xi_find_touch_point (device, xev->detail)) emacs_abort (); - f = x_any_window_to_frame (dpyinfo, xev->event); + f = x_window_to_frame (dpyinfo, xev->event); #ifdef HAVE_GTK3 menu_bar_p = (f && FRAME_X_OUTPUT (f)->menubar_widget @@ -21893,7 +22022,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, touchpoint->x = xev->event_x; touchpoint->y = xev->event_y; - f = x_any_window_to_frame (dpyinfo, xev->event); + f = x_window_to_frame (dpyinfo, xev->event); if (f && device->direct_p) { @@ -21936,7 +22065,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (unlinked_p) { - f = x_any_window_to_frame (dpyinfo, xev->event); + f = x_window_to_frame (dpyinfo, xev->event); if (f && device->direct_p) { @@ -24291,7 +24420,11 @@ x_set_offset (struct frame *f, int xoff, int yoff, int change_gravity) #endif /* 'x_sync_with_move' is too costly for dragging child frames. */ - if (!FRAME_PARENT_FRAME (f)) + if (!FRAME_PARENT_FRAME (f) + /* If no window manager exists, just calling XSync will be + sufficient to ensure that the window geometry has been + updated. */ + && NILP (Vx_no_window_manager)) { x_sync_with_move (f, f->left_pos, f->top_pos, FRAME_DISPLAY_INFO (f)->wm_type == X_WMTYPE_UNKNOWN); @@ -25024,11 +25157,9 @@ x_sync_with_move (struct frame *f, int left, int top, bool fuzzy) current_left = 0; current_top = 0; - /* In theory, this call to XSync only needs to happen once, but in - practice, it doesn't seem to work, hence the need for the surrounding - loop. */ - - XSync (FRAME_X_DISPLAY (f), False); + /* There is no need to call XSync (even when no window manager + is present) because x_real_positions already does that + implicitly. */ x_real_positions (f, ¤t_left, ¤t_top); if (fuzzy) @@ -27290,7 +27421,7 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) if (rc == Success) { dpyinfo->supports_xi2 = true; - x_init_master_valuators (dpyinfo); + x_cache_xi_devices (dpyinfo); } } diff --git a/src/xterm.h b/src/xterm.h index b9e7b094e31..3e237158e7e 100644 --- a/src/xterm.h +++ b/src/xterm.h @@ -614,7 +614,7 @@ struct x_display_info Xatom_net_wm_state_shaded, Xatom_net_frame_extents, Xatom_net_current_desktop, Xatom_net_workarea, Xatom_net_wm_opaque_region, Xatom_net_wm_ping, Xatom_net_wm_sync_request, Xatom_net_wm_sync_request_counter, - Xatom_net_wm_frame_drawn, Xatom_net_wm_user_time, + 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; @@ -1211,8 +1211,12 @@ extern void x_mark_frame_dirty (struct frame *f); #endif #ifdef HAVE_XSYNC -#define FRAME_X_BASIC_COUNTER(f) FRAME_X_OUTPUT (f)->basic_frame_counter -#define FRAME_X_EXTENDED_COUNTER(f) FRAME_X_OUTPUT (f)->extended_frame_counter +#define FRAME_X_BASIC_COUNTER(f) \ + FRAME_X_OUTPUT (f)->basic_frame_counter +#define FRAME_X_EXTENDED_COUNTER(f) \ + FRAME_X_OUTPUT (f)->extended_frame_counter +#define FRAME_X_COUNTER_VALUE(f) \ + FRAME_X_OUTPUT (f)->current_extended_counter_value #endif /* This is the Colormap which frame F uses. */ diff --git a/test/lisp/emacs-lisp/icons-tests.el b/test/lisp/emacs-lisp/icons-tests.el new file mode 100644 index 00000000000..e6e71a8e4fd --- /dev/null +++ b/test/lisp/emacs-lisp/icons-tests.el @@ -0,0 +1,63 @@ +;;; icons-tests.el --- Tests for icons.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'icons) +(require 'ert) +(require 'ert-x) +(require 'cus-edit) + +(define-icon icon-test1 nil + '((symbol ">") + (text "great")) + "Test icon" + :version "29.1") + +(define-icon icon-test2 icon-test1 + '((text "child")) + "Test icon" + :version "29.1") + +(deftheme test-icons-theme "") + +(ert-deftest test-icon-theme () + (let ((icon-preference '(image emoji symbol text))) + (should (equal (icon-string 'icon-test1) ">"))) + (let ((icon-preference '(text))) + (should (equal (icon-string 'icon-test1) "great"))) + (custom-theme-set-icons + 'test-icons-theme + '(icon-test1 ((symbol "<") (text "less")))) + (let ((icon-preference '(image emoji symbol text))) + (should (equal (icon-string 'icon-test1) ">")) + (enable-theme 'test-icons-theme) + (should (equal (icon-string 'icon-test1) "<")))) + +(ert-deftest test-icon-inheretance () + (let ((icon-preference '(image emoji symbol text))) + (should (equal (icon-string 'icon-test2) ">"))) + (let ((icon-preference '(text))) + (should (equal (icon-string 'icon-test2) "child")))) + +;;; icons-tests.el ends here diff --git a/test/lisp/emacs-lisp/subr-x-tests.el b/test/lisp/emacs-lisp/subr-x-tests.el index 99c0e822155..7a3efe9db62 100644 --- a/test/lisp/emacs-lisp/subr-x-tests.el +++ b/test/lisp/emacs-lisp/subr-x-tests.el @@ -766,5 +766,10 @@ (should (equal (sort (hash-table-keys h) #'string<) '(a b c))) (should (equal (sort (hash-table-values h) #'<) '(1 2 3))))) +(ert-deftest test-string-truncate-left () + (should (equal (string-truncate-left "band" 3) "...d")) + (should (equal (string-truncate-left "band" 2) "...d")) + (should (equal (string-truncate-left "longstring" 8) "...tring"))) + (provide 'subr-x-tests) ;;; subr-x-tests.el ends here diff --git a/test/lisp/erc/erc-scenarios-misc.el b/test/lisp/erc/erc-scenarios-misc.el index 9d6d5bc1d6a..ded620ccc1d 100644 --- a/test/lisp/erc/erc-scenarios-misc.el +++ b/test/lisp/erc/erc-scenarios-misc.el @@ -138,4 +138,43 @@ (should-not (get-buffer "$*")))) +(ert-deftest erc-scenarios-dcc-chat-accept () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "dcc/chat") + (dcc-server (erc-d-run "127.0.0.1" t "erc-dcc-server" 'accept-dcc + :ending "\n")) + (dcc-port (process-contact dcc-server :service)) + (dumb-server (erc-d-run "localhost" t 'accept :tmpl-vars + `((port . ,(number-to-string dcc-port))))) + (port (process-contact dumb-server :service)) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect to foonet") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :password "changeme" + :full-name "tester") + (should (string= (buffer-name) (format "127.0.0.1:%d" port))))) + + (ert-info ("Offer received") + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "foonet")) + (funcall expect 10 "DCC: chat offered by dummy") + (erc-cmd-DCC "CHAT" "dummy"))) + + ;; Regression + (erc-d-t-ensure-for 1 (not (get-buffer "tester"))) + + ;; Becomes current buffer by default (because `erc-join-buffer') + (erc-d-t-wait-for 10 (get-buffer "DCC-CHAT-dummy")) + + (with-current-buffer "foonet" + (funcall expect 10 "*** DCC: accepting chat from dummy")) + + (ert-info ("Chat with dummy") + (with-current-buffer "DCC-CHAT-dummy" + (erc-scenarios-common-say "Hi") + (funcall expect 10 "Hola"))))) + ;;; erc-scenarios-misc.el ends here diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index 4971d0e194f..0f222edacfa 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -893,4 +893,86 @@ (should-not calls)))))) +;; Note: if adding an erc-backend-tests.el, please relocate this there. + +(ert-deftest erc-message () + (should-not erc-server-last-peers) + (let (server-proc + calls + erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) + (cl-letf (((symbol-function 'erc-display-message) + (lambda (_ _ _ line) (push line calls))) + ((symbol-function 'erc-server-send) + (lambda (line _) (push line calls))) + ((symbol-function 'erc-server-buffer) + (lambda () (process-buffer server-proc)))) + (with-current-buffer (get-buffer-create "ExampleNet") + (erc-mode) + (setq erc-server-current-nick "tester" + server-proc (start-process "sleep" (current-buffer) "sleep" "1") + erc-server-process server-proc + erc-server-last-peers (cons nil nil) + erc-server-users (make-hash-table :test 'equal) + erc-network 'ExampleNet) + (set-process-query-on-exit-flag erc-server-process nil)) + + (with-current-buffer (get-buffer-create "#chan") + (erc-mode) + (setq erc-server-process (buffer-local-value 'erc-server-process + (get-buffer "ExampleNet")) + erc-default-recipients '("#chan") + erc-channel-users (make-hash-table :test 'equal) + erc-network 'ExampleNet) + (erc-update-current-channel-member "alice" "alice") + (erc-update-current-channel-member "tester" "tester")) + + (with-current-buffer "ExampleNet" + (erc-server-PRIVMSG erc-server-process + (make-erc-response + :sender "alice!~u@fsf.org" + :command "PRIVMSG" + :command-args '("#chan" "hi") + :unparsed ":alice!~u@fsf.org PRIVMSG #chan :hi")) + (should (equal erc-server-last-peers '("alice"))) + (should (string-match "<alice>" (pop calls)))) + + (with-current-buffer "#chan" + (ert-info ("Shortcuts usable in target buffers") + (should-not (local-variable-p 'erc-server-last-peers)) + (should-not erc-server-last-peers) + (erc-message "PRIVMSG" ". hi") + (should-not erc-server-last-peers) + (should (eq 'no-target (pop calls))) + (erc-message "PRIVMSG" ", hi") + (should-not erc-server-last-peers) + (should (string-match "alice :hi" (pop calls))))) + + (with-current-buffer "ExampleNet" + (ert-info ("Shortcuts local in server bufs") + (should (equal erc-server-last-peers '("alice" . "alice"))) + (erc-message "PRIVMSG" ", hi") + (should (equal erc-server-last-peers '("alice" . "alice"))) + (should (string-match "PRIVMSG alice :hi" (pop calls))) + (setcdr erc-server-last-peers "bob") + (erc-message "PRIVMSG" ". hi") + (should (equal erc-server-last-peers '("alice" . "bob"))) + (should (string-match "PRIVMSG bob :hi" (pop calls))))) + + (with-current-buffer "#chan" + (ert-info ("Non-shortcuts are local to server buffer") + (should-not (local-variable-p 'erc-server-last-peers)) + (should-not erc-server-last-peers) + (erc-message "PRIVMSG" "#chan hola") + (should-not erc-server-last-peers) + (should-not (default-value 'erc-server-last-peers)) + (should (equal (buffer-local-value 'erc-server-last-peers + (get-buffer "ExampleNet")) + '("alice" . "#chan"))) + (should (string-match "hola" (pop calls)))))) + + (should-not erc-server-last-peers) + (should-not calls) + (kill-buffer "ExampleNet") + (kill-buffer "#chan"))) + ;;; erc-tests.el ends here diff --git a/test/lisp/erc/resources/dcc/chat/accept-dcc.eld b/test/lisp/erc/resources/dcc/chat/accept-dcc.eld new file mode 100644 index 00000000000..23828a8115e --- /dev/null +++ b/test/lisp/erc/resources/dcc/chat/accept-dcc.eld @@ -0,0 +1,3 @@ +;; -*- mode: lisp-data; -*- +((open 10 "Hi") + (0 "Hola")) diff --git a/test/lisp/erc/resources/dcc/chat/accept.eld b/test/lisp/erc/resources/dcc/chat/accept.eld new file mode 100644 index 00000000000..a23e9580bcc --- /dev/null +++ b/test/lisp/erc/resources/dcc/chat/accept.eld @@ -0,0 +1,23 @@ +;; -*- mode: lisp-data; -*- +((pass 1 "PASS :changeme")) +((nick 1 "NICK tester")) +((user 1 "USER user 0 * :tester") + (0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") + (0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version oragono-2.6.0-7481bf0385b95b16") + (0 ":irc.foonet.org 003 tester :This server was created Mon, 31 May 2021 09:56:24 UTC") + (0 ":irc.foonet.org 004 tester irc.foonet.org oragono-2.6.0-7481bf0385b95b16 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv") + (0 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX KICKLEN=390 :are supported by this server") + (0 ":irc.foonet.org 005 tester MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:1,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8MAPPING=rfc8265 UTF8ONLY WHOX :are supported by this server") + (0 ":irc.foonet.org 005 tester draft/CHATHISTORY=100 :are supported by this server") + (0 ":irc.foonet.org 251 tester :There are 0 users and 4 invisible on 1 server(s)") + (0 ":irc.foonet.org 252 tester 0 :IRC Operators online") + (0 ":irc.foonet.org 254 tester 2 :channels formed") + (0 ":irc.foonet.org 255 tester :I have 4 clients and 0 servers") + (0 ":irc.foonet.org 265 tester 4 4 :Current local users 4, max 4") + (0 ":irc.foonet.org 266 tester 4 4 :Current global users 4, max 4") + (0 ":irc.foonet.org 422 tester :MOTD File is missing")) + +((mode-user 1.2 "MODE tester +i") + ;; No mode answer + (0 ":irc.foonet.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.") + (0.2 ":dummy!~u@34n9brushbpj2.irc PRIVMSG tester :\C-aDCC CHAT chat 2130706433 " port "\C-a")) diff --git a/test/lisp/erc/resources/erc-d/erc-d-tests.el b/test/lisp/erc/resources/erc-d/erc-d-tests.el index 21005cd7600..357bc48b088 100644 --- a/test/lisp/erc/resources/erc-d/erc-d-tests.el +++ b/test/lisp/erc/resources/erc-d/erc-d-tests.el @@ -1343,4 +1343,31 @@ DIALOGS are symbols representing the base names of dialog files in (kill-buffer dumb-server-buffer))) (delete-file sock)))) +(ert-deftest erc-d-run-direct-foreign-protocol () + :tags '(:expensive-test) + (let* ((server (erc-d-run "localhost" t "erc-d-server" 'foreign + :ending "\n")) + (server-buffer (get-buffer "*erc-d-server*")) + (client-buffer (get-buffer-create "*erc-d-client*")) + client) + (with-current-buffer server-buffer (erc-d-t-search-for 4 "Starting")) + (setq client (make-network-process + :buffer client-buffer + :name "erc-d-client" + :family 'ipv4 + :noquery t + :coding 'binary + :service (process-contact server :service) + :host "localhost")) + (process-send-string client "ONE one\n") + (with-current-buffer client-buffer + (erc-d-t-search-for 5 "echo ONE one")) + (process-send-string client "TWO two\n") + (with-current-buffer client-buffer + (erc-d-t-search-for 2 "echo TWO two")) + (erc-d-t-wait-for 2 "server death" (not (process-live-p server))) + (when noninteractive + (kill-buffer client-buffer) + (kill-buffer server-buffer)))) + ;;; erc-d-tests.el ends here diff --git a/test/lisp/erc/resources/erc-d/erc-d.el b/test/lisp/erc/resources/erc-d/erc-d.el index ee9b6a7fec9..d6082227c52 100644 --- a/test/lisp/erc/resources/erc-d/erc-d.el +++ b/test/lisp/erc/resources/erc-d/erc-d.el @@ -136,6 +136,9 @@ Only relevant when starting a server with `erc-d-run'.") Possibly used by overriding handlers, like the one for PING, and/or dialog templates for the sender portion of a reply message.") +(defvar erc-d-line-ending "\r\n" + "Protocol line delimiter for sending and receiving.") + (defvar erc-d-linger-secs nil "Seconds to wait before quitting for all dialogs. For more granular control, use the provided LINGER `rx' variable (alone) @@ -249,6 +252,7 @@ return a replacement.") (mat-h (copy-sequence (process-get process :dialog-match-handlers))) (fqdn (copy-sequence (process-get process :dialog-server-fqdn))) (vars (copy-sequence (process-get process :dialog-vars))) + (ending (process-get process :dialog-ending)) (dialog (make-erc-d-dialog :name name :process process :queue (make-ring 5) @@ -263,6 +267,8 @@ return a replacement.") (erc-d-dialog-hunks dialog) reader) ;; Add reverse link, register client, launch (process-put process :dialog dialog) + (process-put process :ending ending) + (process-put process :ending-regexp (rx-to-string `(+ ,ending))) (push process erc-d--clients) (erc-d--command-refresh dialog nil) (erc-d--on-request process))) @@ -311,7 +317,7 @@ PROCESS should be a client connection or a server network process." (name (erc-d-dialog-name (process-get ,process :dialog)))) (if ,outbound (erc-d--m process "-> %s:%s %s" name id ,string) - (dolist (line (split-string ,string "\r\n")) + (dolist (line (split-string ,string (process-get process :ending))) (erc-d--m process "<- %s:%s %s" name id line))))) (defun erc-d--log-process-event (server process msg) @@ -320,7 +326,7 @@ PROCESS should be a client connection or a server network process." (defun erc-d--send (process string) "Send STRING to PROCESS peer." (erc-d--log process string 'outbound) - (process-send-string process (concat string "\r\n"))) + (process-send-string process (concat string (process-get process :ending)))) (define-inline erc-d--fuzzy-p (exchange) (inline-letevals (exchange) @@ -442,9 +448,10 @@ This will start the teardown for DIALOG." "Handle input received from peer. PROCESS represents a client peer connection and STRING is a raw request including line delimiters." - (let ((queue (erc-d-dialog-queue (process-get process :dialog)))) + (let ((queue (erc-d-dialog-queue (process-get process :dialog))) + (delim (process-get process :ending-regexp))) (setq string (concat (process-get process :stashed-input) string)) - (while (and string (string-match (rx (+ "\r\n")) string)) + (while (and string (string-match delim string)) (let ((line (substring string 0 (match-beginning 0)))) (setq string (unless (= (match-end 0) (length string)) (substring string (match-end 0)))) @@ -913,35 +920,40 @@ Pass HOST and SERVICE directly to `make-network-process'. When present, use string SERVER-NAME for the server-process name as well as that of its buffer (w. surrounding asterisks). When absent, do the same with `erc-d-server-name'. When running \"in process,\" return the server -process, otherwise sleep for the duration of the server process. +process; otherwise sleep until it dies. A dialog must be a symbol matching the base name of a dialog file in -`erc-d-u-canned-dialog-dir'. - -The variable `erc-d-tmpl-vars' determines the common members of the -`erc-d--render-entries' ENTRIES param. Variables `erc-d-server-fqdn' -and `erc-d-linger-secs' determine the `erc-d-dialog' items -`:server-fqdn' and `:linger-secs' for all client processes. - -The variable `erc-d-tmpl-vars' can be used to initialize the -process's `erc-d-dialog' vars item." +`erc-d-u-canned-dialog-dir'. Global variables `erc-d-server-fqdn', +`erc-d-linger-secs', and `erc-d-tmpl-vars' determine the process's +`erc-d-dialog' fields `:server-fqdn', `:linger-secs', and `:vars', +respectively. The latter may also be populated via keyword pairs +appearing among DIALOGS." (when (and server-name (symbolp server-name)) (push server-name dialogs) (setq server-name nil)) - (let (loaded) - (dolist (dialog (nreverse dialogs)) - (let ((reader (erc-d-u--canned-load-dialog dialog))) - (when erc-d--slow-mo - (setq reader (erc-d-u--rewrite-for-slow-mo erc-d--slow-mo reader))) - (push (cons (erc-d-u--normalize-canned-name dialog) reader) loaded))) - (setq dialogs loaded)) - (erc-d--start host service (or server-name erc-d-server-name) - :dialog-dialogs dialogs - :dialog-vars erc-d-tmpl-vars - :dialog-linger-secs erc-d-linger-secs - :dialog-server-fqdn erc-d-server-fqdn - :dialog-match-handlers (erc-d-u--unkeyword - erc-d-match-handlers))) + (let (loaded kwds defaults args) + (while dialogs + (if-let* ((dlog (pop dialogs)) + ((keywordp dlog))) + (progn (push (pop dialogs) kwds) (push dlog kwds)) + (let ((reader (erc-d-u--canned-load-dialog dlog))) + (when erc-d--slow-mo + (setq reader (erc-d-u--rewrite-for-slow-mo erc-d--slow-mo reader))) + (push (cons (erc-d-u--normalize-canned-name dlog) reader) loaded)))) + (setq kwds (erc-d-u--unkeyword kwds) + defaults `((ending . ,erc-d-line-ending) + (server-fqdn . ,erc-d-server-fqdn) + (linger-secs . ,erc-d-linger-secs) + (vars . ,(or (plist-get kwds 'tmpl-vars) erc-d-tmpl-vars)) + (dialogs . ,(nreverse loaded))) + args (list :dialog-match-handlers + (erc-d-u--unkeyword (or (plist-get kwds 'match-handlers) + erc-d-match-handlers)))) + (pcase-dolist (`(,var . ,def) defaults) + (push (or (plist-get kwds var) def) args) + (push (intern (format ":dialog-%s" var)) args)) + (apply #'erc-d--start host service (or server-name erc-d-server-name) + args))) (defun erc-d-serve () "Start serving canned dialogs from the command line. diff --git a/test/lisp/erc/resources/erc-d/resources/foreign.eld b/test/lisp/erc/resources/erc-d/resources/foreign.eld new file mode 100644 index 00000000000..64a5dca8b10 --- /dev/null +++ b/test/lisp/erc/resources/erc-d/resources/foreign.eld @@ -0,0 +1,5 @@ +;;; -*- mode: lisp-data -*- +((one 5 "ONE one") + (0 "echo ONE one")) +((two 5 "TWO two") + (0 "echo TWO two")) diff --git a/test/lisp/ffap-tests.el b/test/lisp/ffap-tests.el index 4b580b5af52..076d8256421 100644 --- a/test/lisp/ffap-tests.el +++ b/test/lisp/ffap-tests.el @@ -28,6 +28,30 @@ (require 'ert-x) (require 'ffap) +(ert-deftest ffap-replace-file-component () + (should (equal + (ffap-replace-file-component "/ftp:who@foo.com:/whatever" "/new") + "/ftp:who@foo.com:/new"))) + +(ert-deftest ffap-file-remote-p () + (dolist (test '(("/user@foo.bar.com:/pub" . + "/user@foo.bar.com:/pub") + ("/cssun.mathcs.emory.edu://dir" . + "/cssun.mathcs.emory.edu:/dir") + ("/ffap.el:80" . + "/ffap.el:80"))) + (let ((A (car test)) + (B (cdr test))) + (should (equal (ffap-file-remote-p A) B))))) + +(ert-deftest ffap-machine-p () + (should-not (ffap-machine-p "ftp")) + (should-not (ffap-machine-p "nonesuch")) + (should (eq (ffap-machine-p "ftp.mathcs.emory.edu") 'accept)) + (should-not (ffap-machine-p "mathcs" 5678)) + (should-not (ffap-machine-p "foo.bonk")) + (should (eq (ffap-machine-p "foo.bonk.com") 'accept))) + (ert-deftest ffap-tests-25243 () "Test for https://debbugs.gnu.org/25243 ." (ert-with-temp-file file diff --git a/test/lisp/help-fns-tests.el b/test/lisp/help-fns-tests.el index e3fed60b4cb..7ff7aa1ccd7 100644 --- a/test/lisp/help-fns-tests.el +++ b/test/lisp/help-fns-tests.el @@ -64,13 +64,13 @@ Return first line of the output of (describe-function-1 FUNC)." (ert-deftest help-fns-test-lisp-defun () (let ((regexp (if (featurep 'native-compile) - "a native compiled Lisp function in .+subr\\.el" - "a compiled Lisp function in .+subr\\.el")) + "a native-compiled Lisp function in .+subr\\.el" + "a byte-compiled Lisp function in .+subr\\.el")) (result (help-fns-tests--describe-function 'last))) (should (string-match regexp result)))) (ert-deftest help-fns-test-lisp-defsubst () - (let ((regexp "a compiled Lisp function in .+subr\\.el") + (let ((regexp "a byte-compiled Lisp function in .+subr\\.el") (result (help-fns-tests--describe-function 'posn-window))) (should (string-match regexp result)))) diff --git a/test/lisp/international/ccl-tests.el b/test/lisp/international/ccl-tests.el index 57ac74639b1..cf472415c7a 100644 --- a/test/lisp/international/ccl-tests.el +++ b/test/lisp/international/ccl-tests.el @@ -25,23 +25,25 @@ (ert-deftest shift () - ;; shift left +ve 5628 #x00000000000015fc - (should (= (ash 5628 8) 1440768)) ; #x000000000015fc00 - (should (= (lsh 5628 8) 1440768)) ; #x000000000015fc00 - - ;; shift left -ve -5628 #x3fffffffffffea04 - (should (= (ash -5628 8) -1440768)) ; #x3fffffffffea0400 - (should (= (lsh -5628 8) -1440768)) ; #x3fffffffffea0400 - - ;; shift right +ve 5628 #x00000000000015fc - (should (= (ash 5628 -8) 21)) ; #x0000000000000015 - (should (= (lsh 5628 -8) 21)) ; #x0000000000000015 - - ;; shift right -ve -5628 #x3fffffffffffea04 - (should (= (ash -5628 -8) -22)) ; #x3fffffffffffffea - (should (= (lsh -5628 -8) - (ash (- -5628 (ash most-negative-fixnum 1)) -8) - (ash (logand (ash -5628 -1) most-positive-fixnum) -7)))) + (with-suppressed-warnings ((suspicious lsh)) + + ;; shift left +ve 5628 #x00000000000015fc + (should (= (ash 5628 8) 1440768)) ; #x000000000015fc00 + (should (= (lsh 5628 8) 1440768)) ; #x000000000015fc00 + + ;; shift left -ve -5628 #x3fffffffffffea04 + (should (= (ash -5628 8) -1440768)) ; #x3fffffffffea0400 + (should (= (lsh -5628 8) -1440768)) ; #x3fffffffffea0400 + + ;; shift right +ve 5628 #x00000000000015fc + (should (= (ash 5628 -8) 21)) ; #x0000000000000015 + (should (= (lsh 5628 -8) 21)) ; #x0000000000000015 + + ;; shift right -ve -5628 #x3fffffffffffea04 + (should (= (ash -5628 -8) -22)) ; #x3fffffffffffffea + (should (= (lsh -5628 -8) + (ash (- -5628 (ash most-negative-fixnum 1)) -8) + (ash (logand (ash -5628 -1) most-positive-fixnum) -7))))) ;; CCl program from `pgg-parse-crc24' in lisp/obsolete/pgg-parse.el (defconst prog-pgg-source diff --git a/test/lisp/misc-tests.el b/test/lisp/misc-tests.el index a56feaa0495..f84827ab025 100644 --- a/test/lisp/misc-tests.el +++ b/test/lisp/misc-tests.el @@ -96,5 +96,43 @@ (should (equal (buffer-string) "abc\nabc\n")) (should (equal (point) 2)))) +(require 'rect) + +(ert-deftest misc--duplicate-dwim () + ;; Duplicate a line. + (with-temp-buffer + (insert "abc\ndefg\nh\n") + (goto-char 7) + (duplicate-dwim 2) + (should (equal (buffer-string) "abc\ndefg\ndefg\ndefg\nh\n")) + (should (equal (point) 7))) + + ;; Duplicate a region. + (with-temp-buffer + (insert "abc\ndef\n") + (set-mark 2) + (goto-char 7) + (transient-mark-mode) + (should (use-region-p)) + (duplicate-dwim) + (should (equal (buffer-string) "abc\ndebc\ndef\n")) + (should (equal (point) 7)) + (should (region-active-p)) + (should (equal (mark) 2))) + + ;; Duplicate a rectangular region. + (with-temp-buffer + (insert "x\n>a\n>bcde\n>fg\nyz\n") + (goto-char 4) + (rectangle-mark-mode) + (goto-char 15) + (rectangle-forward-char 1) + (duplicate-dwim) + (should (equal (buffer-string) "x\n>a a \n>bcdbcde\n>fg fg \nyz\n")) + (should (equal (point) 24)) + (should (region-active-p)) + (should rectangle-mark-mode) + (should (equal (mark) 4)))) + (provide 'misc-tests) ;;; misc-tests.el ends here diff --git a/test/lisp/net/shr-tests.el b/test/lisp/net/shr-tests.el index 821ca5ca636..2254f9bc860 100644 --- a/test/lisp/net/shr-tests.el +++ b/test/lisp/net/shr-tests.el @@ -67,6 +67,21 @@ (should-not (shr--use-cookies-p "http://www.gnu.org" '("http://www.fsf.org"))))) +(ert-deftest shr-srcset () + (should (equal (shr--parse-srcset "") nil)) + + (should (equal (shr--parse-srcset "a 10w, b 20w") + '(("b" 20) ("a" 10)))) + + (should (equal (shr--parse-srcset "a 10w b 20w") + '(("a" 10)))) + + (should (equal (shr--parse-srcset "https://example.org/1\n\n 10w , https://example.org/2 20w ") + '(("https://example.org/2" 20) ("https://example.org/1" 10)))) + + (should (equal (shr--parse-srcset "https://example.org/1,2\n\n 10w , https://example.org/2 20w ") + '(("https://example.org/2" 20) ("https://example.org/1,2" 10))))) + (require 'shr) ;;; shr-tests.el ends here diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el index 54d1ecf3652..f51037aabb4 100644 --- a/test/lisp/net/tramp-archive-tests.el +++ b/test/lisp/net/tramp-archive-tests.el @@ -31,7 +31,6 @@ (require 'ert) (require 'ert-x) (require 'tramp-archive) -(defvar tramp-copy-size-limit) (defvar tramp-persistency-file-name) ;; `ert-resource-file' was introduced in Emacs 28.1. @@ -96,7 +95,6 @@ Do not hexlify \"/\". This hexlified string is used in `file:///' URLs." (setq password-cache-expiry nil tramp-cache-read-persistent-data t ;; For auth-sources. - tramp-copy-size-limit nil tramp-persistency-file-name nil tramp-verbose 0) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 55a6feba9b7..5a8d9100e18 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -201,6 +201,14 @@ being the result.") (file-writable-p ert-remote-temporary-file-directory)))))) (when (cdr tramp--test-enabled-checked) + ;; Remove old test files. + (dolist (dir `(,temporary-file-directory + ,ert-remote-temporary-file-directory)) + (dolist (file (directory-files dir 'full "\\`\\(\\.#\\)?tramp-test")) + (ignore-errors + (if (file-directory-p file) + (delete-directory file 'recursive) + (delete-file file))))) ;; Cleanup connection. (ignore-errors (tramp-cleanup-connection tramp-test-vec nil 'keep-password))) @@ -4078,10 +4086,9 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (setq tmp-name3 (concat (file-remote-p tmp-name3) tmp-name2))))) ;; Cleanup. - (ignore-errors - (delete-file tmp-name2) - (delete-file tmp-name3) - (delete-directory tmp-name1 'recursive))) + (ignore-errors (delete-file tmp-name2)) + (ignore-errors (delete-file tmp-name3)) + (ignore-errors (delete-directory tmp-name1 'recursive))) ;; Detect cyclic symbolic links. (unwind-protect diff --git a/test/lisp/progmodes/python-tests.el b/test/lisp/progmodes/python-tests.el index b2cccdd9569..6f2ad87f81a 100644 --- a/test/lisp/progmodes/python-tests.el +++ b/test/lisp/progmodes/python-tests.el @@ -1122,6 +1122,35 @@ if save: (python-indent-line t) (should (= (python-indent-calculate-indentation t) 8)))) +(ert-deftest python-indent-dedenters-comment-else () + "Test de-indentation for the else keyword with comments before it." + (python-tests-with-temp-buffer + " +if save: + try: + write_to_disk(data) + except IOError: + msg = 'Error saving to disk' + message(msg) + logger.exception(msg) + except Exception: + if hide_details: + logger.exception('Unhandled exception') + # comment + else + finally: + data.free() +" + (python-tests-look-at "else\n") + (should (eq (car (python-indent-context)) :at-dedenter-block-start)) + (should (= (python-indent-calculate-indentation) 8)) + (python-indent-line t) + (should (= (python-indent-calculate-indentation t) 4)) + (python-indent-line t) + (should (= (python-indent-calculate-indentation t) 0)) + (python-indent-line t) + (should (= (python-indent-calculate-indentation t) 8)))) + (ert-deftest python-indent-dedenters-3 () "Test de-indentation for the except keyword." (python-tests-with-temp-buffer @@ -1995,6 +2024,32 @@ def c(): (beginning-of-line) (point)))))) +(ert-deftest python-nav-beginning-of-defun-5 () + (python-tests-with-temp-buffer + " +class C: + + def \\ + m(self): + pass +" + (python-tests-look-at "m(self):") + (should (= (save-excursion + (python-nav-beginning-of-defun) + (point)) + (save-excursion + (python-tests-look-at "def \\" -1) + (beginning-of-line) + (point)))) + (python-tests-look-at "class C:" -1) + (should (= (save-excursion + (python-nav-beginning-of-defun -1) + (point)) + (save-excursion + (python-tests-look-at "def \\") + (beginning-of-line) + (point)))))) + (ert-deftest python-nav-end-of-defun-1 () (python-tests-with-temp-buffer " diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index f5c1c40263e..be613ce7595 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -368,6 +368,17 @@ 2))) (ert-deftest string-comparison-test () + (should (string-equal-ignore-case "abc" "abc")) + (should (string-equal-ignore-case "abc" "ABC")) + (should (string-equal-ignore-case "abc" "abC")) + (should-not (string-equal-ignore-case "abc" "abCD")) + (should (string-equal-ignore-case "S" "s")) + (should (string-equal-ignore-case "ẞ" "ß")) + (should (string-equal-ignore-case "Dz" "DZ")) + (should (string-equal-ignore-case "Όσος" "ΌΣΟΣ")) + ;; not yet: (should (string-equal-ignore-case "SS" "ß")) + ;; not yet: (should (string-equal-ignore-case "SS" "ẞ")) + (should (string-lessp "abc" "acb")) (should (string-lessp "aBc" "abc")) (should (string-lessp "abc" "abcd")) @@ -1026,7 +1037,15 @@ final or penultimate step during initialization.")) (ert-deftest test-readablep () (should (readablep "foo")) - (should-not (readablep (list (make-marker))))) + (should-not (readablep (list (make-marker)))) + (should-not (readablep (make-marker)))) + +(ert-deftest test-print-unreadable-function () + ;; Check that problem with unwinding properly is fixed (bug#56773). + (with-temp-buffer + (let ((buf (current-buffer))) + (readablep (make-marker)) + (should (eq buf (current-buffer)))))) (ert-deftest test-string-lines () (should (equal (string-lines "") '(""))) @@ -1107,5 +1126,15 @@ final or penultimate step during initialization.")) (should (equal (butlast l n) (subr-tests--butlast-ref l n)))))) +(ert-deftest test-print-unreadable-function-buffer () + (with-temp-buffer + (let ((current (current-buffer)) + callback-buffer) + (let ((print-unreadable-function + (lambda (_object _escape) + (setq callback-buffer (current-buffer))))) + (prin1-to-string (make-marker))) + (should (eq current callback-buffer))))) + (provide 'subr-tests) ;;; subr-tests.el ends here diff --git a/test/lisp/x-dnd-tests.el b/test/lisp/x-dnd-tests.el index 8856be79ebc..55994e9b724 100644 --- a/test/lisp/x-dnd-tests.el +++ b/test/lisp/x-dnd-tests.el @@ -90,6 +90,8 @@ AgAABQMAAAYDAAATGwAAGhsAAA==") ;;; XDS tests. +(defvar x-dnd-xds-testing) + (defvar x-dnd-tests-xds-target-dir nil "The name of the target directory where the file will be saved.") @@ -122,8 +124,8 @@ Return the result of the selection." (format "file://%s%s" (system-name) (expand-file-name x-dnd-tests-xds-property-value x-dnd-tests-xds-target-dir)) - (concat "file:///" (expand-file-name x-dnd-tests-xds-property-value - x-dnd-tests-xds-target-dir))))) + (concat "file://" (expand-file-name x-dnd-tests-xds-property-value + x-dnd-tests-xds-target-dir))))) (setq x-dnd-tests-xds-property-value (encode-coding-string (url-encode-url uri) 'raw-text))) @@ -162,7 +164,8 @@ hostname in the target URI." (original-file (expand-file-name (make-temp-name "x-dnd-test") temporary-file-directory)) - (x-dnd-tests-xds-name (make-temp-name "x-dnd-test-target"))) + (x-dnd-tests-xds-name (make-temp-name "x-dnd-test-target")) + (x-dnd-xds-testing t)) ;; The call to `gui-set-selection' is only used for providing the ;; conventional `text/uri-list' target and can be ignored. (cl-flet ((gui-set-selection #'ignore)) diff --git a/test/src/data-tests.el b/test/src/data-tests.el index 7ce2995e562..0f84b2fb776 100644 --- a/test/src/data-tests.el +++ b/test/src/data-tests.el @@ -741,14 +741,15 @@ comparing the subr with a much slower Lisp implementation." (should (= (ash 1000 (* 2 most-negative-fixnum)) 0)) (should (= (ash -1000 (* 2 most-negative-fixnum)) -1)) (should (= (ash (* 2 most-negative-fixnum) (* 2 most-negative-fixnum)) -1)) - (should (= (lsh most-negative-fixnum 1) - (* most-negative-fixnum 2))) (should (= (ash (* 2 most-negative-fixnum) -1) most-negative-fixnum)) - (should (= (lsh most-positive-fixnum -1) (/ most-positive-fixnum 2))) - (should (= (lsh most-negative-fixnum -1) (lsh (- most-negative-fixnum) -1))) - (should (= (lsh -1 -1) most-positive-fixnum)) - (should-error (lsh (1- most-negative-fixnum) -1))) + (with-suppressed-warnings ((suspicious lsh)) + (should (= (lsh most-negative-fixnum 1) + (* most-negative-fixnum 2))) + (should (= (lsh most-positive-fixnum -1) (/ most-positive-fixnum 2))) + (should (= (lsh most-negative-fixnum -1) (lsh (- most-negative-fixnum) -1))) + (should (= (lsh -1 -1) most-positive-fixnum)) + (should-error (lsh (1- most-negative-fixnum) -1)))) (ert-deftest data-tests-make-local-forwarded-var () ;bug#34318 ;; Boy, this bug is tricky to trigger. You need to: diff --git a/test/src/print-tests.el b/test/src/print-tests.el index f818b4d4715..91187d9f45c 100644 --- a/test/src/print-tests.el +++ b/test/src/print-tests.el @@ -529,6 +529,5 @@ otherwise, use a different charset." (should (equal (% (- (length numbers) loopback-index) loop) 0))))))))))) - (provide 'print-tests) ;;; print-tests.el ends here diff --git a/test/src/process-tests.el b/test/src/process-tests.el index f1ed7e18d5b..aab95b2d733 100644 --- a/test/src/process-tests.el +++ b/test/src/process-tests.el @@ -378,6 +378,58 @@ See Bug#30460." (when (ipv6-is-available) (should (network-lookup-address-info "localhost" 'ipv6))))) +(ert-deftest lookup-hints-specification () + "`network-lookup-address-info' should only accept valid hints arg." + (should-error (network-lookup-address-info "1.1.1.1" nil t)) + (should-error (network-lookup-address-info "1.1.1.1" 'ipv4 t)) + (should (network-lookup-address-info "1.1.1.1" nil 'numeric)) + (should (network-lookup-address-info "1.1.1.1" 'ipv4 'numeric)) + (when (ipv6-is-available) + (should-error (network-lookup-address-info "::1" nil t)) + (should-error (network-lookup-address-info "::1" 'ipv6 't)) + (should (network-lookup-address-info "::1" nil 'numeric)) + (should (network-lookup-address-info "::1" 'ipv6 'numeric)))) + +(ert-deftest lookup-hints-values () + "`network-lookup-address-info' should succeed/fail in looking up various numeric IP addresses." + (let ((ipv4-invalid-addrs + '("localhost" "343.1.2.3" "1.2.3.4.5")) + ;; These are valid for IPv4 but invalid for IPv6 + (ipv4-addrs + '("127.0.0.1" "127.0.1" "127.1" "127" "1" "0" + "0xe3010203" "0xe3.1.2.3" "227.0x1.2.3" + "034300201003" "0343.1.2.3" "227.001.2.3")) + (ipv6-only-invalid-addrs + '("fe80:1" "e301:203:1" "e301::203::1" + "1:2:3:4:5:6:7:8:9" "0xe301:203::1" + "343:10001:2::3" + ;; "00343:1:2::3" is invalid on GNU/Linux and FreeBSD, but + ;; valid on macOS. macOS is wrong here, but such is life. + )) + ;; These are valid for IPv6 but invalid for IPv4 + (ipv6-addrs + '("fe80::1" "e301::203:1" "e301:203::1" + "e301:0203::1" "::1" "::0" + "0343:1:2::3" "343:001:2::3"))) + (dolist (a ipv4-invalid-addrs) + (should-not (network-lookup-address-info a nil 'numeric)) + (should-not (network-lookup-address-info a 'ipv4 'numeric))) + (dolist (a ipv6-addrs) + (should-not (network-lookup-address-info a 'ipv4 'numeric))) + (dolist (a ipv4-addrs) + (should (network-lookup-address-info a nil 'numeric)) + (should (network-lookup-address-info a 'ipv4 'numeric))) + (when (ipv6-is-available) + (dolist (a ipv4-addrs) + (should-not (network-lookup-address-info a 'ipv6 'numeric))) + (dolist (a ipv6-only-invalid-addrs) + (should-not (network-lookup-address-info a 'ipv6 'numeric))) + (dolist (a ipv6-addrs) + (should (network-lookup-address-info a nil 'numeric)) + (should (network-lookup-address-info a 'ipv6 'numeric)) + (should (network-lookup-address-info (upcase a) nil 'numeric)) + (should (network-lookup-address-info (upcase a) 'ipv6 'numeric)))))) + (ert-deftest lookup-unicode-domains () "Unicode domains should fail." (skip-unless internet-is-working) |