commit 3e60f7f3c31a8491b085684121e5229be56b3538 (HEAD, refs/remotes/origin/master) Author: Kira Bruneau Date: Thu Aug 4 08:26:38 2022 +0200 Fix ignored-local-variable-values for non-primitive values * lisp/files.el (hack-local-variables-filter): Fix `ignored-local-variable-values' for non-primitive values (bug#56957). diff --git a/lisp/files.el b/lisp/files.el index 5df1966193..e258bf7bbe 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -3848,10 +3848,8 @@ DIR-NAME is the name of the associated directory. Otherwise it is nil." (cond ((memq var ignored-local-variables) ;; Ignore any variable in `ignored-local-variables'. nil) - ((seq-some (lambda (elem) - (and (eq (car elem) var) - (eq (cdr elem) val))) - ignored-local-variable-values) + ;; Ignore variables with the specified values. + ((member elt ignored-local-variable-values) nil) ;; Obey `enable-local-eval'. ((eq var 'eval) commit 118a911159e75f3ad9305cd7f298816bfb59d715 Author: Lars Ingebrigtsen Date: Thu Aug 4 08:16:45 2022 +0200 Make flyspell-check-word-p work better with delete-selection-mode * lisp/textmodes/flyspell.el (flyspell-check-word-p): Deactivate the region immediately (bug#53773). diff --git a/lisp/textmodes/flyspell.el b/lisp/textmodes/flyspell.el index 2c5e30fecd..2ee20ef1d4 100644 --- a/lisp/textmodes/flyspell.el +++ b/lisp/textmodes/flyspell.el @@ -854,6 +854,9 @@ Mostly we check word delimiters." ((get this-command 'flyspell-deplacement) (not (eq flyspell-previous-command this-command))) ((get this-command 'flyspell-delayed) + ;; In case we're using `delete-selection-mode', make the + ;; region be updated immediately. + (deactivate-mark) ;; The current command is not delayed, that ;; is that we must check the word now. (and (not unread-command-events) commit c17f1a2e89e6980853428b5e08d8a005e99565a6 Author: Lars Ingebrigtsen Date: Thu Aug 4 08:05:16 2022 +0200 Adjust documentation for make-docfile * doc/lispref/loading.texi (Autoload): We're no longer using make-docfile for loaddefs.el, but we're retaining the format. Adjust the documentation. * lisp/loadup.el: Adjust commentary. diff --git a/doc/lispref/loading.texi b/doc/lispref/loading.texi index e8dce433a5..874200d9f2 100644 --- a/doc/lispref/loading.texi +++ b/doc/lispref/loading.texi @@ -698,14 +698,13 @@ Switch to *doctor* buffer and start giving psychotherapy. @noindent @cindex @code{fn} in function's documentation string -The backslash and newline immediately following the double-quote are a -convention used only in the preloaded uncompiled Lisp files such as -@file{loaddefs.el}; they tell @code{make-docfile} to put the -documentation string in the @file{etc/DOC} file. @xref{Building Emacs}. -See also the commentary in @file{lib-src/make-docfile.c}. @samp{(fn)} -in the usage part of the documentation string is replaced with the -function's name when the various help functions (@pxref{Help -Functions}) display it. +While the @file{loaddefs.el} isn't for editing, we try to keep it +somewhat readable for people. For instance, control characters in +@code{defvar} values are escaped, and we insert a backslash and +newline immediately following the double-quote of the doc string to +keep the line length down. @samp{(fn)} in the usage part of the +documentation string is replaced with the function's name when the +various help functions (@pxref{Help Functions}) display it. If you write a function definition with an unusual macro that is not one of the known and recognized function definition methods, use of an diff --git a/lisp/loadup.el b/lisp/loadup.el index a65c1724ae..8dad382ac0 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -32,9 +32,6 @@ ;; If you add a file to be loaded here, keep the following points in mind: ;; i) If the file is no-byte-compile, explicitly load the .el version. -;; Such files should (where possible) obey the doc-string conventions -;; expected by make-docfile. They should also be added to the -;; uncompiled[] list in make-docfile.c. ;; ii) If the file is dumped with Emacs (on any platform), put the ;; load statement at the start of a line (leading whitespace is ok). @@ -42,11 +39,9 @@ ;; iii) If the file is _not_ dumped with Emacs, make sure the load ;; statement is _not_ at the start of a line. See pcase for an example. -;; These rules are so that src/Makefile can construct lisp.mk automatically. -;; This ensures both that the Lisp files are compiled (if necessary) -;; before the emacs executable is dumped, and that they are passed to -;; make-docfile. (Any that are not processed for DOC will not have -;; doc strings in the dumped Emacs.) +;; These rules are so that src/Makefile can construct lisp.mk +;; automatically. This ensures that the Lisp files are compiled (if +;; necessary) before the emacs executable is dumped. ;;; Code: commit caa88cfebec2465ba9bf422d75b741ef3fbfef6e Author: Lars Ingebrigtsen Date: Thu Aug 4 07:51:31 2022 +0200 Remove outdated TODO item about make-docfile and .el files * etc/TODO: Remove outdated item about make-docfile and .el files. diff --git a/etc/TODO b/etc/TODO index 5c55a8b999..4d0bfd1c2a 100644 --- a/etc/TODO +++ b/etc/TODO @@ -1713,17 +1713,8 @@ apparently loses under Solaris, at least. [fx has mostly done this.] (Obsolete, since gmalloc.c is nowadays only used on MS-DOS.) -** Rewrite make-docfile to be clean and maintainable -It might be better to replace with Lisp the part of make-docfile that -produces the etc/DOC file by scanning *.el files, for example by -reusing the code in the byte compiler or in autoload.el that already -scans *.el files. -https://lists.gnu.org/r/emacs-devel/2012-06/msg00037.html -https://lists.gnu.org/r/emacs-devel/2021-05/msg00235.html - ** Eliminate the etc/DOC file altogether -As an alternative to the previous item, we could try and eliminate the -DOC file altogether. See +We could try and eliminate the DOC file altogether. See https://lists.gnu.org/r/emacs-devel/2021-05/msg00237.html ** Add an inferior-comint-minor-mode commit 50e4fc9f0ee6ddb547479bffac9ad309ef5ec627 Author: Lars Ingebrigtsen Date: Thu Aug 4 07:48:23 2022 +0200 Adjust src/Makefile.in comments about make-docfile * src/Makefile.in ($(etc)/DOC): Remove comment aboout make-docfile being run twice (because it no longer is). diff --git a/src/Makefile.in b/src/Makefile.in index 8551447c8b..9ef4561c4a 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -641,11 +641,6 @@ $(pdmp): emacs$(EXEEXT) $(lispsource)/loaddefs.elc cp -f $@ $(bootstrap_pdmp) endif -## We run make-docfile twice because the command line may get too long -## on some systems. Unfortunately, no-one has any idea -## exactly how long the maximum safe command line length is on all the -## various systems that Emacs supports. -## ## $(SOME_MACHINE_OBJECTS) comes before $(obj) because some files may ## or may not be included in $(obj), but they are always included in ## $(SOME_MACHINE_OBJECTS). Since a file is processed when it is mentioned commit d6dbaecb2e02cef677462bfdae3228c9b8b46b12 Author: Po Lu Date: Thu Aug 4 13:58:42 2022 +0800 Reduce code duplication in XI scroll bar code * src/xterm.c (xi_select_scroll_bar_events): New function. (x_create_toolkit_scroll_bar) (x_create_horizontal_toolkit_scroll_bar, x_scroll_bar_create): Factor out input extension code there. diff --git a/src/xterm.c b/src/xterm.c index 63e62f39be..7e304bcd6e 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -13283,6 +13283,37 @@ XTmouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, /* Scroll bar support. */ +#if defined HAVE_XINPUT2 + +/* Select for input extension events used by scroll bars. This will + result in the corresponding core events not being generated for + SCROLL_BAR. */ + +MAYBE_UNUSED static void +xi_select_scroll_bar_events (struct x_display_info *dpyinfo, + Window scroll_bar) +{ + XIEventMask mask; + unsigned char *m; + ptrdiff_t length; + + length = XIMaskLen (XI_LASTEVENT); + mask.mask = m = alloca (length); + memset (m, 0, length); + mask.mask_len = length; + + mask.deviceid = XIAllMasterDevices; + XISetMask (m, XI_ButtonPress); + XISetMask (m, XI_ButtonRelease); + XISetMask (m, XI_Motion); + XISetMask (m, XI_Enter); + XISetMask (m, XI_Leave); + + XISelectEvents (dpyinfo->display, scroll_bar, &mask, 1); +} + +#endif + /* Given an X window ID and a DISPLAY, find the struct scroll_bar which manages it. This can be called in GC, so we have to make sure to strip off mark @@ -14073,25 +14104,8 @@ x_create_toolkit_scroll_bar (struct frame *f, struct scroll_bar *bar) /* Ask for input extension button and motion events. This lets us send the proper `wheel-up' or `wheel-down' events to Emacs. */ if (FRAME_DISPLAY_INFO (f)->supports_xi2) - { - XIEventMask mask; - ptrdiff_t l = XIMaskLen (XI_LASTEVENT); - unsigned char *m; - - mask.mask = m = alloca (l); - memset (m, 0, l); - mask.mask_len = l; - - mask.deviceid = XIAllMasterDevices; - XISetMask (m, XI_ButtonPress); - XISetMask (m, XI_ButtonRelease); - XISetMask (m, XI_Motion); - XISetMask (m, XI_Enter); - XISetMask (m, XI_Leave); - - XISelectEvents (XtDisplay (widget), XtWindow (widget), - &mask, 1); - } + xi_select_scroll_bar_events (FRAME_DISPLAY_INFO (f), + XtWindow (widget)); #endif #else /* !USE_MOTIF i.e. use Xaw */ @@ -14298,25 +14312,8 @@ x_create_horizontal_toolkit_scroll_bar (struct frame *f, struct scroll_bar *bar) /* Ask for input extension button and motion events. This lets us send the proper `wheel-up' or `wheel-down' events to Emacs. */ if (FRAME_DISPLAY_INFO (f)->supports_xi2) - { - XIEventMask mask; - ptrdiff_t l = XIMaskLen (XI_LASTEVENT); - unsigned char *m; - - mask.mask = m = alloca (l); - memset (m, 0, l); - mask.mask_len = l; - - mask.deviceid = XIAllMasterDevices; - XISetMask (m, XI_ButtonPress); - XISetMask (m, XI_ButtonRelease); - XISetMask (m, XI_Motion); - XISetMask (m, XI_Enter); - XISetMask (m, XI_Leave); - - XISelectEvents (XtDisplay (widget), XtWindow (widget), - &mask, 1); - } + xi_select_scroll_bar_events (FRAME_DISPLAY_INFO (f), + XtWindow (widget)); #endif #else /* !USE_MOTIF i.e. use Xaw */ @@ -14738,24 +14735,8 @@ x_scroll_bar_create (struct window *w, int top, int left, /* Ask for input extension button and motion events. This lets us send the proper `wheel-up' or `wheel-down' events to Emacs. */ if (FRAME_DISPLAY_INFO (f)->supports_xi2) - { - XIEventMask mask; - ptrdiff_t l = XIMaskLen (XI_LASTEVENT); - unsigned char *m; - - mask.mask = m = alloca (l); - memset (m, 0, l); - mask.mask_len = l; - - mask.deviceid = XIAllMasterDevices; - XISetMask (m, XI_ButtonPress); - XISetMask (m, XI_ButtonRelease); - XISetMask (m, XI_Motion); - XISetMask (m, XI_Enter); - XISetMask (m, XI_Leave); - - XISelectEvents (FRAME_X_DISPLAY (f), window, &mask, 1); - } + xi_select_scroll_bar_events (FRAME_DISPLAY_INFO (f), + window); #endif bar->x_window = window; commit 4ebdc558f62a4cb5101490e11b7f746d651c513a Author: Lars Ingebrigtsen Date: Thu Aug 4 07:44:53 2022 +0200 Adjust loaddefs-generate--print-form comments * lisp/emacs-lisp/loaddefs-gen.el (loaddefs-generate--print-form): Adjust doc string and comments now that make-docfile doesn't scan this. diff --git a/lisp/emacs-lisp/loaddefs-gen.el b/lisp/emacs-lisp/loaddefs-gen.el index 830799ec36..00b3bac53c 100644 --- a/lisp/emacs-lisp/loaddefs-gen.el +++ b/lisp/emacs-lisp/loaddefs-gen.el @@ -635,18 +635,19 @@ If GENERATE-FULL, don't update, but regenerate all the loaddefs files." t "GEN"))))))) (defun loaddefs-generate--print-form (def) - "Print DEF in the way make-docfile.c expects it." + "Print DEF in a format that makes sense for version control." (if (or (not (consp def)) (not (symbolp (car def))) (memq (car def) '( make-obsolete define-obsolete-function-alias)) (not (stringp (nth 3 def)))) (prin1 def (current-buffer) t) - ;; The salient point here is that we have to have the doc string - ;; that starts with a backslash and a newline, and there mustn't - ;; be any newlines before that. So -- typically - ;; (defvar foo 'value "\ - ;; Doc string" ...). + ;; We want to print, for instance, `defvar' values while escaping + ;; control characters (so that we don't end up with lines with + ;; trailing tab characters and the like), but we don't want to do + ;; this for doc strings, because then the doc strings would be on + ;; one single line, which would lead to more VC churn. So -- + ;; typically (defvar foo 'value "\ Doc string" ...). (insert "(") (dotimes (_ 3) (prin1 (pop def) (current-buffer) commit c2bddf8fe77aab1a178a5617783dd9aab68d5a76 Author: Lars Ingebrigtsen Date: Thu Aug 4 07:23:59 2022 +0200 Remove read_string_literal purify doc string hack * src/lread.c (read_string_literal): Since we're now byte-compiling the loaddefs files (so doc strings come from the .elc files), remove the hack that make this return 0 when the string starts with "\\n". diff --git a/src/lread.c b/src/lread.c index 0b46a2e4ee..b7d8d9eeca 100644 --- a/src/lread.c +++ b/src/lread.c @@ -3056,7 +3056,6 @@ read_string_literal (char stackbuf[VLA_ELEMS (stackbufsize)], /* True if we saw an escape sequence specifying a single-byte character. */ bool force_singlebyte = false; - bool cancel = false; ptrdiff_t nchars = 0; int ch; @@ -3085,8 +3084,6 @@ read_string_literal (char stackbuf[VLA_ELEMS (stackbufsize)], case ' ': case '\n': /* `\SPC' and `\LF' generate no characters at all. */ - if (p == read_buffer) - cancel = true; continue; default: UNREAD (ch); @@ -3152,15 +3149,6 @@ read_string_literal (char stackbuf[VLA_ELEMS (stackbufsize)], if (ch < 0) end_of_file_error (); - /* If purifying, and string starts with \ newline, - return zero instead. This is for doc strings - that we are really going to find in etc/DOC.nn.nn. */ - if (!NILP (Vpurify_flag) && NILP (Vdoc_file_name) && cancel) - { - unbind_to (count, Qnil); - return make_fixnum (0); - } - if (!force_multibyte && force_singlebyte) { /* READ_BUFFER contains raw 8-bit bytes and no multibyte commit 40c11327118a6023745dbcbdca0564cbc6ba15da Author: Lars Ingebrigtsen Date: Thu Aug 4 07:03:52 2022 +0200 Remove VCSWITNESS dependency, since we're always rescanning now * Makefile.in (VCSWITNESS): Remove, since we're always rescanning for loaddefs. * src/Makefile.in ($(lispsource)/loaddefs.el): Remove VCSWITNESS dependency. diff --git a/Makefile.in b/Makefile.in index 4b74963665..bf0f52b514 100644 --- a/Makefile.in +++ b/Makefile.in @@ -455,18 +455,11 @@ lisp: src lib lib-src lisp nt: Makefile $(MAKE) -C $@ all -# Ideally, VCSWITNESS should be a file that is modified whenever the -# repository registers a commit from either a local checkin or a -# repository pull. In git there is no single file that guarantees -# this, but the local log for the current head should be close enough. -# # Pass an unexpanded $srcdir to src's Makefile, which then # expands it using its own value of srcdir (which points to the # source directory of src/). -dirstate = .git/logs/HEAD -VCSWITNESS = $(if $(wildcard $(srcdir)/$(dirstate)),$$(srcdir)/../$(dirstate)) src: Makefile - $(MAKE) -C $@ VCSWITNESS='$(VCSWITNESS)' BIN_DESTDIR='$(BIN_DESTDIR)' \ + $(MAKE) -C $@ BIN_DESTDIR='$(BIN_DESTDIR)' \ ELN_DESTDIR='$(ELN_DESTDIR)' all blessmail: Makefile src diff --git a/src/Makefile.in b/src/Makefile.in index e81e7a16d9..8551447c8b 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -886,13 +886,7 @@ elnlisp := $(addprefix ${lispsource}/,${elnlisp}) $(lisp:.elc=.eln) fi endif -## VCSWITNESS points to the file that holds info about the current checkout. -## We use it as a heuristic to decide when to rebuild loaddefs.el. -## If empty it is ignored; the parent makefile can set it to some other value. -VCSWITNESS = - -$(lispsource)/loaddefs.el: $(VCSWITNESS) | \ - bootstrap-emacs$(EXEEXT) $(bootstrap_pdmp) +$(lispsource)/loaddefs.el: | bootstrap-emacs$(EXEEXT) $(bootstrap_pdmp) $(MAKE) -C ../lisp autoloads EMACS="$(bootstrap_exe)" ## Dump an Emacs executable named bootstrap-emacs containing the commit ca57767128469545069ade657657ce76ad3c818b Author: Lars Ingebrigtsen Date: Thu Aug 4 06:53:25 2022 +0200 Regenerate ldefs-boot.el diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el index f7275ef3c6..8dbd8f9903 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -5064,8 +5064,6 @@ evaluate `compilation-shell-minor-mode'. The mode's hook is called both when the mode is enabled and when it is disabled. -\\{compilation-shell-minor-mode-map} - (fn &optional ARG)" t nil) (autoload 'compilation-minor-mode "compile" "\ Toggle Compilation minor mode. @@ -5089,8 +5087,6 @@ evaluate `compilation-minor-mode'. The mode's hook is called both when the mode is enabled and when it is disabled. -\\{compilation-minor-mode-map} - (fn &optional ARG)" t nil) (autoload 'compilation-next-error-function "compile" "\ Advance to the next error message and visit the file where the error was. @@ -7309,7 +7305,7 @@ If given a \\[universal-argument] prefix, also prompt for the QUERY-TYPE paramet If given a \\[universal-argument] \\[universal-argument] prefix, also prompt for the SERVER parameter. (fn DOMAIN &optional QUERY-TYPE QUERY-CLASS QUERY-OPTION DIG-OPTION SERVER)" t nil) -(register-definition-prefixes "dig" '("dig-" "query-dig")) +(register-definition-prefixes "dig" '("dig-")) ;;; Generated autoloads from cedet/ede/dired.el @@ -8442,7 +8438,7 @@ A second call of this function without changing point inserts the next match. A call with prefix PREFIX reads the symbol to insert from the minibuffer with completion. -(fn PREFIX)" t nil) +(fn PREFIX)" '("P") nil) (autoload 'ebrowse-tags-loop-continue "ebrowse" "\ Repeat last operation on files in tree. FIRST-TIME non-nil means this is not a repetition, but the first time. @@ -9979,7 +9975,7 @@ When present, ID should be an opaque object used to identify the connection unequivocally. This is rarely needed and not available interactively. -(fn &key (SERVER (erc-compute-server)) (PORT (erc-compute-port)) (NICK (erc-compute-nick)) (USER (erc-compute-user)) PASSWORD (FULL-NAME (erc-compute-full-name)) ID)" t nil) +(fn &key (SERVER (erc-compute-server)) (PORT (erc-compute-port)) (NICK (erc-compute-nick)) (USER (erc-compute-user)) PASSWORD (FULL-NAME (erc-compute-full-name)) ID)" '((erc-select-read-args)) nil) (defalias 'erc-select #'erc) (autoload 'erc-tls "erc" "\ ERC is a powerful, modular, and extensible IRC client. @@ -10026,7 +10022,7 @@ symbol composed of letters from the Latin alphabet.) This option is generally unneeded, however. See info node `(erc) Connecting' for use cases. Not available interactively. -(fn &key (SERVER (erc-compute-server)) (PORT (erc-compute-port)) (NICK (erc-compute-nick)) (USER (erc-compute-user)) PASSWORD (FULL-NAME (erc-compute-full-name)) CLIENT-CERTIFICATE ID)" t nil) +(fn &key (SERVER (erc-compute-server)) (PORT (erc-compute-port)) (NICK (erc-compute-nick)) (USER (erc-compute-user)) PASSWORD (FULL-NAME (erc-compute-full-name)) CLIENT-CERTIFICATE ID)" '((let ((erc-default-port erc-default-port-tls)) (erc-select-read-args))) nil) (autoload 'erc-handle-irc-url "erc" "\ Use ERC to IRC on HOST:PORT in CHANNEL as USER with PASSWORD. If ERC is already connected to HOST:PORT, simply /join CHANNEL. @@ -10242,9 +10238,7 @@ it has to be wrapped in `(eval (quote ...))'. If NAME is already defined as a test and Emacs is running in batch mode, an error is signalled. -(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] [:tags \\='(TAG...)] BODY...)" nil t) -(function-put 'ert-deftest 'doc-string-elt 3) -(function-put 'ert-deftest 'lisp-indent-function 2) +(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] [:tags \\='(TAG...)] BODY...)" nil 'macro) (autoload 'ert-run-tests-batch "ert" "\ Run the tests specified by SELECTOR, printing results to the terminal. @@ -12325,8 +12319,6 @@ evaluate `flymake-mode'. The mode's hook is called both when the mode is enabled and when it is disabled. -\\{flymake-mode-map} - (fn &optional ARG)" t nil) (autoload 'flymake-mode-on "flymake" "\ Turn Flymake mode on." nil nil) @@ -14650,16 +14642,13 @@ Towers of Hanoi diversion. Use NRINGS rings. (fn NRINGS)" t nil) (autoload 'hanoi-unix "hanoi" "\ -Towers of Hanoi, UNIX doomsday version. -Displays 32-ring towers that have been progressing at one move per -second since 1970-01-01 00:00:00 GMT. +Towers of Hanoi, 32-bit UNIX doomsday version. +Display 32-ring towers that have been progressing at one move per +second since 1970-01-01 00:00:00 UTC. Repent before ring 31 moves." t nil) (autoload 'hanoi-unix-64 "hanoi" "\ -Like `hanoi-unix', but pretend to have a 64-bit clock. -This is, necessarily (as of Emacs 20.3), a crock. When the -`current-time' interface is made s2G-compliant, hanoi.el will need -to be updated." t nil) +Like `hanoi-unix', but with a 64-bit clock." t nil) (register-definition-prefixes "hanoi" '("hanoi-")) @@ -15930,8 +15919,7 @@ inlined into the compiled format versions. This means that if you change its definition, you should explicitly call `ibuffer-recompile-formats'. -(fn SYMBOL (&key NAME INLINE PROPS SUMMARIZER) &rest BODY)" nil t) -(function-put 'define-ibuffer-column 'lisp-indent-function 'defun) +(fn SYMBOL (&key NAME INLINE PROPS SUMMARIZER) &rest BODY)" nil 'macro) (autoload 'define-ibuffer-sorter "ibuf-macs" "\ Define a method of sorting named NAME. DOCUMENTATION is the documentation of the function, which will be called @@ -15942,9 +15930,7 @@ For sorting, the forms in BODY will be evaluated with `a' bound to one buffer object, and `b' bound to another. BODY should return a non-nil value if and only if `a' is \"less than\" `b'. -(fn NAME DOCUMENTATION (&key DESCRIPTION) &rest BODY)" nil t) -(function-put 'define-ibuffer-sorter 'lisp-indent-function 1) -(function-put 'define-ibuffer-sorter 'doc-string-elt 2) +(fn NAME DOCUMENTATION (&key DESCRIPTION) &rest BODY)" nil 'macro) (autoload 'define-ibuffer-op "ibuf-macs" "\ Generate a function which operates on a buffer. OP becomes the name of the function; if it doesn't begin with @@ -15983,9 +15969,7 @@ BODY define the operation; they are forms to evaluate per each marked buffer. BODY is evaluated with `buf' bound to the buffer object. -(fn OP ARGS DOCUMENTATION (&key INTERACTIVE MARK MODIFIER-P DANGEROUS OPSTRING ACTIVE-OPSTRING BEFORE AFTER COMPLEX) &rest BODY)" nil t) -(function-put 'define-ibuffer-op 'lisp-indent-function 2) -(function-put 'define-ibuffer-op 'doc-string-elt 3) +(fn OP ARGS DOCUMENTATION (&key INTERACTIVE MARK MODIFIER-P DANGEROUS OPSTRING ACTIVE-OPSTRING BEFORE AFTER COMPLEX) &rest BODY)" nil 'macro) (autoload 'define-ibuffer-filter "ibuf-macs" "\ Define a filter named NAME. DOCUMENTATION is the documentation of the function. @@ -16000,9 +15984,7 @@ not a particular buffer should be displayed or not. The forms in BODY will be evaluated with BUF bound to the buffer object, and QUALIFIER bound to the current value of the filter. -(fn NAME DOCUMENTATION (&key READER DESCRIPTION) &rest BODY)" nil t) -(function-put 'define-ibuffer-filter 'lisp-indent-function 2) -(function-put 'define-ibuffer-filter 'doc-string-elt 2) +(fn NAME DOCUMENTATION (&key READER DESCRIPTION) &rest BODY)" nil 'macro) (register-definition-prefixes "ibuf-macs" '("ibuffer-")) @@ -23602,11 +23584,6 @@ they are not by default assigned to keys." t nil) (defalias 'edit-picture 'picture-mode) (register-definition-prefixes "picture" '("picture-")) - -;;; Generated autoloads from language/pinyin.el - -(register-definition-prefixes "pinyin" '("pinyin-character-map")) - ;;; Generated autoloads from textmodes/pixel-fill.el @@ -25401,8 +25378,6 @@ evaluate `rectangle-mark-mode'. The mode's hook is called both when the mode is enabled and when it is disabled. -\\{rectangle-mark-mode-map} - (fn &optional ARG)" t nil) (register-definition-prefixes "rect" '("apply-on-rectangle" "clear-rectangle-line" "delete-" "extract-rectangle-" "killed-rectangle" "ope" "rectangle-" "spaces-string" "string-rectangle-")) @@ -31277,7 +31252,7 @@ Gregorian date Sunday, December 31, 1 BC. (fn TIME)" nil nil) (autoload 'safe-date-to-time "time-date" "\ Parse a string DATE that represents a date-time and return a time value. -If DATE is malformed, return a time value of zeros. +If DATE is malformed, return a time value of zero. (fn DATE)" nil nil) (autoload 'format-seconds "time-date" "\ @@ -31790,12 +31765,7 @@ List of suffixes which indicate a compressed file. It must be supported by libarchive(3).") (defmacro tramp-archive-autoload-file-name-regexp nil "\ Regular expression matching archive file names." '(concat "\\`" "\\(" ".+" "\\." (regexp-opt tramp-archive-suffixes) "\\(?:" "\\." (regexp-opt tramp-archive-compression-suffixes) "\\)*" "\\)" "\\(" "/" ".*" "\\)" "\\'")) -(autoload 'tramp-archive-file-name-handler "tramp-archive" "\ -Invoke the file archive related OPERATION. -First arg specifies the OPERATION, second arg ARGS is a list of -arguments to pass to the OPERATION. - -(fn OPERATION &rest ARGS)" nil nil) +(autoload 'tramp-archive-file-name-handler "tramp-archine") (defun tramp-archive-autoload-file-name-handler (operation &rest args) "\ Load Tramp archive file name handler, and perform OPERATION." (defvar tramp-archive-autoload) (let ((default-directory temporary-file-directory) (tramp-archive-autoload tramp-archive-enabled)) (apply #'tramp-autoload-file-name-handler operation args))) (defun tramp-register-archive-file-name-handler nil "\ @@ -31807,7 +31777,7 @@ Add archive file name handler to `file-name-handler-alist'." (when (and tramp-ar ;;; Generated autoloads from net/tramp-cache.el -(register-definition-prefixes "tramp-cache" '("tramp-")) +(register-definition-prefixes "tramp-cache" '("tramp-" "with-tramp-")) ;;; Generated autoloads from net/tramp-cmds.el @@ -31933,9 +31903,11 @@ SUFFIX is a suffix command or a group specification (of LOC is a command, a key vector, a key description (a string as returned by `key-description'), or a coordination list (whose last element may also be a command or key). +Remove a conflicting binding unless optional KEEP-OTHER is + non-nil. See info node `(transient)Modifying Existing Transients'. -(fn PREFIX LOC SUFFIX)" nil nil) +(fn PREFIX LOC SUFFIX &optional KEEP-OTHER)" nil nil) (function-put 'transient-insert-suffix 'lisp-indent-function 'defun) (autoload 'transient-append-suffix "transient" "\ Insert a SUFFIX into PREFIX after LOC. @@ -31945,9 +31917,11 @@ SUFFIX is a suffix command or a group specification (of LOC is a command, a key vector, a key description (a string as returned by `key-description'), or a coordination list (whose last element may also be a command or key). +Remove a conflicting binding unless optional KEEP-OTHER is + non-nil. See info node `(transient)Modifying Existing Transients'. -(fn PREFIX LOC SUFFIX)" nil nil) +(fn PREFIX LOC SUFFIX &optional KEEP-OTHER)" nil nil) (function-put 'transient-append-suffix 'lisp-indent-function 'defun) (autoload 'transient-replace-suffix "transient" "\ Replace the suffix at LOC in PREFIX with SUFFIX. @@ -31971,7 +31945,7 @@ See info node `(transient)Modifying Existing Transients'. (fn PREFIX LOC)" nil nil) (function-put 'transient-remove-suffix 'lisp-indent-function 'defun) -(register-definition-prefixes "transient" '("magit--fit-window-to-buffer" "transient-")) +(register-definition-prefixes "transient" '("magit--fit-window-to-buffer" "transient")) ;;; Generated autoloads from tree-widget.el @@ -32440,11 +32414,6 @@ added to this list, so most requests can just pass in nil. (fn URL)" nil nil) (register-definition-prefixes "url-dav" '("url-dav-")) - -;;; Generated autoloads from url/url-dired.el - -(register-definition-prefixes "url-dired" '("url-")) - ;;; Generated autoloads from url/url-domsuf.el @@ -32798,14 +32767,8 @@ Will not do anything if `url-show-status' is nil. Return a date string that most HTTP servers can understand. (fn &optional SPECIFIED-TIME)" nil nil) -(autoload 'url-eat-trailing-space "url-util" "\ -Remove spaces/tabs at the end of a string. - -(fn X)" nil nil) -(autoload 'url-strip-leading-spaces "url-util" "\ -Remove spaces at the front of a string. - -(fn X)" nil nil) +(define-obsolete-function-alias 'url-eat-trailing-space #'string-trim-right "29.1") +(define-obsolete-function-alias 'url-strip-leading-spaces #'string-trim-left "29.1") (autoload 'url-display-percentage "url-util" "\ @@ -35897,8 +35860,8 @@ Zone out, completely." t nil) (provide 'loaddefs) ;; Local Variables: -;; version-control: never ;; no-byte-compile: t +;; version-control: never ;; no-update-autoloads: t ;; coding: utf-8-emacs-unix ;; End: commit 7520932dbe79ee61bc41718099acfbfbb49f2e86 Author: Lars Ingebrigtsen Date: Thu Aug 4 06:53:04 2022 +0200 Still mark ldefs-boot.el as non-byte-compilable * lisp/Makefile.in (ldefs-boot.el): Mark ldefs-boot.el as non-byte-compiled. diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 315b1fcf7b..7c1f872939 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -171,49 +171,38 @@ org-manuals: main-first ## Comments on loaddefs generation: -# loaddefs depends on gen-lisp for two reasons: -# 1) In ../src, the emacs target depends on loaddefs but not on eg leim-list. +# In ../src, the emacs target depends on loaddefs but not on eg leim-list. # So having leim as a dependency of loaddefs (via gen-lisp) ensures leim-list # gets created before the final emacs is dumped. Having leim # dependencies in ../src as well would create a parallel race condition. # -# FIXME: 2) is no longer correct, so perhaps we could add unidata to -# gen-lisp now? +# FIXME: Is the following true any more? # -# 2) Files that are marked no-update-autoloads still get recorded in loaddefs. -# So those files should be generated before we make autoloads, if we -# don't want a successive make autoloads to change the output file. -# Said changes are trivial (only comments in the "files without autoloads" -# section), but still can be annoying. Of course, if generated lisp files -# do contain autoloads, it is essential they be built before make autoloads. -# (Also, if a generated file is not written atomically, it is possible that -# in a parallel build, make autoloads could read a partial version of it.) -# -# We'd really like to add "make -C ../admin/unidata all" to gen-lisp -# because of 2) above, but it causes a race condition in parallel -# builds because ../src also runs that rule. Given the limitations of -# recursive make, the only way to fix that would be to remove unidata -# from ../src rules, but that doesn't seem possible due to the various -# non-trivial dependencies. - -# That's because the real dependencies of loaddefs.el aren't known to -# Make, they are implemented in loaddefs-generate--emacs-batch, so -# autoloads is an "all" dependency. +# We'd really like to add "make -C ../admin/unidata all" to gen-lisp, +# but it causes a race condition in parallel builds because ../src +# also runs that rule. Given the limitations of recursive make, the +# only way to fix that would be to remove unidata from ../src rules, +# but that doesn't seem possible due to the various non-trivial +# dependencies. + +# The real dependencies of loaddefs.el aren't known to Make, they are +# implemented in loaddefs-generate--emacs-batch, so autoloads is an +# "all" dependency. autoloads: $(AM_V_GEN)$(emacs) \ -l $(lisp)/emacs-lisp/loaddefs-gen.elc \ -f loaddefs-generate--emacs-batch ${SUBDIRS_ALMOST} -# autoloads only runs when loaddefs.el is nonexistent, although it -# generates a number of different files. Provide a force option to enable -# regeneration of all these files. +# autoloads always runs, but only updates when there's something new. +# Provide a force option to enable regeneration of all loaddefs files. .PHONY: autoloads-force autoloads-force: rm -f $(lisp)/loaddefs.el $(MAKE) autoloads ldefs-boot.el: autoloads-force - cp $(lisp)/loaddefs.el $(lisp)/ldefs-boot.el + sed '/^;; Local Variables:/a ;; no-byte-compile: t'\ + < $(lisp)/loaddefs.el > $(lisp)/ldefs-boot.el # This is required by the bootstrap-emacs target in ../src/Makefile, so # we know that if we have an emacs executable, we also have a subdirs.el. commit 57e33b25d118599adf06a0fb1bb147d89f40666f Merge: cb8eb5e830 20ee17385f Author: Stefan Kangas Date: Thu Aug 4 06:30:33 2022 +0200 ; Merge from origin/emacs-28 The following commit was skipped: 20ee17385f * lisp/uniquify.el (uniquify-buffer-name-style): Quote apo... commit cb8eb5e83050f0c58f06820d2f192e583018a66f Author: Po Lu Date: Thu Aug 4 09:13:53 2022 +0800 Avoid redundant calls to XFlush in x_make_frame_visible * src/xterm.c (x_make_frame_visible): Keep track of whether or not the output buffer was implictly flushed before issuing XFlush. diff --git a/src/xterm.c b/src/xterm.c index f82340958e..63e62f39be 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -25750,6 +25750,7 @@ x_make_frame_visible (struct frame *f) struct x_display_info *dpyinfo; struct x_output *output; #endif + bool output_flushed; if (FRAME_PARENT_FRAME (f)) { @@ -25840,8 +25841,6 @@ x_make_frame_visible (struct frame *f) } } - XFlush (FRAME_X_DISPLAY (f)); - /* Synchronize to ensure Emacs knows the frame is visible before we do anything else. We do this loop with input not blocked so that incoming events are handled. */ @@ -25860,6 +25859,10 @@ x_make_frame_visible (struct frame *f) /* This must come after we set COUNT. */ unblock_input (); + /* Keep track of whether or not the output buffer was flushed, to + avoid any extra flushes. */ + output_flushed = false; + /* We unblock here so that arriving X events are processed. */ /* Now move the window back to where it was "supposed to be". @@ -25893,6 +25896,7 @@ x_make_frame_visible (struct frame *f) there, and take the potential window manager hit. */ XGetGeometry (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f), &rootw, &x, &y, &width, &height, &border, &depth); + output_flushed = true; if (original_left != x || original_top != y) XMoveWindow (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f), @@ -25927,7 +25931,11 @@ x_make_frame_visible (struct frame *f) (f, build_string ("x_make_frame_visible")); x_wait_for_event (f, MapNotify); + output_flushed = true; } + + if (!output_flushed) + x_flush (f); } } commit 9e9b0e13bc8fbf716bb48e68bb642b130ff41fed Author: Stefan Monnier Date: Wed Aug 3 17:02:25 2022 -0400 Revert "Revert part of 59732a83c8 to fix bug#52969" This reverts commit 460f35e96df1c39ce2ba0f424b36365a2f9e9825. Re-remove the code that scans .el files for docstrings, now that even `lisp/loaddefs.el` is compiled. * lib-src/make-docfile.c (scan_file): Don't call `scan_lisp_file`. (scan_lisp_file, skip_white, read_lisp_symbol, search_lisp_doc_at_eol): Delete functions. diff --git a/lib-src/make-docfile.c b/lib-src/make-docfile.c index 908d73f525..b5beffce19 100644 --- a/lib-src/make-docfile.c +++ b/lib-src/make-docfile.c @@ -19,8 +19,8 @@ You should have received a copy of the GNU General Public License along with GNU Emacs. If not, see . */ -/* The arguments given to this program are all the C and some Lisp source files - of GNU Emacs. .el and .c files are allowed. +/* The arguments given to this program are all the C files + of GNU Emacs. .c files are allowed. A .o file can also be specified; the .c file it was made from is used. This helps the makefile pass the correct list of files. Option -d DIR means change to DIR before looking for files. @@ -66,7 +66,6 @@ along with GNU Emacs. If not, see . */ #endif /* not DOS_NT */ static void scan_file (char *filename); -static void scan_lisp_file (const char *filename, const char *mode); static void scan_c_file (char *filename, const char *mode); static void scan_c_stream (FILE *infile); static void start_globals (void); @@ -236,14 +235,9 @@ put_filename (char *filename) static void scan_file (char *filename) { - ptrdiff_t len = strlen (filename); - if (!generate_globals) put_filename (filename); - if (len > 3 && !strcmp (filename + len - 3, ".el")) - scan_lisp_file (filename, "r"); - else - scan_c_file (filename, "r"); + scan_c_file (filename, "r"); } static void @@ -1221,352 +1215,4 @@ scan_c_stream (FILE *infile) fatal ("read error"); } -/* Read a file of Lisp source code. - Looks for - (defun NAME ARGS DOCSTRING ...) - (defmacro NAME ARGS DOCSTRING ...) - (defsubst NAME ARGS DOCSTRING ...) - (autoload (quote NAME) FILE DOCSTRING ...) - (defvar NAME VALUE DOCSTRING) - (defconst NAME VALUE DOCSTRING) - (fset (quote NAME) (make-byte-code ... DOCSTRING ...)) - (fset (quote NAME) #[... DOCSTRING ...]) - (defalias (quote NAME) #[... DOCSTRING ...]) - (custom-declare-variable (quote NAME) VALUE DOCSTRING ...) - starting in column zero. - (quote NAME) may appear as 'NAME as well. - - We also look for #@LENGTH CONTENTS^_ at the beginning of the line. - When we find that, we save it for the following defining-form, - and we use that instead of reading a doc string within that defining-form. - - For defvar, defconst, and fset we skip to the docstring with a kludgy - formatting convention: all docstrings must appear on the same line as the - initial open-paren (the one in column zero) and must contain a backslash - and a newline immediately after the initial double-quote. No newlines - must appear between the beginning of the form and the first double-quote. - For defun, defmacro, and autoload, we know how to skip over the - arglist, but the doc string must still have a backslash and newline - immediately after the double quote. - The only source files that follow this convention are autoload-generated - files like loaddefs.el; - The NAME and DOCSTRING are output. - NAME is preceded by `F' for a function or `V' for a variable. - An entry is output only if DOCSTRING has \ newline just after the opening ". - */ - -static void -skip_white (FILE *infile) -{ - int c; - do - c = getc (infile); - while (c_isspace (c)); - - ungetc (c, infile); -} - -static void -read_lisp_symbol (FILE *infile, char *buffer) -{ - int c; - char *fillp = buffer; - - skip_white (infile); - while (true) - { - c = getc (infile); - if (c == '\\') - { - c = getc (infile); - if (c < 0) - return; - *fillp++ = c; - } - else if (c_isspace (c) || c == '(' || c == ')' || c < 0) - { - ungetc (c, infile); - *fillp = 0; - break; - } - else - *fillp++ = c; - } - - if (! buffer[0]) - fprintf (stderr, "## expected a symbol, got '%c'\n", c); - - skip_white (infile); -} - -static bool -search_lisp_doc_at_eol (FILE *infile) -{ - int c = 0, c1 = 0, c2 = 0; - - /* Skip until the end of line; remember two previous chars. */ - while (c != '\n' && c != '\r' && c != EOF) - { - c2 = c1; - c1 = c; - c = getc (infile); - } - - /* If two previous characters were " and \, - this is a doc string. Otherwise, there is none. */ - if (c2 != '"' || c1 != '\\') - { -#ifdef DEBUG - fprintf (stderr, "## non-docstring found\n"); -#endif - ungetc (c, infile); - return false; - } - return true; -} - -static void -scan_lisp_file (const char *filename, const char *mode) -{ - FILE *infile; - int c; - - if (generate_globals) - fatal ("scanning lisp file when -g specified"); - - infile = fopen (filename, mode); - if (infile == NULL) - { - perror (filename); - exit (EXIT_FAILURE); - } - - c = '\n'; - while (!feof (infile)) - { - char buffer[BUFSIZ]; - char type; - - /* If not at end of line, skip till we get to one. */ - if (c != '\n' && c != '\r') - { - c = getc (infile); - continue; - } - /* Skip the line break. */ - while (c == '\n' || c == '\r') - c = getc (infile); - - if (c != '(') - continue; - - read_lisp_symbol (infile, buffer); - - if (! strcmp (buffer, "defun") - || ! strcmp (buffer, "defmacro") - || ! strcmp (buffer, "defsubst")) - { - type = 'F'; - read_lisp_symbol (infile, buffer); - - /* Skip the arguments: either "nil" or a list in parens. */ - - c = getc (infile); - if (c == 'n') /* nil */ - { - if ((c = getc (infile)) != 'i' - || (c = getc (infile)) != 'l') - { - fprintf (stderr, "## unparsable arglist in %s (%s)\n", - buffer, filename); - continue; - } - } - else if (c != '(') - { - fprintf (stderr, "## unparsable arglist in %s (%s)\n", - buffer, filename); - continue; - } - else - while (! (c == ')' || c < 0)) - c = getc (infile); - skip_white (infile); - - /* If the next three characters aren't `dquote bslash newline' - then we're not reading a docstring. - */ - if ((c = getc (infile)) != '"' - || (c = getc (infile)) != '\\' - || ((c = getc (infile)) != '\n' && c != '\r')) - { -#ifdef DEBUG - fprintf (stderr, "## non-docstring in %s (%s)\n", - buffer, filename); -#endif - continue; - } - } - - else if (! strcmp (buffer, "defvar") - || ! strcmp (buffer, "defconst") - || ! strcmp (buffer, "defcustom")) - { - type = 'V'; - read_lisp_symbol (infile, buffer); - - if (!search_lisp_doc_at_eol (infile)) - continue; - } - - else if (! strcmp (buffer, "custom-declare-variable") - || ! strcmp (buffer, "defvaralias") - ) - { - type = 'V'; - - c = getc (infile); - if (c == '\'') - read_lisp_symbol (infile, buffer); - else - { - if (c != '(') - { - fprintf (stderr, - "## unparsable name in custom-declare-variable in %s\n", - filename); - continue; - } - read_lisp_symbol (infile, buffer); - if (strcmp (buffer, "quote")) - { - fprintf (stderr, - "## unparsable name in custom-declare-variable in %s\n", - filename); - continue; - } - read_lisp_symbol (infile, buffer); - c = getc (infile); - if (c != ')') - { - fprintf (stderr, - "## unparsable quoted name in custom-declare-variable in %s\n", - filename); - continue; - } - } - - if (!search_lisp_doc_at_eol (infile)) - continue; - } - - else if (! strcmp (buffer, "fset") || ! strcmp (buffer, "defalias")) - { - type = 'F'; - - c = getc (infile); - if (c == '\'') - read_lisp_symbol (infile, buffer); - else - { - if (c != '(') - { - fprintf (stderr, "## unparsable name in fset in %s\n", - filename); - continue; - } - read_lisp_symbol (infile, buffer); - if (strcmp (buffer, "quote")) - { - fprintf (stderr, "## unparsable name in fset in %s\n", - filename); - continue; - } - read_lisp_symbol (infile, buffer); - c = getc (infile); - if (c != ')') - { - fprintf (stderr, - "## unparsable quoted name in fset in %s\n", - filename); - continue; - } - } - - if (!search_lisp_doc_at_eol (infile)) - continue; - } - - else if (! strcmp (buffer, "autoload")) - { - type = 'F'; - c = getc (infile); - if (c == '\'') - read_lisp_symbol (infile, buffer); - else - { - if (c != '(') - { - fprintf (stderr, "## unparsable name in autoload in %s\n", - filename); - continue; - } - read_lisp_symbol (infile, buffer); - if (strcmp (buffer, "quote")) - { - fprintf (stderr, "## unparsable name in autoload in %s\n", - filename); - continue; - } - read_lisp_symbol (infile, buffer); - c = getc (infile); - if (c != ')') - { - fprintf (stderr, - "## unparsable quoted name in autoload in %s\n", - filename); - continue; - } - } - skip_white (infile); - c = getc (infile); - if (c != '\"') - { - fprintf (stderr, "## autoload of %s unparsable (%s)\n", - buffer, filename); - continue; - } - read_c_string_or_comment (infile, 0, false, 0); - - if (!search_lisp_doc_at_eol (infile)) - continue; - } - -#ifdef DEBUG - else if (! strcmp (buffer, "if") - || ! strcmp (buffer, "byte-code")) - continue; -#endif - - else - { -#ifdef DEBUG - fprintf (stderr, "## unrecognized top-level form, %s (%s)\n", - buffer, filename); -#endif - continue; - } - - /* At this point, we should gobble a doc string from the input file. - The opening quote (and leading backslash-newline) - have already been read. */ - - printf ("\037%c%s\n", type, buffer); - read_c_string_or_comment (infile, 1, false, 0); - } - if (ferror (infile) || fclose (infile) != 0) - fatal ("%s: read error", filename); -} - - /* make-docfile.c ends here */ commit eb2f39428935aa6ea42bc12272df8f43da7cde6c Author: Stefan Kangas Date: Wed Aug 3 17:32:52 2022 +0200 * lisp/help.el (describe-map-tree, describe-map): Simplify. diff --git a/lisp/help.el b/lisp/help.el index f58d252bae..37aab15df0 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -1323,18 +1323,17 @@ If BUFFER, lookup keys while in that buffer. This only affects things like :filters for menu bindings." (let* ((amaps (accessible-keymaps startmap prefix)) (orig-maps (if no-menu - (progn - ;; Delete from MAPS each element that is for - ;; the menu bar. - (let* ((tail amaps) - result) - (while tail - (let ((elem (car tail))) - (when (not (and (>= (length (car elem)) 1) - (eq (elt (car elem) 0) 'menu-bar))) - (setq result (append result (list elem))))) - (setq tail (cdr tail))) - result)) + ;; Delete from MAPS each element that is for + ;; the menu bar. + (let* ((tail amaps) + result) + (while tail + (let ((elem (car tail))) + (when (not (and (>= (length (car elem)) 1) + (eq (elt (car elem) 0) 'menu-bar))) + (setq result (append result (list elem))))) + (setq tail (cdr tail))) + result) amaps)) (maps orig-maps) (print-title (or maps always-title)) @@ -1448,8 +1447,7 @@ prefix keys PREFIX (a string or vector). TRANSL, PARTIAL, SHADOW, NOMENU, MENTION-SHADOW and BUFFER are as in `describe-map-tree'." ;; Converted from describe_map in keymap.c. - (let* ((suppress (and partial 'suppress-keymap)) - (map (keymap-canonicalize map)) + (let* ((map (keymap-canonicalize map)) (tail map) (first t) done vect) @@ -1480,7 +1478,7 @@ in `describe-map-tree'." ;; commands. (setq definition (keymap--get-keyelt (cdr (car tail)) nil)) (or (not (symbolp definition)) - (null (get definition suppress))) + (not (get definition (when partial 'suppress-keymap)))) ;; Don't show a command that isn't really ;; visible because a local definition of the ;; same key shadows it. @@ -1513,7 +1511,7 @@ in `describe-map-tree'." (push (cons tail prefix) help--keymaps-seen))))) (setq tail (cdr tail))) ;; If we found some sparse map events, sort them. - (let ((vect (sort vect 'help--describe-map-compare)) + (let ((vect (sort vect #'help--describe-map-compare)) (columns ()) line-start key-end column) ;; Now output them in sorted order. commit 21afc26d4df6bae35ba032d4b6b03fb7fb2bf1b3 Author: Michael Albinus Date: Wed Aug 3 17:30:09 2022 +0200 Reorganize Tramp * lisp/net/tramp-adb.el (tramp-adb-handle-write-region): Handle special case that START is "". (tramp-adb-handle-set-file-modes) (tramp-adb-handle-set-file-times): Use `tramp-skeleton-set-file-modes-times-uid-gid'. (tramp-adb-handle-make-process): Use `with-tramp-saved-connection-properties'. * lisp/net/tramp-archive.el (tramp-archive-file-name-handler-alist): Use `tramp-archive-handle-file-exists-p'. (tramp-archive-handle-file-exists-p): New defun. (tramp-archive-file-name-handler): Add ;;;###tramp-autoload cookie. * lisp/net/tramp-cache.el (tramp-compat, tramp-loaddefs) (time-stamp): Require. (tramp-get-file-property, tramp-set-file-property) (tramp-flush-file-property, tramp-flush-file-upper-properties) (tramp-flush-file-properties): Use `tramp-file-name-unify'. Adapt message. (tramp-flush-directory-properties): Simplify. (tramp-flush-file-function): Add ;;;###tramp-autoload cookie. Don't use `with-parsed-tramp-file-name', it isn't exposed. (with-tramp-file-property, with-tramp-connection-property) (with-tramp-saved-connection-property): Macros moved from tramp.el. (with-tramp-saved-file-property) (with-tramp-saved-file-properties) (with-tramp-saved-connection-properties): New defmacros. * lisp/net/tramp-cmds.el (tramp-cleanup-connection): Flush "/". * lisp/net/tramp-crypt.el (tramp-crypt-handle-set-file-modes) (tramp-crypt-handle-set-file-times) (tramp-crypt-handle-set-file-uid-gid): Use `tramp-skeleton-set-file-modes-times-uid-gid'. * lisp/net/tramp-ftp.el (tramp-archive-file-name-handler): Don't declare. * lisp/net/tramp-gvfs.el (tramp-gvfs-info): New defun. (tramp-gvfs-do-copy-or-rename-file) (tramp-gvfs-handle-delete-directory) (tramp-gvfs-handle-delete-file, tramp-gvfs-get-root-attributes) (tramp-gvfs-handle-make-directory): Use it. (tramp-gvfs-handle-set-file-modes) (tramp-gvfs-handle-set-file-times) (tramp-gvfs-handle-set-file-uid-gid): Use `tramp-skeleton-set-file-modes-times-uid-gid'. * lisp/net/tramp-sh.el (tramp-sh-handle-make-symbolic-link): Expand TARGET when flushing file properties. (tramp-sh-handle-set-file-modes, tramp-sh-handle-set-file-times) (tramp-sh-handle-set-file-uid-gid): Use `tramp-skeleton-set-file-modes-times-uid-gid'. (tramp-sh-handle-file-name-all-completions): Protect, when connection is not established yet. (tramp-do-copy-or-rename-file-directly): Flush file properties of NEWNAME when constructing a new remote file name. (tramp-do-copy-or-rename-file-out-of-band, tramp-sh-handle-make-process): Use `with-tramp-saved-connection-properties'. (tramp-sh-handle-delete-file): Flush file properties only after deleting, otherwise we get a false alarm. (tramp-sh-handle-process-file): Flush "/". (tramp-sh-handle-write-region): Handle special case that START is "". * lisp/net/tramp-smb.el (tramp-smb-handle-copy-directory) (tramp-smb-handle-file-acl, tramp-smb-handle-process-file) (tramp-smb-handle-set-file-acl) (tramp-smb-handle-start-file-process): Use `with-tramp-saved-connection-properties'. (tramp-smb-remote-acl-p): New defun. (tramp-smb-handle-file-acl, tramp-smb-handle-set-file-acl): Use it. (tramp-smb-handle-set-file-modes): Use `tramp-skeleton-set-file-modes-times-uid-gid'. (tramp-smb-handle-process-file, tramp-smb-maybe-open-connection): Flush "/". * lisp/net/tramp-sshfs.el (tramp-sshfs-handle-process-file): Flush "/". (tramp-sshfs-handle-set-file-modes) (tramp-sshfs-handle-set-file-times): Use `tramp-skeleton-set-file-modes-times-uid-gid'. * lisp/net/tramp-sudoedit.el (tramp-sudoedit-handle-set-file-modes) (tramp-sudoedit-handle-set-file-times) (tramp-sudoedit-handle-set-file-uid-gid): Use `tramp-skeleton-set-file-modes-times-uid-gid'. * lisp/net/tramp.el (tramp-archive-file-name-handler): Don't declare. (tramp-verbose, tramp-file-name-unify, tramp-tramp-file-p) (tramp-file-local-name, tramp-dissect-file-name) (tramp-make-tramp-file-name, tramp-get-connection-buffer) (tramp-get-buffer-string, tramp-debug-message) (tramp-inhibit-progress-reporter, tramp-message): Add ;;;###tramp-autoload cookie. (tramp-file-name): Expose defstruct to tramp-loaddefs.el (tramp-file-name-unify): New optional arg FILE. (tramp-get-default-directory, tramp-get-buffer-string) (tramp-message, tramp-backtrace, tramp-error-with-buffer) (tramp-with-demoted-errors, tramp-barf-if-file-missing) (tramp-skeleton-copy-directory, tramp-skeleton-delete-directory) (tramp-skeleton-directory-files) (tramp-skeleton-directory-files-and-attributes) (tramp-skeleton-file-local-copy, tramp-skeleton-write-region): Remove `tramp-suppress-trace' property, it isn't needed for defmacros and defsubsts. (with-tramp-file-property, with-tramp-connection-property) (with-tramp-saved-connection-property): Move macros to tramp-cache.el. (tramp-skeleton-directory-files-and-attributes): Fix implementation. (tramp-skeleton-file-local-copy): Fix docstring. (tramp-skeleton-set-file-modes-times-uid-gid): New defmacro. (tramp-skeleton-write-region): Set "file-exists-p" cache property. (tramp-handle-file-exists-p): Use cached value. (tramp-process-sentinel): Flush "/". (tramp-make-tramp-temp-file): Suppress also `tramp-smb-remote-acl-p'. (tramp-get-connection-buffer): * test/lisp/net/tramp-tests.el (tramp-test10-write-region) (tramp-test20-file-modes, tramp-test22-file-times): Extend tests. diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 3e780aa1a1..1d35f2b2ff 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -517,34 +517,39 @@ Emacs dired can't find files." (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." (tramp-skeleton-write-region start end filename append visit lockname mustbenew - (let ((tmpfile (tramp-compat-make-temp-file filename))) - (when (and append (file-exists-p filename)) - (copy-file filename tmpfile 'ok) - (set-file-modes tmpfile (logior (or (file-modes tmpfile) 0) #o0600))) - (let (create-lockfiles) - (write-region start end tmpfile append 'no-message)) - (with-tramp-progress-reporter - v 3 (format-message - "Moving tmp file `%s' to `%s'" tmpfile filename) - (unwind-protect - (unless (tramp-adb-execute-adb-command - v "push" tmpfile (tramp-compat-file-name-unquote localname)) - (tramp-error v 'file-error "Cannot write: `%s'" filename)) - (delete-file tmpfile)))))) + ;; If `start' is the empty string, it is likely that a temporary + ;; file is created. Do it directly. + (if (and (stringp start) (string-empty-p start)) + (tramp-adb-send-command-and-check + v (format "echo -n \"\">%s" (tramp-shell-quote-argument localname))) + + (let ((tmpfile (tramp-compat-make-temp-file filename))) + (when (and append (file-exists-p filename)) + (copy-file filename tmpfile 'ok) + (set-file-modes tmpfile (logior (or (file-modes tmpfile) 0) #o0600))) + (let (create-lockfiles) + (write-region start end tmpfile append 'no-message)) + (with-tramp-progress-reporter + v 3 (format-message + "Moving tmp file `%s' to `%s'" tmpfile filename) + (unwind-protect + (unless (tramp-adb-execute-adb-command + v "push" tmpfile + (tramp-compat-file-name-unquote localname)) + (tramp-error v 'file-error "Cannot write: `%s'" filename)) + (delete-file tmpfile))))))) (defun tramp-adb-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." - (with-parsed-tramp-file-name filename nil - ;; ADB shell does not support "chmod -h". - (unless (and (eq flag 'nofollow) (file-symlink-p filename)) - (tramp-flush-file-properties v localname) + ;; ADB shell does not support "chmod -h". + (unless (and (eq flag 'nofollow) (file-symlink-p filename)) + (tramp-skeleton-set-file-modes-times-uid-gid filename (tramp-adb-send-command-and-check v (format "chmod %o %s" mode (tramp-shell-quote-argument localname)))))) (defun tramp-adb-handle-set-file-times (filename &optional time flag) "Like `set-file-times' for Tramp files." - (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v localname) + (tramp-skeleton-set-file-modes-times-uid-gid filename (let ((time (if (or (null time) (tramp-compat-time-equal-p time tramp-time-doesnt-exist) (tramp-compat-time-equal-p time tramp-time-dont-know)) @@ -827,7 +832,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; because the remote process could have changed them. (when tmpinput (delete-file tmpinput)) (when process-file-side-effects - (tramp-flush-directory-properties v "")) + (tramp-flush-directory-properties v "/")) ;; Return exit status. (if (equal ret -1) @@ -923,102 +928,99 @@ implementation will be used." name1 (format "%s<%d>" name i))) (setq name name1) - (with-tramp-saved-connection-property v "process-name" - (with-tramp-saved-connection-property v "process-buffer" - ;; Set the new process properties. - (tramp-set-connection-property v "process-name" name) - (tramp-set-connection-property v "process-buffer" buffer) - (with-current-buffer (tramp-get-connection-buffer v) - (unwind-protect - ;; We catch this event. Otherwise, - ;; `make-process' could be called on the local - ;; host. - (save-excursion - (save-restriction - ;; Activate narrowing in order to save - ;; BUFFER contents. Clear also the - ;; modification time; otherwise we might be - ;; interrupted by `verify-visited-file-modtime'. - (let ((buffer-undo-list t) - (inhibit-read-only t) - (coding-system-for-write - (if (symbolp coding) coding (car coding))) - (coding-system-for-read - (if (symbolp coding) coding (cdr coding)))) - (clear-visited-file-modtime) - (narrow-to-region (point-max) (point-max)) - ;; We call `tramp-adb-maybe-open-connection', - ;; in order to cleanup the prompt afterwards. - (tramp-adb-maybe-open-connection v) - (delete-region (point-min) (point-max)) - ;; Send the command. - (setq p (tramp-get-connection-process v)) - (tramp-adb-send-command v command nil t) ; nooutput - ;; Set sentinel and filter. - (when sentinel - (set-process-sentinel p sentinel)) - (when filter - (set-process-filter p filter)) - (process-put p 'remote-command orig-command) - (tramp-set-connection-property - p "remote-command" orig-command) - ;; Set query flag and process marker for - ;; this process. We ignore errors, - ;; because the process could have finished - ;; already. - (ignore-errors - (set-process-query-on-exit-flag p (null noquery)) - (set-marker (process-mark p) (point)) - ;; We must flush them here already; - ;; otherwise `rename-file', `delete-file' or - ;; `insert-file-contents' will fail. - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property - v "process-buffer") - ;; Copy tmpstderr file. - (when (and (stringp stderr) - (not (tramp-tramp-file-p stderr))) - (add-function - :after (process-sentinel p) - (lambda (_proc _msg) - (rename-file remote-tmpstderr stderr)))) - ;; Read initial output. Remove the - ;; first line, which is the command - ;; echo. - (unless (eq filter t) - (while - (progn - (goto-char (point-min)) - (not (re-search-forward "[\n]" nil t))) - (tramp-accept-process-output p 0)) - (delete-region (point-min) (point))) - ;; Provide error buffer. This shows - ;; only initial error messages; messages - ;; arriving later on will be inserted - ;; when the process is deleted. The - ;; temporary file will exist until the - ;; process is deleted. - (when (bufferp stderr) - (with-current-buffer stderr - (insert-file-contents-literally - remote-tmpstderr 'visit)) - ;; Delete tmpstderr file. - (add-function - :after (process-sentinel p) - (lambda (_proc _msg) - (with-current-buffer stderr - (insert-file-contents-literally - remote-tmpstderr 'visit nil nil 'replace)) - (delete-file remote-tmpstderr)))) - ;; Return process. - p)))) - - ;; Save exit. - (if (string-prefix-p tramp-temp-buffer-name (buffer-name)) - (ignore-errors - (set-process-buffer p nil) - (kill-buffer (current-buffer))) - (set-buffer-modified-p bmp)))))))))))) + (with-tramp-saved-connection-properties + v '("process-name" "process-buffer") + ;; Set the new process properties. + (tramp-set-connection-property v "process-name" name) + (tramp-set-connection-property v "process-buffer" buffer) + (with-current-buffer (tramp-get-connection-buffer v) + (unwind-protect + ;; We catch this event. Otherwise, `make-process' + ;; could be called on the local host. + (save-excursion + (save-restriction + ;; Activate narrowing in order to save BUFFER + ;; contents. Clear also the modification + ;; time; otherwise we might be interrupted by + ;; `verify-visited-file-modtime'. + (let ((buffer-undo-list t) + (inhibit-read-only t) + (coding-system-for-write + (if (symbolp coding) coding (car coding))) + (coding-system-for-read + (if (symbolp coding) coding (cdr coding)))) + (clear-visited-file-modtime) + (narrow-to-region (point-max) (point-max)) + ;; We call `tramp-adb-maybe-open-connection', + ;; in order to cleanup the prompt afterwards. + (tramp-adb-maybe-open-connection v) + (delete-region (point-min) (point-max)) + ;; Send the command. + (setq p (tramp-get-connection-process v)) + (tramp-adb-send-command v command nil t) ; nooutput + ;; Set sentinel and filter. + (when sentinel + (set-process-sentinel p sentinel)) + (when filter + (set-process-filter p filter)) + (process-put p 'remote-command orig-command) + (tramp-set-connection-property + p "remote-command" orig-command) + ;; Set query flag and process marker for + ;; this process. We ignore errors, because + ;; the process could have finished already. + (ignore-errors + (set-process-query-on-exit-flag p (null noquery)) + (set-marker (process-mark p) (point)) + ;; We must flush them here already; + ;; otherwise `rename-file', `delete-file' + ;; or `insert-file-contents' will fail. + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property + v "process-buffer") + ;; Copy tmpstderr file. + (when (and (stringp stderr) + (not (tramp-tramp-file-p stderr))) + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (rename-file remote-tmpstderr stderr)))) + ;; Read initial output. Remove the first + ;; line, which is the command echo. + (unless (eq filter t) + (while + (progn + (goto-char (point-min)) + (not (re-search-forward "[\n]" nil t))) + (tramp-accept-process-output p 0)) + (delete-region (point-min) (point))) + ;; Provide error buffer. This shows only + ;; initial error messages; messages + ;; arriving later on will be inserted when + ;; the process is deleted. The temporary + ;; file will exist until the process is + ;; deleted. + (when (bufferp stderr) + (with-current-buffer stderr + (insert-file-contents-literally + remote-tmpstderr 'visit)) + ;; Delete tmpstderr file. + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (with-current-buffer stderr + (insert-file-contents-literally + remote-tmpstderr 'visit nil nil 'replace)) + (delete-file remote-tmpstderr)))) + ;; Return process. + p)))) + + ;; Save exit. + (if (string-prefix-p tramp-temp-buffer-name (buffer-name)) + (ignore-errors + (set-process-buffer p nil) + (kill-buffer (current-buffer))) + (set-buffer-modified-p bmp))))))))))) (defun tramp-adb-handle-exec-path () "Like `exec-path' for Tramp files." diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index b224494110..fda1441615 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -240,7 +240,7 @@ It must be supported by libarchive(3).") (file-directory-p . tramp-handle-file-directory-p) (file-equal-p . tramp-handle-file-equal-p) (file-executable-p . tramp-archive-handle-file-executable-p) - (file-exists-p . tramp-handle-file-exists-p) + (file-exists-p . tramp-archive-handle-file-exists-p) (file-in-directory-p . tramp-handle-file-in-directory-p) (file-local-copy . tramp-archive-handle-file-local-copy) (file-locked-p . ignore) @@ -322,7 +322,11 @@ arguments to pass to the OPERATION." (inhibit-file-name-operation operation)) (apply operation args)))) -;;;###autoload +;; Starting with Emacs 29, `tramp-archive-file-name-handler' is +;; autoloaded. But it must still be in tramp-loaddefs.el for older +;; Emacsen. +;;;###autoload(autoload 'tramp-archive-file-name-handler "tramp-archine") +;;;###tramp-autoload (defun tramp-archive-file-name-handler (operation &rest args) "Invoke the file archive related OPERATION. First arg specifies the OPERATION, second arg ARGS is a list of @@ -645,6 +649,10 @@ offered." "Like `file-executable-p' for file archives." (file-executable-p (tramp-archive-gvfs-file-name filename))) +(defun tramp-archive-handle-file-exists-p (filename) + "Like `file-exists-p' for file archives." + (file-exists-p (tramp-archive-gvfs-file-name filename))) + (defun tramp-archive-handle-file-local-copy (filename) "Like `file-local-copy' for file archives." (file-local-copy (tramp-archive-gvfs-file-name filename))) diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index 68f4fda475..289df2f9aa 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -48,7 +48,7 @@ ;; - The key is a process. These are temporary properties related to ;; an open connection. Examples: "scripts" keeps shell script ;; definitions already sent to the remote shell, "last-cmd-time" is -;; the time stamp a command has been sent to the remote process. +;; the timestamp a command has been sent to the remote process. ;; ;; - The key is nil. These are temporary properties related to the ;; local machine. Examples: "parse-passwd" and "parse-group" keep @@ -75,8 +75,9 @@ ;;; Code: -(require 'tramp) -(autoload 'time-stamp-string "time-stamp") +(require 'tramp-compat) +(require 'tramp-loaddefs) +(require 'time-stamp) ;;; -- Cache -- @@ -133,11 +134,7 @@ If KEY is `tramp-cache-undefined', don't create anything, and return nil." "Get the PROPERTY of FILE from the cache context of KEY. Return DEFAULT if not set." ;; Unify localname. Remove hop from `tramp-file-name' structure. - (setq file (tramp-compat-file-name-unquote file) - key (copy-tramp-file-name key)) - (setf (tramp-file-name-localname key) - (tramp-run-real-handler #'directory-file-name (list file)) - (tramp-file-name-hop key) nil) + (setq key (tramp-file-name-unify key file)) (let* ((hash (tramp-get-hash-table key)) (cached (and (hash-table-p hash) (gethash property hash))) (cached-at (and (consp cached) (format-time-string "%T" (car cached)))) @@ -161,7 +158,8 @@ Return DEFAULT if not set." (tramp-message key 8 "%s %s %s; inhibit: %s; cache used: %s; cached at: %s" - file property value remote-file-name-inhibit-cache cache-used cached-at) + (tramp-file-name-localname key) + property value remote-file-name-inhibit-cache cache-used cached-at) ;; For analysis purposes, count the number of getting this file attribute. (when (>= tramp-verbose 10) (let* ((var (intern (concat "tramp-cache-get-count-" property))) @@ -181,15 +179,12 @@ Return DEFAULT if not set." "Set the PROPERTY of FILE to VALUE, in the cache context of KEY. Return VALUE." ;; Unify localname. Remove hop from `tramp-file-name' structure. - (setq file (tramp-compat-file-name-unquote file) - key (copy-tramp-file-name key)) - (setf (tramp-file-name-localname key) - (tramp-run-real-handler #'directory-file-name (list file)) - (tramp-file-name-hop key) nil) + (setq key (tramp-file-name-unify key file)) (let ((hash (tramp-get-hash-table key))) ;; We put the timestamp there. (puthash property (cons (current-time) value) hash) - (tramp-message key 8 "%s %s %s" file property value) + (tramp-message + key 8 "%s %s %s" (tramp-file-name-localname key) property value) ;; For analysis purposes, count the number of setting this file attribute. (when (>= tramp-verbose 10) (let* ((var (intern (concat "tramp-cache-set-count-" property))) @@ -214,13 +209,9 @@ Return VALUE." (defun tramp-flush-file-property (key file property) "Remove PROPERTY of FILE in the cache context of KEY." ;; Unify localname. Remove hop from `tramp-file-name' structure. - (setq file (tramp-compat-file-name-unquote file) - key (copy-tramp-file-name key)) - (setf (tramp-file-name-localname key) - (tramp-run-real-handler #'directory-file-name (list file)) - (tramp-file-name-hop key) nil) + (setq key (tramp-file-name-unify key file)) (remhash property (tramp-get-hash-table key)) - (tramp-message key 8 "%s %s" file property) + (tramp-message key 8 "%s %s" (tramp-file-name-localname key) property) (when (>= tramp-verbose 10) (let ((var (intern (concat "tramp-cache-set-count-" property)))) (makunbound var)))) @@ -232,10 +223,7 @@ Return VALUE." (when-let ((file (file-name-directory file)) (file (directory-file-name file))) ;; Unify localname. Remove hop from `tramp-file-name' structure. - (setq file (tramp-compat-file-name-unquote file) - key (copy-tramp-file-name key)) - (setf (tramp-file-name-localname key) file - (tramp-file-name-hop key) nil) + (setq key (tramp-file-name-unify key file)) (dolist (property (hash-table-keys (tramp-get-hash-table key))) (when (string-match-p "^\\(directory-\\|file-name-all-completions\\|file-entries\\)" @@ -245,14 +233,10 @@ Return VALUE." ;;;###tramp-autoload (defun tramp-flush-file-properties (key file) "Remove all properties of FILE in the cache context of KEY." - (let* ((file (tramp-run-real-handler #'directory-file-name (list file))) - (truename (tramp-get-file-property key file "file-truename"))) + (let ((truename (tramp-get-file-property key file "file-truename"))) ;; Unify localname. Remove hop from `tramp-file-name' structure. - (setq file (tramp-compat-file-name-unquote file) - key (copy-tramp-file-name key)) - (setf (tramp-file-name-localname key) file - (tramp-file-name-hop key) nil) - (tramp-message key 8 "%s" file) + (setq key (tramp-file-name-unify key file)) + (tramp-message key 8 "%s" (tramp-file-name-localname key)) (remhash key tramp-cache-data) ;; Remove file properties of symlinks. (when (and (stringp truename) @@ -265,9 +249,8 @@ Return VALUE." (defun tramp-flush-directory-properties (key directory) "Remove all properties of DIRECTORY in the cache context of KEY. Remove also properties of all files in subdirectories." - (setq directory (tramp-compat-file-name-unquote directory)) - (let* ((directory (tramp-run-real-handler - #'directory-file-name (list directory))) + (let* ((directory + (directory-file-name (tramp-compat-file-name-unquote directory))) (truename (tramp-get-file-property key directory "file-truename"))) (tramp-message key 8 "%s" directory) (dolist (key (hash-table-keys tramp-cache-data)) @@ -288,6 +271,7 @@ Remove also properties of all files in subdirectories." ;; not show proper directory contents when a file has been copied or ;; deleted before. We must apply `save-match-data', because it would ;; corrupt other packages otherwise (reported from org). +;;;###tramp-autoload (defun tramp-flush-file-function () "Flush all Tramp cache properties from `buffer-file-name'. This is suppressed for temporary buffers." @@ -299,8 +283,8 @@ This is suppressed for temporary buffers." default-directory)) (tramp-verbose 0)) (when (tramp-tramp-file-p bfn) - (with-parsed-tramp-file-name bfn nil - (tramp-flush-file-properties v localname))))))) + (tramp-flush-file-properties + (tramp-dissect-file-name bfn) (tramp-file-local-name bfn))))))) (add-hook 'before-revert-hook #'tramp-flush-file-function) (add-hook 'eshell-pre-command-hook #'tramp-flush-file-function) @@ -314,6 +298,61 @@ This is suppressed for temporary buffers." (remove-hook 'kill-buffer-hook #'tramp-flush-file-function))) +;;;###tramp-autoload +(defmacro with-tramp-file-property (key file property &rest body) + "Check in Tramp cache for PROPERTY, otherwise execute BODY and set cache. +FILE must be a local file name on a connection identified via KEY." + (declare (indent 3) (debug t)) + `(let ((value (tramp-get-file-property + ,key ,file ,property tramp-cache-undefined))) + (when (eq value tramp-cache-undefined) + ;; We cannot pass @body as parameter to + ;; `tramp-set-file-property' because it mangles our debug + ;; messages. + (setq value (progn ,@body)) + (tramp-set-file-property ,key ,file ,property value)) + value)) + +;;;###tramp-autoload +(defmacro with-tramp-saved-file-property (key file property &rest body) + "Save PROPERTY, run BODY, reset PROPERTY. +Preserve timestamps." + (declare (indent 3) (debug t)) + `(progn + ;; Unify localname. Remove hop from `tramp-file-name' structure. + (setq ,key (tramp-file-name-unify ,key ,file)) + (let* ((hash (tramp-get-hash-table ,key)) + (cached (and (hash-table-p hash) (gethash ,property hash)))) + (unwind-protect (progn ,@body) + ;; Reset PROPERTY. Recompute hash, it could have been flushed. + (setq hash (tramp-get-hash-table ,key)) + (if (consp cached) + (puthash ,property cached hash) + (remhash ,property hash)))))) + +;;;###tramp-autoload +(defmacro with-tramp-saved-file-properties (key file properties &rest body) + "Save PROPERTIES, run BODY, reset PROPERTIES. +PROPERTIES is a list of file properties (strings). +Preserve timestamps." + (declare (indent 3) (debug t)) + `(progn + ;; Unify localname. Remove hop from `tramp-file-name' structure. + (setq ,key (tramp-file-name-unify ,key ,file)) + (let* ((hash (tramp-get-hash-table ,key)) + (values + (and (hash-table-p hash) + (mapcar + (lambda (property) (cons property (gethash property hash))) + ,properties)))) + (unwind-protect (progn ,@body) + ;; Reset PROPERTIES. Recompute hash, it could have been flushed. + (setq hash (tramp-get-hash-table ,key)) + (dolist (value values) + (if (consp (cdr value)) + (puthash (car value) (cdr value) hash) + (remhash (car value) hash))))))) + ;;; -- Properties -- ;;;###tramp-autoload @@ -396,6 +435,57 @@ used to cache connection properties of the local machine." (or tramp-cache-data-changed (tramp-file-name-p key))) (remhash key tramp-cache-data)) +;;;###tramp-autoload +(defmacro with-tramp-connection-property (key property &rest body) + "Check in Tramp for property PROPERTY, otherwise execute BODY and set." + (declare (indent 2) (debug t)) + `(let ((value (tramp-get-connection-property + ,key ,property tramp-cache-undefined))) + (when (eq value tramp-cache-undefined) + ;; We cannot pass ,@body as parameter to + ;; `tramp-set-connection-property' because it mangles our debug + ;; messages. + (setq value (progn ,@body)) + (tramp-set-connection-property ,key ,property value)) + value)) + +;;;###tramp-autoload +(defmacro with-tramp-saved-connection-property (key property &rest body) + "Save PROPERTY, run BODY, reset PROPERTY." + (declare (indent 2) (debug t)) + `(progn + (setq ,key (tramp-file-name-unify ,key)) + (let* ((hash (tramp-get-hash-table ,key)) + (cached (and (hash-table-p hash) + (gethash ,property hash tramp-cache-undefined)))) + (unwind-protect (progn ,@body) + ;; Reset PROPERTY. Recompute hash, it could have been flushed. + (setq hash (tramp-get-hash-table ,key)) + (if (not (eq cached tramp-cache-undefined)) + (puthash ,property cached hash) + (remhash ,property hash)))))) + +;;;###tramp-autoload +(defmacro with-tramp-saved-connection-properties (key properties &rest body) + "Save PROPERTIES, run BODY, reset PROPERTIES. +PROPERTIES is a list of file properties (strings)." + (declare (indent 2) (debug t)) + `(progn + (setq ,key (tramp-file-name-unify ,key)) + (let* ((hash (tramp-get-hash-table ,key)) + (values + (mapcar + (lambda (property) + (cons property (gethash property hash tramp-cache-undefined))) + ,properties))) + (unwind-protect (progn ,@body) + ;; Reset PROPERTIES. Recompute hash, it could have been flushed. + (setq hash (tramp-get-hash-table ,key)) + (dolist (value values) + (if (not (eq (cdr value) tramp-cache-undefined)) + (puthash (car value) (cdr value) hash) + (remhash (car value) hash))))))) + ;;;###tramp-autoload (defun tramp-cache-print (table) "Print hash table TABLE." diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index 5c8012e553..f7704864ec 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -139,7 +139,7 @@ When called interactively, a Tramp connection has to be selected." (when (bufferp buf) (kill-buffer buf))) ;; Flush file cache. - (tramp-flush-directory-properties vec "") + (tramp-flush-directory-properties vec "/") ;; Flush connection cache. (tramp-flush-connection-properties vec) diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index 4fcd132ab0..7f38529262 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -824,24 +824,21 @@ WILDCARD is not supported." (defun tramp-crypt-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." - (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v localname) + (tramp-skeleton-set-file-modes-times-uid-gid filename (let (tramp-crypt-enabled) (tramp-compat-set-file-modes (tramp-crypt-encrypt-file-name filename) mode flag)))) (defun tramp-crypt-handle-set-file-times (filename &optional time flag) "Like `set-file-times' for Tramp files." - (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v localname) + (tramp-skeleton-set-file-modes-times-uid-gid filename (let (tramp-crypt-enabled) (tramp-compat-set-file-times (tramp-crypt-encrypt-file-name filename) time flag)))) (defun tramp-crypt-handle-set-file-uid-gid (filename &optional uid gid) "Like `tramp-set-file-uid-gid' for Tramp files." - (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v localname) + (tramp-skeleton-set-file-modes-times-uid-gid filename (let (tramp-crypt-enabled) (tramp-set-file-uid-gid (tramp-crypt-encrypt-file-name filename) uid gid)))) diff --git a/lisp/net/tramp-ftp.el b/lisp/net/tramp-ftp.el index d4bbb94479..dd7e0f9f34 100644 --- a/lisp/net/tramp-ftp.el +++ b/lisp/net/tramp-ftp.el @@ -31,7 +31,6 @@ (require 'tramp) ;; Pacify byte-compiler. -(declare-function tramp-archive-file-name-handler "tramp-archive") (defvar ange-ftp-ftp-name-arg) (defvar ange-ftp-ftp-name-res) (defvar ange-ftp-name-format) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 2f97b2cb91..0b40ff867f 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -960,6 +960,15 @@ The global value will always be nil; it is bound where needed.") ;; File name primitives. +(defun tramp-gvfs-info (filename &optional arg) + "Check FILENAME via `gvfs-info'. +Set file property \"file-exists-p\" with the result." + (with-parsed-tramp-file-name filename nil + (tramp-set-file-property + v localname "file-exists-p" + (tramp-gvfs-send-command + v "gvfs-info" arg (tramp-gvfs-url-file-name filename))))) + (defun tramp-gvfs-do-copy-or-rename-file (op filename newname &optional ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes) @@ -1046,12 +1055,9 @@ file names." ;; 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)) + (tramp-gvfs-info newname) (eq op 'copy) - (not (tramp-gvfs-send-command - v "gvfs-info" - (tramp-gvfs-url-file-name filename))))) + (not (tramp-gvfs-info filename)))) (if (or (not equal-remote) (and equal-remote @@ -1111,8 +1117,9 @@ file names." (tramp-error v 'file-error "Couldn't delete non-empty %s" directory))) - (unless (tramp-gvfs-send-command - v "gvfs-rm" (tramp-gvfs-url-file-name directory)) + (unless (and (tramp-gvfs-send-command + v "gvfs-rm" (tramp-gvfs-url-file-name directory)) + (not (tramp-gvfs-info directory))) ;; Propagate the error. (with-current-buffer (tramp-get-connection-buffer v) (goto-char (point-min)) @@ -1125,8 +1132,9 @@ file names." (tramp-flush-file-properties v localname) (if (and delete-by-moving-to-trash trash) (move-file-to-trash filename) - (unless (tramp-gvfs-send-command - v "gvfs-rm" (tramp-gvfs-url-file-name filename)) + (unless (and (tramp-gvfs-send-command + v "gvfs-rm" (tramp-gvfs-url-file-name filename)) + (not (tramp-gvfs-info filename))) ;; Propagate the error. (with-current-buffer (tramp-get-connection-buffer v) (goto-char (point-min)) @@ -1239,10 +1247,8 @@ If FILE-SYSTEM is non-nil, return file system attributes." (if file-system " system" "") localname) ;; Send command. (if file-system - (tramp-gvfs-send-command - v "gvfs-info" "--filesystem" (tramp-gvfs-url-file-name filename)) - (tramp-gvfs-send-command - v "gvfs-info" (tramp-gvfs-url-file-name filename))) + (tramp-gvfs-info filename "--filesystem") + (tramp-gvfs-info filename)) ;; Parse output. (with-current-buffer (tramp-get-connection-buffer v) (goto-char (point-min)) @@ -1547,8 +1553,10 @@ If FILE-SYSTEM is non-nil, return file system attributes." (make-directory ldir parents)) ;; Just do it. (or (when-let ((mkdir-succeeded - (tramp-gvfs-send-command - v "gvfs-mkdir" (tramp-gvfs-url-file-name dir)))) + (and + (tramp-gvfs-send-command + v "gvfs-mkdir" (tramp-gvfs-url-file-name dir)) + (tramp-gvfs-info dir)))) (set-file-modes dir (default-file-modes)) mkdir-succeeded) (and parents (file-directory-p dir)) @@ -1582,16 +1590,14 @@ If FILE-SYSTEM is non-nil, return file system attributes." (defun tramp-gvfs-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." - (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v localname) + (tramp-skeleton-set-file-modes-times-uid-gid filename (tramp-gvfs-set-attribute v (if (eq flag 'nofollow) "-nt" "-t") "uint32" (tramp-gvfs-url-file-name filename) "unix::mode" (number-to-string mode)))) (defun tramp-gvfs-handle-set-file-times (filename &optional time flag) "Like `set-file-times' for Tramp files." - (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v localname) + (tramp-skeleton-set-file-modes-times-uid-gid filename (tramp-gvfs-set-attribute v (if (eq flag 'nofollow) "-nt" "-t") "uint64" (tramp-gvfs-url-file-name filename) "time::modified" @@ -1644,8 +1650,7 @@ ID-FORMAT valid values are `string' and `integer'." (defun tramp-gvfs-handle-set-file-uid-gid (filename &optional uid gid) "Like `tramp-set-file-uid-gid' for Tramp files." - (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v localname) + (tramp-skeleton-set-file-modes-times-uid-gid filename (when (natnump uid) (tramp-gvfs-set-attribute v "-t" "uint32" diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 172933859c..d88e388cd5 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1113,7 +1113,8 @@ component is used as the target of the symlink." (tramp-file-name-equal-p v (tramp-dissect-file-name target))) (setq target (tramp-file-local-name (expand-file-name target)))) ;; There could be a cyclic link. - (tramp-flush-file-properties v target)) + (tramp-flush-file-properties + v (expand-file-name target (tramp-file-local-name default-directory)))) ;; If TARGET is still remote, quote it. (if (tramp-tramp-file-p target) @@ -1465,12 +1466,11 @@ of." (defun tramp-sh-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." - (with-parsed-tramp-file-name filename nil - ;; We need "chmod -h" when the flag is set. - (when (or (not (eq flag 'nofollow)) - (not (file-symlink-p filename)) - (tramp-get-remote-chmod-h v)) - (tramp-flush-file-properties v localname) + ;; We need "chmod -h" when the flag is set. + (when (or (not (eq flag 'nofollow)) + (not (file-symlink-p filename)) + (tramp-get-remote-chmod-h (tramp-dissect-file-name filename))) + (tramp-skeleton-set-file-modes-times-uid-gid filename ;; FIXME: extract the proper text from chmod's stderr. (tramp-barf-unless-okay v @@ -1482,9 +1482,8 @@ of." (defun tramp-sh-handle-set-file-times (filename &optional time flag) "Like `set-file-times' for Tramp files." - (with-parsed-tramp-file-name filename nil + (tramp-skeleton-set-file-modes-times-uid-gid filename (when (tramp-get-remote-touch v) - (tramp-flush-file-properties v localname) (let ((time (if (or (null time) (tramp-compat-time-equal-p time tramp-time-doesnt-exist) @@ -1543,9 +1542,9 @@ ID-FORMAT valid values are `string' and `integer'." ;; another implementation, see `dired-do-chown'. OTOH, it is mostly ;; working with su(do)? when it is needed, so it shall succeed in ;; the majority of cases. - ;; Don't modify `last-coding-system-used' by accident. - (let ((last-coding-system-used last-coding-system-used)) - (with-parsed-tramp-file-name filename nil + (tramp-skeleton-set-file-modes-times-uid-gid filename + ;; Don't modify `last-coding-system-used' by accident. + (let ((last-coding-system-used last-coding-system-used)) (if (and (zerop (user-uid)) (tramp-local-host-p v)) ;; If we are root on the local host, we can do it directly. (tramp-set-file-uid-gid localname uid gid) @@ -1767,10 +1766,11 @@ ID-FORMAT valid values are `string' and `integer'." ;; files. (defun tramp-sh-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." - (unless (tramp-compat-string-search "/" filename) - (all-completions - filename - (with-parsed-tramp-file-name (expand-file-name directory) nil + (with-parsed-tramp-file-name (expand-file-name directory) nil + (when (and (not (tramp-compat-string-search "/" filename)) + (tramp-connectable-p v)) + (all-completions + filename (with-tramp-file-property v localname "file-name-all-completions" (let (result) ;; Get a list of directories and files, including reliably @@ -2197,6 +2197,8 @@ the uid and gid from FILENAME." (file-name-directory (concat prefix localname2))) (or (file-directory-p (concat prefix localname2)) (file-writable-p (concat prefix localname2)))) + (with-parsed-tramp-file-name prefix nil + (tramp-flush-file-properties v localname2)) (tramp-do-copy-or-rename-file-directly op (concat prefix localname1) (concat prefix localname2) ok-if-already-exists keep-date preserve-uid-gid) @@ -2406,52 +2408,52 @@ The method used must be an out-of-band method." (with-temp-buffer (unwind-protect - (with-tramp-saved-connection-property v "process-name" - (with-tramp-saved-connection-property v "process-buffer" - ;; The default directory must be remote. - (let ((default-directory - (file-name-directory (if v1 filename newname))) - (process-environment (copy-sequence process-environment))) - ;; 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 copy-env - (tramp-message - v 6 "%s=\"%s\"" - (car copy-env) (string-join (cdr copy-env) " ")) - (setenv (car copy-env) (string-join (cdr copy-env) " "))) - (setq - copy-args - (append - copy-args - (if remote-copy-program - (list (if v1 (concat ">" target) (concat "<" source))) - (list source target))) - ;; Use an asynchronous process. By this, password - ;; can be handled. We don't set a timeout, because - ;; the copying of large files can last longer than - ;; 60 secs. - p (let ((default-directory - tramp-compat-temporary-file-directory)) - (apply - #'start-process - (tramp-get-connection-name v) - (tramp-get-connection-buffer v) - copy-program copy-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) - - ;; We must adapt `tramp-local-end-of-line' for sending - ;; the password. Also, we indicate that perhaps several - ;; password prompts might appear. - (let ((tramp-local-end-of-line tramp-rsh-end-of-line) - (tramp-password-prompt-not-unique (and v1 v2))) - (tramp-process-actions - p v nil tramp-actions-copy-out-of-band))))) + (with-tramp-saved-connection-properties + v '("process-name" "process-buffer") + ;; The default directory must be remote. + (let ((default-directory + (file-name-directory (if v1 filename newname))) + (process-environment (copy-sequence process-environment))) + ;; 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 copy-env + (tramp-message + v 6 "%s=\"%s\"" + (car copy-env) (string-join (cdr copy-env) " ")) + (setenv (car copy-env) (string-join (cdr copy-env) " "))) + (setq + copy-args + (append + copy-args + (if remote-copy-program + (list (if v1 (concat ">" target) (concat "<" source))) + (list source target))) + ;; Use an asynchronous process. By this, password + ;; can be handled. We don't set a timeout, because + ;; the copying of large files can last longer than 60 + ;; secs. + p (let ((default-directory + tramp-compat-temporary-file-directory)) + (apply + #'start-process + (tramp-get-connection-name v) + (tramp-get-connection-buffer v) + copy-program copy-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) + + ;; We must adapt `tramp-local-end-of-line' for sending + ;; the password. Also, we indicate that perhaps + ;; several password prompts might appear. + (let ((tramp-local-end-of-line tramp-rsh-end-of-line) + (tramp-password-prompt-not-unique (and v1 v2))) + (tramp-process-actions + p v nil tramp-actions-copy-out-of-band)))) ;; Clear the remote prompt. (when (and remote-copy-program @@ -2510,12 +2512,12 @@ The method used must be an out-of-band method." "Like `delete-file' for Tramp files." (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v localname) (if (and delete-by-moving-to-trash trash) (move-file-to-trash filename) (tramp-barf-unless-okay v (format "rm -f %s" (tramp-shell-quote-argument localname)) - "Couldn't delete %s" filename)))) + "Couldn't delete %s" filename)) + (tramp-flush-file-properties v localname))) ;; Dired. @@ -2966,102 +2968,102 @@ implementation will be used." name1 (format "%s<%d>" name i))) (setq name name1) - (with-tramp-saved-connection-property v "process-name" - (with-tramp-saved-connection-property v "process-buffer" - ;; Set the new process properties. - (tramp-set-connection-property v "process-name" name) - (tramp-set-connection-property v "process-buffer" buffer) - (with-current-buffer (tramp-get-connection-buffer v) - (unwind-protect - ;; We catch this event. Otherwise, - ;; `make-process' could be called on the local - ;; host. - (save-excursion - (save-restriction - ;; Activate narrowing in order to save - ;; BUFFER contents. Clear also the - ;; modification time; otherwise we might be - ;; interrupted by `verify-visited-file-modtime'. - (let ((buffer-undo-list t) - (inhibit-read-only t) - (mark (point-max)) - (coding-system-for-write - (if (symbolp coding) coding (car coding))) - (coding-system-for-read - (if (symbolp coding) coding (cdr coding)))) - (clear-visited-file-modtime) + (with-tramp-saved-connection-properties + v '("process-name" "process-buffer") + ;; Set the new process properties. + (tramp-set-connection-property v "process-name" name) + (tramp-set-connection-property v "process-buffer" buffer) + (with-current-buffer (tramp-get-connection-buffer v) + (unwind-protect + ;; We catch this event. Otherwise, `make-process' + ;; could be called on the local host. + (save-excursion + (save-restriction + ;; Activate narrowing in order to save BUFFER + ;; contents. Clear also the modification + ;; time; otherwise we might be interrupted by + ;; `verify-visited-file-modtime'. + (let ((buffer-undo-list t) + (inhibit-read-only t) + (mark (point-max)) + (coding-system-for-write + (if (symbolp coding) coding (car coding))) + (coding-system-for-read + (if (symbolp coding) coding (cdr coding)))) + (clear-visited-file-modtime) + (narrow-to-region (point-max) (point-max)) + (catch 'suppress + ;; Set the pid of the remote shell. This + ;; is needed when sending signals + ;; remotely. + (let ((pid + (tramp-send-command-and-read v "echo $$"))) + (setq p (tramp-get-connection-process v)) + (process-put p 'remote-pid pid) + (tramp-set-connection-property + p "remote-pid" pid)) + ;; Disable carriage return to newline + ;; translation. This does not work on + ;; macOS, see Bug#50748. + (when (and (memq connection-type '(nil pipe)) + (not + (tramp-check-remote-uname v "Darwin"))) + (tramp-send-command v "stty -icrnl")) + ;; `tramp-maybe-open-connection' and + ;; `tramp-send-command-and-read' could + ;; have trashed the connection buffer. + ;; Remove this. + (widen) + (delete-region mark (point-max)) (narrow-to-region (point-max) (point-max)) - (catch 'suppress - ;; Set the pid of the remote shell. This is - ;; needed when sending signals remotely. - (let ((pid - (tramp-send-command-and-read v "echo $$"))) - (setq p (tramp-get-connection-process v)) - (process-put p 'remote-pid pid) - (tramp-set-connection-property - p "remote-pid" pid)) - ;; Disable carriage return to newline - ;; translation. This does not work on - ;; macOS, see Bug#50748. - (when (and (memq connection-type '(nil pipe)) - (not - (tramp-check-remote-uname v "Darwin"))) - (tramp-send-command v "stty -icrnl")) - ;; `tramp-maybe-open-connection' and - ;; `tramp-send-command-and-read' could have - ;; trashed the connection buffer. Remove this. - (widen) - (delete-region mark (point-max)) - (narrow-to-region (point-max) (point-max)) - ;; Now do it. - (if command - ;; Send the command. - (tramp-send-command v command nil t) ; nooutput - ;; Check, whether a pty is associated. - (unless (process-get p 'remote-tty) - (tramp-error - v 'file-error - "pty association is not supported for `%s'" - name)))) - ;; Set sentinel and filter. - (when sentinel - (set-process-sentinel p sentinel)) - (when filter - (set-process-filter p filter)) - (process-put p 'remote-command orig-command) - (tramp-set-connection-property - p "remote-command" orig-command) - ;; Set query flag and process marker for - ;; this process. We ignore errors, - ;; because the process could have finished - ;; already. - (ignore-errors - (set-process-query-on-exit-flag p (null noquery)) - (set-marker (process-mark p) (point))) - ;; We must flush them here already; - ;; otherwise `delete-file' will fail. - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer") - ;; Kill stderr process and delete named pipe. - (when (bufferp stderr) - (add-function - :after (process-sentinel p) - (lambda (_proc _msg) - (ignore-errors - (while (accept-process-output - (get-buffer-process stderr) 0 nil t)) - (delete-process (get-buffer-process stderr))) - (ignore-errors - (delete-file remote-tmpstderr))))) - ;; Return process. - p))) - - ;; Save exit. - (if (string-prefix-p tramp-temp-buffer-name (buffer-name)) - (ignore-errors - (set-process-buffer p nil) - (kill-buffer (current-buffer))) - (set-buffer-modified-p bmp)))))))))))) + ;; Now do it. + (if command + ;; Send the command. + (tramp-send-command v command nil t) ; nooutput + ;; Check, whether a pty is associated. + (unless (process-get p 'remote-tty) + (tramp-error + v 'file-error + "pty association is not supported for `%s'" + name)))) + ;; Set sentinel and filter. + (when sentinel + (set-process-sentinel p sentinel)) + (when filter + (set-process-filter p filter)) + (process-put p 'remote-command orig-command) + (tramp-set-connection-property + p "remote-command" orig-command) + ;; Set query flag and process marker for + ;; this process. We ignore errors, because + ;; the process could have finished already. + (ignore-errors + (set-process-query-on-exit-flag p (null noquery)) + (set-marker (process-mark p) (point))) + ;; We must flush them here already; + ;; otherwise `delete-file' will fail. + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") + ;; Kill stderr process and delete named pipe. + (when (bufferp stderr) + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (ignore-errors + (while (accept-process-output + (get-buffer-process stderr) 0 nil t)) + (delete-process (get-buffer-process stderr))) + (ignore-errors + (delete-file remote-tmpstderr))))) + ;; Return process. + p))) + + ;; Save exit. + (if (string-prefix-p tramp-temp-buffer-name (buffer-name)) + (ignore-errors + (set-process-buffer p nil) + (kill-buffer (current-buffer))) + (set-buffer-modified-p bmp))))))))))) (defun tramp-sh-get-signal-strings (vec) "Strings to return by `process-file' in case of signals." @@ -3242,7 +3244,7 @@ implementation will be used." ;; because the remote process could have changed them. (when tmpinput (delete-file tmpinput)) (when process-file-side-effects - (tramp-flush-directory-properties v "")) + (tramp-flush-directory-properties v "/")) ;; Return exit status. (if (equal ret -1) @@ -3334,194 +3336,201 @@ implementation will be used." (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." (tramp-skeleton-write-region start end filename append visit lockname mustbenew - (if (and (tramp-local-host-p v) - ;; `file-writable-p' calls `file-expand-file-name'. We - ;; cannot use `tramp-run-real-handler' therefore. - (file-writable-p (file-name-directory localname)) - (or (file-directory-p localname) - (file-writable-p localname))) - ;; Short track: if we are on the local host, we can run directly. - (let ((create-lockfiles (not file-locked))) - (write-region start end localname append 'no-message lockname)) - - (let* ((modes (tramp-default-file-modes - filename (and (eq mustbenew 'excl) 'nofollow))) - ;; We use this to save the value of - ;; `last-coding-system-used' after writing the tmp file. - ;; At the end of the function, we set - ;; `last-coding-system-used' to this saved value. This - ;; way, any intermediary coding systems used while - ;; talking to the remote shell or suchlike won't hose - ;; this variable. This approach was snarfed from - ;; ange-ftp.el. - coding-system-used - ;; Write region into a tmp file. This isn't really - ;; needed if we use an encoding function, but currently - ;; we use it always because this makes the logic simpler. - ;; We must also set `temporary-file-directory', because - ;; it could point to a remote directory. - (temporary-file-directory - tramp-compat-temporary-file-directory) - (tmpfile (or tramp-temp-buffer-file-name - (tramp-compat-make-temp-file filename)))) - - ;; If `append' is non-nil, we copy the file locally, and let - ;; the native `write-region' implementation do the job. - (when (and append (file-exists-p filename)) - (copy-file filename tmpfile 'ok)) - - ;; We say `no-message' here because we don't want the visited - ;; file modtime data to be clobbered from the temp file. We - ;; call `set-visited-file-modtime' ourselves later on. We - ;; must ensure that `file-coding-system-alist' matches - ;; `tmpfile'. - (let ((file-coding-system-alist - (tramp-find-file-name-coding-system-alist filename tmpfile)) - create-lockfiles) - (condition-case err - (write-region start end tmpfile append 'no-message) - ((error quit) - (setq tramp-temp-buffer-file-name nil) - (delete-file tmpfile) - (signal (car err) (cdr err)))) - - ;; Now, `last-coding-system-used' has the right value. - ;; Remember it. - (setq coding-system-used last-coding-system-used)) - - ;; The permissions of the temporary file should be set. If - ;; FILENAME does not exist (eq modes nil) it has been renamed - ;; to the backup file. This case `save-buffer' handles - ;; permissions. Ensure that it is still readable. - (when modes - (set-file-modes tmpfile (logior (or modes 0) #o0400))) - - ;; This is a bit lengthy due to the different methods possible - ;; for file transfer. First, we check whether the method uses - ;; an scp program. If so, we call it. Otherwise, both - ;; encoding and decoding command must be specified. However, - ;; if the method _also_ specifies an encoding function, then - ;; that is used for encoding the contents of the tmp file. - (let* ((size (file-attribute-size (file-attributes tmpfile))) - (rem-dec (tramp-get-inline-coding v "remote-decoding" size)) - (loc-enc (tramp-get-inline-coding v "local-encoding" size))) - (cond - ;; `copy-file' handles direct copy and out-of-band methods. - ((or (tramp-local-host-p v) - (tramp-method-out-of-band-p v size)) - (if (and (not (stringp start)) - (= (or end (point-max)) (point-max)) - (= (or start (point-min)) (point-min)) - (tramp-get-method-parameter - v 'tramp-copy-keep-tmpfile)) - (progn - (setq tramp-temp-buffer-file-name tmpfile) - (condition-case err - ;; We keep the local file for performance - ;; reasons, useful for "rsync". - (copy-file tmpfile filename t) - ((error quit) - (setq tramp-temp-buffer-file-name nil) - (delete-file tmpfile) - (signal (car err) (cdr err))))) - (setq tramp-temp-buffer-file-name nil) - ;; Don't rename, in order to keep context in SELinux. + ;; If `start' is the empty string, it is likely that a temporary + ;; file is created. Do it directly. + (if (and (stringp start) (string-empty-p start)) + (tramp-send-command + v (format "echo -n \"\">%s" (tramp-shell-quote-argument localname))) + + ;; Short track: if we are on the local host, we can run directly. + (if (and (tramp-local-host-p v) + ;; `file-writable-p' calls `file-expand-file-name'. We + ;; cannot use `tramp-run-real-handler' therefore. + (file-writable-p (file-name-directory localname)) + (or (file-directory-p localname) + (file-writable-p localname))) + (let ((create-lockfiles (not file-locked))) + (write-region start end localname append 'no-message lockname)) + + (let* ((modes (tramp-default-file-modes + filename (and (eq mustbenew 'excl) 'nofollow))) + ;; We use this to save the value of + ;; `last-coding-system-used' after writing the tmp + ;; file. At the end of the function, we set + ;; `last-coding-system-used' to this saved value. This + ;; way, any intermediary coding systems used while + ;; talking to the remote shell or suchlike won't hose + ;; this variable. This approach was snarfed from + ;; ange-ftp.el. + coding-system-used + ;; Write region into a tmp file. This isn't really + ;; needed if we use an encoding function, but currently + ;; we use it always because this makes the logic + ;; simpler. We must also set + ;; `temporary-file-directory', because it could point + ;; to a remote directory. + (temporary-file-directory + tramp-compat-temporary-file-directory) + (tmpfile (or tramp-temp-buffer-file-name + (tramp-compat-make-temp-file filename)))) + + ;; If `append' is non-nil, we copy the file locally, and let + ;; the native `write-region' implementation do the job. + (when (and append (file-exists-p filename)) + (copy-file filename tmpfile 'ok)) + + ;; We say `no-message' here because we don't want the + ;; visited file modtime data to be clobbered from the temp + ;; file. We call `set-visited-file-modtime' ourselves later + ;; on. We must ensure that `file-coding-system-alist' + ;; matches `tmpfile'. + (let ((file-coding-system-alist + (tramp-find-file-name-coding-system-alist filename tmpfile)) + create-lockfiles) + (condition-case err + (write-region start end tmpfile append 'no-message) + ((error quit) + (setq tramp-temp-buffer-file-name nil) + (delete-file tmpfile) + (signal (car err) (cdr err)))) + + ;; Now, `last-coding-system-used' has the right value. + ;; Remember it. + (setq coding-system-used last-coding-system-used)) + + ;; The permissions of the temporary file should be set. If + ;; FILENAME does not exist (eq modes nil) it has been + ;; renamed to the backup file. This case `save-buffer' + ;; handles permissions. Ensure that it is still readable. + (when modes + (set-file-modes tmpfile (logior (or modes 0) #o0400))) + + ;; This is a bit lengthy due to the different methods + ;; possible for file transfer. First, we check whether the + ;; method uses an scp program. If so, we call it. + ;; Otherwise, both encoding and decoding command must be + ;; specified. However, if the method _also_ specifies an + ;; encoding function, then that is used for encoding the + ;; contents of the tmp file. + (let* ((size (file-attribute-size (file-attributes tmpfile))) + (rem-dec (tramp-get-inline-coding v "remote-decoding" size)) + (loc-enc (tramp-get-inline-coding v "local-encoding" size))) + (cond + ;; `copy-file' handles direct copy and out-of-band methods. + ((or (tramp-local-host-p v) + (tramp-method-out-of-band-p v size)) + (if (and (not (stringp start)) + (= (or end (point-max)) (point-max)) + (= (or start (point-min)) (point-min)) + (tramp-get-method-parameter + v 'tramp-copy-keep-tmpfile)) + (progn + (setq tramp-temp-buffer-file-name tmpfile) + (condition-case err + ;; We keep the local file for performance + ;; reasons, useful for "rsync". + (copy-file tmpfile filename t) + ((error quit) + (setq tramp-temp-buffer-file-name nil) + (delete-file tmpfile) + (signal (car err) (cdr err))))) + (setq tramp-temp-buffer-file-name nil) + ;; Don't rename, in order to keep context in SELinux. + (unwind-protect + (copy-file tmpfile filename t) + (delete-file tmpfile)))) + + ;; Use inline file transfer. + (rem-dec + ;; Encode tmpfile. (unwind-protect - (copy-file tmpfile filename t) - (delete-file tmpfile)))) - - ;; Use inline file transfer. - (rem-dec - ;; Encode tmpfile. - (unwind-protect - (with-temp-buffer - (set-buffer-multibyte nil) - ;; Use encoding function or command. - (with-tramp-progress-reporter - v 3 (format-message - "Encoding local file `%s' using `%s'" - tmpfile loc-enc) - (if (functionp loc-enc) - ;; The following `let' is a workaround for the - ;; base64.el that comes with pgnus-0.84. If - ;; both of the following conditions are - ;; satisfied, it tries to write to a local - ;; file in default-directory, but at this - ;; point, default-directory is remote. - ;; (`call-process-region' can't write to - ;; remote files, it seems.) The file in - ;; question is a tmp file anyway. - (let ((coding-system-for-read 'binary) - (default-directory - tramp-compat-temporary-file-directory)) - (insert-file-contents-literally tmpfile) - (funcall loc-enc (point-min) (point-max))) - - (unless (zerop (tramp-call-local-coding-command - loc-enc tmpfile t)) - (tramp-error - v 'file-error - (concat "Cannot write to `%s', " - "local encoding command `%s' failed") - filename loc-enc)))) - - ;; Send buffer into remote decoding command which - ;; writes to remote file. Because this happens on - ;; the remote host, we cannot use the function. - (with-tramp-progress-reporter - v 3 (format-message - "Decoding remote file `%s' using `%s'" - filename rem-dec) - (goto-char (point-max)) - (unless (bolp) (newline)) - (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) - "Couldn't write region to `%s', decode using `%s' failed" - filename rem-dec) - ;; When `file-precious-flag' is set, the region is - ;; written to a temporary file. Check that the - ;; checksum is equal to that from the local tmpfile. - (when file-precious-flag - (erase-buffer) - (and - ;; cksum runs locally, if possible. - (zerop (tramp-call-process v "cksum" tmpfile t)) - ;; cksum runs remotely. - (tramp-send-command-and-check - v - (format - "cksum <%s" - (tramp-shell-quote-argument localname))) - ;; ... they are different. - (not - (string-equal - (buffer-string) - (tramp-get-buffer-string (tramp-get-buffer v)))) - (tramp-error - v 'file-error - "Couldn't write region to `%s', decode using `%s' failed" - filename rem-dec))))) - - ;; Save exit. - (delete-file tmpfile))) - - ;; That's not expected. - (t - (tramp-error - v 'file-error - (concat "Method `%s' should specify both encoding and " - "decoding command or an scp program") - method)))) + (with-temp-buffer + (set-buffer-multibyte nil) + ;; Use encoding function or command. + (with-tramp-progress-reporter + v 3 (format-message + "Encoding local file `%s' using `%s'" + tmpfile loc-enc) + (if (functionp loc-enc) + ;; The following `let' is a workaround for + ;; the base64.el that comes with pgnus-0.84. + ;; If both of the following conditions are + ;; satisfied, it tries to write to a local + ;; file in default-directory, but at this + ;; point, default-directory is remote. + ;; (`call-process-region' can't write to + ;; remote files, it seems.) The file in + ;; question is a tmp file anyway. + (let ((coding-system-for-read 'binary) + (default-directory + tramp-compat-temporary-file-directory)) + (insert-file-contents-literally tmpfile) + (funcall loc-enc (point-min) (point-max))) + + (unless (zerop (tramp-call-local-coding-command + loc-enc tmpfile t)) + (tramp-error + v 'file-error + (concat "Cannot write to `%s', " + "local encoding command `%s' failed") + filename loc-enc)))) + + ;; Send buffer into remote decoding command which + ;; writes to remote file. Because this happens on + ;; the remote host, we cannot use the function. + (with-tramp-progress-reporter + v 3 (format-message + "Decoding remote file `%s' using `%s'" + filename rem-dec) + (goto-char (point-max)) + (unless (bolp) (newline)) + (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) + "Couldn't write region to `%s', decode using `%s' failed" + filename rem-dec) + ;; When `file-precious-flag' is set, the region + ;; is written to a temporary file. Check that + ;; the checksum is equal to that from the local + ;; tmpfile. + (when file-precious-flag + (erase-buffer) + (and + ;; cksum runs locally, if possible. + (zerop (tramp-call-process v "cksum" tmpfile t)) + ;; cksum runs remotely. + (tramp-send-command-and-check + v (format + "cksum <%s" (tramp-shell-quote-argument localname))) + ;; ... they are different. + (not + (string-equal + (buffer-string) + (tramp-get-buffer-string (tramp-get-buffer v)))) + (tramp-error + v 'file-error + (concat "Couldn't write region to `%s'," + " decode using `%s' failed") + filename rem-dec))))) + + ;; Save exit. + (delete-file tmpfile))) - ;; Make `last-coding-system-used' have the right value. - (when coding-system-used - (setq last-coding-system-used coding-system-used)))))) + ;; That's not expected. + (t + (tramp-error + v 'file-error + (concat "Method `%s' should specify both encoding and " + "decoding command or an scp program") + method)))) + + ;; Make `last-coding-system-used' have the right value. + (when coding-system-used + (setq last-coding-system-used coding-system-used))))))) (defvar tramp-vc-registered-file-names nil "List used to collect file names, which are checked during `vc-registered'.") diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 29abdb575d..a81a8f1363 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -523,49 +523,49 @@ arguments to pass to the OPERATION." "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)))))) + (with-tramp-saved-connection-properties + v '("process-name" "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)))) @@ -751,6 +751,10 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." localname (tramp-run-real-handler #'expand-file-name (list localname))))))) +(defun tramp-smb-remote-acl-p (_vec) + "Check, whether ACL is enabled on the remote host." + (and (stringp tramp-smb-acl-program) (executable-find tramp-smb-acl-program))) + (defun tramp-smb-action-get-acl (proc vec) "Read ACL data from connection buffer." (unless (process-live-p proc) @@ -774,7 +778,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (ignore-errors (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname "file-acl" - (when (executable-find tramp-smb-acl-program) + (when (tramp-smb-remote-acl-p v) (let* ((share (tramp-smb-get-share v)) (localname (tramp-compat-string-replace "\\" "/" (tramp-smb-get-localname v))) @@ -799,31 +803,31 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (concat "2>" (tramp-get-remote-null-device v))))) (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)) - - ;; Use an asynchronous process. By this, - ;; password can be handled. - (let ((p (apply - #'start-process - (tramp-get-connection-name v) - (tramp-get-connection-buffer v) - tramp-smb-acl-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-get-acl) - (when (> (point-max) (point-min)) - (substring-no-properties (buffer-string)))))))))))))) + (with-tramp-saved-connection-properties + v '("process-name" "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)) + + ;; Use an asynchronous process. By this, password + ;; can be handled. + (let ((p (apply + #'start-process + (tramp-get-connection-name v) + (tramp-get-connection-buffer v) + tramp-smb-acl-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-get-acl) + (when (> (point-max) (point-min)) + (substring-no-properties (buffer-string))))))))))))) (defun tramp-smb-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." @@ -1311,32 +1315,32 @@ component is used as the target of the symlink." ;; Call it. (condition-case nil - (with-tramp-saved-connection-property v "process-name" - (with-tramp-saved-connection-property v "process-buffer" - ;; Set the new process properties. - (tramp-set-connection-property v "process-name" name1) - (tramp-set-connection-property - v "process-buffer" - (or outbuf (generate-new-buffer tramp-temp-buffer-name))) - (with-current-buffer (tramp-get-connection-buffer v) - ;; Preserve buffer contents. - (narrow-to-region (point-max) (point-max)) - (tramp-smb-call-winexe v) - (when (tramp-smb-get-share v) - (tramp-smb-send-command - v (format "cd //%s%s" host - (tramp-smb-shell-quote-argument - (file-name-directory localname))))) - (tramp-smb-send-command v command) - ;; Preserve command output. - (narrow-to-region (point-max) (point-max)) - (let ((p (tramp-get-connection-process v))) - (tramp-smb-send-command v "exit $lasterrorcode") - (while (process-live-p p) - (sleep-for 0.1) - (setq ret (process-exit-status p)))) - (delete-region (point-min) (point-max)) - (widen)))) + (with-tramp-saved-connection-properties + v '("process-name" "process-buffer") + ;; Set the new process properties. + (tramp-set-connection-property v "process-name" name1) + (tramp-set-connection-property + v "process-buffer" + (or outbuf (generate-new-buffer tramp-temp-buffer-name))) + (with-current-buffer (tramp-get-connection-buffer v) + ;; Preserve buffer contents. + (narrow-to-region (point-max) (point-max)) + (tramp-smb-call-winexe v) + (when (tramp-smb-get-share v) + (tramp-smb-send-command + v (format "cd //%s%s" host + (tramp-smb-shell-quote-argument + (file-name-directory localname))))) + (tramp-smb-send-command v command) + ;; Preserve command output. + (narrow-to-region (point-max) (point-max)) + (let ((p (tramp-get-connection-process v))) + (tramp-smb-send-command v "exit $lasterrorcode") + (while (process-live-p p) + (sleep-for 0.1) + (setq ret (process-exit-status p)))) + (delete-region (point-min) (point-max)) + (widen))) ;; When the user did interrupt, we should do it also. We use ;; return code -1 as marker. @@ -1356,7 +1360,7 @@ component is used as the target of the symlink." (unless outbuf (kill-buffer (tramp-get-connection-property v "process-buffer"))) (when process-file-side-effects - (tramp-flush-directory-properties v "")) + (tramp-flush-directory-properties v "/")) ;; Return exit status. (if (equal ret -1) @@ -1427,7 +1431,7 @@ component is used as the target of the symlink." (with-parsed-tramp-file-name filename nil (tramp-flush-file-property v localname "file-acl") - (when (and (stringp acl-string) (executable-find tramp-smb-acl-program)) + (when (and (stringp acl-string) (tramp-smb-remote-acl-p v)) (let* ((share (tramp-smb-get-share v)) (localname (tramp-compat-string-replace "\\" "/" (tramp-smb-get-localname v))) @@ -1455,52 +1459,50 @@ component is used as the target of the symlink." "||" "echo" "tramp_exit_status" "1"))) (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)) - - ;; Use an asynchronous process. By this, password - ;; can be handled. - (let ((p (apply - #'start-process - (tramp-get-connection-name v) - (tramp-get-connection-buffer v) - tramp-smb-acl-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-set-acl) - ;; This is meant for traces, and returning from - ;; the function. No error is propagated - ;; outside, due to the `ignore-errors' closure. - (unless - (tramp-search-regexp "tramp_exit_status [[:digit:]]+") - (tramp-error - v 'file-error - "Couldn't find exit status of `%s'" - tramp-smb-acl-program)) - (skip-chars-forward "^ ") - (when (zerop (read (current-buffer))) - ;; Success. - (tramp-set-file-property - v localname "file-acl" acl-string) - t))))))))))) + (with-tramp-saved-connection-properties + v '("process-name" "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)) + + ;; Use an asynchronous process. By this, password + ;; can be handled. + (let ((p (apply + #'start-process + (tramp-get-connection-name v) + (tramp-get-connection-buffer v) + tramp-smb-acl-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-set-acl) + ;; This is meant for traces, and returning from + ;; the function. No error is propagated outside, + ;; due to the `ignore-errors' closure. + (unless + (tramp-search-regexp "tramp_exit_status [[:digit:]]+") + (tramp-error + v 'file-error + "Couldn't find exit status of `%s'" + tramp-smb-acl-program)) + (skip-chars-forward "^ ") + (when (zerop (read (current-buffer))) + ;; Success. + (tramp-set-file-property v localname "file-acl" acl-string) + t)))))))))) (defun tramp-smb-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." - (with-parsed-tramp-file-name filename nil - ;; smbclient chmod does not support nofollow. - (unless (and (eq flag 'nofollow) (file-symlink-p filename)) + ;; smbclient chmod does not support nofollow. + (unless (and (eq flag 'nofollow) (file-symlink-p filename)) + (tramp-skeleton-set-file-modes-times-uid-gid filename (when (tramp-smb-get-cifs-capabilities v) - (tramp-flush-file-properties v localname) (unless (tramp-smb-send-command v (format "chmod %s %o" (tramp-smb-shell-quote-localname v) mode)) @@ -1524,38 +1526,38 @@ component is used as the target of the symlink." (i 0) p) (unwind-protect - (with-tramp-saved-connection-property v "process-name" - (with-tramp-saved-connection-property v "process-buffer" - (save-excursion - (save-restriction - (while (get-process name1) - ;; NAME must be unique as process name. - (setq i (1+ i) - name1 (format "%s<%d>" name i))) - ;; Set the new process properties. - (tramp-set-connection-property v "process-name" name1) - (tramp-set-connection-property v "process-buffer" buffer) - ;; Activate narrowing in order to save BUFFER contents. - (with-current-buffer (tramp-get-connection-buffer v) - (let ((buffer-undo-list t)) - (narrow-to-region (point-max) (point-max)) - (tramp-smb-call-winexe v) - (when (tramp-smb-get-share v) - (tramp-smb-send-command - v (format - "cd //%s%s" - host - (tramp-smb-shell-quote-argument - (file-name-directory localname))))) - (tramp-message v 6 "(%s); exit" command) - (tramp-send-string v command))) - (setq p (tramp-get-connection-process v)) - (when program - (process-put p 'remote-command (cons program args)) - (tramp-set-connection-property - p "remote-command" (cons program args))) - ;; Return value. - p)))) + (with-tramp-saved-connection-properties + v '("process-name" "process-buffer") + (save-excursion + (save-restriction + (while (get-process name1) + ;; NAME must be unique as process name. + (setq i (1+ i) + name1 (format "%s<%d>" name i))) + ;; Set the new process properties. + (tramp-set-connection-property v "process-name" name1) + (tramp-set-connection-property v "process-buffer" buffer) + ;; Activate narrowing in order to save BUFFER contents. + (with-current-buffer (tramp-get-connection-buffer v) + (let ((buffer-undo-list t)) + (narrow-to-region (point-max) (point-max)) + (tramp-smb-call-winexe v) + (when (tramp-smb-get-share v) + (tramp-smb-send-command + v (format + "cd //%s%s" + host + (tramp-smb-shell-quote-argument + (file-name-directory localname))))) + (tramp-message v 6 "(%s); exit" command) + (tramp-send-string v command))) + (setq p (tramp-get-connection-process v)) + (when program + (process-put p 'remote-command (cons program args)) + (tramp-set-connection-property + p "remote-command" (cons program args))) + ;; Return value. + p))) ;; Save exit. ;; FIXME: Does `tramp-get-connection-buffer' return the proper value? @@ -1933,7 +1935,7 @@ If ARGUMENT is non-nil, use it as argument for tramp-smb-version (tramp-get-connection-property vec "smbclient-version" tramp-smb-version)) - (tramp-flush-directory-properties vec "") + (tramp-flush-directory-properties vec "/") (tramp-flush-connection-properties vec)) (tramp-set-connection-property diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index d7c918fbc8..a9225db434 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -333,7 +333,7 @@ arguments to pass to the OPERATION." ;; them. (when tmpinput (delete-file tmpinput)) (when process-file-side-effects - (tramp-flush-directory-properties v "")))))) + (tramp-flush-directory-properties v "/")))))) (defun tramp-sshfs-handle-rename-file (filename newname &optional ok-if-already-exists) @@ -355,18 +355,15 @@ arguments to pass to the OPERATION." (defun tramp-sshfs-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." - (with-parsed-tramp-file-name filename nil - (unless (and (eq flag 'nofollow) (file-symlink-p filename)) - (tramp-flush-file-properties v localname) + (unless (and (eq flag 'nofollow) (file-symlink-p filename)) + (tramp-skeleton-set-file-modes-times-uid-gid filename (tramp-compat-set-file-modes (tramp-fuse-local-file-name filename) mode flag)))) (defun tramp-sshfs-handle-set-file-times (filename &optional timestamp flag) "Like `set-file-times' for Tramp files." - (or (file-exists-p filename) (write-region "" nil filename nil 0)) - (with-parsed-tramp-file-name filename nil - (unless (and (eq flag 'nofollow) (file-symlink-p filename)) - (tramp-flush-file-properties v localname) + (unless (and (eq flag 'nofollow) (file-symlink-p filename)) + (tramp-skeleton-set-file-modes-times-uid-gid filename (tramp-compat-set-file-times (tramp-fuse-local-file-name filename) timestamp flag)))) diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 5ec68e904e..3564a1b7b4 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -484,10 +484,9 @@ the result will be a local, non-Tramp, file name." (defun tramp-sudoedit-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." - (with-parsed-tramp-file-name filename nil - ;; It is unlikely that "chmod -h" works. - (unless (and (eq flag 'nofollow) (file-symlink-p filename)) - (tramp-flush-file-properties v localname) + ;; It is unlikely that "chmod -h" works. + (unless (and (eq flag 'nofollow) (file-symlink-p filename)) + (tramp-skeleton-set-file-modes-times-uid-gid filename (unless (tramp-sudoedit-send-command v "chmod" (format "%o" mode) (tramp-compat-file-name-unquote localname)) @@ -542,8 +541,7 @@ the result will be a local, non-Tramp, file name." (defun tramp-sudoedit-handle-set-file-times (filename &optional time flag) "Like `set-file-times' for Tramp files." - (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v localname) + (tramp-skeleton-set-file-modes-times-uid-gid filename (let ((time (if (or (null time) (tramp-compat-time-equal-p time tramp-time-doesnt-exist) @@ -730,13 +728,13 @@ ID-FORMAT valid values are `string' and `integer'." (defun tramp-sudoedit-handle-set-file-uid-gid (filename &optional uid gid) "Like `tramp-set-file-uid-gid' for Tramp files." - (with-parsed-tramp-file-name filename nil - (tramp-sudoedit-send-command - v "chown" - (format "%d:%d" - (or uid (tramp-get-remote-uid v 'integer)) - (or gid (tramp-get-remote-gid v 'integer))) - (tramp-unquote-file-local-name filename)))) + (tramp-skeleton-set-file-modes-times-uid-gid filename + (tramp-sudoedit-send-command + v "chown" + (format "%d:%d" + (or uid (tramp-get-remote-uid v 'integer)) + (or gid (tramp-get-remote-gid v 'integer))) + (tramp-unquote-file-local-name filename)))) ;; Internal functions. diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 0afa6fc431..aac63882ce 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -62,7 +62,6 @@ (require 'cl-lib) (declare-function file-notify-rm-watch "filenotify") (declare-function netrc-parse "netrc") -(declare-function tramp-archive-file-name-handler "tramp-archive") (defvar auto-save-file-name-transforms) ;; Reload `tramp-compat' when we reload `tramp-autoloads' of the GNU ELPA package. @@ -97,6 +96,7 @@ If it is set to nil, all remote file names are used literally." :type 'boolean) +;;;###tramp-autoload (defcustom tramp-verbose 3 "Verbosity level for Tramp messages. Any level x includes messages for all levels 1 .. x-1. The levels are @@ -1441,8 +1441,9 @@ calling HANDLER.") ;; work otherwise when unloading / reloading Tramp. (Bug#50869) ;;;###tramp-autoload(require 'cl-lib) ;;;###tramp-autoload -(cl-defstruct (tramp-file-name (:type list) :named) - method user domain host port localname hop) +(progn + (cl-defstruct (tramp-file-name (:type list) :named) + method user domain host port localname hop)) (put #'tramp-file-name-method 'tramp-suppress-trace t) (put #'tramp-file-name-user 'tramp-suppress-trace t) @@ -1485,13 +1486,22 @@ If nil, return `tramp-default-port'." (put #'tramp-file-name-port-or-default 'tramp-suppress-trace t) -(defun tramp-file-name-unify (vec) +;;;###tramp-autoload +(defun tramp-file-name-unify (vec &optional file) "Unify VEC by removing localname and hop from `tramp-file-name' structure. +If FILE is a string, set it as localname. Objects returned by this function compare `equal' if they refer to the same connection. Make a copy in order to avoid side effects." (when (tramp-file-name-p vec) (setq vec (copy-tramp-file-name vec)) - (setf (tramp-file-name-localname vec) nil + (setf (tramp-file-name-localname vec) + (and (stringp file) + ;; FIXME: This is a sanity check. When this error + ;; doesn't happen for a while, it can be removed. + (or (file-name-absolute-p file) + (tramp-error + vec 'file-error "File `%s' must be absolute" file)) + (directory-file-name (tramp-compat-file-name-unquote file))) (tramp-file-name-hop vec) nil)) vec) @@ -1525,6 +1535,7 @@ entry does not exist, return nil." "Return unquoted localname component of VEC." (tramp-compat-file-name-unquote (tramp-file-name-localname vec))) +;;;###tramp-autoload (defun tramp-tramp-file-p (name) "Return t if NAME is a string with Tramp file name syntax." (and tramp-mode (stringp name) @@ -1546,6 +1557,7 @@ entry does not exist, return nil." ;; However, it is more performant than `file-local-name', and might be ;; useful where performance matters, like in operations over a bulk ;; list of file names. +;;;###tramp-autoload (defun tramp-file-local-name (name) "Return the local name component of NAME. This function removes from NAME the specification of the remote @@ -1637,6 +1649,7 @@ This is HOST, if non-nil. Otherwise, do a lookup in (put #'tramp-find-host 'tramp-suppress-trace t) +;;;###tramp-autoload (defun tramp-dissect-file-name (name &optional nodefault) "Return a `tramp-file-name' structure of NAME, a remote file name. The structure consists of method, user, domain, host, port, @@ -1747,6 +1760,7 @@ See `tramp-dissect-file-name' for details." (put #'tramp-buffer-name 'tramp-suppress-trace t) +;;;###tramp-autoload (defun tramp-make-tramp-file-name (&rest args) "Construct a Tramp file name from ARGS. @@ -1856,6 +1870,7 @@ Unless DONT-CREATE, the buffer is created when it doesn't exist yet." (tramp-make-tramp-file-name vec 'noloc)) (current-buffer))))) +;;;###tramp-autoload (defun tramp-get-connection-buffer (vec &optional dont-create) "Get the connection buffer to be used for VEC. Unless DONT-CREATE, the buffer is created when it doesn't exist yet. @@ -1912,8 +1927,7 @@ version, the function does nothing." "Return `default-directory' of BUFFER." (buffer-local-value 'default-directory buffer)) -(put #'tramp-get-default-directory 'tramp-suppress-trace t) - +;;;###tramp-autoload (defsubst tramp-get-buffer-string (&optional buffer) "Return contents of BUFFER. If BUFFER is not a buffer or a buffer name, return the contents @@ -1921,8 +1935,6 @@ of `current-buffer'." (with-current-buffer (or buffer (current-buffer)) (substring-no-properties (buffer-string)))) -(put #'tramp-get-buffer-string 'tramp-suppress-trace t) - (defun tramp-debug-buffer-name (vec) "A name for the debug buffer for VEC." (let ((method (tramp-file-name-method vec)) @@ -2034,6 +2046,7 @@ They are completed by \"M-x TAB\" only in Tramp debug buffers." (defvar tramp-trace-functions nil "A list of non-Tramp functions to be traced with `tramp-verbose' > 10.") +;;;###tramp-autoload (defun tramp-debug-message (vec fmt-string &rest arguments) "Append message to debug buffer of VEC. Message is formatted with FMT-STRING as control string and the remaining @@ -2107,10 +2120,12 @@ ARGUMENTS to actually emit the message (if applicable)." (put #'tramp-debug-message 'tramp-suppress-trace t) +;;;###tramp-autoload (defvar tramp-inhibit-progress-reporter nil "Show Tramp progress reporter in the minibuffer. This variable is used to disable concurrent progress reporter messages.") +;;;###tramp-autoload (defsubst tramp-message (vec-or-proc level fmt-string &rest arguments) "Emit a message depending on verbosity level. VEC-OR-PROC identifies the Tramp buffer to use. It can be either a @@ -2163,8 +2178,6 @@ applicable)." (concat (format "(%d) # " level) fmt-string) arguments)))))) -(put #'tramp-message 'tramp-suppress-trace t) - (defsubst tramp-backtrace (&optional vec-or-proc force) "Dump a backtrace into the debug buffer. If VEC-OR-PROC is nil, the buffer *debug tramp* is used. FORCE @@ -2177,8 +2190,6 @@ This function is meant for debugging purposes." vec-or-proc 10 "\n%s" (with-output-to-string (backtrace))) (with-output-to-temp-buffer "*debug tramp*" (backtrace)))))) -(put #'tramp-backtrace 'tramp-suppress-trace t) - (defun tramp-error (vec-or-proc signal fmt-string &rest arguments) "Emit an error. VEC-OR-PROC identifies the connection to use, SIGNAL is the @@ -2246,8 +2257,6 @@ an input event arrives. The other arguments are passed to `tramp-error'." (when (tramp-file-name-equal-p vec (car tramp-current-connection)) (setcdr tramp-current-connection (current-time))))))) -(put #'tramp-error-with-buffer 'tramp-suppress-trace t) - ;; We must make it a defun, because it is used earlier already. (defun tramp-user-error (vec-or-proc fmt-string &rest arguments) "Signal a user error (or \"pilot error\")." @@ -2284,8 +2293,6 @@ the resulting error message." (progn ,@body) (error (tramp-message ,vec-or-proc 3 ,format ,err) nil)))) -(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. @@ -2302,8 +2309,6 @@ does not exist, otherwise propagate the error." (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 @@ -2399,45 +2404,6 @@ without a visible progress reporter." (if tm (cancel-timer tm)) (tramp-message ,vec ,level "%s...%s" ,message cookie))))) -(defmacro with-tramp-file-property (vec file property &rest body) - "Check in Tramp cache for PROPERTY, otherwise execute BODY and set cache. -FILE must be a local file name on a connection identified via VEC." - (declare (indent 3) (debug t)) - `(if (file-name-absolute-p ,file) - (let ((value (tramp-get-file-property - ,vec ,file ,property tramp-cache-undefined))) - (when (eq value tramp-cache-undefined) - ;; We cannot pass @body as parameter to - ;; `tramp-set-file-property' because it mangles our debug - ;; messages. - (setq value (progn ,@body)) - (tramp-set-file-property ,vec ,file ,property value)) - value) - ,@body)) - -(defmacro with-tramp-connection-property (key property &rest body) - "Check in Tramp for property PROPERTY, otherwise execute BODY and set." - (declare (indent 2) (debug t)) - `(let ((value (tramp-get-connection-property - ,key ,property tramp-cache-undefined))) - (when (eq value tramp-cache-undefined) - ;; We cannot pass ,@body as parameter to - ;; `tramp-set-connection-property' because it mangles our debug - ;; messages. - (setq value (progn ,@body)) - (tramp-set-connection-property ,key ,property value)) - value)) - -(defmacro with-tramp-saved-connection-property (key property &rest body) - "Save PROPERTY, run BODY, reset PROPERTY." - (declare (indent 2) (debug t)) - `(let ((value (tramp-get-connection-property - ,key ,property tramp-cache-undefined))) - (unwind-protect (progn ,@body) - (if (eq value tramp-cache-undefined) - (tramp-flush-connection-property ,key ,property) - (tramp-set-connection-property ,key ,property value))))) - (defun tramp-drop-volume-letter (name) "Cut off unnecessary drive letter from file NAME. The functions `tramp-*-handle-expand-file-name' call `expand-file-name' @@ -3424,8 +3390,6 @@ BODY is the backend specific code." (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." @@ -3441,8 +3405,6 @@ BODY is the backend specific code." ,@body) (tramp-flush-directory-properties v localname))) -(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'. @@ -3474,8 +3436,6 @@ BODY is the backend specific code." (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'. @@ -3485,7 +3445,6 @@ BODY is the backend specific code." (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 @@ -3493,9 +3452,10 @@ BODY is the backend specific code." (cons (car x) (tramp-convert-file-attributes - v (car x) ,id-format (cdr x)))) + v (expand-file-name (car x) localname) + ,id-format (cdr x)))) (with-tramp-file-property - v localname ",directory-files-and-attributes" + v localname "directory-files-and-attributes" ,@body)))) result item) @@ -3524,10 +3484,8 @@ BODY is the backend specific code." (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'. + "Skeleton for `tramp-*-handle-file-local-copy'. BODY is the backend specific code." (declare (indent 1) (debug t)) `(with-parsed-tramp-file-name (file-truename ,filename) nil @@ -3541,7 +3499,22 @@ BODY is the backend specific code." ;; Trigger the `file-missing' error. (signal 'error nil))))) -(put #'tramp-skeleton-file-local-copy 'tramp-suppress-trace t) +(defmacro tramp-skeleton-set-file-modes-times-uid-gid + (filename &rest body) + "Skeleton for `tramp-*-set-file-{modes,times,uid-gid}'. +BODY is the backend specific code." + (declare (indent 1) (debug t)) + `(with-parsed-tramp-file-name ,filename nil + (when (not (file-exists-p ,filename)) + (tramp-error v 'file-missing ,filename)) + (with-tramp-saved-file-properties + v localname + ;; We cannot add "file-attributes", "file-executable-p", + ;; "file-ownership-preserved-p", "file-readable-p", + ;; "file-writable-p". + '("file-directory-p" "file-exists-p" "file-symlinkp" "file-truename") + (tramp-flush-file-properties v localname)) + ,@body)) (defmacro tramp-skeleton-write-region (start end filename append visit lockname mustbenew &rest body) @@ -3602,6 +3575,9 @@ BODY is the backend specific code." ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. (tramp-flush-file-properties v localname) + ;; Set the "file-exists-p" file property, because it is + ;; likely that it is needed shortly after `write-region'. + (tramp-set-file-property v localname "file-exists-p" t) ;; We must protect `last-coding-system-used', now we have ;; set it to its correct value. @@ -3645,8 +3621,6 @@ BODY is the backend specific code." (tramp-message v 0 "Wrote %s" filename)) (run-hooks 'tramp-handle-write-region-hook)))))) -(put #'tramp-skeleton-write-region 'tramp-suppress-trace t) - ;;; Common file name handler functions for different backends: (defvar tramp-handle-file-local-copy-hook nil @@ -3843,7 +3817,9 @@ Let-bind it when necessary.") ;; We don't want to run it when `non-essential' is t, or there is ;; no connection process yet. (when (tramp-connectable-p filename) - (not (null (file-attributes filename))))) + (with-parsed-tramp-file-name filename nil + (with-tramp-file-property v localname "file-exists-p" + (not (null (file-attributes filename))))))) (defun tramp-handle-file-in-directory-p (filename directory) "Like `file-in-directory-p' for Tramp files." @@ -5620,7 +5596,7 @@ the remote host use line-endings as defined in the variable (when vec (tramp-message vec 5 "Sentinel called: `%S' `%s'" proc event) (tramp-flush-connection-properties proc) - (tramp-flush-directory-properties vec "")) + (tramp-flush-directory-properties vec "/")) (when (buffer-live-p buf) (with-current-buffer buf (when (and prompt (tramp-search-regexp (regexp-quote prompt))) @@ -6049,6 +6025,7 @@ Return the local name of the temporary file." (let (create-lockfiles) (cl-letf (((symbol-function 'tramp-remote-acl-p) #'ignore) ((symbol-function 'tramp-remote-selinux-p) #'ignore) + ((symbol-function 'tramp-smb-remote-acl-p) #'ignore) ((symbol-function 'tramp-sudoedit-remote-acl-p) #'ignore) ((symbol-function 'tramp-sudoedit-remote-selinux-p) #'ignore)) (tramp-file-local-name diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 5a8d9100e1..63ccd05a26 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -2481,6 +2481,19 @@ This checks also `file-name-as-directory', `file-name-directory', (insert-file-contents tmp-name) (should (string-equal (buffer-string) "foo"))) + ;; Write empty string. Used for creation of temprorary files. + ;; Since Emacs 27.1. + (when (fboundp 'make-empty-file) + (with-no-warnings + (should-error + (make-empty-file tmp-name) + :type 'file-already-exists) + (delete-file tmp-name) + (make-empty-file tmp-name) + (with-temp-buffer + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) ""))))) + ;; Write partly. (with-temp-buffer (insert "123456789") @@ -3790,7 +3803,11 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (when (tramp--test-emacs28-p) (with-no-warnings (set-file-modes tmp-name1 #o222 'nofollow) - (should (= (file-modes tmp-name1 'nofollow) #o222))))) + (should (= (file-modes tmp-name1 'nofollow) #o222)))) + ;; Setting the mode for not existing files shall fail. + (should-error + (set-file-modes tmp-name2 #o777) + :type 'file-missing)) ;; Cleanup. (ignore-errors (delete-file tmp-name1))) @@ -4153,6 +4170,10 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (tramp-compat-time-equal-p (file-attribute-modification-time (file-attributes tmp-name1)) (seconds-to-time 1))) + ;; Setting the time for not existing files shall fail. + (should-error + (set-file-times tmp-name2) + :type 'file-missing) (write-region "bla" nil tmp-name2) (should (file-exists-p tmp-name2)) (should (file-newer-than-file-p tmp-name2 tmp-name1)) commit 3ec6b806b246c147ae30408a1d659083619883af Author: Stefan Kangas Date: Wed Aug 3 16:10:30 2022 +0200 Mark keys in apropos.el for substitute-command-keys * lisp/apropos.el (apropos-symbol, apropos-function) (apropos-macro, apropos-command, apropos-variable) (apropos-user-option, apropos-face, apropos-group) (apropos-widget, apropos-plist, apropos-library): Mark keys for 'substitute-command-keys'. diff --git a/lisp/apropos.el b/lisp/apropos.el index 9682128586..624c29cb41 100644 --- a/lisp/apropos.el +++ b/lisp/apropos.el @@ -1,7 +1,6 @@ ;;; apropos.el --- apropos commands for users and programmers -*- lexical-binding: t -*- -;; Copyright (C) 1989, 1994-1995, 2001-2022 Free Software Foundation, -;; Inc. +;; Copyright (C) 1989-2022 Free Software Foundation, Inc. ;; Author: Joe Wells ;; Daniel Pfeiffer (rewrite) @@ -218,7 +217,7 @@ before `apropos-mode' makes it buffer-local.") (define-button-type 'apropos-symbol 'face 'apropos-symbol - 'help-echo "mouse-2, RET: Display more help on this symbol" + 'help-echo "\\`mouse-2', \\`RET': Display more help on this symbol" 'follow-link t 'action #'apropos-symbol-button-display-help) @@ -232,7 +231,7 @@ before `apropos-mode' makes it buffer-local.") 'apropos-label "Function" 'apropos-short-label "f" 'face 'apropos-function-button - 'help-echo "mouse-2, RET: Display more help on this function" + 'help-echo "\\`mouse-2', \\`RET': Display more help on this function" 'follow-link t 'action (lambda (button) (describe-function (button-get button 'apropos-symbol)))) @@ -241,7 +240,7 @@ before `apropos-mode' makes it buffer-local.") 'apropos-label "Macro" 'apropos-short-label "m" 'face 'apropos-function-button - 'help-echo "mouse-2, RET: Display more help on this macro" + 'help-echo "\\`mouse-2', \\`RET': Display more help on this macro" 'follow-link t 'action (lambda (button) (describe-function (button-get button 'apropos-symbol)))) @@ -250,7 +249,7 @@ before `apropos-mode' makes it buffer-local.") 'apropos-label "Command" 'apropos-short-label "c" 'face 'apropos-function-button - 'help-echo "mouse-2, RET: Display more help on this command" + 'help-echo "\\`mouse-2', \\`RET': Display more help on this command" 'follow-link t 'action (lambda (button) (describe-function (button-get button 'apropos-symbol)))) @@ -264,7 +263,7 @@ before `apropos-mode' makes it buffer-local.") 'apropos-label "Variable" 'apropos-short-label "v" 'face 'apropos-variable-button - 'help-echo "mouse-2, RET: Display more help on this variable" + 'help-echo "\\`mouse-2', \\`RET': Display more help on this variable" 'follow-link t 'action (lambda (button) (describe-variable (button-get button 'apropos-symbol)))) @@ -273,7 +272,7 @@ before `apropos-mode' makes it buffer-local.") 'apropos-label "User option" 'apropos-short-label "o" 'face 'apropos-user-option-button - 'help-echo "mouse-2, RET: Display more help on this user option" + 'help-echo "\\`mouse-2', \\`RET': Display more help on this user option" 'follow-link t 'action (lambda (button) (describe-variable (button-get button 'apropos-symbol)))) @@ -282,7 +281,7 @@ before `apropos-mode' makes it buffer-local.") 'apropos-label "Face" 'apropos-short-label "F" 'face 'apropos-button - 'help-echo "mouse-2, RET: Display more help on this face" + 'help-echo "\\`mouse-2', \\`RET': Display more help on this face" 'follow-link t 'action (lambda (button) (describe-face (button-get button 'apropos-symbol)))) @@ -291,7 +290,7 @@ before `apropos-mode' makes it buffer-local.") 'apropos-label "Group" 'apropos-short-label "g" 'face 'apropos-misc-button - 'help-echo "mouse-2, RET: Display more help on this group" + 'help-echo "\\`mouse-2', \\`RET': Display more help on this group" 'follow-link t 'action (lambda (button) (customize-group-other-window @@ -301,7 +300,7 @@ before `apropos-mode' makes it buffer-local.") 'apropos-label "Widget" 'apropos-short-label "w" 'face 'apropos-misc-button - 'help-echo "mouse-2, RET: Display more help on this widget" + 'help-echo "\\`mouse-2', \\`RET': Display more help on this widget" 'follow-link t 'action (lambda (button) (widget-browse-other-window (button-get button 'apropos-symbol)))) @@ -310,13 +309,13 @@ before `apropos-mode' makes it buffer-local.") 'apropos-label "Properties" 'apropos-short-label "p" 'face 'apropos-misc-button - 'help-echo "mouse-2, RET: Display more help on this plist" + 'help-echo "\\`mouse-2', \\`RET': Display more help on this plist" 'follow-link t 'action (lambda (button) (apropos-describe-plist (button-get button 'apropos-symbol)))) (define-button-type 'apropos-library - 'help-echo "mouse-2, RET: Display more help on this library" + 'help-echo "\\`mouse-2', \\`RET': Display more help on this library" 'follow-link t 'action (lambda (button) (apropos-library (button-get button 'apropos-symbol)))) commit 95856c515464cfaf90d3fa9104b55dbcce9ac586 Author: Stefan Kangas Date: Wed Aug 3 16:08:17 2022 +0200 Add face to mouse buttons in command substitutions * lisp/help.el (substitute-command-keys): Add help-key-binding face to mouse buttons in literal key substitutions. * test/lisp/help-tests.el (help-tests-substitute-command-keys/literal-key-sequence): Expand test for above change. diff --git a/lisp/help.el b/lisp/help.el index 1c1ce1618c..f58d252bae 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -1182,6 +1182,7 @@ Otherwise, return a new string." (let ((k (buffer-substring-no-properties (+ orig-point 2) end-point))) (when (or (key-valid-p k) + (string-match-p "\\`mouse-[1-9]" k) (string-match-p "\\`M-x " k)) (goto-char orig-point) (delete-char 2) diff --git a/test/lisp/help-tests.el b/test/lisp/help-tests.el index 5c935965f7..7f30b27b00 100644 --- a/test/lisp/help-tests.el +++ b/test/lisp/help-tests.el @@ -93,7 +93,9 @@ (with-substitute-command-keys-test (test "\\`C-m'" "C-m") (test "\\`C-m'\\`C-j'" "C-mC-j") - (test "foo\\`C-m'bar\\`C-j'baz" "fooC-mbarC-jbaz"))) + (test "foo\\`C-m'bar\\`C-j'baz" "fooC-mbarC-jbaz") + (test "\\`M-x next-line'" "M-x next-line") + (test "\\`mouse-1'" "mouse-1"))) (ert-deftest help-tests-substitute-command-keys/literal-key-sequence-ignore-invalid () "Ignore any invalid literal key sequence." commit ec22e923c0dab286cdcf18595e836f1013e9a9f1 Author: Eli Zaretskii Date: Wed Aug 3 17:16:09 2022 +0300 Teach 'symbol-file' about .eln natively-compiled files * lisp/subr.el (locate-eln-file): New function. (symbol-file): Accept an optional 3rd argument NATIVE-P, and, if non-nil, try to locate and report the .eln file where SYMBOL was defined. * etc/NEWS: * doc/lispref/loading.texi (Where Defined): Document the new optional argument of 'symbol-file'. diff --git a/doc/lispref/loading.texi b/doc/lispref/loading.texi index 54fc16ec9f..e8dce433a5 100644 --- a/doc/lispref/loading.texi +++ b/doc/lispref/loading.texi @@ -1032,7 +1032,7 @@ with a call to @code{provide}. The order of the elements in the @cindex symbol, where defined @cindex where was a symbol defined -@defun symbol-file symbol &optional type +@defun symbol-file symbol &optional type native-p This function returns the name of the file that defined @var{symbol}. If @var{type} is @code{nil}, then any kind of definition is acceptable. If @var{type} is @code{defun}, @code{defvar}, or @code{defface}, that @@ -1043,6 +1043,14 @@ The value is normally an absolute file name. It can also be @code{nil}, if the definition is not associated with any file. If @var{symbol} specifies an autoloaded function, the value can be a relative file name without extension. + +If the optional third argument @var{native-p} is non-@code{nil}, and +Emacs was built with native compilation support (@pxref{Native +Compilation}), this function will try to find the @file{.eln} file +that defined @var{symbol}, instead of the @file{.elc} or @file{.el} +file. If such a @file{.eln} file is found and is not outdated, the +function will return its absolute file name; otherwise it will report +the name of either the source or the byte-compiled file. @end defun The basis for @code{symbol-file} is the data in the variable diff --git a/etc/NEWS b/etc/NEWS index b88fb63662..7e8ed465eb 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2575,6 +2575,11 @@ things to be saved. ** New function 'string-equal-ignore-case'. This compares strings ignoring case differences. +** 'symbol-file' can now report natively-compiled .eln files. +If Emacs was built with native-compilation enabled, Lisp programs can +now call 'symbol-file' with the new optional 3rd argument non-nil to +request the name of the .eln file which defined a given symbol. + ** Themes --- diff --git a/lisp/subr.el b/lisp/subr.el index ff82d0d1d8..1b59db0604 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -2700,18 +2700,44 @@ This is to `put' what `defalias' is to `fset'." (setcdr ps (cons symbol (cdr ps)))))) (put symbol prop val)) -(defun symbol-file (symbol &optional type) +(defvar comp-native-version-dir) +(defvar native-comp-eln-load-path) +(declare-function subr-native-elisp-p "data.c") +(declare-function native-comp-unit-file "data.c") +(declare-function subr-native-comp-unit "data.c") +(declare-function comp-el-to-eln-rel-filename "comp.c") + +(defun locate-eln-file (eln-file) + "Locate a natively-compiled ELN-FILE by searching its load path. +This function looks in directories named by `native-comp-eln-load-path'." + (or (locate-file-internal (concat comp-native-version-dir "/" eln-file) + native-comp-eln-load-path) + (locate-file-internal + ;; Preloaded *.eln files live in the preloaded/ subdirectory of + ;; the last entry in `native-comp-eln-load-path'. + (concat comp-native-version-dir "/preloaded/" eln-file) + (last native-comp-eln-load-path)))) + +(defun symbol-file (symbol &optional type native-p) "Return the name of the file that defined SYMBOL. The value is normally an absolute file name. It can also be nil, if the definition is not associated with any file. If SYMBOL specifies an autoloaded function, the value can be a relative file name without extension. -If TYPE is nil, then any kind of definition is acceptable. If -TYPE is `defun', `defvar', or `defface', that specifies function +If TYPE is nil, then any kind of SYMBOL's definition is acceptable. +If TYPE is `defun', `defvar', or `defface', that specifies function definition, variable definition, or face definition only. Otherwise TYPE is assumed to be a symbol property. +If NATIVE-P is non-nil, and SYMBOL was loaded from a .eln file, +this function will return the absolute file name of that .eln file, +if found. Note that if the .eln file is older than its source .el +file, Emacs won't load such an outdated .eln file, and this function +will not return it. If the .eln file couldn't be found, or is +outdated, the function returns the corresponding .elc or .el file +instead. + This function only works for symbols defined in Lisp files. For symbols that are defined in C files, use `help-C-file-name' instead." @@ -2719,24 +2745,59 @@ instead." (symbolp symbol) (autoloadp (symbol-function symbol))) (nth 1 (symbol-function symbol)) - (catch 'found - (pcase-dolist (`(,file . ,elems) load-history) - (when (if type - (if (eq type 'defvar) - ;; Variables are present just as their names. - (member symbol elems) - ;; Many other types are represented as (TYPE . NAME). - (or (member (cons type symbol) elems) - (memq symbol (alist-get type - (alist-get 'define-symbol-props - elems))))) - ;; We accept all types, so look for variable def - ;; and then for any other kind. - (or (member symbol elems) - (let ((match (rassq symbol elems))) - (and match - (not (eq 'require (car match))))))) - (throw 'found file)))))) + (if (and native-p (or (null type) (eq type 'defun)) + (symbolp symbol) + (native-comp-available-p) + ;; If it's a defun, we have a shortcut. + (subr-native-elisp-p (symbol-function symbol))) + ;; native-comp-unit-file returns unnormalized file names. + (expand-file-name (native-comp-unit-file (subr-native-comp-unit + (symbol-function symbol)))) + (let ((elc-file + (catch 'found + (pcase-dolist (`(,file . ,elems) load-history) + (when (if type + (if (eq type 'defvar) + ;; Variables are present just as their + ;; names. + (member symbol elems) + ;; Many other types are represented as + ;; (TYPE . NAME). + (or (member (cons type symbol) elems) + (memq + symbol + (alist-get type + (alist-get 'define-symbol-props + elems))))) + ;; We accept all types, so look for variable def + ;; and then for any other kind. + (or (member symbol elems) + (let ((match (rassq symbol elems))) + (and match + (not (eq 'require (car match))))))) + (throw 'found file)))))) + ;; If they asked for the .eln file, try to find it. + (or (and elc-file + native-p + (native-comp-available-p) + (let* ((sans-ext (file-name-sans-extension elc-file)) + (el-file + (and (fboundp 'zlib-available-p) + (zlib-available-p) + (concat sans-ext ".el.gz"))) + (el-file-backup (concat sans-ext ".el"))) + (or (and el-file (file-exists-p el-file)) + (and (file-exists-p el-file-backup) + (setq el-file el-file-backup)) + (setq el-file nil)) + (when (stringp el-file) + (let ((eln-file (locate-eln-file + (comp-el-to-eln-rel-filename el-file)))) + ;; Emacs will not load an outdated .eln file, + ;; so we mimic this behavior here. + (if (file-newer-than-file-p eln-file el-file) + eln-file))))) + elc-file))))) (declare-function read-library-name "find-func" nil) commit 6861ed117592bf45eeb0e21f17f756d58e407313 Author: Stefan Kangas Date: Wed Aug 3 15:45:06 2022 +0200 Do interactive mode tagging in apropos.el * lisp/apropos.el (apropos-follow, apropos-next-symbol) (apropos-previous-symbol): Tag for 'apropos-mode'. diff --git a/lisp/apropos.el b/lisp/apropos.el index 13dc8fa139..9682128586 100644 --- a/lisp/apropos.el +++ b/lisp/apropos.el @@ -1332,14 +1332,14 @@ as a heading." (defun apropos-follow () "Invokes any button at point, otherwise invokes the nearest label button." - (interactive) + (interactive nil apropos-mode) (button-activate (or (apropos-next-label-button (line-beginning-position)) (error "There is nothing to follow here")))) (defun apropos-next-symbol () "Move cursor down to the next symbol in an `apropos-mode' buffer." - (interactive) + (interactive nil apropos-mode) (forward-line) (while (and (not (eq (face-at-point) 'apropos-symbol)) (< (point) (point-max))) @@ -1347,7 +1347,7 @@ as a heading." (defun apropos-previous-symbol () "Move cursor back to the last symbol in an `apropos-mode' buffer." - (interactive) + (interactive nil apropos-mode) (forward-line -1) (while (and (not (eq (face-at-point) 'apropos-symbol)) (> (point) (point-min))) commit d71d5b2a9691c5448765f61a4f8879cc171559f5 Author: Stefan Kangas Date: Wed Aug 3 15:41:37 2022 +0200 Remove superfluous autoloads from url-util.el * lisp/url/url-util.el (timezone-parse-date) (timezone-make-date-arpa-standard): Remove superfluous autoloads. diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el index de8e674797..48ea947fab 100644 --- a/lisp/url/url-util.el +++ b/lisp/url/url-util.el @@ -27,8 +27,6 @@ (require 'url-parse) (require 'url-vars) -(autoload 'timezone-parse-date "timezone") -(autoload 'timezone-make-date-arpa-standard "timezone") (autoload 'mail-header-extract "mailheader") (defvar url-parse-args-syntax-table commit 261d6afd6e6f3ba2bbf4db0d9ac57b0cbacc0137 Author: Lars Ingebrigtsen Date: Wed Aug 3 14:22:08 2022 +0200 Byte-compile the in-tree loaddefs.el files * lisp/Makefile.in (all): Add "autoloads", which now otherwise won't be done. ($(lisp)/loaddefs.el): Remove this target, since it's always done, and would then trigger a re-compilation of loaddefs.elc. * lisp/loadup.el: Load loaddefs.elc (if it exists). * lisp/emacs-lisp/loaddefs-gen.el (loaddefs-generate): Don't include no-byte-compile cookies in the Emacs build. * src/Makefile.in ($(pdmp)): Depend on loaddefs.elc to ensure that it's built by this point. ($(etc)/DOC): Don't scan loaddefs.el for doc strings, since they are now picked up from the .elc file (bug#53024). diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 9516f2fc36..315b1fcf7b 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -123,10 +123,10 @@ SUBDIRS_FINDER = $(filter-out ${srcdir}/leim%,${SUBDIRS_ALMOST}) ## All subdirectories in which we might want to create subdirs.el. SUBDIRS_SUBDIRS = $(filter-out ${srcdir}/cedet% ${srcdir}/leim%,${SUBDIRS}) -# cus-load and finder-inf are not explicitly requested by anything, so -# we add them here to make sure they get built. +# cus-load, finder-inf and autoloads are not explicitly requested by +# anything, so we add them here to make sure they get built. all: compile-main $(lisp)/cus-load.el $(lisp)/finder-inf.el generate-ja-dic \ - org-manuals + org-manuals autoloads PHONY_EXTRAS = .PHONY: all custom-deps finder-data autoloads update-subdirs $(PHONY_EXTRAS) \ @@ -196,13 +196,10 @@ org-manuals: main-first # from ../src rules, but that doesn't seem possible due to the various # non-trivial dependencies. -# We make $(lisp)/loaddefs.el a dependency of .PHONY to cause Make to -# ignore its time stamp. That's because the real dependencies of -# loaddefs.el aren't known to Make, they are implemented in -# loaddefs-generate--emacs-batch. - -autoloads .PHONY: $(lisp)/loaddefs.el -$(lisp)/loaddefs.el: gen-lisp $(LOADDEFS) $(lisp)/emacs-lisp/loaddefs-gen.elc +# That's because the real dependencies of loaddefs.el aren't known to +# Make, they are implemented in loaddefs-generate--emacs-batch, so +# autoloads is an "all" dependency. +autoloads: $(AM_V_GEN)$(emacs) \ -l $(lisp)/emacs-lisp/loaddefs-gen.elc \ -f loaddefs-generate--emacs-batch ${SUBDIRS_ALMOST} diff --git a/lisp/emacs-lisp/loaddefs-gen.el b/lisp/emacs-lisp/loaddefs-gen.el index 36b0b1e9cd..830799ec36 100644 --- a/lisp/emacs-lisp/loaddefs-gen.el +++ b/lisp/emacs-lisp/loaddefs-gen.el @@ -588,7 +588,8 @@ If GENERATE-FULL, don't update, but regenerate all the loaddefs files." (with-temp-buffer (if (and updating (file-exists-p loaddefs-file)) (insert-file-contents loaddefs-file) - (insert (loaddefs-generate--rubric loaddefs-file nil t)) + (insert (loaddefs-generate--rubric + loaddefs-file nil t include-package-version)) (search-backward "\f") (when extra-data (insert extra-data) diff --git a/lisp/loadup.el b/lisp/loadup.el index 21a87dbd77..a65c1724ae 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -185,9 +185,10 @@ ;; should be updated by overwriting it with an up-to-date copy of ;; loaddefs.el that is not corrupted by local changes. ;; admin/update_autogen can be used to update ldefs-boot.el periodically. -(condition-case nil (load "loaddefs.el") - ;; In case loaddefs hasn't been generated yet. - (file-error (load "ldefs-boot.el"))) +(condition-case nil + (load "loaddefs") + (file-error + (load "ldefs-boot.el"))) (let ((new (make-hash-table :test #'equal))) ;; Now that loaddefs has populated definition-prefixes, purify its contents. diff --git a/src/Makefile.in b/src/Makefile.in index 7d15b7afd5..e81e7a16d9 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -635,7 +635,7 @@ Emacs.pdmp: $(pdmp) endif ifeq ($(DUMPING),pdumper) -$(pdmp): emacs$(EXEEXT) +$(pdmp): emacs$(EXEEXT) $(lispsource)/loaddefs.elc LC_ALL=C $(RUN_TEMACS) -batch $(BUILD_DETAILS) -l loadup --temacs=pdump \ --bin-dest $(BIN_DESTDIR) --eln-dest $(ELN_DESTDIR) cp -f $@ $(bootstrap_pdmp) @@ -652,13 +652,11 @@ endif ## for the first time, this prevents any variation between configurations ## in the contents of the DOC file. ## -$(etc)/DOC: $(libsrc)/make-docfile$(EXEEXT) $(doc_obj) $(lispsource)/loaddefs.el +$(etc)/DOC: $(libsrc)/make-docfile$(EXEEXT) $(doc_obj) $(AM_V_GEN)$(MKDIR_P) $(etc) $(AM_V_at)rm -f $(etc)/DOC $(AM_V_at)$(libsrc)/make-docfile -d $(srcdir) \ $(SOME_MACHINE_OBJECTS) $(doc_obj) > $(etc)/DOC - $(AM_V_at)$(libsrc)/make-docfile -a $(etc)/DOC -d $(lispsource) \ - loaddefs.el $(libsrc)/make-docfile$(EXEEXT) $(libsrc)/make-fingerprint$(EXEEXT): \ $(lib)/libgnu.a commit 6fb206329f9c3f14154bd425e08b2e72e7f31855 Author: Po Lu Date: Wed Aug 3 20:17:18 2022 +0800 ; * src/xterm.c (x_if_event): Minor speed improvements. diff --git a/src/xterm.c b/src/xterm.c index eb1a557e88..f82340958e 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -6605,12 +6605,17 @@ x_if_event (Display *dpy, XEvent *event_return, current_time = current_timespec (); target = timespec_add (current_time, timeout); + /* Check if an event is already in the queue. If it is, avoid + syncing. */ + if (XCheckIfEvent (dpy, event_return, predicate, arg)) + return 0; + while (true) { /* Get events into the queue. */ XSync (dpy, False); - /* Check if an event is now in the queue. */ + /* Look for an event again. */ if (XCheckIfEvent (dpy, event_return, predicate, arg)) return 0; commit bb56cc4cad3a5680e30dc29723690708bcff08f2 Author: Po Lu Date: Wed Aug 3 20:16:31 2022 +0800 Fix crash on setting frame background color * src/xfns.c (x_set_background_color): Stop setting scroll bar window background, since this is now taken care of automatically. diff --git a/src/xfns.c b/src/xfns.c index c149eaeca3..614a5b3455 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -1202,20 +1202,6 @@ x_set_background_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) xg_set_background_color (f, bg); #endif -#ifndef USE_TOOLKIT_SCROLL_BARS /* Turns out to be annoying with - toolkit scroll bars. */ - { - Lisp_Object bar; - for (bar = FRAME_SCROLL_BARS (f); - !NILP (bar); - bar = XSCROLL_BAR (bar)->next) - { - Window window = XSCROLL_BAR (bar)->x_window; - XSetWindowBackground (dpy, window, bg); - } - } -#endif /* USE_TOOLKIT_SCROLL_BARS */ - unblock_input (); update_face_from_frame_parameter (f, Qbackground_color, arg); commit 4bbd1f38ca43c543f27178ba9b2b600d25711c61 Author: Mattias Engdegård Date: Wed Aug 3 14:09:15 2022 +0200 ; * lisp/url/url-util.el (url-display-percentage): simplify diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el index b7fdd73762..de8e674797 100644 --- a/lisp/url/url-util.el +++ b/lisp/url/url-util.el @@ -193,10 +193,9 @@ Will not do anything if `url-show-status' is nil." ;;;###autoload (defun url-display-percentage (fmt _perc &rest args) (when (and url-show-status - (or (null url-current-object) - (not (url-silent url-current-object)))) - (when (not (null fmt)) - (apply 'message fmt args)))) + (not (and url-current-object (url-silent url-current-object))) + fmt) + (apply #'message fmt args))) ;;;###autoload (defun url-percentage (x y) commit 8a9839348fb8762c8843362595f2ca9de60d515c Author: Protesilaos Stavrou Date: Wed Aug 3 14:32:38 2022 +0300 Update modus-themes to their version 2.5.0 * doc/misc/modus-themes.org (Debian 11 Bullseye): Clarify that the Debian package as it is long outdated. (Option for inhibiting theme reload): Fix typo (Option for completion framework aesthetics): Remove reference to obsolete package. (Option for line highlighting): Mention 'lin' package from GNU ELPA. (Option for the headings' overall style): Document support for headings level 0. (Advanced customization): Fix typo. (Override colors): Remove obsolete entries. Add link to new section. (Override colors through blending): Add section with a complete technology demonstration of overriding the color values. (Font configurations for Org and others): Mention the 'fontaine' package from GNU ELPA. (Custom Org emphasis faces): Fix typo. (Full support for packages or face groups, Indirectly covered packages): Update list of supported packages. (Note on vc-annotate-background-mode): Remove note.:(Are these color schemes?): Fix typo. (Acknowledgements): Update acknowledgements. * etc/themes/modus-operandi-theme.el * etc/themes/modus-vivendi-theme.el: Update version header. * etc/themes/modus-themes.el (modus-themes--version): Update version. (modus-themes-special-cold, modus-themes-special-mild) (modus-themes-special-warm, modus-themes-special-calm) (modus-themes-diff-added, modus-themes-diff-changed) (modus-themes-diff-removed, modus-themes-diff-refine-added) (modus-themes-diff-refine-changed, modus-themes-diff-refine-removed) (modus-themes-diff-focus-added, modus-themes-diff-focus-changed) (modus-themes-diff-focus-removed, modus-themes-mark-symbol) (modus-themes-inhibit-reload, modus-themes-mode-line) (modus-themes--paren): Fix doc string warning about quotes. (modus-themes-operandi-color-overrides) (modus-themes-vivendi-color-overrides): Fix ":link" to the Info manual's relevant node. (modus-themes-headings): Add support for headings level 0. (modus-themes-org-agenda): Tweak spacing in the doc string. (modus-themes--syntax-comment): Tweak combination of properties. (modus-themes--list-colors-render, modus-themes-list-colors): Refine how the command works to preview colors in the buffer. (modus-themes-faces): Edit supported faces. (modus-themes-custom-variables): Edit supported variables. Release notes: . diff --git a/doc/misc/modus-themes.org b/doc/misc/modus-themes.org index 943294b626..a80bf6be8a 100644 --- a/doc/misc/modus-themes.org +++ b/doc/misc/modus-themes.org @@ -1,25 +1,23 @@ -#+title: Modus themes for GNU Emacs -#+author: Protesilaos Stavrou -#+email: info@protesilaos.com -#+language: en -#+options: ':t toc:nil author:t email:t num:t -#+startup: content - -#+macro: stable-version 2.4.0 -#+macro: release-date 2022-06-01 -#+macro: development-version 2.5.0-dev -#+macro: file @@texinfo:@file{@@$1@@texinfo:}@@ -#+macro: space @@texinfo:@: @@ -#+macro: kbd @@texinfo:@kbd{@@$1@@texinfo:}@@ - -#+texinfo_filename: modus-themes.info -#+texinfo_dir_category: Emacs misc features -#+texinfo_dir_title: Modus Themes: (modus-themes) -#+texinfo_dir_desc: Elegant, highly legible and customizable themes -#+texinfo_header: @set MAINTAINERSITE @uref{https://protesilaos.com,maintainer webpage} -#+texinfo_header: @set MAINTAINER Protesilaos Stavrou -#+texinfo_header: @set MAINTAINEREMAIL @email{info@protesilaos.com} -#+texinfo_header: @set MAINTAINERCONTACT @uref{mailto:info@protesilaos.com,contact the maintainer} +#+title: Modus themes for GNU Emacs +#+author: Protesilaos Stavrou +#+email: info@protesilaos.com +#+language: en +#+options: ':t toc:nil author:t email:t num:t +#+startup: content +#+macro: stable-version 2.5.0 +#+macro: release-date 2022-08-03 +#+macro: development-version 2.6.0-dev +#+macro: file @@texinfo:@file{@@$1@@texinfo:}@@ +#+macro: space @@texinfo:@: @@ +#+macro: kbd @@texinfo:@kbd{@@$1@@texinfo:}@@ +#+texinfo_filename: modus-themes.info +#+texinfo_dir_category: Emacs misc features +#+texinfo_dir_title: Modus Themes: (modus-themes) +#+texinfo_dir_desc: Elegant, highly legible and customizable themes +#+texinfo_header: @set MAINTAINERSITE @uref{https://protesilaos.com,maintainer webpage} +#+texinfo_header: @set MAINTAINER Protesilaos Stavrou +#+texinfo_header: @set MAINTAINEREMAIL @email{info@protesilaos.com} +#+texinfo_header: @set MAINTAINERCONTACT @uref{mailto:info@protesilaos.com,contact the maintainer} #+texinfo: @insertcopying @@ -198,6 +196,9 @@ sudo apt install elpa-modus-themes They are now ready to be used: [[#h:3f3c3728-1b34-437d-9d0c-b110f5b161a9][Enable and load]]. +NOTE that Debian's package is severely out-of-date as of this writing +2022-07-24 09:57 +0300. + *** GNU Guix :properties: :custom_id: h:a4ca52cd-869f-46a5-9e16-4d9665f5b88e @@ -618,7 +619,7 @@ By default, customizing a theme-related user option through the Custom interfaces or with {{{kbd(M-x customize-set-variable)}}} will not reload the currently active Modus theme. -Enable this behavior by setting this variable to ~nil~. +Enable this behaviour by setting this variable to ~nil~. Regardless of this option, the active theme must be reloaded for changes to user options to take effect ([[#h:3f3c3728-1b34-437d-9d0c-b110f5b161a9][Enable and load]]). @@ -1199,7 +1200,7 @@ Brief: Set the overall style of completion framework interfaces. Symbol: ~modus-themes-completions~ (=alist= type properties) -This affects Company, Corfu, Flx, Helm, Icomplete/Fido, Ido, Ivy, Mct, +This affects Company, Corfu, Flx, Helm, Icomplete/Fido, Ido, Ivy, Orderless, Selectrum, Vertico. The value is an alist that takes the form of a =(key . properties)= combination. Here is a sample, followed by a description of the particularities: @@ -1252,7 +1253,7 @@ accepts is as follows (order is not significant): The ~popup~ key takes the same values as ~selection~. -Apart from specifying each key separately, a fallback list is accepted. +Apart from specfying each key separately, a fallback list is accepted. This is only useful when the desired aesthetic is the same across all keys that are not explicitly referenced. For example, this: @@ -1476,6 +1477,9 @@ with underlines. This style affects several packages that enable ~hl-line-mode~, such as =elfeed=, =notmuch=, and =mu4e=. +[ Also check the =lin= package on GNU ELPA (by the author of the + modus-themes) for a stylistic enhancement to ~hl-line-mode~. ] + ** Option for line numbers :properties: :alt_title: Line numbers @@ -2000,16 +2004,21 @@ Putting it all together, the alist can look like this: :end: #+vindex: modus-themes-headings -Brief: Control the style of headings. This can be particularised for -each level of heading (e.g. Org has eight levels). +Brief: Heading styles with optional list of values for levels 0-8. Symbol: ~modus-themes-headings~ (=alist= type, multiple properties) -This is an alist that accepts a =(key . list-of-values)= combination. The -key is either a number, representing the heading's level or ~t~, which -pertains to the fallback style. The list of values covers symbols that -refer to properties, as described below. Here is a sample, followed by -a presentation of all available properties: +This is an alist that accepts a =(key . list-of-values)= combination. +The key is either a number, representing the heading's level (0-8) or t, +which pertains to the fallback style. + +Level 0 is a special heading: it is used for what counts as a document +title or equivalent, such as the =#+title= construct we find in Org +files. Levels 1-8 are regular headings. + +The list of values covers symbols that refer to properties, as described +below. Here is a complete sample, followed by a presentation of all +available properties: #+begin_src emacs-lisp (setq modus-themes-headings @@ -2162,7 +2171,7 @@ things with precision ([[#h:bf1c82f2-46c7-4eb2-ad00-dd11fdd8b53f][Customization This section is of interest only to users who are prepared to maintain their own local tweaks and who are willing to deal with any possible incompatibilities between versioned releases of the themes. As such, -they are labeled as "do-it-yourself" or "DIY". +they are labelled as "do-it-yourself" or "DIY". ** More accurate colors in terminal emulators :PROPERTIES: @@ -2605,7 +2614,7 @@ this example: Whenever we enter a ~diff-mode~ buffer, we now get a magenta-colored region. -Perhaps you may wish to generalize those findings in to a set of +Perhaps you may wish to generalise those findings in to a set of functions that also accept an arbitrary face. We shall leave the experimentation up to you. @@ -2624,7 +2633,7 @@ contrast on an on-demand basis. One way to achieve this is to design a command that cycles through three distinct levels of intensity, though the following can be adapted to any -kind of cyclic behavior, such as to switch between red, green, and +kind of cyclic behaviour, such as to switch between red, green, and blue. In the following example, we employ the ~modus-themes-color~ function @@ -2848,7 +2857,6 @@ both themes and expands to some more assosiations in the palette: (bg-inactive . "#f6ece5") (bg-region . "#c6bab1") (bg-header . "#ede3e0") - (bg-tab-bar . "#dcd3d3") (bg-tab-active . "#fdf6eb") (bg-tab-inactive . "#c8bab8")) modus-themes-vivendi-color-overrides @@ -2860,7 +2868,6 @@ both themes and expands to some more assosiations in the palette: (bg-inactive . "#1a1e39") (bg-region . "#393a53") (bg-header . "#202037") - (bg-tab-bar . "#262b41") (bg-tab-active . "#120f18") (bg-tab-inactive . "#3a3a5a"))) (setq modus-themes-operandi-color-overrides nil @@ -2879,7 +2886,6 @@ look like this: (bg-inactive . "#e6e6e6") (bg-region . "#b5b5b5") (bg-header . "#e4e4e4") - (bg-tab-bar . "#d1d1d4") (bg-tab-active . "#f5f5f5") (bg-tab-inactive . "#c0c0c0")) #+end_src @@ -2897,6 +2903,9 @@ fall below the minimum 7:1 contrast ratio that governs the design of the themes (the WCAG AAA legibility standard). Alternatively, this can also be done programmatically ([[#h:4589acdc-2505-41fc-9f5e-699cfc45ab00][Override color saturation]]). +The above are expanded into a fully fledged derivative elsewhere in this +document ([[#h:736c0ff5-8c9c-4565-82cf-989e57d07d4a][Override colors completely]]). + For manual interventions it is advised to inspect the source code of ~modus-themes-operandi-colors~ and ~modus-themes-vivendi-colors~ for the inline commentary: it explains what the intended use of each palette @@ -3092,6 +3101,286 @@ Blend background colors with BG-BLEND and foreground colors with FG-BLEND." (modus-themes-tinted-mode 1) #+end_src +** Override colors completely +:PROPERTIES: +:CUSTOM_ID: h:736c0ff5-8c9c-4565-82cf-989e57d07d4a +:END: + +Based on the ideas we have already covered in these sections, the +following code block provides a complete, bespoke pair of color palettes +which override the defaults. They are implemented as a minor mode, as +explained before ([[#h:307d95dd-8dbd-4ece-a543-10ae86f155a6][Override colors]]). We call them "Summertime" for +convenience. + +#+begin_src emacs-lisp +;; Read the relevant blog post: +;; +(define-minor-mode modus-themes-summertime + "Refashion the Modus themes by overriding their colors. + +This is a complete technology demonstration to show how to +manually override the colors of the Modus themes. I have taken +good care of those overrides to make them work as a fully fledged +color scheme that is compatible with all user options of the +Modus themes. + +These overrides are usable by those who (i) like something more +fancy than the comparatively austere looks of the Modus themes, +and (ii) can cope with a lower contrast ratio. + +The overrides are set up as a minor mode, so that the user can +activate the effect on demand. Those who want to load the +overrides at all times can either add them directly to their +configuration or enable `modus-themes-summertime' BEFORE loading +either of the Modus themes (if the overrides are evaluated after +the theme, the theme must be reloaded). + +Remember that all changes to theme-related variables require a +reload of the theme to take effect (the Modus themes have lots of +user options, apart from those overrides). + +The `modus-themes-summertime' IS NOT an official extension to the +Modus themes and DOES NOT comply with its lofty accessibility +standards. It is included in the official manual as guidance for +those who want to make use of the color overriding facility we +provide." + :init-value nil + :global t + (if modus-themes-summertime + (setq modus-themes-operandi-color-overrides + '((bg-main . "#fff0f2") + (bg-dim . "#fbe6ef") + (bg-alt . "#f5dae6") + (bg-hl-line . "#fad8e3") + (bg-active . "#efcadf") + (bg-inactive . "#f3ddef") + (bg-active-accent . "#ffbbef") + (bg-region . "#dfc5d1") + (bg-region-accent . "#efbfef") + (bg-region-accent-subtle . "#ffd6ef") + (bg-header . "#edd3e0") + (bg-tab-active . "#ffeff2") + (bg-tab-inactive . "#f8d3ef") + (bg-tab-inactive-accent . "#ffd9f5") + (bg-tab-inactive-alt . "#e5c0d5") + (bg-tab-inactive-alt-accent . "#f3cce0") + (fg-main . "#543f78") + (fg-dim . "#5f476f") + (fg-alt . "#7f6f99") + (fg-unfocused . "#8f6f9f") + (fg-active . "#563068") + (fg-inactive . "#8a5698") + (fg-docstring . "#5f5fa7") + (fg-comment-yellow . "#a9534f") + (fg-escape-char-construct . "#8b207f") + (fg-escape-char-backslash . "#a06d00") + (bg-special-cold . "#d3e0f4") + (bg-special-faint-cold . "#e0efff") + (bg-special-mild . "#c4ede0") + (bg-special-faint-mild . "#e0f0ea") + (bg-special-warm . "#efd0c4") + (bg-special-faint-warm . "#ffe4da") + (bg-special-calm . "#f0d3ea") + (bg-special-faint-calm . "#fadff9") + (fg-special-cold . "#405fb8") + (fg-special-mild . "#407f74") + (fg-special-warm . "#9d6f4f") + (fg-special-calm . "#af509f") + (bg-completion . "#ffc5e5") + (bg-completion-subtle . "#f7cfef") + (red . "#ed2f44") + (red-alt . "#e0403d") + (red-alt-other . "#e04059") + (red-faint . "#ed4f44") + (red-alt-faint . "#e0603d") + (red-alt-other-faint . "#e06059") + (green . "#217a3c") + (green-alt . "#417a1c") + (green-alt-other . "#006f3c") + (green-faint . "#318a4c") + (green-alt-faint . "#518a2c") + (green-alt-other-faint . "#20885c") + (yellow . "#b06202") + (yellow-alt . "#a95642") + (yellow-alt-other . "#a06f42") + (yellow-faint . "#b07232") + (yellow-alt-faint . "#a96642") + (yellow-alt-other-faint . "#a08042") + (blue . "#275ccf") + (blue-alt . "#475cc0") + (blue-alt-other . "#3340ef") + (blue-faint . "#476ce0") + (blue-alt-faint . "#575ccf") + (blue-alt-other-faint . "#3f60d7") + (magenta . "#bf317f") + (magenta-alt . "#d033c0") + (magenta-alt-other . "#844fe4") + (magenta-faint . "#bf517f") + (magenta-alt-faint . "#d053c0") + (magenta-alt-other-faint . "#846fe4") + (cyan . "#007a9f") + (cyan-alt . "#3f709f") + (cyan-alt-other . "#107f7f") + (cyan-faint . "#108aaf") + (cyan-alt-faint . "#3f80af") + (cyan-alt-other-faint . "#3088af") + (red-active . "#cd2f44") + (green-active . "#116a6c") + (yellow-active . "#993602") + (blue-active . "#475ccf") + (magenta-active . "#7f2ccf") + (cyan-active . "#007a8f") + (red-nuanced-bg . "#ffdbd0") + (red-nuanced-fg . "#ed6f74") + (green-nuanced-bg . "#dcf0dd") + (green-nuanced-fg . "#3f9a4c") + (yellow-nuanced-bg . "#fff3aa") + (yellow-nuanced-fg . "#b47232") + (blue-nuanced-bg . "#e3e3ff") + (blue-nuanced-fg . "#201f6f") + (magenta-nuanced-bg . "#fdd0ff") + (magenta-nuanced-fg . "#c0527f") + (cyan-nuanced-bg . "#dbefff") + (cyan-nuanced-fg . "#0f3f60") + (bg-diff-heading . "#b7cfe0") + (fg-diff-heading . "#041645") + (bg-diff-added . "#d6f0d6") + (fg-diff-added . "#004520") + (bg-diff-changed . "#fcefcf") + (fg-diff-changed . "#524200") + (bg-diff-removed . "#ffe0ef") + (fg-diff-removed . "#891626") + (bg-diff-refine-added . "#84cfa4") + (fg-diff-refine-added . "#002a00") + (bg-diff-refine-changed . "#cccf8f") + (fg-diff-refine-changed . "#302010") + (bg-diff-refine-removed . "#da92b0") + (fg-diff-refine-removed . "#500010") + (bg-diff-focus-added . "#a6e5c6") + (fg-diff-focus-added . "#002c00") + (bg-diff-focus-changed . "#ecdfbf") + (fg-diff-focus-changed . "#392900") + (bg-diff-focus-removed . "#efbbcf") + (fg-diff-focus-removed . "#5a0010")) + modus-themes-vivendi-color-overrides + '((bg-main . "#25152a") + (bg-dim . "#2a1930") + (bg-alt . "#382443") + (bg-hl-line . "#332650") + (bg-active . "#463358") + (bg-inactive . "#2d1f3a") + (bg-active-accent . "#50308f") + (bg-region . "#5d4a67") + (bg-region-accent . "#60509f") + (bg-region-accent-subtle . "#3f285f") + (bg-header . "#3a2543") + (bg-tab-active . "#26162f") + (bg-tab-inactive . "#362647") + (bg-tab-inactive-accent . "#36265a") + (bg-tab-inactive-alt . "#3e2f5a") + (bg-tab-inactive-alt-accent . "#3e2f6f") + (fg-main . "#debfe0") + (fg-dim . "#d0b0da") + (fg-alt . "#ae85af") + (fg-unfocused . "#8e7f9f") + (fg-active . "#cfbfef") + (fg-inactive . "#b0a0c0") + (fg-docstring . "#c8d9f7") + (fg-comment-yellow . "#cf9a70") + (fg-escape-char-construct . "#ff75aa") + (fg-escape-char-backslash . "#dbab40") + (bg-special-cold . "#2a3f58") + (bg-special-faint-cold . "#1e283f") + (bg-special-mild . "#0f3f31") + (bg-special-faint-mild . "#0f281f") + (bg-special-warm . "#44331f") + (bg-special-faint-warm . "#372213") + (bg-special-calm . "#4a314f") + (bg-special-faint-calm . "#3a223f") + (fg-special-cold . "#c0b0ff") + (fg-special-mild . "#bfe0cf") + (fg-special-warm . "#edc0a6") + (fg-special-calm . "#ff9fdf") + (bg-completion . "#502d70") + (bg-completion-subtle . "#451d65") + (red . "#ff5f6f") + (red-alt . "#ff8f6d") + (red-alt-other . "#ff6f9d") + (red-faint . "#ffa0a0") + (red-alt-faint . "#f5aa80") + (red-alt-other-faint . "#ff9fbf") + (green . "#51ca5c") + (green-alt . "#71ca3c") + (green-alt-other . "#51ca9c") + (green-faint . "#78bf78") + (green-alt-faint . "#99b56f") + (green-alt-other-faint . "#88bf99") + (yellow . "#f0b262") + (yellow-alt . "#f0e242") + (yellow-alt-other . "#d0a272") + (yellow-faint . "#d2b580") + (yellow-alt-faint . "#cabf77") + (yellow-alt-other-faint . "#d0ba95") + (blue . "#778cff") + (blue-alt . "#8f90ff") + (blue-alt-other . "#8380ff") + (blue-faint . "#82b0ec") + (blue-alt-faint . "#a0acef") + (blue-alt-other-faint . "#80b2f0") + (magenta . "#ff70cf") + (magenta-alt . "#ff77f0") + (magenta-alt-other . "#ca7fff") + (magenta-faint . "#e0b2d6") + (magenta-alt-faint . "#ef9fe4") + (magenta-alt-other-faint . "#cfa6ff") + (cyan . "#30cacf") + (cyan-alt . "#60caff") + (cyan-alt-other . "#40b79f") + (cyan-faint . "#90c4ed") + (cyan-alt-faint . "#a0bfdf") + (cyan-alt-other-faint . "#a4d0bb") + (red-active . "#ff6059") + (green-active . "#64dc64") + (yellow-active . "#ffac80") + (blue-active . "#4fafff") + (magenta-active . "#cf88ff") + (cyan-active . "#50d3d0") + (red-nuanced-bg . "#440a1f") + (red-nuanced-fg . "#ffcccc") + (green-nuanced-bg . "#002904") + (green-nuanced-fg . "#b8e2b8") + (yellow-nuanced-bg . "#422000") + (yellow-nuanced-fg . "#dfdfb0") + (blue-nuanced-bg . "#1f1f5f") + (blue-nuanced-fg . "#bfd9ff") + (magenta-nuanced-bg . "#431641") + (magenta-nuanced-fg . "#e5cfef") + (cyan-nuanced-bg . "#042f49") + (cyan-nuanced-fg . "#a8e5e5") + (bg-diff-heading . "#304466") + (fg-diff-heading . "#dae7ff") + (bg-diff-added . "#0a383a") + (fg-diff-added . "#94ba94") + (bg-diff-changed . "#2a2000") + (fg-diff-changed . "#b0ba9f") + (bg-diff-removed . "#50163f") + (fg-diff-removed . "#c6adaa") + (bg-diff-refine-added . "#006a46") + (fg-diff-refine-added . "#e0f6e0") + (bg-diff-refine-changed . "#585800") + (fg-diff-refine-changed . "#ffffcc") + (bg-diff-refine-removed . "#952838") + (fg-diff-refine-removed . "#ffd9eb") + (bg-diff-focus-added . "#1d4c3f") + (fg-diff-focus-added . "#b4dfb4") + (bg-diff-focus-changed . "#424200") + (fg-diff-focus-changed . "#d0daaf") + (bg-diff-focus-removed . "#6f0f39") + (fg-diff-focus-removed . "#eebdba"))) + (setq modus-themes-operandi-color-overrides nil + modus-themes-vivendi-color-overrides nil))) +#+end_src + ** Font configurations for Org and others :properties: :custom_id: h:defcf4fc-8fa8-4c29-b12e-7119582cc929 @@ -3117,6 +3406,9 @@ the ~variable-pitch~ (proportional spacing) and ~fixed-pitch~ (monospaced) faces respectively. It may also be convenient to set your main typeface by configuring the ~default~ face the same way. +[ The =fontaine= package on GNU ELPA (by the author of the modus-themes) + is designed to handle this case. ] + Put something like this in your initialization file (also consider reading the doc string of ~set-face-attribute~): @@ -3347,7 +3639,7 @@ it if you plan to control face attributes. :end: #+cindex: Org custom emphasis faces -Org provides the user option ~org-emphasis-alist~ which associates a +Org provides the user option ~org-emphasis-alist~ which assosiates a character with a face, list of faces, or face attributes. The default specification of that variable looks like this: @@ -4165,9 +4457,9 @@ have lots of extensions, so the "full support" may not be 100% true… + calendar and diary + calfw + calibredb -+ centaur-tabs + cfrs + change-log and log-view (such as ~vc-print-log~, ~vc-print-root-log~) ++ chart + cider + circe + citar @@ -4187,13 +4479,12 @@ have lots of extensions, so the "full support" may not be 100% true… + css-mode + csv-mode + ctrlf -+ cursor-flash + custom (what you get with {{{kbd(M-x customize)}}}) + dap-mode -+ dashboard (emacs-dashboard) + deadgrep + debbugs + deft ++ denote + devdocs + dictionary + diff-hl @@ -4210,7 +4501,6 @@ have lots of extensions, so the "full support" may not be 100% true… + diredp (dired+) + display-fill-column-indicator-mode + doom-modeline -+ dynamic-ruler + easy-jekyll + ebdb + ediff @@ -4251,7 +4541,6 @@ have lots of extensions, so the "full support" may not be 100% true… + flyspell + flx + freeze-it -+ frog-menu + focus + fold-this + font-lock (generic syntax highlighting) @@ -4289,6 +4578,7 @@ have lots of extensions, so the "full support" may not be 100% true… + imenu-list + indium + info ++ info+ (info-plus) + info-colors + interaction-log + ioccur @@ -4303,6 +4593,7 @@ have lots of extensions, so the "full support" may not be 100% true… + kaocha-runner + keycast + ledger-mode ++ leerzeichen + line numbers (~display-line-numbers-mode~ and global variant) + lsp-mode + lsp-ui @@ -4314,7 +4605,6 @@ have lots of extensions, so the "full support" may not be 100% true… + marginalia + markdown-mode + markup-faces (~adoc-mode~) -+ mct + mentor + messages + mini-modeline @@ -4341,14 +4631,12 @@ have lots of extensions, so the "full support" may not be 100% true… + org-superstar + org-table-sticky-header + org-tree-slide -+ org-treescope + origami + outline-mode + outline-minor-faces + package (what you get with {{{kbd(M-x list-packages)}}}) + page-break-lines + pandoc-mode -+ paradox + paren-face + pass + pdf-tools @@ -4420,7 +4708,6 @@ have lots of extensions, so the "full support" may not be 100% true… + typescript + undo-tree + vc (vc-dir.el, vc-hooks.el) -+ vc-annotate (the output of {{{kbd(C-x v g)}}}) + vertico + vertico-quick + vimish-fold @@ -4464,9 +4751,11 @@ supported by the themes. + bufler + counsel-notmuch + counsel-org-capture-string ++ dashboard (emacs-dashboard) + define-word + disk-usage + dtache ++ dynamic-ruler + easy-kill + edit-indirect + egerrit @@ -4542,7 +4831,7 @@ The =git-gutter= and =git-gutter-fr= packages default to drawing bitmaps for the indicators they display (e.g. bitmap of a plus sign for added lines). In Doom Emacs, these bitmaps are replaced with contiguous lines which may look nicer, but require a change to the foreground of the -relevant faces to yield the desired color combinations. +relevant faces to yield the desired colour combinations. Since this is Doom-specific, we urge users to apply changes in their local setup. Below is some sample code, based on what we cover at @@ -5181,24 +5470,6 @@ candidates. That style still meets the contrast ratio target of >= 7:1 ANSI color number 1 (red) from the already-supported array of ~ansi-color-names-vector~. -** Note on vc-annotate-background-mode -:properties: -:custom_id: h:5095cbd1-e17a-419c-93e8-951c186362a3 -:end: - -Due to the unique way ~vc-annotate~ ({{{kbd(C-x v g)}}}) applies colors, support -for its background mode (~vc-annotate-background-mode~) is disabled at the -theme level. - -Normally, such a drastic measure should not belong in a theme: assuming -the user's preferences is bad practice. However, it has been deemed -necessary in the interest of preserving color contrast accessibility -while still supporting a useful built-in tool. - -If there actually is a way to avoid such a course of action, without -prejudice to the accessibility standard of this project, then please -report as much or send patches ([[#h:9c3cd842-14b7-44d7-84b2-a5c8bc3fc3b1][Contributing]]). - ** Note on pdf-tools link hints :properties: :custom_id: h:2659d13e-b1a5-416c-9a89-7c3ce3a76574 @@ -5519,7 +5790,7 @@ interface virtually unusable. [[#h:5808be52-361a-4d18-88fd-90129d206f9b][Option for links]]. -Again, one must exercise judgment in order to avoid discrimination, +Again, one must exercise judgement in order to avoid discrimination, where "discrimination" refers to: + The treatment of substantially different magnitudes as if they were of @@ -5535,11 +5806,11 @@ usability beyond matters of color---they would be making a not-so-obvious error of treating different cases as if they were the same. -The Modus themes prioritize "thematic consistency" over abstract harmony +The Modus themes prioritise "thematic consistency" over abstract harmony or regularity among their applicable colors. In concrete terms, we do not claim that, say, our yellows are the best complements for our blues because we generally avoid using complementary colors side-by-side, so -it is wrong to optimize for a decontextualised blue+yellow combination. +it is wrong to optimise for a decontextualised blue+yellow combination. Not to imply that our colors do not work well together because they do, just to clarify that consistency of context is what themes must strive for, and that requires widening the scope of the design beyond the @@ -5758,22 +6029,22 @@ The Modus themes are a collective effort. Every bit of work matters. Gautier Ponsinet, Gerry Agbobada, Gianluca Recchia, Gonçalo Marrafa, Guilherme Semente, Gustavo Barros, Hörmetjan Yiltiz, Ilja Kocken, Iris Garcia, Ivan Popovych, Jeremy Friesen, Jerry Zhang, Johannes Grødem, - John Haman, Jorge Morais, Joshua O'Connor, Julio C. Villasante, Kenta - Usami, Kevin Fleming, Kévin Le Gouguec, Kostadin Ninev, Len Trigg, - Lennart C. Karssen, Magne Hov, Manuel Uberti, Mark Bestley, Mark - Burton, Markus Beppler, Mauro Aranda, Maxime Tréca, Michael - Goldenberg, Morgan Smith, Morgan Willcock, Murilo Pereira, Nicky van - Foreest, Nicolas De Jaeghere, Paul Poloskov, Pengji Zhang, Pete - Kazmier, Peter Wu, Philip Kaludercic, Pierre Téchoueyres, Przemysław - Kryger, Robert Hepple, Roman Rudakov, Ryan Phillips, Rytis Paškauskas, - Rudolf Adamkovič, Sam Kleinman, Samuel Culpepper, Saša Janiška, - Shreyas Ragavan, Simon Pugnet, Tassilo Horn, Thibaut Verron, Thomas - Heartman, Togan Muftuoglu, Tony Zorman, Trey Merkley, Tomasz - Hołubowicz, Toon Claes, Uri Sharf, Utkarsh Singh, Vincent Foley. As - well as users: Ben, CsBigDataHub1, Emacs Contrib, Eugene, Fourchaux, - Fredrik, Moesasji, Nick, TheBlob42, Trey, bepolymathe, bit9tream, - derek-upham, doolio, fleimgruber, gitrj95, iSeeU, jixiuf, okamsn, - pRot0ta1p. + John Haman, Jonas Collberg, Jorge Morais, Joshua O'Connor, Julio + C. Villasante, Kenta Usami, Kevin Fleming, Kévin Le Gouguec, Kostadin + Ninev, Len Trigg, Lennart C. Karssen, Magne Hov, Manuel Uberti, Mark + Bestley, Mark Burton, Markus Beppler, Matt Armstrong, Mauro Aranda, + Maxime Tréca, Michael Goldenberg, Morgan Smith, Morgan Willcock, + Murilo Pereira, Nicky van Foreest, Nicolas De Jaeghere, Paul Poloskov, + Pengji Zhang, Pete Kazmier, Peter Wu, Philip Kaludercic, Pierre + Téchoueyres, Przemysław Kryger, Robert Hepple, Roman Rudakov, Ryan + Phillips, Rytis Paškauskas, Rudolf Adamkovič, Sam Kleinman, Samuel + Culpepper, Saša Janiška, Shreyas Ragavan, Simon Pugnet, Tassilo Horn, + Thibaut Verron, Thomas Heartman, Togan Muftuoglu, Tony Zorman, Trey + Merkley, Tomasz Hołubowicz, Toon Claes, Uri Sharf, Utkarsh Singh, + Vincent Foley. As well as users: Ben, CsBigDataHub1, Emacs Contrib, + Eugene, Fourchaux, Fredrik, Moesasji, Nick, Summer Emacs, TheBlob42, + Trey, bepolymathe, bit9tream, derek-upham, doolio, fleimgruber, + gitrj95, iSeeU, jixiuf, okamsn, pRot0ta1p. + Packaging :: Basil L.{{{space()}}} Contovounesios, Eli Zaretskii, Glenn Morris, Mauro Aranda, Richard Stallman, Stefan Kangas (core @@ -5784,10 +6055,12 @@ The Modus themes are a collective effort. Every bit of work matters. + Inspiration for certain features :: Bozhidar Batsov (zenburn-theme), Fabrice Niessen (leuven-theme). -Special thanks (from A-Z) to Gustavo Barros, Manuel Uberti, Nicolas De -Jaeghere, and Omar Antolín Camarena for their long time contributions -and insightful commentary on key aspects of the themes' design and/or -aspects of their functionality. +Special thanks (from A-Z) to Daniel Mendler, Gustavo Barros, Manuel +Uberti, Nicolas De Jaeghere, and Omar Antolín Camarena for their long +time contributions and insightful commentary on key aspects of the +themes' design and/or aspects of their functionality. + +All errors are my own. * Other notes about the project :properties: diff --git a/etc/themes/modus-operandi-theme.el b/etc/themes/modus-operandi-theme.el index 646504636f..20af99df94 100644 --- a/etc/themes/modus-operandi-theme.el +++ b/etc/themes/modus-operandi-theme.el @@ -3,8 +3,10 @@ ;; Copyright (C) 2019-2022 Free Software Foundation, Inc. ;; Author: Protesilaos Stavrou +;; Maintainer: Modus-Themes Development <~protesilaos/modus-themes@lists.sr.ht> ;; URL: https://git.sr.ht/~protesilaos/modus-themes -;; Version: 2.4.1 +;; Mailing-List: https://lists.sr.ht/~protesilaos/modus-themes +;; Version: 2.5.0 ;; Package-Requires: ((emacs "27.1")) ;; Keywords: faces, theme, accessibility diff --git a/etc/themes/modus-themes.el b/etc/themes/modus-themes.el index c543e7ec43..54e5e465b1 100644 --- a/etc/themes/modus-themes.el +++ b/etc/themes/modus-themes.el @@ -3,9 +3,10 @@ ;; Copyright (C) 2019-2022 Free Software Foundation, Inc. ;; Author: Protesilaos Stavrou +;; Maintainer: Modus-Themes Development <~protesilaos/modus-themes@lists.sr.ht> ;; URL: https://git.sr.ht/~protesilaos/modus-themes -;; Mailing list: https://lists.sr.ht/~protesilaos/modus-themes -;; Version: 2.4.1 +;; Mailing-List: https://lists.sr.ht/~protesilaos/modus-themes +;; Version: 2.5.0 ;; Package-Requires: ((emacs "27.1")) ;; Keywords: faces, theme, accessibility @@ -108,7 +109,7 @@ cover the blue-cyan-magenta side of the spectrum." :prefix "modus-themes-" :tag "Modus Themes Faces") -(defvar modus-themes--version "2.5.0-dev" +(defvar modus-themes--version "2.5.0" "Current version of the Modus themes. The version either is the last tagged release, such as '2.4.0', @@ -954,7 +955,7 @@ The actual styling of the face is done by `modus-themes-faces'." :group 'modus-themes-faces) (defface modus-themes-special-cold nil - "Combines the 'special cold' background and foreground values. + "Combines the special cold background and foreground values. This is intended for cases when a neutral gray background is not suitable and where a combination of more saturated colors would not be appropriate. @@ -963,7 +964,7 @@ The actual styling of the face is done by `modus-themes-faces'." :group 'modus-themes-faces) (defface modus-themes-special-mild nil - "Combines the 'special mild' background and foreground values. + "Combines the special mild background and foreground values. This is intended for cases when a neutral gray background is not suitable and where a combination of more saturated colors would not be appropriate. @@ -972,7 +973,7 @@ The actual styling of the face is done by `modus-themes-faces'." :group 'modus-themes-faces) (defface modus-themes-special-warm nil - "Combines the 'special warm' background and foreground values. + "Combines the special warm background and foreground values. This is intended for cases when a neutral gray background is not suitable and where a combination of more saturated colors would not be appropriate. @@ -981,7 +982,7 @@ The actual styling of the face is done by `modus-themes-faces'." :group 'modus-themes-faces) (defface modus-themes-special-calm nil - "Combines the 'special calm' background and foreground values. + "Combines the special calm background and foreground values. This is intended for cases when a neutral gray background is not suitable and where a combination of more saturated colors would not be appropriate. @@ -990,7 +991,7 @@ The actual styling of the face is done by `modus-themes-faces'." :group 'modus-themes-faces) (defface modus-themes-diff-added nil - "Combines green colors for the 'added' state in diffs. + "Combines green colors for the added state in diffs. The applied colors are contingent on the value assigned to `modus-themes-diffs'. @@ -998,7 +999,7 @@ The actual styling of the face is done by `modus-themes-faces'." :group 'modus-themes-faces) (defface modus-themes-diff-changed nil - "Combines yellow colors for the 'changed' state in diffs. + "Combines yellow colors for the changed state in diffs. The applied colors are contingent on the value assigned to `modus-themes-diffs'. @@ -1006,7 +1007,7 @@ The actual styling of the face is done by `modus-themes-faces'." :group 'modus-themes-faces) (defface modus-themes-diff-removed nil - "Combines red colors for the 'removed' state in diffs. + "Combines red colors for the removed state in diffs. The applied colors are contingent on the value assigned to `modus-themes-diffs'. @@ -1014,7 +1015,7 @@ The actual styling of the face is done by `modus-themes-faces'." :group 'modus-themes-faces) (defface modus-themes-diff-refine-added nil - "Combines green colors for word-wise 'added' state in diffs. + "Combines green colors for word-wise added state in diffs. The applied colors are contingent on the value assigned to `modus-themes-diffs'. @@ -1022,7 +1023,7 @@ The actual styling of the face is done by `modus-themes-faces'." :group 'modus-themes-faces) (defface modus-themes-diff-refine-changed nil - "Combines yellow colors for word-wise 'changed' state in diffs. + "Combines yellow colors for word-wise changed state in diffs. The applied colors are contingent on the value assigned to `modus-themes-diffs'. @@ -1030,7 +1031,7 @@ The actual styling of the face is done by `modus-themes-faces'." :group 'modus-themes-faces) (defface modus-themes-diff-refine-removed nil - "Combines red colors for word-wise 'removed' state in diffs. + "Combines red colors for word-wise removed state in diffs. The applied colors are contingent on the value assigned to `modus-themes-diffs'. @@ -1038,7 +1039,7 @@ The actual styling of the face is done by `modus-themes-faces'." :group 'modus-themes-faces) (defface modus-themes-diff-focus-added nil - "Combines green colors for the focused 'added' state in diffs. + "Combines green colors for the focused added state in diffs. The applied colors are contingent on the value assigned to `modus-themes-diffs'. @@ -1046,7 +1047,7 @@ The actual styling of the face is done by `modus-themes-faces'." :group 'modus-themes-faces) (defface modus-themes-diff-focus-changed nil - "Combines yellow colors for the focused 'changed' state in. + "Combines yellow colors for the focused changed state in diffs. The applied colors are contingent on the value assigned to `modus-themes-diffs'. @@ -1054,7 +1055,7 @@ The actual styling of the face is done by `modus-themes-faces'." :group 'modus-themes-faces) (defface modus-themes-diff-focus-removed nil - "Combines red colors for the focused 'removed' state in diffs. + "Combines red colors for the focused removed state in diffs. The applied colors are contingent on the value assigned to `modus-themes-diffs'. @@ -1099,6 +1100,14 @@ The actual styling of the face is done by `modus-themes-faces'." "Applies a blue color and other styles for mark indicators. This is intended for use in modes such as Dired, Ibuffer, Proced. +The actual styling of the face is done by `modus-themes-faces'." + :group 'modus-themes-faces) + +(defface modus-themes-heading-0 nil + "General purpose face for use as the document's title. +The exact attributes assigned to this face are contingent on the +values assigned to the `modus-themes-headings' variable. + The actual styling of the face is done by `modus-themes-faces'." :group 'modus-themes-faces) @@ -1426,7 +1435,7 @@ By default, customizing a theme-related user option through the Custom interfaces or with `customize-set-variable' will not reload the currently active Modus theme. -Enable this behavior by setting this variable to nil." +Enable this behaviour by setting this variable to nil." :group 'modus-themes :package-version '(modus-themes . "1.5.0") :version "28.1" @@ -1459,7 +1468,7 @@ For form, see `modus-themes-operandi-colors'." :type '(alist :key-type symbol :value-type color) :set #'modus-themes--set-option :initialize #'custom-initialize-default - :link '(info-link "(modus-themes) Override colors (DIY)")) + :link '(info-link "(modus-themes) Override colors")) (defcustom modus-themes-vivendi-color-overrides nil "Override colors in the Modus Vivendi palette. @@ -1471,7 +1480,7 @@ For form, see `modus-themes-vivendi-colors'." :type '(alist :key-type symbol :value-type color) :set #'modus-themes--set-option :initialize #'custom-initialize-default - :link '(info-link "(modus-themes) Override colors (DIY)")) + :link '(info-link "(modus-themes) Override colors")) ;; The byte compiler complains when a defcustom isn't a top level form (let* ((names (mapcar (lambda (pair) @@ -1576,14 +1585,19 @@ speaking, is not limited to mouse usage." This is a helper variable intended for internal use.") (defcustom modus-themes-headings nil - "Heading styles with optional list of values for levels 1-8. + "Heading styles with optional list of values for levels 0-8. This is an alist that accepts a (key . list-of-values) combination. The key is either a number, representing the -heading's level or t, which pertains to the fallback style. The -list of values covers symbols that refer to properties, as -described below. Here is a sample, followed by a presentation of -all available properties: +heading's level (0-8) or t, which pertains to the fallback style. + +Level 0 is a special heading: it is used for what counts as a +document title or equivalent, such as the #+title construct we +find in Org files. Levels 1-8 are regular headings. + +The list of values covers symbols that refer to properties, as +described below. Here is a complete sample, followed by a +presentation of all available properties: (setq modus-themes-headings (quote ((1 . (background overline variable-pitch 1.5)) @@ -1668,12 +1682,12 @@ For Org users, the extent of the heading depends on the variable and `background' properties. Depending on the version of Org, there may be others, such as `org-fontify-done-headline'." :group 'modus-themes - :package-version '(modus-themes . "2.3.0") + :package-version '(modus-themes . "2.5.0") :version "29.1" :type `(alist :options ,(mapcar (lambda (el) (list el modus-themes--headings-choice)) - '(1 2 3 4 5 6 7 8 t)) + '(0 1 2 3 4 5 6 7 8 t)) :key-type symbol :value-type ,modus-themes--headings-choice) :set #'modus-themes--set-option @@ -1827,6 +1841,7 @@ value are passed as a symbol. Those are: yellow, green, blue, in tinted and shaded versions. They cover the full set of information provided by the `org-habit' consistency graph. + - `simplified' is like the default except that it removes the dichotomy between current and future variants by applying uniform color-coded values. It applies a total of four colors: @@ -1835,15 +1850,17 @@ value are passed as a symbol. Those are: the default. The intent is to shift focus towards the distinction between the four states of a habit task, rather than each state's present/future outlook. + - `traffic-light' further reduces the available colors to red, yellow, and green. As in `simplified', present and future - variants appear uniformly, but differently from it, the 'clear' + variants appear uniformly, but differently from it, the CLEAR state is rendered in a green hue, instead of the original blue. This is meant to capture the use-case where a habit task being - \"too early\" is less important than it being \"too late\". - The difference between ready and clear states is attenuated by + too early is less important than it being too late. The + difference between READY and CLEAR states is attenuated by painting both of them using shades of green. This option thus highlights the alert and overdue states. + - When `modus-themes-deuteranopia' is non-nil the exact style of the habit graph adapts to the needs of users with red-green color deficiency by substituting every instance of green with @@ -2060,7 +2077,7 @@ active mode line. The inactive mode lines remain two-dimensional and are toned down a bit, relative to the default style. The `moody' property optimizes the mode line for use with the -library of the same name (hereinafter referred to as 'Moody'). +library of the same name (hereinafter referred to as Moody). In practice, it removes the box effect and replaces it with underline and overline properties. It also tones down the inactive mode lines. Despite its intended purpose, this option @@ -3113,10 +3130,10 @@ theme's fallback text color." (defun modus-themes--paren (normalbg intensebg) "Conditional use of intense colors for matching parentheses. -NORMALBG should be the special palette color 'bg-paren-match' or +NORMALBG should be the special palette color bg-paren-match or something similar. INTENSEBG must be easier to discern next to other backgrounds, such as the special palette color -'bg-paren-match-intense'." +bg-paren-match-intense." (let ((properties (modus-themes--list-or-warn 'modus-themes-paren-match))) (list :inherit (if (memq 'bold properties) @@ -3197,7 +3214,7 @@ an alternative to the default value." ((and (memq 'alt-syntax properties) (memq 'yellow-comments properties) (not (memq 'green-strings properties))) - (or faint-yellow yellow)) + yellow) ((memq 'yellow-comments properties) yellow) ((memq 'faint properties) @@ -3382,8 +3399,8 @@ clearly distinguishes past, present, future tasks." (defun modus-themes--agenda-habit (default traffic simple &optional default-d traffic-d simple-d) "Specify background values for `modus-themes-org-agenda' habits. DEFAULT is the original foregrounc color. TRAFFIC is to be used -when the 'traffic-light' style is applied, while SIMPLE -corresponds to the 'simplified style'. +when the traffic-light style is applied, while SIMPLE corresponds +to the simplified style. Optional DEFAULT-D, TRAFFIC-D, SIMPLE-D are alternatives to the main colors, meant for dopia when `modus-themes-deuteranopia' is @@ -3880,32 +3897,44 @@ pressed button style, else the released button." ;;;; Utilities for DIY users -;;;;; List colors (a respin of M-x list-colors-display) +;;;;; List colors (a variant of M-x list-colors-display) -(defun modus-themes--list-colors-render (buffer palette) - "Render colors in BUFFER from PALETTE. +(defun modus-themes--list-colors-render (buffer theme &rest _) + "Render colors in BUFFER from THEME. Routine for `modus-themes-list-colors'." - (with-help-window buffer - (with-current-buffer standard-output - (erase-buffer) - ;; We need this to properly render the first line. - (insert " ") - (dolist (cell palette) - (let* ((name (car cell)) - (color (cdr cell)) - (fg (readable-foreground-color color)) - (pad (make-string 5 ?\s))) - (let ((old-point (point))) - (insert (format "%s %s" color pad)) - (put-text-property old-point (point) 'face `( :foreground ,color))) - (let ((old-point (point))) - (insert (format " %s %s %s\n" color pad name)) - (put-text-property old-point (point) - 'face `( :background ,color - :foreground ,fg - :extend t))) - ;; We need this to properly render the last line. - (insert " ")))))) + (let ((palette (seq-uniq (modus-themes--palette theme) + (lambda (x y) + (eq (car x) (car y))))) + (current-buffer buffer) + (current-theme theme)) + (with-help-window buffer + (with-current-buffer standard-output + (erase-buffer) + (when (<= (display-color-cells) 256) + (insert (concat "Your display terminal may not render all color previews!\n" + "It seems to only support <= 256 colors.\n\n")) + (put-text-property (point-min) (point) 'face 'warning)) + ;; We need this to properly render the first line. + (insert " ") + (dolist (cell palette) + (let* ((name (car cell)) + (color (cdr cell)) + (fg (readable-foreground-color color)) + (pad (make-string 5 ?\s))) + (let ((old-point (point))) + (insert (format "%s %s" color pad)) + (put-text-property old-point (point) 'face `( :foreground ,color))) + (let ((old-point (point))) + (insert (format " %s %s %s\n" color pad name)) + (put-text-property old-point (point) + 'face `( :background ,color + :foreground ,fg + :extend t))) + ;; We need this to properly render the last line. + (insert " "))) + (setq-local revert-buffer-function + (lambda (_ignore-auto _noconfirm) + (modus-themes--list-colors-render current-buffer current-theme))))))) (defvar modus-themes--list-colors-prompt-history '() "Minibuffer history for `modus-themes--list-colors-prompt'.") @@ -3921,15 +3950,10 @@ Helper function for `modus-themes-list-colors'." (defun modus-themes-list-colors (theme) "Preview palette of the Modus THEME of choice." - (interactive - (list (intern (modus-themes--list-colors-prompt)))) - (let ((palette (pcase theme - ('modus-operandi modus-themes-operandi-colors) - ('modus-vivendi modus-themes-vivendi-colors) - (_ (user-error "`%s' is not a Modus theme" theme))))) - (modus-themes--list-colors-render - (format "*%s-list-colors*" theme) - palette))) + (interactive (list (intern (modus-themes--list-colors-prompt)))) + (modus-themes--list-colors-render + (format "*%s-list-colors*" theme) + theme)) (defun modus-themes-list-colors-current () "Call `modus-themes-list-colors' for the current Modus theme." @@ -4209,6 +4233,10 @@ by virtue of calling either of `modus-themes-load-operandi' and `(modus-themes-mark-symbol ((,class :inherit bold :foreground ,blue-alt))) ;;;;; heading levels ;; styles for regular headings used in Org, Markdown, Info, etc. + `(modus-themes-heading-0 + ((,class ,@(modus-themes--heading + 0 cyan-alt-other blue-alt + cyan-nuanced-bg bg-alt bg-region)))) `(modus-themes-heading-1 ((,class ,@(modus-themes--heading 1 fg-main magenta-alt-other @@ -4265,12 +4293,8 @@ by virtue of calling either of `modus-themes-load-operandi' and ((,class ,@(modus-themes--markup magenta-alt magenta-intense bg-alt bg-special-faint-calm)))) ;;;;; search - `(modus-themes-search-success ((,class :inherit ,@(modus-themes--deuteran - 'modus-themes-intense-blue - 'modus-themes-intense-green)))) - `(modus-themes-search-success-lazy ((,class :inherit ,@(modus-themes--deuteran - 'modus-themes-special-mild - 'modus-themes-refine-cyan)))) + `(modus-themes-search-success ((,class :inherit modus-themes-intense-yellow))) + `(modus-themes-search-success-lazy ((,class :inherit modus-themes-subtle-cyan))) `(modus-themes-search-success-modeline ((,class :foreground ,@(modus-themes--deuteran blue-active green-active)))) @@ -4330,7 +4354,8 @@ by virtue of calling either of `modus-themes-load-operandi' and cyan-alt-other blue-alt-other fg-alt cyan-nuanced-bg blue-refine-bg fg-main bg-alt bg-active)))) - `(modus-themes-reset-hard ((,class :inherit (fixed-pitch modus-themes-reset-soft)))) + `(modus-themes-reset-hard ((,class :inherit (fixed-pitch modus-themes-reset-soft) + :family ,(face-attribute 'default :family)))) `(modus-themes-reset-soft ((,class :background ,bg-main :foreground ,fg-main :weight normal :slant normal :strike-through nil :box nil :underline nil :overline nil :extend nil))) @@ -4350,6 +4375,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(comint-highlight-input ((,class :inherit bold))) `(comint-highlight-prompt ((,class :inherit modus-themes-prompt))) `(confusingly-reordered ((,class :inherit modus-themes-lang-error))) + `(edmacro-label ((,class :inherit bold :foreground ,cyan))) `(elisp-shorthand-font-lock-face ((,class :inherit font-lock-variable-name-face))) `(error ((,class :inherit bold :foreground ,red))) `(escape-glyph ((,class :foreground ,fg-escape-char-construct))) @@ -4369,8 +4395,8 @@ by virtue of calling either of `modus-themes-load-operandi' and `(mm-command-output ((,class :foreground ,red-alt-other))) `(mm-uu-extract ((,class :background ,bg-dim :foreground ,fg-special-mild))) `(next-error ((,class :inherit modus-themes-subtle-red :extend t))) - `(pgtk-im-0 ((,class :inherit modus-themes-fringe-blue :underline t))) - `(rectangle-preview ((,class :background ,bg-special-faint-warm :foreground ,fg-special-warm))) + `(pgtk-im-0 ((,class :inherit modus-themes-refine-cyan))) + `(rectangle-preview ((,class :inherit modus-themes-special-warm))) `(region ((,class ,@(modus-themes--region bg-region fg-main bg-hl-alt-intense bg-region-accent bg-region-accent-subtle)))) @@ -4477,8 +4503,8 @@ by virtue of calling either of `modus-themes-load-operandi' and `(anzu-match-3 ((,class :inherit modus-themes-subtle-yellow))) `(anzu-mode-line ((,class :inherit (bold modus-themes-search-success-modeline)))) `(anzu-mode-line-no-match ((,class :inherit bold :foreground ,red-active))) - `(anzu-replace-highlight ((,class :inherit modus-themes-refine-yellow :underline t))) - `(anzu-replace-to ((,class :inherit (modus-themes-search-success bold)))) + `(anzu-replace-highlight ((,class :inherit modus-themes-refine-red :underline t))) + `(anzu-replace-to ((,class :inherit modus-themes-search-success))) ;;;;; apropos `(apropos-button ((,class :foreground ,magenta-alt-other))) `(apropos-function-button ((,class :foreground ,magenta))) @@ -4631,18 +4657,6 @@ by virtue of calling either of `modus-themes-load-operandi' and `(calibredb-mark-face ((,class :inherit modus-themes-mark-sel))) `(calibredb-size-face (( ))) `(calibredb-tag-face ((,class :foreground ,magenta-alt-faint))) -;;;;; centaur-tabs - `(centaur-tabs-active-bar-face ((,class :background ,blue-active))) - `(centaur-tabs-close-mouse-face ((,class :inherit bold :foreground ,red-active :underline t))) - `(centaur-tabs-close-selected ((,class :inherit centaur-tabs-selected))) - `(centaur-tabs-close-unselected ((,class :inherit centaur-tabs-unselected))) - `(centaur-tabs-modified-marker-selected ((,class :inherit centaur-tabs-selected))) - `(centaur-tabs-modified-marker-unselected ((,class :inherit centaur-tabs-unselected))) - `(centaur-tabs-default ((,class :background ,bg-main))) - `(centaur-tabs-selected ((,class :inherit modus-themes-tab-active))) - `(centaur-tabs-selected-modified ((,class :inherit (italic centaur-tabs-selected)))) - `(centaur-tabs-unselected ((,class :inherit modus-themes-tab-inactive))) - `(centaur-tabs-unselected-modified ((,class :inherit (italic centaur-tabs-unselected)))) ;;;;; cfrs `(cfrs-border-color ((,class :background ,fg-window-divider-inner))) ;;;;; change-log and log-view (`vc-print-log' and `vc-print-root-log') @@ -4737,7 +4751,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(company-tooltip-scrollbar-thumb ((,class :background ,fg-active))) `(company-tooltip-scrollbar-track ((,class :background ,bg-active))) `(company-tooltip-search ((,class :inherit (modus-themes-search-success-lazy bold)))) - `(company-tooltip-search-selection ((,class :inherit (modus-themes-search-success bold) :underline t))) + `(company-tooltip-search-selection ((,class :inherit modus-themes-search-success :underline t))) `(company-tooltip-selection ((,class :inherit modus-themes-completion-selected-popup))) ;;;;; company-posframe `(company-posframe-active-backend-name ((,class :inherit bold :background ,bg-active :foreground ,blue-active))) @@ -4815,11 +4829,9 @@ by virtue of calling either of `modus-themes-load-operandi' and ;;;;; csv-mode `(csv-separator-face ((,class :foreground ,red-intense))) ;;;;; ctrlf - `(ctrlf-highlight-active ((,class :inherit (modus-themes-search-success bold)))) + `(ctrlf-highlight-active ((,class :inherit modus-themes-search-success))) `(ctrlf-highlight-line ((,class :inherit modus-themes-hl-line))) `(ctrlf-highlight-passive ((,class :inherit modus-themes-search-success-lazy))) -;;;;; cursor-flash - `(cursor-flash-face ((,class :inherit modus-themes-intense-blue))) ;;;;; custom (M-x customize) `(custom-button ((,class :inherit modus-themes-box-button))) `(custom-button-mouse ((,class :inherit (highlight custom-button)))) @@ -4852,12 +4864,6 @@ by virtue of calling either of `modus-themes-load-operandi' and `(dap-ui-sessions-stack-frame-face ((,class :inherit bold :foreground ,magenta-alt))) `(dap-ui-sessions-terminated-active-face ((,class :inherit bold :foreground ,fg-alt))) `(dap-ui-sessions-terminated-face ((,class :inherit shadow))) -;;;;; dashboard (emacs-dashboard) - `(dashboard-banner-logo-title ((,class :inherit bold :foreground ,fg-special-cold))) - `(dashboard-footer ((,class :inherit bold :foreground ,fg-special-mild))) - `(dashboard-heading ((,class :inherit bold :foreground ,fg-special-warm))) - `(dashboard-navigator ((,class :foreground ,cyan-alt-other))) - `(dashboard-text-banner ((,class :foreground ,fg-dim))) ;;;;; deadgrep `(deadgrep-filename-face ((,class :inherit bold :foreground ,fg-special-cold))) `(deadgrep-match-face ((,class :inherit modus-themes-special-calm))) @@ -4878,13 +4884,15 @@ by virtue of calling either of `modus-themes-load-operandi' and `(debbugs-gnu-stale-5 ((,class :foreground ,red-alt))) `(debbugs-gnu-tagged ((,class :foreground ,magenta-alt))) ;;;;; deft - `(deft-filter-string-error-face ((,class :inherit modus-themes-refine-red))) - `(deft-filter-string-face ((,class :foreground ,green-intense))) - `(deft-header-face ((,class :inherit bold :foreground ,fg-special-warm))) - `(deft-separator-face ((,class :inherit shadow))) + `(deft-filter-string-face ((,class :inherit bold :foreground ,blue))) + `(deft-header-face ((,class :foreground ,fg-special-warm))) + `(deft-separator-face ((,class :foreground "gray50"))) `(deft-summary-face ((,class :inherit (shadow modus-themes-slant)))) - `(deft-time-face ((,class :foreground ,fg-special-cold))) - `(deft-title-face ((,class :inherit bold :foreground ,fg-main))) + `(deft-time-face ((,class :foreground ,cyan))) + `(deft-title-face ((,class :inherit bold))) +;;;;; denote + `(denote-faces-date ((,class :foreground ,cyan))) + `(denote-faces-keywords ((,class :inherit modus-themes-bold :foreground ,magenta-alt))) ;;;;; devdocs `(devdocs-code-block ((,class :inherit modus-themes-fixed-pitch :background ,bg-dim :extend t))) ;;;;; dictionary @@ -4962,7 +4970,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(dired-git-branch-else ((,class :inherit bold :foreground ,magenta-alt))) `(dired-git-branch-master ((,class :inherit bold :foreground ,magenta-alt-other))) ;;;;; dired-git-info - `(dgi-commit-message-face ((,class :foreground ,fg-special-mild))) + `(dgi-commit-message-face ((,class :foreground ,cyan-alt-other))) ;;;;; dired-narrow `(dired-narrow-blink ((,class :inherit (modus-themes-subtle-cyan bold)))) ;;;;; dired-subtree @@ -5072,11 +5080,8 @@ by virtue of calling either of `modus-themes-load-operandi' and `(doom-modeline-unread-number ((,class :inherit italic :foreground ,fg-active))) `(doom-modeline-urgent ((,class :inherit bold :foreground ,red-active))) `(doom-modeline-warning ((,class :inherit bold :foreground ,yellow-active))) -;;;;; dynamic-ruler - `(dynamic-ruler-negative-face ((,class :inherit modus-themes-intense-neutral))) - `(dynamic-ruler-positive-face ((,class :inherit modus-themes-intense-yellow))) ;;;;; easy-jekyll - `(easy-jekyll-help-face ((,class :background ,bg-dim :foreground ,cyan-alt-other))) + `(easy-jekyll-help-face ((,class :background ,bg-dim :foreground ,blue-alt-other))) ;;;;; ebdb `(ebdb-address-default ((,class :foreground ,fg-special-calm))) `(ebdb-defunct ((,class :inherit shadow))) @@ -5318,7 +5323,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(evil-ex-lazy-highlight ((,class :inherit modus-themes-search-success-lazy))) `(evil-ex-search ((,class :inherit modus-themes-search-success))) `(evil-ex-substitute-matches ((,class :inherit modus-themes-refine-yellow :underline t))) - `(evil-ex-substitute-replacement ((,class :inherit (modus-themes-search-success bold)))) + `(evil-ex-substitute-replacement ((,class :inherit modus-themes-search-success))) ;;;;; evil-goggles `(evil-goggles-change-face ((,class :inherit modus-themes-refine-yellow))) `(evil-goggles-commentary-face ((,class :inherit (modus-themes-subtle-neutral modus-themes-slant)))) @@ -5403,13 +5408,6 @@ by virtue of calling either of `modus-themes-load-operandi' and `(flx-highlight-face ((,class :inherit modus-themes-completion-match-0))) ;;;;; freeze-it `(freeze-it-show ((,class :background ,bg-dim :foreground ,fg-special-warm))) -;;;;; frog-menu - `(frog-menu-action-keybinding-face ((,class :inherit modus-themes-key-binding))) - `(frog-menu-actions-face ((,class :foreground ,magenta))) - `(frog-menu-border ((,class :background ,bg-active))) - `(frog-menu-candidates-face ((,class :foreground ,fg-main))) - `(frog-menu-posframe-background-face ((,class :background ,bg-dim))) - `(frog-menu-prompt-face ((,class :foreground ,cyan))) ;;;;; focus `(focus-unfocused ((,class :foreground ,fg-unfocused))) ;;;;; fold-this @@ -5467,7 +5465,7 @@ by virtue of calling either of `modus-themes-load-operandi' and blue-alt blue-alt-faint)))) `(font-lock-warning-face ((,class :inherit modus-themes-bold ,@(modus-themes--syntax-foreground - yellow-active yellow-alt-faint)))) + yellow yellow-alt-faint)))) ;;;;; forge `(forge-post-author ((,class :inherit bold :foreground ,fg-main))) `(forge-post-date ((,class :foreground ,fg-special-cold))) @@ -5715,18 +5713,20 @@ by virtue of calling either of `modus-themes-load-operandi' and ;;;;; helpful `(helpful-heading ((,class :inherit modus-themes-heading-1))) ;;;;; highlight region or ad-hoc regexp - `(hi-aquamarine ((,class :background ,cyan-subtle-bg :foreground ,fg-main))) - `(hi-black-b ((,class :inherit bold :background ,fg-main :foreground ,bg-main))) - `(hi-black-hb ((,class :inherit bold :background ,fg-alt :foreground ,bg-main))) - `(hi-blue ((,class :background ,blue-subtle-bg :foreground ,fg-main))) + ;; HACK 2022-06-23: The :inverse-video prevents hl-line-mode from + ;; overriding the background. Such an override really defeats the + ;; purpose of setting those highlights. + `(hi-aquamarine ((,class :background ,bg-main :foreground ,cyan :inverse-video t))) + `(hi-black-b ((,class :inverse-video t))) + `(hi-black-hb ((,class :background ,bg-main :foreground ,fg-alt :inverse-video t))) + `(hi-blue ((,class :background ,bg-main :foreground ,blue-alt :inverse-video t))) `(hi-blue-b ((,class :inherit (bold hi-blue)))) - `(hi-green ((,class :background ,green-subtle-bg :foreground ,fg-main))) + `(hi-green ((,class :background ,bg-main :foreground ,green :inverse-video t))) `(hi-green-b ((,class :inherit (bold hi-green)))) - `(hi-pink ((,class :background ,magenta-subtle-bg :foreground ,fg-main))) - `(hi-pink-b ((,class :inherit (bold hi-pink)))) - `(hi-red-b ((,class :inherit bold :background ,red-intense-bg :foreground ,fg-main))) - `(hi-salmon ((,class :background ,red-subtle-bg :foreground ,fg-main))) - `(hi-yellow ((,class :background ,yellow-subtle-bg :foreground ,fg-main))) + `(hi-pink ((,class :background ,bg-main :foreground ,magenta :inverse-video t))) + `(hi-red-b ((,class :inherit bold :background ,bg-main :foreground ,red :inverse-video t))) + `(hi-salmon ((,class :background ,bg-main :foreground ,red-alt-faint :inverse-video t))) + `(hi-yellow ((,class :background ,bg-main :foreground ,yellow-alt :inverse-video t))) `(highlight ((,class ,@(if modus-themes-intense-mouseovers (list :background blue-intense-bg :foreground fg-main) (list :background cyan-subtle-bg :foreground fg-main))))) @@ -5740,7 +5740,7 @@ by virtue of calling either of `modus-themes-load-operandi' and ;;;;; highlight-numbers `(highlight-numbers-number ((,class :foreground ,blue-alt-other))) ;;;;; highlight-thing - `(highlight-thing ((,class :background ,bg-alt :foreground ,cyan))) + `(highlight-thing ((,class :inherit modus-themes-special-calm))) ;;;;; hl-defined `(hdefd-functions ((,class :foreground ,blue))) `(hdefd-undefined ((,class :foreground ,red-alt))) @@ -5805,6 +5805,26 @@ by virtue of calling either of `modus-themes-load-operandi' and `(info-title-2 ((,class :inherit modus-themes-heading-2))) `(info-title-3 ((,class :inherit modus-themes-heading-3))) `(info-title-4 ((,class :inherit modus-themes-heading-4))) +;;;;; info+ (info-plus) + `(info-command-ref-item ((,class :inherit font-lock-function-name-face))) + `(info-constant-ref-item ((,class :inherit font-lock-constant-face))) + `(info-custom-delimited ((,class :inherit modus-themes-markup-verbatim))) + `(info-double-quoted-name ((,class :inherit font-lock-string-face))) + `(info-file (( ))) + `(info-function-ref-item ((,class :inherit font-lock-function-name-face))) + `(info-glossary-word ((,class :inherit modus-themes-box-button))) + `(info-indented-text (( ))) + `(info-isolated-backquote (( ))) + `(info-isolated-quote (( ))) + `(info-macro-ref-item ((,class :inherit font-lock-keyword-face))) + `(info-menu ((,class :inherit bold))) + `(info-quoted-name ((,class :inherit modus-themes-markup-verbatim))) + `(info-reference-item ((,class :inherit bold))) + `(info-special-form-ref-item ((,class :inherit warning))) + `(info-string ((,class :inherit font-lock-string-face))) + `(info-syntax-class-item ((,class :inherit modus-themes-markup-code))) + `(info-user-option-ref-item ((,class :inherit font-lock-variable-name-face))) + `(info-variable-ref-item ((,class :inherit font-lock-variable-name-face))) ;;;;; info-colors `(info-colors-lisp-code-block ((,class :inherit modus-themes-fixed-pitch))) `(info-colors-ref-item-command ((,class :inherit font-lock-function-name-face))) @@ -5834,13 +5854,13 @@ by virtue of calling either of `modus-themes-load-operandi' and `(ioccur-regexp-face ((,class :inherit (modus-themes-intense-magenta bold)))) `(ioccur-title-face ((,class :inherit modus-themes-pseudo-header :foreground ,fg-special-cold))) ;;;;; isearch, occur, and the like - `(isearch ((,class :inherit (modus-themes-search-success bold)))) + `(isearch ((,class :inherit modus-themes-search-success))) `(isearch-fail ((,class :inherit modus-themes-refine-red))) `(isearch-group-1 ((,class :inherit modus-themes-refine-blue))) `(isearch-group-2 ((,class :inherit modus-themes-refine-magenta))) `(lazy-highlight ((,class :inherit modus-themes-search-success-lazy))) `(match ((,class :inherit modus-themes-special-calm))) - `(query-replace ((,class :inherit (modus-themes-intense-yellow bold)))) + `(query-replace ((,class :inherit modus-themes-intense-red))) ;;;;; ivy `(ivy-action ((,class :inherit modus-themes-key-binding))) `(ivy-confirm-face ((,class :inherit success))) @@ -5921,12 +5941,14 @@ by virtue of calling either of `modus-themes-load-operandi' and `(ledger-font-payee-pending-face ((,class :foreground ,yellow))) `(ledger-font-payee-uncleared-face ((,class :foreground ,red-alt-other))) `(ledger-font-xact-highlight-face ((,class :background ,bg-hl-alt))) +;;;;; leerzeichen + `(leerzeichen ((,class :background ,bg-whitespace :foreground ,fg-whitespace))) ;;;;; line numbers (display-line-numbers-mode and global variant) ;; Here we cannot inherit `modus-themes-fixed-pitch'. We need to ;; fall back to `default' otherwise line numbers do not scale when ;; using `text-scale-adjust'. `(line-number - ((,class :inherit ,(if modus-themes-mixed-fonts 'fixed-pitch 'default) + ((,class :inherit ,(if modus-themes-mixed-fonts '(fixed-pitch default) 'default) ,@(modus-themes--line-numbers fg-alt bg-dim fg-unfocused)))) @@ -6120,8 +6142,9 @@ by virtue of calling either of `modus-themes-load-operandi' and `(makefile-makepp-perl ((,class :background ,cyan-nuanced-bg))) `(makefile-space ((,class :background ,magenta-nuanced-bg))) ;;;;; man - `(Man-overstrike ((,class :inherit bold :foreground ,fg-special-calm))) + `(Man-overstrike ((,class :inherit bold :foreground ,magenta-alt))) `(Man-reverse ((,class :inherit modus-themes-subtle-magenta))) + `(Man-underline ((,class :foreground ,cyan-alt-other :underline t))) ;;;;; marginalia `(marginalia-archive ((,class :foreground ,cyan-alt-other))) `(marginalia-char ((,class :foreground ,magenta))) @@ -6235,8 +6258,6 @@ by virtue of calling either of `modus-themes-load-operandi' and `(markup-title-4-face ((,class :inherit modus-themes-heading-5))) `(markup-title-5-face ((,class :inherit modus-themes-heading-6))) `(markup-verbatim-face ((,class :inherit modus-themes-fixed-pitch :background ,bg-alt))) -;;;;; mct - `(mct-highlight-candidate ((,class :inherit modus-themes-completion-selected))) ;;;;; mentor `(mentor-download-message ((,class :foreground ,fg-special-warm))) `(mentor-download-name ((,class :foreground ,fg-special-cold))) @@ -6450,14 +6471,12 @@ by virtue of calling either of `modus-themes-load-operandi' and `(org-agenda-column-dateline ((,class :background ,bg-alt))) `(org-agenda-current-time ((,class :foreground ,blue-alt-other-faint))) `(org-agenda-date ((,class ,@(modus-themes--agenda-date cyan fg-main)))) - `(org-agenda-date-today ((,class ,@(modus-themes--agenda-date cyan fg-main - nil nil - bg-inactive t t)))) - `(org-agenda-date-weekend ((,class ,@(modus-themes--agenda-date cyan-alt-other-faint fg-alt - cyan fg-main)))) - `(org-agenda-date-weekend-today ((,class ,@(modus-themes--agenda-date cyan-alt-other-faint fg-alt - cyan fg-main - bg-inactive t t)))) + `(org-agenda-date-today + ((,class ,@(modus-themes--agenda-date cyan fg-main nil nil bg-special-cold t t)))) + `(org-agenda-date-weekend + ((,class ,@(modus-themes--agenda-date cyan-alt-other-faint fg-alt cyan fg-main)))) + `(org-agenda-date-weekend-today + ((,class ,@(modus-themes--agenda-date cyan-alt-other-faint fg-alt cyan fg-main bg-special-cold t t)))) `(org-agenda-diary ((,class :inherit org-agenda-calendar-sexp))) `(org-agenda-dimmed-todo-face ((,class :inherit shadow))) `(org-agenda-done ((,class :inherit modus-themes-grue-nuanced))) @@ -6491,7 +6510,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(org-dispatcher-highlight ((,class :inherit (bold modus-themes-mark-alt)))) `(org-document-info ((,class :foreground ,fg-special-cold))) `(org-document-info-keyword ((,class :inherit (shadow modus-themes-fixed-pitch)))) - `(org-document-title ((,class :inherit modus-themes-heading-1 :background ,bg-main :overline nil :foreground ,fg-special-cold))) + `(org-document-title ((,class :inherit modus-themes-heading-0))) `(org-done ((,class :inherit modus-themes-grue))) `(org-drawer ((,class :inherit (shadow modus-themes-fixed-pitch)))) `(org-ellipsis (())) ; inherits from the heading's color @@ -6589,8 +6608,8 @@ by virtue of calling either of `modus-themes-load-operandi' and `(org-journal-calendar-scheduled-face ((,class :inherit modus-themes-slant :foreground ,red-alt-other))) `(org-journal-highlight ((,class :foreground ,magenta-alt))) ;;;;; org-noter - `(org-noter-no-notes-exist-face ((,class :inherit bold :foreground ,red-active))) - `(org-noter-notes-exist-face ((,class :inherit bold :foreground ,green-active))) + `(org-noter-no-notes-exist-face ((,class :inherit error))) + `(org-noter-notes-exist-face ((,class :inherit success))) ;;;;; org-pomodoro `(org-pomodoro-mode-line ((,class :foreground ,red-active))) `(org-pomodoro-mode-line-break ((,class :foreground ,cyan-active))) @@ -6613,9 +6632,6 @@ by virtue of calling either of `modus-themes-load-operandi' and `(org-table-sticky-header-face ((,class :inherit modus-themes-special-cold))) ;;;;; org-tree-slide `(org-tree-slide-header-overlay-face ((,class :inherit org-document-title))) -;;;;; org-treescope - `(org-treescope-faces--markerinternal-midday ((,class :inherit modus-themes-intense-blue))) - `(org-treescope-faces--markerinternal-range ((,class :inherit modus-themes-special-mild))) ;;;;; origami `(origami-fold-header-face ((,class :background ,bg-dim :foreground ,fg-dim :box t))) `(origami-fold-replacement-face ((,class :background ,bg-alt :foreground ,fg-alt))) @@ -6632,19 +6648,19 @@ by virtue of calling either of `modus-themes-load-operandi' and `(outline-minor-0 (())) ;;;;; package (M-x list-packages) `(package-description ((,class :foreground ,fg-special-cold))) - `(package-help-section-name ((,class :inherit bold :foreground ,magenta-alt-other))) + `(package-help-section-name ((,class :inherit bold :foreground ,cyan))) `(package-name ((,class :inherit button))) - `(package-status-avail-obso ((,class :inherit bold :foreground ,red))) - `(package-status-available ((,class :foreground ,fg-special-mild))) + `(package-status-available ((,class :foreground ,cyan-alt-other))) + `(package-status-avail-obso ((,class :inherit error))) `(package-status-built-in ((,class :foreground ,magenta))) `(package-status-dependency ((,class :foreground ,magenta-alt-other))) `(package-status-disabled ((,class :inherit modus-themes-subtle-red))) `(package-status-external ((,class :foreground ,cyan-alt-other))) `(package-status-held ((,class :foreground ,yellow-alt))) - `(package-status-incompat ((,class :inherit bold :foreground ,yellow))) + `(package-status-incompat ((,class :inherit warning))) `(package-status-installed ((,class :foreground ,fg-special-warm))) - `(package-status-new ((,class :inherit bold :foreground ,green))) - `(package-status-unsigned ((,class :inherit bold :foreground ,red-alt))) + `(package-status-new ((,class :inherit success))) + `(package-status-unsigned ((,class :inherit error))) ;;;;; page-break-lines `(page-break-lines ((,class :inherit default :foreground ,fg-window-divider-outer))) ;;;;; pandoc-mode @@ -6653,19 +6669,6 @@ by virtue of calling either of `modus-themes-load-operandi' and `(pandoc-directive-braces-face ((,class :foreground ,blue-alt-other))) `(pandoc-directive-contents-face ((,class :foreground ,cyan-alt-other))) `(pandoc-directive-type-face ((,class :foreground ,magenta))) -;;;;; paradox - `(paradox-archive-face ((,class :foreground ,fg-special-mild))) - `(paradox-comment-face ((,class :inherit font-lock-comment-face))) - `(paradox-commit-tag-face ((,class :inherit modus-themes-refine-magenta :box t))) - `(paradox-description-face ((,class :foreground ,fg-special-cold))) - `(paradox-description-face-multiline ((,class :foreground ,fg-special-cold))) - `(paradox-download-face ((,class :inherit modus-themes-bold :foreground ,blue-alt-other))) - `(paradox-highlight-face ((,class :inherit modus-themes-bold :foreground ,cyan-alt-other))) - `(paradox-homepage-button-face ((,class :foreground ,magenta-alt-other :underline t))) - `(paradox-mode-line-face ((,class :inherit bold :foreground ,cyan-active))) - `(paradox-name-face ((,class :foreground ,blue :underline t))) - `(paradox-star-face ((,class :foreground ,magenta))) - `(paradox-starred-face ((,class :foreground ,magenta-alt))) ;;;;; paren-face `(parenthesis ((,class :foreground ,fg-unfocused))) ;;;;; pass @@ -6695,7 +6698,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(pomidor-work-face ((,class :inherit modus-themes-grue))) ;;;;; popup `(popup-face ((,class :background ,bg-alt :foreground ,fg-main))) - `(popup-isearch-match ((,class :inherit (modus-themes-search-success bold)))) + `(popup-isearch-match ((,class :inherit modus-themes-search-success))) `(popup-menu-mouse-face ((,class :inherit highlight))) `(popup-menu-selection-face ((,class :inherit modus-themes-completion-selected-popup))) `(popup-scroll-bar-background-face ((,class :background ,bg-active))) @@ -6703,12 +6706,12 @@ by virtue of calling either of `modus-themes-load-operandi' and `(popup-summary-face ((,class :background ,bg-active :foreground ,fg-inactive))) `(popup-tip-face ((,class :inherit modus-themes-refine-yellow))) ;;;;; powerline - `(powerline-active0 ((,class :background ,blue-faint :foreground ,bg-main))) - `(powerline-active1 ((,class :background ,blue-nuanced-bg :foreground ,blue-nuanced-fg))) - `(powerline-active2 ((,class :background ,bg-active :foreground ,fg-active))) - `(powerline-inactive0 ((,class :background ,bg-special-cold :foreground ,fg-special-cold))) - `(powerline-inactive1 ((,class :background ,bg-dim :foreground ,fg-inactive))) - `(powerline-inactive2 ((,class :background ,bg-inactive :foreground ,fg-inactive))) + `(powerline-active0 ((,class :background ,fg-unfocused :foreground ,bg-main))) + `(powerline-active1 ((,class :inherit mode-line-active))) + `(powerline-active2 ((,class :inherit mode-line-inactive))) + `(powerline-inactive0 ((,class :background ,bg-active :foreground ,fg-alt))) + `(powerline-inactive1 ((,class :background ,bg-main :foreground ,fg-alt))) + `(powerline-inactive2 ((,class :inherit mode-line-inactive))) ;;;;; powerline-evil `(powerline-evil-base-face ((,class :background ,fg-main :foreground ,bg-main))) `(powerline-evil-emacs-face ((,class :inherit modus-themes-active-magenta))) @@ -6834,10 +6837,8 @@ by virtue of calling either of `modus-themes-load-operandi' and ;;;;; selectrum `(selectrum-current-candidate ((,class :inherit modus-themes-completion-selected))) `(selectrum-mouse-highlight ((,class :inherit highlight))) - `(selectrum-quick-keys-highlight - ((,class :inherit modus-themes-refine-red))) - `(selectrum-quick-keys-match - ((,class :inherit (bold modus-themes-search-success)))) + `(selectrum-quick-keys-highlight ((,class :inherit bold :background ,bg-char-0))) + `(selectrum-quick-keys-match ((,class :inherit bold :background ,bg-char-1))) ;;;;; selectrum-prescient `(selectrum-prescient-primary-highlight ((,class :inherit modus-themes-completion-match-0))) `(selectrum-prescient-secondary-highlight ((,class :inherit modus-themes-completion-match-1))) @@ -6854,8 +6855,8 @@ by virtue of calling either of `modus-themes-load-operandi' and `(semantic-tag-boundary-face ((,class :overline ,blue-intense))) `(semantic-unmatched-syntax-face ((,class :underline ,fg-lang-error))) ;;;;; sesman - `(sesman-browser-button-face ((,class :foreground ,blue-alt-other :underline t))) - `(sesman-browser-highligh-face ((,class :inherit modus-themes-subtle-blue))) + `(sesman-browser-button-face ((,class :inherit button))) + `(sesman-browser-highligh-face ((,class :inherit highlight))) `(sesman-buffer-face ((,class :foreground ,magenta))) `(sesman-directory-face ((,class :inherit bold :foreground ,blue))) `(sesman-project-face ((,class :inherit bold :foreground ,magenta-alt-other))) @@ -6986,7 +6987,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(speedbar-button-face ((,class :inherit button))) `(speedbar-directory-face ((,class :inherit bold :foreground ,blue))) `(speedbar-file-face ((,class :foreground ,fg-main))) - `(speedbar-highlight-face ((,class :inherit modus-themes-subtle-blue))) + `(speedbar-highlight-face ((,class :inherit highlight))) `(speedbar-selected-face ((,class :inherit bold :foreground ,cyan))) `(speedbar-separator-face ((,class :inherit modus-themes-intense-neutral))) `(speedbar-tag-face ((,class :foreground ,yellow-alt-other))) @@ -7047,14 +7048,14 @@ by virtue of calling either of `modus-themes-load-operandi' and `(symbol-overlay-face-8 ((,class :inherit modus-themes-refine-cyan))) ;;;;; syslog-mode `(syslog-debug ((,class :inherit bold :foreground ,cyan-alt-other))) - `(syslog-error ((,class :inherit bold :foreground ,red))) + `(syslog-error ((,class :inherit error))) `(syslog-file ((,class :inherit bold :foreground ,fg-special-cold))) `(syslog-hide ((,class :background ,bg-main :foreground ,fg-main))) `(syslog-hour ((,class :inherit bold :foreground ,magenta-alt-other))) - `(syslog-info ((,class :inherit bold :foreground ,blue-alt-other))) + `(syslog-info ((,class :inherit success))) `(syslog-ip ((,class :inherit bold :foreground ,fg-special-mild :underline t))) `(syslog-su ((,class :inherit bold :foreground ,red-alt))) - `(syslog-warn ((,class :inherit bold :foreground ,yellow))) + `(syslog-warn ((,class :inherit warning))) ;;;;; tab-bar-groups `(tab-bar-groups-tab-1 ((,class :inherit modus-themes-ui-variable-pitch :foreground ,blue-tab))) `(tab-bar-groups-tab-2 ((,class :inherit modus-themes-ui-variable-pitch :foreground ,red-tab))) @@ -7427,8 +7428,9 @@ by virtue of calling either of `modus-themes-load-operandi' and `(writegood-weasels-face ((,class :inherit modus-themes-lang-error))) ;;;;; woman `(woman-addition ((,class :foreground ,magenta-alt-other))) - `(woman-bold ((,class :inherit bold :foreground ,fg-special-calm))) - `(woman-unknown ((,class :foreground ,cyan))) + `(woman-bold ((,class :inherit bold :foreground ,magenta-alt))) + `(woman-italic ((,class :inherit italic :foreground ,cyan))) + `(woman-unknown ((,class :foreground ,green-alt))) ;;;;; xah-elisp-mode `(xah-elisp-at-symbol ((,class :inherit font-lock-warning-face))) `(xah-elisp-cap-variable ((,class :inherit font-lock-preprocessor-face))) @@ -7465,6 +7467,10 @@ by virtue of calling either of `modus-themes-load-operandi' and ;;;; awesome-tray `(awesome-tray-mode-line-active-color ,blue) `(awesome-tray-mode-line-inactive-color ,bg-active) +;;;; chart + `(chart-face-color-list + '( ,red-graph-0-bg ,green-graph-0-bg ,yellow-graph-0-bg ,blue-graph-0-bg ,magenta-graph-0-bg ,cyan-graph-0-bg + ,red-graph-1-bg ,green-graph-1-bg ,yellow-graph-1-bg ,blue-graph-1-bg ,magenta-graph-1-bg ,cyan-graph-1-bg)) ;;;; exwm `(exwm-floating-border-color ,fg-window-divider-inner) ;;;; flymake fringe indicators @@ -7504,29 +7510,6 @@ by virtue of calling either of `modus-themes-load-operandi' and ;;;; pdf-tools `(pdf-view-midnight-colors '(,fg-main . ,bg-dim)) -;;;; vc-annotate (C-x v g) - `(vc-annotate-background nil) - `(vc-annotate-background-mode nil) - `(vc-annotate-color-map - '((20 . ,red) - (40 . ,magenta) - (60 . ,magenta-alt) - (80 . ,red-alt) - (100 . ,yellow) - (120 . ,yellow-alt) - (140 . ,fg-special-warm) - (160 . ,fg-special-mild) - (180 . ,green) - (200 . ,green-alt) - (220 . ,cyan-alt-other) - (240 . ,cyan-alt) - (260 . ,cyan) - (280 . ,fg-special-cold) - (300 . ,blue) - (320 . ,blue-alt) - (340 . ,blue-alt-other) - (360 . ,magenta-alt-other))) - `(vc-annotate-very-old-color nil) ;;;; wid-edit `(widget-link-prefix ,(if (memq 'all-buttons modus-themes-box-buttons) " " diff --git a/etc/themes/modus-vivendi-theme.el b/etc/themes/modus-vivendi-theme.el index fe52aefc84..f2c916ef30 100644 --- a/etc/themes/modus-vivendi-theme.el +++ b/etc/themes/modus-vivendi-theme.el @@ -3,8 +3,10 @@ ;; Copyright (C) 2019-2022 Free Software Foundation, Inc. ;; Author: Protesilaos Stavrou +;; Maintainer: Modus-Themes Development <~protesilaos/modus-themes@lists.sr.ht> ;; URL: https://git.sr.ht/~protesilaos/modus-themes -;; Version: 2.4.1 +;; Mailing-List: https://lists.sr.ht/~protesilaos/modus-themes +;; Version: 2.5.0 ;; Package-Requires: ((emacs "27.1")) ;; Keywords: faces, theme, accessibility commit 0a54a5017a801b5a333e1bf9d861d075ff45d486 Author: Lars Ingebrigtsen Date: Wed Aug 3 13:22:09 2022 +0200 Fix #' quoting in uniquify-buffer-name-style doc string * lisp/uniquify.el (uniquify-buffer-name-style): Fix wrong quoting. diff --git a/lisp/uniquify.el b/lisp/uniquify.el index 0b7db9b54f..b75b47c03c 100644 --- a/lisp/uniquify.el +++ b/lisp/uniquify.el @@ -110,7 +110,7 @@ is a list of strings. For example the current implementation for post-forward-angle-brackets could be: (defun my-post-forward-angle-brackets (base extra-string) - (concat base \"<\" (mapconcat #'identity extra-string \"/\") \">\")) + (concat base \"<\" (mapconcat #\\='identity extra-string \"/\") \">\")) The \"mumble\" part may be stripped as well, depending on the setting of `uniquify-strip-common-suffix'. For more options that commit 0596c6918667704c486bd7ffba8b13572b8237d9 Author: Lars Ingebrigtsen Date: Wed Aug 3 13:14:24 2022 +0200 Check for mis-quoted #' in doc strings during byte-compile * lisp/emacs-lisp/bytecomp.el (byte-compile-docstring-style-warn): Check for mis-quoted #' in doc strings, too. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index b4954eee9f..7d2971502d 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1760,7 +1760,7 @@ It is too wide if it has any lines longer than the largest of kind name col)) ;; There's a "naked" ' character before a symbol/list, so it ;; should probably be quoted with \=. - (when (string-match-p "\\( \"\\|[ \t]\\|^\\)'[a-z(]" docs) + (when (string-match-p "\\( [\"#]\\|[ \t]\\|^\\)'[a-z(]" docs) (byte-compile-warn-x name "%s%sdocstring has wrong usage of unescaped single quotes (use \\= or different quoting)" kind name)) commit 0a6e2b3bfce8b5ae9e713e0668cb3cf5609073e2 Author: Lars Ingebrigtsen Date: Wed Aug 3 13:13:57 2022 +0200 Fix quoting of #' in some doc strings * lisp/org/ox.el (org-export-to-file): * lisp/eshell/esh-arg.el (eshell-concat): * lisp/emacs-lisp/edebug.el (edebug-read-special): * lisp/dired-aux.el (dired-split): Fix quoting of #' in doc strings. diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index b9f33036e3..bb24954386 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -3058,7 +3058,7 @@ Optional third arg LIMIT (>= 1) is a limit to the length of the resulting list. Thus, if SEP is a regexp that only matches itself, - (mapconcat #'identity (dired-split SEP STRING) SEP) + (mapconcat #\\='identity (dired-split SEP STRING) SEP) is always equal to STRING." (declare (obsolete split-string "29.1")) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 1a1d58d6e3..dff16df002 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -864,7 +864,7 @@ marker. The needed data will then come from property (defun edebug-read-special (stream) "Read from STREAM a Lisp object beginning with #. -Turn #'thing into (function thing) and handle the read syntax for +Turn #\\='thing into (function thing) and handle the read syntax for circular objects. Let `read' read everything else." (catch 'return (forward-char 1) diff --git a/lisp/eshell/esh-arg.el b/lisp/eshell/esh-arg.el index 459487f435..8e44a88459 100644 --- a/lisp/eshell/esh-arg.el +++ b/lisp/eshell/esh-arg.el @@ -186,7 +186,7 @@ If QUOTED is nil, the resulting value(s) may be converted to numbers (see `eshell-concat-1'). If each argument in REST is a non-list value, the result will be -a single value, as if (mapconcat #'eshell-stringify REST) had been +a single value, as if (mapconcat #\\='eshell-stringify REST) had been called, possibly converted to a number. If there is at least one (non-nil) list argument, the result will diff --git a/lisp/org/ox.el b/lisp/org/ox.el index 1bdf4dead8..9a2a69b2c1 100644 --- a/lisp/org/ox.el +++ b/lisp/org/ox.el @@ -6479,7 +6479,7 @@ to send the output file through additional processing, e.g, (let ((outfile (org-export-output-file-name \".tex\" subtreep))) (org-export-to-file \\='latex outfile async subtreep visible-only body-only ext-plist - #'org-latex-compile))) + #\\='org-latex-compile))) When expressed as an anonymous function, using `lambda', POST-PROCESS needs to be quoted. commit 90addeb2442687c34cd236edead285348d49f4ba Author: Jonas Bernoulli Date: Wed Aug 3 12:10:22 2022 +0200 * lisp/transient.el: Update to package version v0.3.7-143-g1b0a8a7 diff --git a/lisp/transient.el b/lisp/transient.el index 8c41706f15..250201903d 100644 --- a/lisp/transient.el +++ b/lisp/transient.el @@ -1,16 +1,18 @@ -;;; transient.el --- Transient commands -*- lexical-binding: t; -*- +;;; transient.el --- Transient commands -*- lexical-binding:t -*- ;; Copyright (C) 2018-2022 Free Software Foundation, Inc. ;; Author: Jonas Bernoulli ;; URL: https://github.com/magit/transient -;; Keywords: bindings +;; Keywords: extensions -;; Package-Requires: ((emacs "25.1")) ;; Package-Version: 0.3.7 +;; Package-Requires: ((emacs "26.1")) ;; SPDX-License-Identifier: GPL-3.0-or-later +;; 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, @@ -24,8 +26,6 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . -;; This file is part of GNU Emacs. - ;;; Commentary: ;; Taking inspiration from prefix keys and prefix arguments, Transient @@ -58,14 +58,14 @@ (require 'format-spec) (require 'seq) -(eval-when-compile - (require 'subr-x)) +(eval-when-compile (require 'subr-x)) -(declare-function info "info") -(declare-function Man-find-section "man") -(declare-function Man-next-section "man") -(declare-function Man-getpage-in-background "man") +(declare-function info "info" (&optional file-or-node buffer)) +(declare-function Man-find-section "man" (section)) +(declare-function Man-next-section "man" (n)) +(declare-function Man-getpage-in-background "man" (topic)) +(defvar display-line-numbers) ; since Emacs 26.1 (defvar Man-notify-method) (define-obsolete-function-alias 'define-transient-command @@ -77,6 +77,8 @@ (define-obsolete-function-alias 'define-infix-argument #'transient-define-argument "Transient 0.3.0") +(define-obsolete-variable-alias 'transient--source-buffer + 'transient--original-buffer "Transient 0.2.0") (define-obsolete-variable-alias 'current-transient-prefix 'transient-current-prefix "Transient 0.3.0") (define-obsolete-variable-alias 'current-transient-command @@ -107,21 +109,20 @@ (defcustom transient-show-popup t "Whether to show the current transient in a popup buffer. - +\\ - If t, then show the popup as soon as a transient prefix command is invoked. - If nil, then do not show the popup unless the user explicitly - requests it, by pressing an incomplete prefix key sequence. + requests it, by pressing \\[transient-show] or a prefix key. - If a number, then delay displaying the popup and instead show a brief one-line summary. If zero or negative, then suppress even showing that summary and display the pressed key only. Show the popup when the user explicitly requests it by pressing - an incomplete prefix key sequence. Unless zero, then also show - the popup after that many seconds of inactivity (using the - absolute value)." + \\[transient-show] or a prefix key. Unless zero, then also show the popup + after that many seconds of inactivity (using the absolute value)." :package-version '(transient . "0.1.0") :group 'transient :type '(choice (const :tag "instantly" t) @@ -129,20 +130,32 @@ (const :tag "on demand (no summary)" 0) (number :tag "after delay" 1))) -(defcustom transient-enable-popup-navigation nil +(defcustom transient-enable-popup-navigation t "Whether navigation commands are enabled in the transient popup. While a transient is active the transient popup buffer is not the current buffer, making it necessary to use dedicated commands to -act on that buffer itself. If this non-nil, then the following -features are available: - -- \"\" moves the cursor to the previous suffix. - \"\" moves the cursor to the next suffix. - \"RET\" invokes the suffix the cursor is on. -- \"\" invokes the clicked on suffix. -- \"C-s\" and \"C-r\" start isearch in the popup buffer." - :package-version '(transient . "0.2.0") +act on that buffer itself. If this is non-nil, then the following +bindings are available: + +\\\ +- \\[transient-backward-button] moves the cursor to the previous suffix. +- \\[transient-forward-button] moves the cursor to the next suffix. +- \\[transient-push-button] invokes the suffix the cursor is on. +\\\ +- \\`' and \\`' invoke the clicked on suffix. +\\\ +- \\[transient-isearch-backward]\ + and \\[transient-isearch-forward] start isearch in the popup buffer. + +\\`' and \\`' are bound in `transient-push-button'. +All other bindings are in `transient-popup-navigation-map'. + +By default \\`M-RET' is bound to `transient-push-button', instead of +\\`RET', because if a transient allows the invocation of non-suffixes +then it is likely that you would want \\`RET' to do what it would do +if no transient were active." + :package-version '(transient . "0.4.0") :group 'transient :type 'boolean) @@ -244,7 +257,7 @@ arguments. When this option is non-nil, then the key binding for infix argument are highlighted when only a long argument \(e.g. \"--verbose\") is specified but no shor-thand (e.g \"-v\"). In the rare case that a short-hand is specified but does not -match the key binding, then it is highlighed differently. +match the key binding, then it is highlighted differently. The highlighting is done using `transient-mismatched-key' and `transient-nonstandard-key'." @@ -317,13 +330,32 @@ used." :group 'transient :type 'boolean) +(defcustom transient-align-variable-pitch nil + "Whether to align columns pixel-wise in the popup buffer. + +If this is non-nil, then columns are aligned pixel-wise to +support variable-pitch fonts. Keys are not aligned, so you +should use a fixed-pitch font for the `transient-key' face. +Other key faces inherit from that face unless a theme is +used that breaks that relationship. + +This option is intended for users who use a variable-pitch +font for the `default' face. + +Also see `transient-force-fixed-pitch'." + :package-version '(transient . "0.4.0") + :group 'transient + :type 'boolean) + (defcustom transient-force-fixed-pitch nil "Whether to force use of monospaced font in the popup buffer. Even if you use a proportional font for the `default' face, you might still want to use a monospaced font in transient's popup buffer. Setting this option to t causes `default' to -be remapped to `fixed-pitch' in that buffer." +be remapped to `fixed-pitch' in that buffer. + +Also see `transient-align-variable-pitch'." :package-version '(transient . "0.2.0") :group 'transient :type 'boolean) @@ -337,6 +369,12 @@ text and might otherwise have to scroll in two dimensions." :group 'transient :type 'boolean) +(defcustom transient-hide-during-minibuffer-read nil + "Whether to hide the transient buffer while reading in the minibuffer." + :package-version '(transient . "0.4.0") + :group 'transient + :type 'boolean) + (defconst transient--default-child-level 1) (defconst transient--default-prefix-level 4) @@ -375,21 +413,21 @@ give you as many additional suffixes as you hoped.)" (const :tag "7 - most suffixes" 7))) (defcustom transient-levels-file - (locate-user-emacs-file (convert-standard-filename "transient/levels.el")) + (locate-user-emacs-file "transient/levels.el") "File used to save levels of transients and their suffixes." :package-version '(transient . "0.1.0") :group 'transient :type 'file) (defcustom transient-values-file - (locate-user-emacs-file (convert-standard-filename "transient/values.el")) + (locate-user-emacs-file "transient/values.el") "File used to save values of transients." :package-version '(transient . "0.1.0") :group 'transient :type 'file) (defcustom transient-history-file - (locate-user-emacs-file (convert-standard-filename "transient/history.el")) + (locate-user-emacs-file "transient/history.el") "File used to save history of transients and their infixes." :package-version '(transient . "0.1.0") :group 'transient @@ -445,7 +483,7 @@ give you as many additional suffixes as you hoped.)" "Face used for the infix for which the value is being read." :group 'transient-faces) -(defface transient-unreachable-key '((t :inherit shadow)) +(defface transient-unreachable-key '((t :inherit (transient-key shadow))) "Face used for keys unreachable from the current prefix sequence." :group 'transient-faces) @@ -524,6 +562,15 @@ These faces are only used if `transient-semantic-coloring' "Face used for teal prefixes." :group 'transient-color-faces) +(defface transient-purple + '((t :inherit transient-key :foreground "#a020f0")) + "Face used for purple prefixes. + +This is an addition to the colors supported by Hydra. It is +used by suffixes that quit the current prefix but return to +the previous prefix." + :group 'transient-color-faces) + ;;; Persistence (defun transient--read-file-contents (file) @@ -825,11 +872,11 @@ to the setup function: (transient-setup \\='NAME nil nil :scope SCOPE) \(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]... GROUP... [BODY...])" - (declare (debug (&define name lambda-list - [&optional lambda-doc] - [&rest keywordp sexp] - [&rest vectorp] - [&optional ("interactive" interactive) def-body])) + (declare (debug ( &define name lambda-list + [&optional lambda-doc] + [&rest keywordp sexp] + [&rest vectorp] + [&optional ("interactive" interactive) def-body])) (indent defun) (doc-string 3)) (pcase-let ((`(,class ,slots ,suffixes ,docstr ,body) @@ -866,11 +913,11 @@ ARGLIST. The infix arguments are usually accessed by using `transient-args' inside `interactive'. \(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]... BODY...)" - (declare (debug (&define name lambda-list - [&optional lambda-doc] - [&rest keywordp sexp] - ("interactive" interactive) - def-body)) + (declare (debug ( &define name lambda-list + [&optional lambda-doc] + [&rest keywordp sexp] + ("interactive" interactive) + def-body)) (indent defun) (doc-string 3)) (pcase-let ((`(,class ,slots ,_ ,docstr ,body) @@ -912,14 +959,14 @@ functions. Different infix commands behave differently because the concrete methods are different for different infix command classes. In rare case the above command function might not be suitable, even if you define your own infix command class. In -that case you have to use `transient-suffix-command' to define +that case you have to use `transient-define-suffix' to define the infix command and use t as the value of the `:transient' keyword. \(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]...)" - (declare (debug (&define name lambda-list - [&optional lambda-doc] - [&rest keywordp sexp])) + (declare (debug ( &define name lambda-list + [&optional lambda-doc] + [&rest keywordp sexp])) (indent defun) (doc-string 3)) (pcase-let ((`(,class ,slots ,_ ,docstr ,_) @@ -927,6 +974,7 @@ keyword. `(progn (defalias ',name ,(transient--default-infix-command)) (put ',name 'interactive-only t) + (put ',name 'command-modes (list 'not-a-mode)) (put ',name 'function-documentation ,docstr) (put ',name 'transient--suffix (,(or class 'transient-switch) :command ',name ,@slots))))) @@ -952,8 +1000,9 @@ example, sets a variable use `transient-define-infix' instead. (push k keys) (push v keys)))) (while (let ((arg (car args))) - (or (vectorp arg) - (and arg (symbolp arg)))) + (if (vectorp arg) + (setcar args (eval (cdr (backquote-process arg)))) + (and arg (symbolp arg)))) (push (pop args) suffixes)) (list (if (eq (car-safe class) 'quote) (cadr class) @@ -971,8 +1020,8 @@ example, sets a variable use `transient-define-infix' instead. (vectorp (car value)))) (cl-mapcan (lambda (s) (transient--parse-child prefix s)) value) (transient--parse-child prefix value)))) - (vector (when-let ((c (transient--parse-group prefix spec))) (list c))) - (list (when-let ((c (transient--parse-suffix prefix spec))) (list c))) + (vector (and-let* ((c (transient--parse-group prefix spec))) (list c))) + (list (and-let* ((c (transient--parse-suffix prefix spec))) (list c))) (string (list spec)))) (defun transient--parse-group (prefix spec) @@ -1092,7 +1141,7 @@ example, sets a variable use `transient-define-infix' instead. ;;; Edit -(defun transient--insert-suffix (prefix loc suffix action) +(defun transient--insert-suffix (prefix loc suffix action &optional keep-other) (let* ((suf (cl-etypecase suffix (vector (transient--parse-group prefix suffix)) (list (transient--parse-suffix prefix suffix)) @@ -1110,25 +1159,18 @@ example, sets a variable use `transient-define-infix' instead. suffix prefix loc "suffixes and groups cannot be siblings")) (t - (when (and (listp suffix) - (listp elt)) - ;; Both suffixes are key bindings; not heading strings. - (let ((key (transient--spec-key suf))) - (if (equal (transient--kbd key) - (transient--kbd (transient--spec-key elt))) - ;; We must keep `mem' until after we have inserted - ;; behind it, which `transient-remove-suffix' does - ;; not allow us to do. - (let ((spred (transient--suffix-predicate suf)) - (epred (transient--suffix-predicate elt))) - ;; If both suffixes have a predicate and they - ;; are not identical, then there is a high - ;; probability that we want to keep both. - (when (or (not spred) - (not epred) - (equal spred epred)) - (setq action 'replace))) - (transient-remove-suffix prefix key)))) + (when-let* ((bindingp (listp suf)) + (key (transient--spec-key suf)) + (conflict (car (transient--layout-member key prefix))) + (conflictp + (and (not (and (eq action 'replace) + (eq conflict elt))) + (or (not keep-other) + (eq (plist-get (nth 2 suf) :command) + (plist-get (nth 2 conflict) :command))) + (equal (transient--suffix-predicate suf) + (transient--suffix-predicate conflict))))) + (transient-remove-suffix prefix key)) (cl-ecase action (insert (setcdr mem (cons elt (cdr mem))) (setcar mem suf)) @@ -1136,7 +1178,7 @@ example, sets a variable use `transient-define-infix' instead. (replace (setcar mem suf))))))) ;;;###autoload -(defun transient-insert-suffix (prefix loc suffix) +(defun transient-insert-suffix (prefix loc suffix &optional keep-other) "Insert a SUFFIX into PREFIX before LOC. PREFIX is a prefix command, a symbol. SUFFIX is a suffix command or a group specification (of @@ -1144,12 +1186,14 @@ SUFFIX is a suffix command or a group specification (of LOC is a command, a key vector, a key description (a string as returned by `key-description'), or a coordination list (whose last element may also be a command or key). +Remove a conflicting binding unless optional KEEP-OTHER is + non-nil. See info node `(transient)Modifying Existing Transients'." (declare (indent defun)) - (transient--insert-suffix prefix loc suffix 'insert)) + (transient--insert-suffix prefix loc suffix 'insert keep-other)) ;;;###autoload -(defun transient-append-suffix (prefix loc suffix) +(defun transient-append-suffix (prefix loc suffix &optional keep-other) "Insert a SUFFIX into PREFIX after LOC. PREFIX is a prefix command, a symbol. SUFFIX is a suffix command or a group specification (of @@ -1157,9 +1201,11 @@ SUFFIX is a suffix command or a group specification (of LOC is a command, a key vector, a key description (a string as returned by `key-description'), or a coordination list (whose last element may also be a command or key). +Remove a conflicting binding unless optional KEEP-OTHER is + non-nil. See info node `(transient)Modifying Existing Transients'." (declare (indent defun)) - (transient--insert-suffix prefix loc suffix 'append)) + (transient--insert-suffix prefix loc suffix 'append keep-other)) ;;;###autoload (defun transient-replace-suffix (prefix loc suffix) @@ -1269,7 +1315,7 @@ See info node `(transient)Modifying Existing Transients'." (plist-get plist :command))))) (defun transient--command-key (cmd) - (when-let ((obj (get cmd 'transient--suffix))) + (and-let* ((obj (get cmd 'transient--suffix))) (cond ((slot-boundp obj 'key) (oref obj key)) ((slot-exists-p obj 'shortarg) @@ -1290,7 +1336,7 @@ This is an object representing that transient, use (defvar transient-current-command nil "The transient from which this suffix command was invoked. This is a symbol representing that transient, use -`current-transient-object' to get the respective object.") +`transient-current-prefix' to get the respective object.") (defvar transient-current-suffixes nil "The suffixes of the transient from which this suffix command was invoked. @@ -1320,6 +1366,8 @@ variable instead.") (defvar transient--stack nil) +(defvar transient--minibuffer-depth 0) + (defvar transient--buffer-name " *transient*" "Name of the transient buffer.") @@ -1330,9 +1378,6 @@ variable instead.") "The window that was selected before the transient was invoked. Usually it remains selected while the transient is active.") -(define-obsolete-variable-alias 'transient--source-buffer - 'transient--original-buffer "Transient 0.2.0") - (defvar transient--original-buffer nil "The buffer that was current before the transient was invoked. Usually it remains current while the transient is active.") @@ -1341,6 +1386,17 @@ Usually it remains current while the transient is active.") (defvar transient--history nil) +(defvar transient--abort-commands + '(abort-minibuffers ; (minibuffer-quit-recursive-edit) + abort-recursive-edit ; (throw 'exit t) + exit-recursive-edit ; (throw 'exit nil) + keyboard-escape-quit ; dwim + keyboard-quit ; (signal 'quit nil) + minibuffer-keyboard-quit ; (abort-minibuffers) + minibuffer-quit-recursive-edit ; (throw 'exit (lambda () + ; (signal 'minibuffer-quit nil))) + top-level)) ; (throw 'top-level nil) + (defvar transient--scroll-commands '(transient-scroll-up transient-scroll-down @@ -1392,11 +1448,12 @@ probably use this instead: transient-current-prefix) (cl-find-if (lambda (obj) (eq (transient--suffix-command obj) - (or command this-original-command))) + (or command this-command))) (or transient--suffixes transient-current-suffixes)) - (when-let ((obj (get (or command this-command) 'transient--suffix)) - (obj (clone obj))) + (when-let* ((obj (get (or command this-command) 'transient--suffix)) + (obj (clone obj))) + ;; Cannot use and-let* because of debbugs#31840. (transient-init-scope obj) (transient-init-value obj) obj))) @@ -1500,13 +1557,15 @@ to `transient-predicate-map'. Also see `transient-base-map'.") 'transient--layout (cl-mapcan (lambda (s) (transient--parse-child 'transient-common-commands s)) - '([:hide (lambda () - (and (not (memq (car transient--redisplay-key) - transient--common-command-prefixes)) - (not transient-show-common-commands))) + `([:hide ,(lambda () + (and (not (memq (car (bound-and-true-p + transient--redisplay-key)) + transient--common-command-prefixes)) + (not transient-show-common-commands))) ["Value commands" ("C-x s " "Set" transient-set) ("C-x C-s" "Save" transient-save) + ("C-x C-k" "Reset" transient-reset) ("C-x p " "Previous value" transient-history-prev) ("C-x n " "Next value" transient-history-next)] ["Sticky commands" @@ -1517,22 +1576,41 @@ to `transient-predicate-map'. Also see `transient-base-map'.") ("C-z" "Suspend transient stack" transient-suspend)] ["Customize" ("C-x t" transient-toggle-common - :description (lambda () - (if transient-show-common-commands - "Hide common commands" - "Show common permanently"))) + :description ,(lambda () + (if transient-show-common-commands + "Hide common commands" + "Show common permanently"))) ("C-x l" "Show/hide suffixes" transient-set-level)]]))) +(defvar transient-popup-navigation-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "") #'transient-noop) + (define-key map (kbd "") #'transient-backward-button) + (define-key map (kbd "") #'transient-forward-button) + (define-key map (kbd "C-r") #'transient-isearch-backward) + (define-key map (kbd "C-s") #'transient-isearch-forward) + (define-key map (kbd "M-RET") #'transient-push-button) + map) + "One of the keymaps used when popup navigation is enabled. +See `transient-enable-popup-navigation'.") + +(defvar transient-button-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "") #'transient-push-button) + (define-key map (kbd "") #'transient-push-button) + map) + "One of the keymaps used when popup navigation is enabled. +See `transient-enable-popup-navigation'.") + (defvar transient-predicate-map (let ((map (make-sparse-keymap))) - (define-key map [handle-switch-frame] #'transient--do-suspend) (define-key map [transient-suspend] #'transient--do-suspend) (define-key map [transient-help] #'transient--do-stay) (define-key map [transient-set-level] #'transient--do-stay) (define-key map [transient-history-prev] #'transient--do-stay) (define-key map [transient-history-next] #'transient--do-stay) (define-key map [universal-argument] #'transient--do-stay) - (define-key map [negative-argument] #'transient--do-stay) + (define-key map [negative-argument] #'transient--do-minus) (define-key map [digit-argument] #'transient--do-stay) (define-key map [transient-quit-all] #'transient--do-quit-all) (define-key map [transient-quit-one] #'transient--do-quit-one) @@ -1542,6 +1620,7 @@ to `transient-predicate-map'. Also see `transient-base-map'.") (define-key map [transient-toggle-common] #'transient--do-stay) (define-key map [transient-set] #'transient--do-call) (define-key map [transient-save] #'transient--do-call) + (define-key map [transient-reset] #'transient--do-call) (define-key map [describe-key-briefly] #'transient--do-stay) (define-key map [describe-key] #'transient--do-stay) (define-key map [transient-scroll-up] #'transient--do-stay) @@ -1550,11 +1629,16 @@ to `transient-predicate-map'. Also see `transient-base-map'.") (define-key map [scroll-bar-toolkit-scroll] #'transient--do-stay) (define-key map [transient-noop] #'transient--do-noop) (define-key map [transient-mouse-push-button] #'transient--do-move) - (define-key map [transient-push-button] #'transient--do-move) + (define-key map [transient-push-button] #'transient--do-push-button) (define-key map [transient-backward-button] #'transient--do-move) (define-key map [transient-forward-button] #'transient--do-move) (define-key map [transient-isearch-backward] #'transient--do-move) (define-key map [transient-isearch-forward] #'transient--do-move) + ;; If a valid but incomplete prefix sequence is followed by + ;; an unbound key, then Emacs calls the `undefined' command + ;; but does not set `this-command', `this-original-command' + ;; or `real-this-command' accordingly. Instead they are nil. + (define-key map [nil] #'transient--do-warn) map) "Base keymap used to map common commands to their transient behavior. @@ -1574,22 +1658,24 @@ For transient commands that are bound in individual transients, the transient behavior is specified using the `:transient' slot of the corresponding object.") -(defvar transient-popup-navigation-map) - (defvar transient--transient-map nil) (defvar transient--predicate-map nil) (defvar transient--redisplay-map nil) (defvar transient--redisplay-key nil) -(defun transient--push-keymap (map) - (transient--debug " push %s%s" map (if (symbol-value map) "" " VOID")) - (with-demoted-errors "transient--push-keymap: %S" - (internal-push-keymap (symbol-value map) 'overriding-terminal-local-map))) +(defun transient--push-keymap (var) + (let ((map (symbol-value var))) + (transient--debug " push %s%s" var (if map "" " VOID")) + (when map + (with-demoted-errors "transient--push-keymap: %S" + (internal-push-keymap map 'overriding-terminal-local-map))))) -(defun transient--pop-keymap (map) - (transient--debug " pop %s%s" map (if (symbol-value map) "" " VOID")) - (with-demoted-errors "transient--pop-keymap: %S" - (internal-pop-keymap (symbol-value map) 'overriding-terminal-local-map))) +(defun transient--pop-keymap (var) + (let ((map (symbol-value var))) + (transient--debug " pop %s%s" var (if map "" " VOID")) + (when map + (with-demoted-errors "transient--pop-keymap: %S" + (internal-pop-keymap map 'overriding-terminal-local-map))))) (defun transient--make-transient-map () (let ((map (make-sparse-keymap))) @@ -1614,17 +1700,27 @@ of the corresponding object.") (string-trim key) cmd conflict))) (define-key map kbd cmd)))) + (when-let ((b (lookup-key map "-"))) (define-key map [kp-subtract] b)) + (when-let ((b (lookup-key map "="))) (define-key map [kp-equal] b)) + (when-let ((b (lookup-key map "+"))) (define-key map [kp-add] b)) (when transient-enable-popup-navigation - (setq map - (make-composed-keymap (list map transient-popup-navigation-map)))) + ;; `transient--make-redisplay-map' maps only over bindings that are + ;; directly in the base keymap, so that cannot be a composed keymap. + (set-keymap-parent + map (make-composed-keymap + (keymap-parent map) + transient-popup-navigation-map))) map)) (defun transient--make-predicate-map () (let ((map (make-sparse-keymap))) (set-keymap-parent map transient-predicate-map) + (when (memq (oref transient--prefix transient-non-suffix) + '(nil transient--do-warn transient--do-noop)) + (define-key map [handle-switch-frame] #'transient--do-suspend)) (dolist (obj transient--suffixes) (let* ((cmd (oref obj command)) - (sub-prefix (and (symbolp cmd) (get cmd 'transient--prefix))) + (sub-prefix (and (symbolp cmd) (get cmd 'transient--prefix) t)) (sym (transient--suffix-symbol cmd))) (cond ((oref obj inapt) @@ -1632,13 +1728,14 @@ of the corresponding object.") ((slot-boundp obj 'transient) (define-key map (vector sym) (let ((do (oref obj transient))) - (pcase do - (`t (cond (sub-prefix #'transient--do-replace) - ((cl-typep obj 'transient-infix) - #'transient--do-stay) - (t #'transient--do-call))) - (`nil 'transient--do-exit) - (_ do))))) + (pcase (list do sub-prefix) + ('(t t) #'transient--do-recurse) + ('(t nil) (if (cl-typep obj 'transient-infix) + #'transient--do-stay + #'transient--do-call)) + ('(nil t) #'transient--do-replace) + ('(nil nil) #'transient--do-exit) + (_ do))))) ((not (lookup-key transient-predicate-map (vector sym))) (define-key map (vector sym) (if sub-prefix @@ -1674,7 +1771,10 @@ of the corresponding object.") (define-key topmap (vconcat transient--redisplay-key (list key)) #'transient-update))) (if transient--redisplay-key - (lookup-key transient--transient-map (vconcat transient--redisplay-key)) + (let ((key (vconcat transient--redisplay-key))) + (or (lookup-key transient--transient-map key) + (and-let* ((regular (lookup-key local-function-key-map key))) + (lookup-key transient--transient-map (vconcat regular))))) transient--transient-map)) topmap)) @@ -1691,8 +1791,6 @@ be nil and PARAMS may be (but usually is not) used to set e.g. the This function is also called internally in which case LAYOUT and EDIT may be non-nil." (transient--debug 'setup) - (when (> (minibuffer-depth) 0) - (user-error "Cannot invoke transient %s while minibuffer is active" name)) (transient--with-emergency-exit (cond ((not name) @@ -1720,6 +1818,7 @@ EDIT may be non-nil." (setq transient--redisplay-map (transient--make-redisplay-map)) (setq transient--original-window (selected-window)) (setq transient--original-buffer (current-buffer)) + (setq transient--minibuffer-depth (minibuffer-depth)) (transient--redisplay) (transient--init-transient) (transient--suspend-which-key-mode))) @@ -1745,6 +1844,7 @@ value. Otherwise return CHILDREN as is." :level (or (alist-get t (alist-get name transient-levels)) transient-default-level) params)))) + (transient--setup-recursion obj) (transient-init-value obj) obj)) @@ -1758,13 +1858,13 @@ value. Otherwise return CHILDREN as is." (defun transient--flatten-suffixes (layout) (cl-labels ((s (def) - (cond - ((stringp def) nil) - ((listp def) (cl-mapcan #'s def)) - ((transient-group--eieio-childp def) - (cl-mapcan #'s (oref def suffixes))) - ((transient-suffix--eieio-childp def) - (list def))))) + (cond + ((stringp def) nil) + ((listp def) (cl-mapcan #'s def)) + ((transient-group--eieio-childp def) + (cl-mapcan #'s (oref def suffixes))) + ((transient-suffix--eieio-childp def) + (list def))))) (cl-mapcan #'s layout))) (defun transient--init-child (levels spec) @@ -1775,14 +1875,14 @@ value. Otherwise return CHILDREN as is." (defun transient--init-group (levels spec) (pcase-let ((`(,level ,class ,args ,children) (append spec nil))) - (when (transient--use-level-p level) - (let ((obj (apply class :level level args))) - (when (transient--use-suffix-p obj) - (when-let ((suffixes - (cl-mapcan (lambda (c) (transient--init-child levels c)) - (transient-setup-children obj children)))) - (oset obj suffixes suffixes) - (list obj))))))) + (when-let* ((- (transient--use-level-p level)) + (obj (apply class :level level args)) + (- (transient--use-suffix-p obj)) + (suffixes (cl-mapcan (lambda (c) (transient--init-child levels c)) + (transient-setup-children obj children)))) + ;; Cannot use and-let* because of debbugs#31840. + (oset obj suffixes suffixes) + (list obj)))) (defun transient--init-suffix (levels spec) (pcase-let* ((`(,level ,class ,args) spec) @@ -1878,7 +1978,7 @@ value. Otherwise return CHILDREN as is." (defun transient--suffix-predicate (spec) (let ((plist (nth 2 spec))) (seq-some (lambda (prop) - (when-let ((pred (plist-get plist prop))) + (and-let* ((pred (plist-get plist prop))) (list prop pred))) '( :if :if-not :if-nil :if-non-nil @@ -1895,11 +1995,8 @@ value. Otherwise return CHILDREN as is." (transient--debug 'init-transient) (transient--push-keymap 'transient--transient-map) (transient--push-keymap 'transient--redisplay-map) - (add-hook 'pre-command-hook #'transient--pre-command) - (add-hook 'minibuffer-setup-hook #'transient--minibuffer-setup) - (add-hook 'minibuffer-exit-hook #'transient--minibuffer-exit) - (add-hook 'post-command-hook #'transient--post-command) - (advice-add 'abort-recursive-edit :after #'transient--minibuffer-exit) + (add-hook 'pre-command-hook #'transient--pre-command) + (add-hook 'post-command-hook #'transient--post-command) (when transient--exitp ;; This prefix command was invoked as the suffix of another. ;; Prevent `transient--post-command' from removing the hooks @@ -1908,46 +2005,62 @@ value. Otherwise return CHILDREN as is." (defun transient--pre-command () (transient--debug 'pre-command) - (cond - ((memq this-command '(transient-update transient-quit-seq)) - (transient--pop-keymap 'transient--redisplay-map)) - ((and transient--helpp - (not (memq this-command '(transient-quit-one - transient-quit-all)))) + (transient--with-emergency-exit + ;; The use of `overriding-terminal-local-map' does not prevent the + ;; lookup of command remappings in the overridden maps, which can + ;; lead to a suffix being remapped to a non-suffix. We have to undo + ;; the remapping in that case. However, remapping a non-suffix to + ;; another should remain possible. + (when (and (transient--get-predicate-for this-original-command 'suffix) + (not (transient--get-predicate-for this-command 'suffix))) + (setq this-command this-original-command)) (cond - ((transient-help) - (transient--do-suspend) - (setq this-command 'transient-suspend) - (transient--pre-exit)) - ((not (transient--edebug-command-p)) - (setq this-command 'transient-undefined)))) - ((and transient--editp - (transient-suffix-object) - (not (memq this-command '(transient-quit-one - transient-quit-all - transient-help)))) - (setq this-command 'transient-set-level)) - (t - (setq transient--exitp nil) - (when (eq (if-let ((fn (transient--get-predicate-for - this-original-command))) - (let ((action (funcall fn))) - (when (eq action transient--exit) - (setq transient--exitp (or transient--exitp t))) - action) - (if (let ((keys (this-command-keys-vector))) - (eq (aref keys (1- (length keys))) ?\C-g)) - (setq this-command 'transient-noop) - (unless (transient--edebug-command-p) - (setq this-command 'transient-undefined))) - transient--stay) - transient--exit) - (transient--pre-exit))))) - -(defun transient--get-predicate-for (cmd) - (or (lookup-key transient--predicate-map - (vector (transient--suffix-symbol cmd))) - (oref transient--prefix transient-non-suffix))) + ((memq this-command '(transient-update transient-quit-seq)) + (transient--pop-keymap 'transient--redisplay-map)) + ((and transient--helpp + (not (memq this-command '(transient-quit-one + transient-quit-all)))) + (cond + ((transient-help) + (transient--do-suspend) + (setq this-command 'transient-suspend) + (transient--pre-exit)) + ((not (transient--edebug-command-p)) + (setq this-command 'transient-undefined)))) + ((and transient--editp + (transient-suffix-object) + (not (memq this-command '(transient-quit-one + transient-quit-all + transient-help)))) + (setq this-command 'transient-set-level)) + (t + (setq transient--exitp nil) + (when (eq (transient--do-pre-command) transient--exit) + (transient--pre-exit)))))) + +(defun transient--do-pre-command () + (if-let ((fn (transient--get-predicate-for this-command))) + (let ((action (funcall fn))) + (when (eq action transient--exit) + (setq transient--exitp (or transient--exitp t))) + action) + (if (let ((keys (this-command-keys-vector))) + (eq (aref keys (1- (length keys))) ?\C-g)) + (setq this-command 'transient-noop) + (unless (transient--edebug-command-p) + (setq this-command 'transient-undefined))) + transient--stay)) + +(defun transient--get-predicate-for (cmd &optional suffix-only) + (or (ignore-errors + (lookup-key transient--predicate-map + (vector (transient--suffix-symbol cmd)))) + (and (not suffix-only) + (let ((pred (oref transient--prefix transient-non-suffix))) + (pcase pred + ('t #'transient--do-stay) + ('nil #'transient--do-warn) + (_ pred)))))) (defun transient--pre-exit () (transient--debug 'pre-exit) @@ -1955,7 +2068,6 @@ value. Otherwise return CHILDREN as is." (transient--timer-cancel) (transient--pop-keymap 'transient--transient-map) (transient--pop-keymap 'transient--redisplay-map) - (remove-hook 'pre-command-hook #'transient--pre-command) (unless transient--showp (let ((message-log-max nil)) (message ""))) @@ -1963,7 +2075,6 @@ value. Otherwise return CHILDREN as is." (setq transient--predicate-map nil) (setq transient--redisplay-map nil) (setq transient--redisplay-key nil) - (setq transient--showp nil) (setq transient--helpp nil) (setq transient--editp nil) (setq transient--prefix nil) @@ -1975,12 +2086,17 @@ value. Otherwise return CHILDREN as is." (defun transient--delete-window () (when (window-live-p transient--window) - (let ((buf (window-buffer transient--window))) + (let ((remain-in-minibuffer-window + (and (minibuffer-selected-window) + (selected-window))) + (buf (window-buffer transient--window))) ;; Only delete the window if it never showed another buffer. (unless (eq (car (window-parameter transient--window 'quit-restore)) 'other) (with-demoted-errors "Error while exiting transient: %S" (delete-window transient--window))) - (kill-buffer buf)))) + (kill-buffer buf) + (when remain-in-minibuffer-window + (select-window remain-in-minibuffer-window))))) (defun transient--export () (setq transient-current-prefix transient--prefix) @@ -1988,80 +2104,155 @@ value. Otherwise return CHILDREN as is." (setq transient-current-suffixes transient--suffixes) (transient--history-push transient--prefix)) -(defun transient--minibuffer-setup () - (transient--debug 'minibuffer-setup) - (unless (> (minibuffer-depth) 1) - (unless transient--exitp - (transient--pop-keymap 'transient--transient-map) - (transient--pop-keymap 'transient--redisplay-map) - (remove-hook 'pre-command-hook #'transient--pre-command)) - (remove-hook 'post-command-hook #'transient--post-command))) - -(defun transient--minibuffer-exit () - (transient--debug 'minibuffer-exit) - (unless (> (minibuffer-depth) 1) - (unless transient--exitp - (transient--push-keymap 'transient--transient-map) - (transient--push-keymap 'transient--redisplay-map) - (add-hook 'pre-command-hook #'transient--pre-command)) - (add-hook 'post-command-hook #'transient--post-command))) - -(defun transient--suspend-override (&optional minibuffer-hooks) +(defun transient--suspend-override (&optional nohide) (transient--debug 'suspend-override) + (transient--timer-cancel) + (cond ((and (not nohide) transient-hide-during-minibuffer-read) + (transient--delete-window)) + ((and transient--prefix transient--redisplay-key) + (setq transient--redisplay-key nil) + (when transient--showp + (transient--show)))) (transient--pop-keymap 'transient--transient-map) (transient--pop-keymap 'transient--redisplay-map) (remove-hook 'pre-command-hook #'transient--pre-command) - (remove-hook 'post-command-hook #'transient--post-command) - (when minibuffer-hooks - (remove-hook 'minibuffer-setup-hook #'transient--minibuffer-setup) - (remove-hook 'minibuffer-exit-hook #'transient--minibuffer-exit) - (advice-remove 'abort-recursive-edit #'transient--minibuffer-exit))) + (remove-hook 'post-command-hook #'transient--post-command)) -(defun transient--resume-override (&optional minibuffer-hooks) +(defun transient--resume-override () (transient--debug 'resume-override) + (when (and transient--showp transient-hide-during-minibuffer-read) + (transient--show)) (transient--push-keymap 'transient--transient-map) (transient--push-keymap 'transient--redisplay-map) (add-hook 'pre-command-hook #'transient--pre-command) - (add-hook 'post-command-hook #'transient--post-command) - (when minibuffer-hooks - (add-hook 'minibuffer-setup-hook #'transient--minibuffer-setup) - (add-hook 'minibuffer-exit-hook #'transient--minibuffer-exit) - (advice-add 'abort-recursive-edit :after #'transient--minibuffer-exit))) + (add-hook 'post-command-hook #'transient--post-command)) + +(defmacro transient--with-suspended-override (&rest body) + (let ((depth (make-symbol "depth")) + (setup (make-symbol "setup")) + (exit (make-symbol "exit"))) + `(if (and transient--transient-map + (memq transient--transient-map + overriding-terminal-local-map)) + (let ((,depth (1+ (minibuffer-depth))) ,setup ,exit) + (setq ,setup + (lambda () "@transient--with-suspended-override" + (transient--debug 'minibuffer-setup) + (remove-hook 'minibuffer-setup-hook ,setup) + (transient--suspend-override))) + (setq ,exit + (lambda () "@transient--with-suspended-override" + (transient--debug 'minibuffer-exit) + (when (= (minibuffer-depth) ,depth) + (transient--resume-override)))) + (unwind-protect + (progn + (add-hook 'minibuffer-setup-hook ,setup) + (add-hook 'minibuffer-exit-hook ,exit) + ,@body) + (remove-hook 'minibuffer-setup-hook ,setup) + (remove-hook 'minibuffer-exit-hook ,exit))) + ,@body))) + +(defun transient--post-command-hook () + (run-hooks 'transient--post-command-hook)) + +(add-hook 'post-command-hook #'transient--post-command-hook) + +(defun transient--delay-post-command (&optional abort-only) + (transient--debug 'delay-post-command) + (let ((depth (minibuffer-depth)) + (command this-command) + (delayed (if transient--exitp + (apply-partially #'transient--post-exit this-command) + #'transient--resume-override)) + post-command abort-minibuffer) + (unless abort-only + (setq post-command + (lambda () "@transient--delay-post-command" + (let ((act (and (not (eq (this-command-keys-vector) [])) + (or (eq this-command command) + ;; `execute-extended-command' was + ;; used to call another command + ;; that also uses the minibuffer. + (equal + (string-to-multibyte (this-command-keys)) + (format "\M-x%s\r" this-command)))))) + (transient--debug 'post-command-hook "act: %s" act) + (when act + (remove-hook 'transient--post-command-hook post-command) + (remove-hook 'minibuffer-exit-hook abort-minibuffer) + (funcall delayed))))) + (add-hook 'transient--post-command-hook post-command)) + (setq abort-minibuffer + (lambda () "@transient--delay-post-command" + (let ((act (and (or (memq this-command transient--abort-commands) + (equal (this-command-keys) "")) + (= (minibuffer-depth) depth)))) + (transient--debug + 'abort-minibuffer + "mini: %s|%s, act %s" (minibuffer-depth) depth act) + (when act + (remove-hook 'transient--post-command-hook post-command) + (remove-hook 'minibuffer-exit-hook abort-minibuffer) + (funcall delayed))))) + (add-hook 'minibuffer-exit-hook abort-minibuffer))) (defun transient--post-command () (transient--debug 'post-command) - (unless this-command - (transient--debug "-- force pre-exit from post-command") - (message "Quit transient!") - (transient--pre-exit) - (setq transient--exitp t)) - (if transient--exitp - (progn - (unless (and (eq transient--exitp 'replace) - (or transient--prefix - ;; The current command could act as a prefix, - ;; but decided not to call `transient-setup'. - (prog1 nil (transient--stack-zap)))) - (remove-hook 'minibuffer-setup-hook #'transient--minibuffer-setup) - (remove-hook 'minibuffer-exit-hook #'transient--minibuffer-exit) - (advice-remove 'abort-recursive-edit #'transient--minibuffer-exit) - (remove-hook 'post-command-hook #'transient--post-command)) - (setq transient-current-prefix nil) - (setq transient-current-command nil) - (setq transient-current-suffixes nil) - (let ((resume (and transient--stack - (not (memq transient--exitp '(replace suspend)))))) - (setq transient--exitp nil) - (setq transient--helpp nil) - (setq transient--editp nil) - (run-hooks 'transient-exit-hook) - (when resume - (transient--stack-pop)))) - (transient--pop-keymap 'transient--redisplay-map) - (setq transient--redisplay-map (transient--make-redisplay-map)) - (transient--push-keymap 'transient--redisplay-map) - (unless (eq this-command (oref transient--prefix command)) - (transient--redisplay)))) + (transient--with-emergency-exit + (cond + ((and (eq (this-command-keys-vector) []) + (= (minibuffer-depth) + (1+ transient--minibuffer-depth))) + (transient--suspend-override) + (transient--delay-post-command (eq transient--exitp 'replace))) + (transient--exitp + (transient--post-exit)) + ((eq this-command (oref transient--prefix command))) + (t + (let ((old transient--redisplay-map) + (new (transient--make-redisplay-map))) + (unless (equal old new) + (transient--pop-keymap 'transient--redisplay-map) + (setq transient--redisplay-map new) + (transient--push-keymap 'transient--redisplay-map))) + (transient--redisplay))))) + +(defun transient--post-exit (&optional command) + (transient--debug 'post-exit) + (unless (and (eq transient--exitp 'replace) + (or transient--prefix + ;; The current command could act as a prefix, + ;; but decided not to call `transient-setup', + ;; or it is prevented from doing so because it + ;; uses the minibuffer and the user aborted + ;; that. + (prog1 nil + (if (let ((obj (transient-suffix-object command))) + (and (slot-boundp obj 'transient) + (oref obj transient))) + ;; This sub-prefix is a transient suffix; + ;; go back to outer prefix, by calling + ;; `transient--stack-pop' further down. + (setq transient--exitp nil) + (transient--stack-zap))))) + (remove-hook 'pre-command-hook #'transient--pre-command) + (remove-hook 'post-command-hook #'transient--post-command)) + (setq transient-current-prefix nil) + (setq transient-current-command nil) + (setq transient-current-suffixes nil) + (let ((resume (and transient--stack + (not (memq transient--exitp '(replace suspend)))))) + (unless (or resume (eq transient--exitp 'replace)) + (setq transient--showp nil)) + (setq transient--exitp nil) + (setq transient--helpp nil) + (setq transient--editp nil) + (setq transient--minibuffer-depth 0) + (run-hooks 'transient-exit-hook) + (when resume + (transient--stack-pop)))) (defun transient--stack-push () (transient--debug 'stack-push) @@ -2083,7 +2274,14 @@ value. Otherwise return CHILDREN as is." (defun transient--redisplay () (if (or (eq transient-show-popup t) transient--showp) - (unless (memq this-command transient--scroll-commands) + (unless + (or (memq this-command transient--scroll-commands) + (and (or (memq this-command '(mouse-drag-region + mouse-set-region)) + (equal (key-description (this-command-keys-vector)) + "")) + (and (eq (current-buffer) + (get-buffer transient--buffer-name))))) (transient--show)) (when (and (numberp transient-show-popup) (not (zerop transient-show-popup)) @@ -2107,14 +2305,22 @@ value. Otherwise return CHILDREN as is." (defun transient--debug (arg &rest args) (when transient--debug - (if (symbolp arg) - (message "-- %-16s (cmd: %s, event: %S, exit: %s)" - arg - (or (transient--suffix-symbol this-command) - (list this-command this-original-command last-command)) - (key-description (this-command-keys-vector)) - transient--exitp) - (apply #'message arg args)))) + (let ((inhibit-message (not (eq transient--debug 'message)))) + (if (symbolp arg) + (message "-- %-18s (cmd: %s, event: %S, exit: %s%s)" + arg + (or (ignore-errors (transient--suffix-symbol this-command)) + (if (byte-code-function-p this-command) + "#[...]" + this-command)) + (key-description (this-command-keys-vector)) + transient--exitp + (cond ((stringp (car args)) + (concat ", " (apply #'format args))) + (args + (concat ", " (apply (car args) (cdr args)))) + (t ""))) + (apply #'message arg args))))) (defun transient--emergency-exit () "Exit the current transient command after an error occurred. @@ -2125,7 +2331,7 @@ nil) then do nothing." (setq transient--stack nil) (setq transient--exitp t) (transient--pre-exit) - (transient--post-command))) + (transient--post-exit))) ;;; Pre-Commands @@ -2153,12 +2359,49 @@ nil) then do nothing." (transient--export) transient--stay) +(defun transient--do-return () + "Call the command after exporting variables and return to parent prefix. +If there is no parent prefix, then behave like `transient--do-exit'." + (if (not transient--stack) + (transient--do-exit) + (transient--export) + transient--exit)) + (defun transient--do-exit () "Call the command after exporting variables and exit the transient." (transient--export) (transient--stack-zap) transient--exit) +(defun transient--do-push-button () + "Call the command represented by the activated button. +Use that command's pre-command to determine transient behavior." + (if (and (mouse-event-p last-command-event) + (not (eq (posn-window (event-start last-command-event)) + transient--window))) + transient--stay + (setq this-command + (with-selected-window transient--window + (get-text-property (if (mouse-event-p last-command-event) + (posn-point (event-start last-command-event)) + (point)) + 'command))) + (transient--do-pre-command))) + +(defun transient--do-recurse () + "Call the transient prefix command, preparing for return to active transient. +If there is no parent prefix, then just call the command." + (transient--do-replace)) + +(defun transient--setup-recursion (prefix-obj) + (when transient--stack + (let ((command (oref prefix-obj command))) + (when-let ((suffix-obj (transient-suffix-object command))) + (when (and (slot-boundp suffix-obj 'transient) + (memq (oref suffix-obj transient) + (list t #'transient--do-recurse))) + (oset prefix-obj transient-suffix 'transient--do-return)))))) + (defun transient--do-replace () "Call the transient prefix command, replacing the active transient." (transient--export) @@ -2196,17 +2439,28 @@ to `transient--do-warn'." (setq this-command 'transient-popup-navigation-help)) transient--stay) +(defun transient--do-minus () + "Call `negative-argument' or pivot to `transient-update'. +If `negative-argument' is invoked using \"-\" then preserve the +prefix argument and pivot to `transient-update'." + (when (equal (this-command-keys) "-") + (setq this-command 'transient-update)) + transient--stay) + (put 'transient--do-stay 'transient-color 'transient-red) (put 'transient--do-noop 'transient-color 'transient-red) (put 'transient--do-warn 'transient-color 'transient-red) (put 'transient--do-warn-inapt 'transient-color 'transient-red) (put 'transient--do-call 'transient-color 'transient-red) +(put 'transient--do-return 'transient-color 'transient-purple) (put 'transient--do-exit 'transient-color 'transient-blue) +(put 'transient--do-recurse 'transient-color 'transient-red) (put 'transient--do-replace 'transient-color 'transient-blue) (put 'transient--do-suspend 'transient-color 'transient-blue) (put 'transient--do-quit-one 'transient-color 'transient-blue) (put 'transient--do-quit-all 'transient-color 'transient-blue) (put 'transient--do-move 'transient-color 'transient-red) +(put 'transient--do-minus 'transient-color 'transient-red) ;;; Commands @@ -2232,6 +2486,8 @@ to `transient--do-warn'." 'face 'font-lock-warning-face) (propertize "C-g" 'face 'transient-key) (propertize "?" 'face 'transient-key) + ;; `this-command' is `transient--undefined' or similar at this + ;; point. Show the command the user actually tried to invoke. (propertize (symbol-name (transient--suffix-symbol this-original-command)) 'face 'font-lock-warning-face)) @@ -2272,7 +2528,9 @@ transient is active." (defun transient-update () "Redraw the transient's state in the popup buffer." - (interactive)) + (interactive) + (when (equal this-original-command 'negative-argument) + (setq prefix-arg current-prefix-arg))) (defun transient-show () "Show the transient's state in the popup buffer." @@ -2337,7 +2595,8 @@ transient is active." (oset (transient-suffix-object command) level level)) (setf (alist-get sym alist) level) (setf (alist-get prefix transient-levels) alist)) - (transient-save-levels)) + (transient-save-levels) + (transient--show)) (t (transient-undefined)))) @@ -2351,6 +2610,11 @@ transient is active." (interactive) (transient-save-value (or transient--prefix transient-current-prefix))) +(defun transient-reset () + "Clear the set and saved values of the active transient." + (interactive) + (transient-reset-value (or transient--prefix transient-current-prefix))) + (defun transient-history-next () "Switch to the next value used for the active transient." (interactive) @@ -2392,6 +2656,10 @@ around `scroll-down-command' (which see)." (with-selected-window transient--window (scroll-down-command arg))) +(defun transient-push-button () + "Invoke the suffix command represented by this button." + (interactive)) + (defun transient-resume () "Resume a previously suspended stack of transients." (interactive) @@ -2461,12 +2729,7 @@ Otherwise call the primary method according to object's class." (oset obj value (if-let ((saved (assq (oref obj command) transient-values))) (cdr saved) - (if-let ((default (and (slot-boundp obj 'default-value) - (oref obj default-value)))) - (if (functionp default) - (funcall default) - default) - nil))))) + (transient-default-value obj))))) (cl-defmethod transient-init-value ((obj transient-argument)) (oset obj value @@ -2474,6 +2737,7 @@ Otherwise call the primary method according to object's class." (argument (and (slot-boundp obj 'argument) (oref obj argument))) (multi-value (oref obj multi-value)) + (case-fold-search nil) (regexp (if (slot-exists-p obj 'argument-regexp) (oref obj argument-regexp) (format "\\`%s\\(.*\\)" (oref obj argument))))) @@ -2492,6 +2756,20 @@ Otherwise call the primary method according to object's class." (car (member (oref obj argument) (oref transient--prefix value))))) +;;;; Default + +(cl-defgeneric transient-default-value (_) + "Return the default value." + nil) + +(cl-defmethod transient-default-value ((obj transient-prefix)) + (if-let ((default (and (slot-boundp obj 'default-value) + (oref obj default-value)))) + (if (functionp default) + (funcall default) + default) + nil)) + ;;;; Read (cl-defgeneric transient-infix-read (obj) @@ -2512,13 +2790,24 @@ on the previous value.") (cl-defmethod transient-infix-read :around ((obj transient-infix)) "Highlight the infix in the popup buffer. -Also arrange for the transient to be exited in case of an error -because otherwise Emacs would get stuck in an inconsistent state, -which might make it necessary to kill it from the outside." +This also wraps the call to `cl-call-next-method' with two +macros. + +`transient--with-suspended-override' is necessary to allow +reading user input using the minibuffer. + +`transient--with-emergency-exit' arranges for the transient to +be exited in case of an error because otherwise Emacs would get +stuck in an inconsistent state, which might make it necessary to +kill it from the outside. + +If you replace this method, then you must make sure to always use +the latter macro and most likely also the former." (let ((transient--active-infix obj)) (transient--show)) (transient--with-emergency-exit - (cl-call-next-method obj))) + (transient--with-suspended-override + (cl-call-next-method obj)))) (cl-defmethod transient-infix-read ((obj transient-infix)) "Read a value while taking care of history. @@ -2542,7 +2831,7 @@ it\", in which case it is pointless to preserve history.)" (not always-read) transient--prefix) (oset obj value nil) - (let* ((overriding-terminal-local-map nil) + (let* ((enable-recursive-minibuffers t) (reader (oref obj reader)) (prompt (transient-prompt obj)) (value (if multi-value (mapconcat #'identity value ",") value)) @@ -2678,11 +2967,11 @@ prompt." (if (stringp prompt) prompt "(BUG: no prompt): ")) - (or (when-let ((arg (and (slot-boundp obj 'argument) (oref obj argument)))) + (or (and-let* ((arg (and (slot-boundp obj 'argument) (oref obj argument)))) (if (and (stringp arg) (string-suffix-p "=" arg)) arg (concat arg ": "))) - (when-let ((var (and (slot-boundp obj 'variable) (oref obj variable)))) + (and-let* ((var (and (slot-boundp obj 'variable) (oref obj variable)))) (and (stringp var) (concat var ": "))) "(BUG: no prompt): "))) @@ -2720,12 +3009,18 @@ prompt." (transient-infix-set obj nil))))) (cl-call-next-method obj value)))) +(cl-defgeneric transient-set-value (obj) + "Set the value of the transient prefix OBJ.") + (cl-defmethod transient-set-value ((obj transient-prefix)) (oset (oref obj prototype) value (transient-get-value)) (transient--history-push obj)) ;;;; Save +(cl-defgeneric transient-save-value (obj) + "Save the value of the transient prefix OBJ.") + (cl-defmethod transient-save-value ((obj transient-prefix)) (let ((value (transient-get-value))) (oset (oref obj prototype) value value) @@ -2733,6 +3028,20 @@ prompt." (transient-save-values)) (transient--history-push obj)) +;;;; Reset + +(cl-defgeneric transient-reset-value (obj) + "Clear the set and saved values of the transient prefix OBJ.") + +(cl-defmethod transient-reset-value ((obj transient-prefix)) + (let ((value (transient-default-value obj))) + (oset obj value value) + (oset (oref obj prototype) value value) + (setf (alist-get (oref obj command) transient-values nil 'remove) nil) + (transient-save-values)) + (transient--history-push obj) + (mapc #'transient-init-value transient--suffixes)) + ;;;; Get (defun transient-args (prefix) @@ -2760,7 +3069,7 @@ the set, saved or default value for PREFIX." transient-current-suffixes))) (defun transient--get-wrapped-value (obj) - (when-let ((value (transient-infix-value obj))) + (and-let* ((value (transient-infix-value obj))) (cl-ecase (and (slot-exists-p obj 'multi-value) (oref obj multi-value)) ((nil) (list value)) @@ -2798,7 +3107,7 @@ does nothing." nil) (cl-defmethod transient-infix-value ((obj transient-option)) "Return ARGUMENT and VALUE as a unit or nil if the latter is nil." - (when-let ((value (oref obj value))) + (and-let* ((value (oref obj value))) (let ((arg (oref obj argument))) (cl-ecase (oref obj multi-value) ((nil) (concat arg value)) @@ -2821,9 +3130,10 @@ contribute to the value of the transient." For a switch return a boolean. For an option return the value as a string, using the empty string for the empty value, or nil if the option does not appear in ARGS." - (if (string-match-p "=\\'" arg) + (if (string-suffix-p "=" arg) (save-match-data - (when-let ((match (let ((re (format "\\`%s\\(?:=\\(.+\\)\\)?\\'" + (and-let* ((match (let ((case-fold-search nil) + (re (format "\\`%s\\(?:=\\(.+\\)\\)?\\'" (substring arg 0 -1)))) (cl-find-if (lambda (a) (and (stringp a) @@ -2906,6 +3216,7 @@ have a history of their own.") (setq window-size-fixed t) (when (bound-and-true-p tab-line-format) (setq tab-line-format nil)) + (setq header-line-format nil) (setq mode-line-format (if (eq transient-mode-line-format 'line) nil transient-mode-line-format)) @@ -2963,13 +3274,18 @@ have a history of their own.") (when groups (insert ?\n))))) +(defvar transient--max-group-level 1) + (cl-defgeneric transient--insert-group (group) "Format GROUP and its elements and insert the result.") -(cl-defmethod transient--insert-group :before ((group transient-group)) +(cl-defmethod transient--insert-group :around ((group transient-group)) "Insert GROUP's description, if any." (when-let ((desc (transient-format-description group))) - (insert desc ?\n))) + (insert desc ?\n)) + (let ((transient--max-group-level + (max (oref group level) transient--max-group-level))) + (cl-call-next-method group))) (cl-defmethod transient--insert-group ((group transient-row)) (transient--maybe-pad-keys group) @@ -2994,9 +3310,10 @@ have a history of their own.") (let ((rows (mapcar #'transient-format (oref column suffixes)))) (when-let ((desc (transient-format-description column))) (push desc rows)) - rows)) + (flatten-tree rows))) (oref group suffixes))) - (vp (oref transient--prefix variable-pitch)) + (vp (or (oref transient--prefix variable-pitch) + transient-align-variable-pitch)) (rs (apply #'max (mapcar #'length columns))) (cs (length columns)) (cw (mapcar (lambda (col) @@ -3096,7 +3413,7 @@ Optional support for popup buttons is also implemented here." (add-face-text-property 0 (length str) 'transient-inapt-suffix nil str)) (if transient-enable-popup-navigation (make-text-button str nil - 'type 'transient-button + 'type 'transient 'command (transient--suffix-command obj)) str))) @@ -3129,27 +3446,33 @@ Optional support for popup buttons is also implemented here." (let ((len (length transient--redisplay-key)) (seq (cl-coerce (edmacro-parse-keys key t) 'list))) (cond - ((equal (seq-take seq len) transient--redisplay-key) + ((member (seq-take seq len) + (list transient--redisplay-key + (thread-last transient--redisplay-key + (cl-substitute ?- 'kp-subtract) + (cl-substitute ?= 'kp-equal) + (cl-substitute ?+ 'kp-add)))) (let ((pre (key-description (vconcat (seq-take seq len)))) (suf (key-description (vconcat (seq-drop seq len))))) - (setq pre (replace-regexp-in-string "RET" "C-m" pre t)) - (setq pre (replace-regexp-in-string "TAB" "C-i" pre t)) - (setq suf (replace-regexp-in-string "RET" "C-m" suf t)) - (setq suf (replace-regexp-in-string "TAB" "C-i" suf t)) + (setq pre (string-replace "RET" "C-m" pre)) + (setq pre (string-replace "TAB" "C-i" pre)) + (setq suf (string-replace "RET" "C-m" suf)) + (setq suf (string-replace "TAB" "C-i" suf)) ;; We use e.g. "-k" instead of the more correct "- k", ;; because the former is prettier. If we did that in ;; the definition, then we want to drop the space that ;; is reinserted above. False-positives are possible ;; for silly bindings like "-C-c C-c". - (unless (string-match-p " " key) - (setq pre (replace-regexp-in-string " " "" pre)) - (setq suf (replace-regexp-in-string " " "" suf))) - (concat (propertize pre 'face 'default) + (unless (string-search " " key) + (setq pre (string-replace " " "" pre)) + (setq suf (string-replace " " "" suf))) + (concat (propertize pre 'face 'transient-unreachable-key) (and (string-prefix-p (concat pre " ") key) " ") (transient--colorize-key suf cmd) (save-excursion - (when (string-match " +\\'" key) - (match-string 0 key)))))) + (and (string-match " +\\'" key) + (propertize (match-string 0 key) + 'face 'fixed-pitch)))))) ((transient--lookup-key transient-sticky-map (kbd key)) (transient--colorize-key key cmd)) (t @@ -3180,7 +3503,7 @@ Optional support for popup buttons is also implemented here." "The `description' slot may be a function, in which case that is called inside the correct buffer (see `transient-insert-group') and its value is returned to the caller." - (when-let ((desc (oref obj description))) + (and-let* ((desc (oref obj description))) (if (functionp desc) (with-current-buffer transient--original-buffer (funcall desc)) @@ -3190,7 +3513,7 @@ and its value is returned to the caller." "Format the description by calling the next method. If the result doesn't use the `face' property at all, then apply the face `transient-heading' to the complete string." - (when-let ((desc (cl-call-next-method obj))) + (and-let* ((desc (cl-call-next-method obj))) (if (text-property-not-all 0 (length desc) 'face nil desc) desc (propertize desc 'face 'transient-heading)))) @@ -3208,7 +3531,8 @@ If the OBJ's `key' is currently unreachable, then apply the face (cond ((transient--key-unreachable-p obj) (propertize desc 'face 'transient-unreachable)) ((and transient-highlight-higher-levels - (> (oref obj level) transient--default-prefix-level)) + (> (max (oref obj level) transient--max-group-level) + transient--default-prefix-level)) (add-face-text-property 0 (length desc) 'transient-higher-level nil desc) desc) @@ -3344,9 +3668,24 @@ manpage, then try to jump to the correct location." (transient--describe-function cmd)) (defun transient--describe-function (fn) - (describe-function fn) + (describe-function (if (symbolp fn) fn 'transient--anonymous-infix-argument)) (select-window (get-buffer-window (help-buffer)))) +(defun transient--anonymous-infix-argument () + "Cannot show any documentation for this anonymous infix command. + +The infix command in question was defined anonymously, i.e., +it was define when the prefix command that it belongs to was +defined, which means that it gets no docstring and also that +no symbol is bound to it. + +When you request help for an infix command, then we usually +show the respective man-page and jump to the location where +the respective argument is being described. + +Because the containing prefix command does not specify any +man-page, we cannot do that in this case. Sorry about that.") + (defun transient--show-manual (manual) (info manual)) @@ -3454,8 +3793,14 @@ resumes the suspended transient.") (define-minor-mode transient-resume-mode "Auxiliary minor-mode used to resume a transient after viewing help.") -;;; Compatibility -;;;; Popup Navigation +(defun transient-toggle-debug () + "Toggle debugging statements for transient commands." + (interactive) + (setq transient--debug (not transient--debug)) + (message "Debugging transient %s" + (if transient--debug "enabled" "disabled"))) + +;;; Popup Navigation (defun transient-popup-navigation-help () "Inform the user how to enable popup navigation commands." @@ -3463,39 +3808,9 @@ resumes the suspended transient.") (message "This command is only available if `%s' is non-nil" 'transient-enable-popup-navigation)) -(define-button-type 'transient-button +(define-button-type 'transient 'face nil - 'action (lambda (button) - (let ((command (button-get button 'command))) - ;; Yes, I know that this is wrong(tm). - ;; Unfortunately it is also necessary. - (setq this-original-command command) - (transient--pre-command) - (call-interactively command)))) - -(defvar transient-popup-navigation-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "") #'transient-noop) - (define-key map (kbd "") #'transient-mouse-push-button) - (define-key map (kbd "RET") #'transient-push-button) - (define-key map (kbd "") #'transient-backward-button) - (define-key map (kbd "C-p") #'transient-backward-button) - (define-key map (kbd "") #'transient-forward-button) - (define-key map (kbd "C-n") #'transient-forward-button) - (define-key map (kbd "C-r") #'transient-isearch-backward) - (define-key map (kbd "C-s") #'transient-isearch-forward) - map)) - -(defun transient-mouse-push-button (&optional pos) - "Invoke the suffix the user clicks on." - (interactive (list last-command-event)) - (push-button pos)) - -(defun transient-push-button () - "Invoke the selected suffix command." - (interactive) - (with-selected-window transient--window - (push-button))) + 'keymap transient-button-map) (defun transient-backward-button (n) "Move to the previous button in the transient popup buffer. @@ -3530,6 +3845,7 @@ See `forward-button' for information about N." beg (next-single-property-change beg 'face nil (line-end-position)))))) +;;; Compatibility ;;;; Popup Isearch (defvar transient--isearch-mode-map @@ -3578,7 +3894,7 @@ search instead." (defun transient--isearch-setup () (select-window transient--window) - (transient--suspend-override)) + (transient--suspend-override t)) (defun transient--isearch-exit () (select-window transient--original-window) @@ -3607,11 +3923,12 @@ search instead." 'transient-red 'transient-blue)))) (pcase (list suffix nonsuf) - (`(transient-red disallow) 'transient-amaranth) - (`(transient-blue disallow) 'transient-teal) - (`(transient-red transient-red) 'transient-pink) - (`(transient-red transient-blue) 'transient-red) - (`(transient-blue transient-blue) 'transient-blue)))) + (`(transient-purple ,_) 'transient-purple) + ('(transient-red disallow) 'transient-amaranth) + ('(transient-blue disallow) 'transient-teal) + ('(transient-red transient-red) 'transient-pink) + ('(transient-red transient-blue) 'transient-red) + ('(transient-blue transient-blue) 'transient-blue)))) ;;;; Edebug @@ -3621,7 +3938,7 @@ search instead." (funcall fn arg-mode) (transient--suspend-override t) (funcall fn arg-mode) - (transient--resume-override t))) + (transient--resume-override))) (advice-add 'edebug--recursive-edit :around #'transient--edebug--recursive-edit) @@ -3639,6 +3956,18 @@ search instead." ;;;; Miscellaneous +(cl-pushnew (list nil (concat "^\\s-*(" + (eval-when-compile + (regexp-opt + '("transient-define-prefix" + "transient-define-suffix" + "transient-define-infix" + "transient-define-argument") + t)) + "\\s-+\\(" lisp-mode-symbol-regexp "\\)") + 2) + lisp-imenu-generic-expression :test #'equal) + (declare-function which-key-mode "which-key" (&optional arg)) (defun transient--suspend-which-key-mode () @@ -3741,7 +4070,7 @@ we stop there." (oset obj value value))) (cl-defmethod transient-format-description ((obj transient-lisp-variable)) - (or (oref obj description) + (or (cl-call-next-method obj) (symbol-name (oref obj variable)))) (cl-defmethod transient-format-value ((obj transient-lisp-variable)) commit d60ba336af9ecbad4250b64bbe289f5822c8babf Author: Stefan Kangas Date: Wed Aug 3 11:52:57 2022 +0200 Improve obsoletion of trimming functions in url-util.el * lisp/url/url-util.el (url-eat-trailing-space): Redefine as obsolete function alias for 'string-trim-right'. (url-strip-leading-spaces): Redefine as obsolete function alias for 'string-trim-left'. diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el index a6a4becceb..b7fdd73762 100644 --- a/lisp/url/url-util.el +++ b/lisp/url/url-util.el @@ -180,17 +180,12 @@ Will not do anything if `url-show-status' is nil." (format-time-string "%a, %d %b %Y %T GMT" specified-time t))) ;;;###autoload -(defun url-eat-trailing-space (x) - "Remove spaces/tabs at the end of a string." - (declare (obsolete string-trim "29.1")) - (string-trim x "")) +(define-obsolete-function-alias 'url-eat-trailing-space + #'string-trim-right "29.1") ;;;###autoload -(defun url-strip-leading-spaces (x) - "Remove spaces at the front of a string." - (declare (obsolete string-trim "29.1")) - (string-trim x nil "")) - +(define-obsolete-function-alias 'url-strip-leading-spaces + #'string-trim-left "29.1") (define-obsolete-function-alias 'url-pretty-length 'file-size-human-readable "24.4") commit 165675797efdddb32170ce58ddf5c8ec813f1d4a Author: Stefan Kangas Date: Wed Aug 3 11:48:45 2022 +0200 Use string-trim in newsticker--remove-whitespace * lisp/net/newst-backend.el (newsticker--remove-whitespace): Use string-trim. diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el index 5ae2df769a..f65ef522f2 100644 --- a/lisp/net/newst-backend.el +++ b/lisp/net/newst-backend.el @@ -1552,12 +1552,8 @@ argument, which is one of the items in ITEMLIST." (defun newsticker--remove-whitespace (string) "Remove leading and trailing whitespace from STRING." - ;; we must have ...+ but not ...* in the regexps otherwise xemacs loops - ;; endlessly... - (when (and string (stringp string)) - (replace-regexp-in-string - "[ \t\r\n]+$" "" - (replace-regexp-in-string "^[ \t\r\n]+" "" string)))) + (when (stringp string) + (string-trim string))) (defun newsticker--do-forget-preformatted (item) "Forget pre-formatted data for ITEM. commit 984b8f7ed0687702c524082efb0945f6778fb370 Author: Stefan Kangas Date: Wed Aug 3 11:40:27 2022 +0200 Remove some spurious references to XEmacs * lisp/desktop.el (desktop--emacs-pid-running-p): * lisp/emacs-lisp/checkdoc.el (checkdoc-ispell-lisp-words): Don't mention XEmacs. diff --git a/lisp/desktop.el b/lisp/desktop.el index a0931e053e..ef73bc596d 100644 --- a/lisp/desktop.el +++ b/lisp/desktop.el @@ -701,7 +701,7 @@ DIRNAME omitted or nil means use `desktop-dirname'." -4)))) ;; We should err on the safe side here: if any of the ;; executables is something like "emacs-nox" or "emacs-42.1" - ;; or "gemacs" or "xemacs", let's recognize them as well. + ;; or "gemacs", let's recognize them as well. (and (string-match-p "emacs" proc-cmd) (string-match-p "emacs" my-cmd)))))) diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 611f32e23c..94ade5928f 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -248,7 +248,7 @@ with these words enabled." ;;;###autoload(put 'checkdoc-spellcheck-documentation-flag 'safe-local-variable #'booleanp) (defvar checkdoc-ispell-lisp-words - '("alist" "emacs" "etags" "keymap" "paren" "regexp" "sexp" "xemacs") + '("alist" "emacs" "etags" "keymap" "paren" "regexp" "sexp") "List of words that are correct when spell-checking Lisp documentation.") ;;;###autoload(put 'checkdoc-ispell-list-words 'safe-local-variable #'checkdoc-list-of-strings-p) commit fc139b629cb6626eb76fbb9a465f6eb0f4d14b5a Author: Stefan Kangas Date: Wed Aug 3 11:39:25 2022 +0200 Remove XEmacs compat code from reftex-ref.el * lisp/textmodes/reftex-ref.el (reftex-latin1-to-ascii): Remove XEmacs compat code. diff --git a/lisp/textmodes/reftex-ref.el b/lisp/textmodes/reftex-ref.el index 3fe7a79a27..fead734be7 100644 --- a/lisp/textmodes/reftex-ref.el +++ b/lisp/textmodes/reftex-ref.el @@ -294,14 +294,12 @@ also applies `reftex-translate-to-ascii-function' to the string." (defun reftex-latin1-to-ascii (string) ;; Translate the upper 128 chars in the Latin-1 charset to ASCII equivalents - (let ((tab "@@@@@@@@@@@@@@@@@@'@@@@@@@@@@@@@ icLxY|S\"ca<--R-o|23'uq..1o>423?AAAAAAACEEEEIIIIDNOOOOOXOUUUUYP3aaaaaaaceeeeiiiidnooooo:ouuuuypy") - (emacsp (not (featurep 'xemacs)))) + (let ((tab "@@@@@@@@@@@@@@@@@@'@@@@@@@@@@@@@ icLxY|S\"ca<--R-o|23'uq..1o>423?AAAAAAACEEEEIIIIDNOOOOOXOUUUUYP3aaaaaaaceeeeiiiidnooooo:ouuuuypy")) (mapconcat (lambda (c) (cond ((and (> c 127) (< c 256)) ; 8 bit Latin-1 (char-to-string (aref tab (- c 128)))) - ((and emacsp ; Not for XEmacs - (> c 2175) (< c 2304)) ; Mule Latin-1 + ((and (> c 2175) (< c 2304)) ; Mule Latin-1 (char-to-string (aref tab (- c 2176)))) (t (char-to-string c)))) string ""))) commit 9b630dc252702230e1e111c1b3ee363c65ae9c32 Author: Stefan Kangas Date: Wed Aug 3 11:31:41 2022 +0200 Remove more XEmacs compat code from viper-util.el * lisp/emulation/viper-util.el (viper-check-version): Remove XEmacs compat code. (viper-get-visible-buffer-window): Make obsolete. Update caller. (viper-key-press-events-to-chars): Make obsolete. diff --git a/lisp/emulation/viper-ex.el b/lisp/emulation/viper-ex.el index d1bf5e38d5..ec7b1e4cac 100644 --- a/lisp/emulation/viper-ex.el +++ b/lisp/emulation/viper-ex.el @@ -1547,7 +1547,7 @@ reversed." (if skip-rest () ;; setup buffer - (if (setq wind (viper-get-visible-buffer-window buf)) + (if (setq wind (get-buffer-window buf 'visible)) () (setq wind (get-lru-window 'visible)) (set-window-buffer wind buf)) diff --git a/lisp/emulation/viper-util.el b/lisp/emulation/viper-util.el index 6d23ae9a0f..c9e4fa70d0 100644 --- a/lisp/emulation/viper-util.el +++ b/lisp/emulation/viper-util.el @@ -1,6 +1,6 @@ ;;; viper-util.el --- Utilities used by viper.el -*- lexical-binding:t -*- -;; Copyright (C) 1994-1997, 1999-2022 Free Software Foundation, Inc. +;; Copyright (C) 1994-2022 Free Software Foundation, Inc. ;; Author: Michael Kifer ;; Package: viper @@ -175,35 +175,23 @@ Otherwise return the normal value." ;; Check the current version against the major and minor version numbers -;; using op: cur-vers op major.minor If emacs-major-version or -;; emacs-minor-version are not defined, we assume that the current version -;; is hopelessly outdated. We assume that emacs-major-version and -;; emacs-minor-version are defined. Otherwise, for Emacs/XEmacs 19, if the -;; current minor version is < 10 (xemacs) or < 23 (emacs) the return value -;; will be nil (when op is =, >, or >=) and t (when op is <, <=), which may be -;; incorrect. However, this gives correct result in our cases, since we are -;; testing for sufficiently high Emacs versions. -(defun viper-check-version (op major minor &optional type-of-emacs) +;; using op: cur-vers op major.minor +(defun viper-check-version (op major minor &optional _type-of-emacs) (declare (obsolete nil "28.1")) - (if (and (boundp 'emacs-major-version) (boundp 'emacs-minor-version)) - (and (cond ((eq type-of-emacs 'xemacs) (featurep 'xemacs)) - ((eq type-of-emacs 'emacs) (featurep 'emacs)) - (t t)) - (cond ((eq op '=) (and (= emacs-minor-version minor) - (= emacs-major-version major))) - ((memq op '(> >= < <=)) - (and (or (funcall op emacs-major-version major) - (= emacs-major-version major)) - (if (= emacs-major-version major) - (funcall op emacs-minor-version minor) - t))) - (t - (error "%S: Invalid op in viper-check-version" op)))) - (cond ((memq op '(= > >=)) nil) - ((memq op '(< <=)) t)))) + (cond ((eq op '=) (and (= emacs-minor-version minor) + (= emacs-major-version major))) + ((memq op '(> >= < <=)) + (and (or (funcall op emacs-major-version major) + (= emacs-major-version major)) + (if (= emacs-major-version major) + (funcall op emacs-minor-version minor) + t))) + (t + (error "%S: Invalid op in viper-check-version" op)))) (defun viper-get-visible-buffer-window (wind) + (declare (obsolete "use `(get-buffer-window wind 'visible)'." "29.1")) (get-buffer-window wind 'visible)) ;; Return line position. @@ -1005,6 +993,7 @@ Otherwise return the normal value." (t (prin1-to-string event-seq))))) (defun viper-key-press-events-to-chars (events) + (declare (obsolete nil "29.1")) (mapconcat #'char-to-string events "")) commit 4f3e95bed523be11f3be7b791c6ae909ffa77a8d Author: Stefan Monnier Date: Wed Aug 3 04:50:54 2022 -0400 CEDET: Try and (re)fix bug#56902, in a better way * lisp/cedet/semantic/complete.el (semantic-displayer-abstract): Move definition before first use (in `semantic-displayer-focus-abstract`). diff --git a/lisp/cedet/semantic/complete.el b/lisp/cedet/semantic/complete.el index 2597a431e1..dc270603a0 100644 --- a/lisp/cedet/semantic/complete.el +++ b/lisp/cedet/semantic/complete.el @@ -314,6 +314,22 @@ HISTORY is a symbol representing a variable to story the history in." ;; Abstract baseclass for any displayer which supports focus + +(defclass semantic-displayer-abstract () + ((table :type (or null semanticdb-find-result-with-nil) + :initform nil + :protection :protected + :documentation "List of tags this displayer is showing.") + (last-prefix :type string + :protection :protected + :documentation "Prefix associated with slot `table'.") + ) + "Abstract displayer baseclass. +Manages the display of some number of tags. +Provides the basics for a displayer, including interacting with +a collector, and tracking tables of completion to display." + :abstract t) + (defclass semantic-displayer-focus-abstract (semantic-displayer-abstract) ((focus :type number :protection :protected @@ -1317,21 +1333,6 @@ Uses semanticdb for searching all tags in the current project." ;; * semantic-displayer-scroll-request ;; * semantic-displayer-focus-request -(defclass semantic-displayer-abstract () - ((table :type (or null semanticdb-find-result-with-nil) - :initform nil - :protection :protected - :documentation "List of tags this displayer is showing.") - (last-prefix :type string - :protection :protected - :documentation "Prefix associated with slot `table'.") - ) - "Abstract displayer baseclass. -Manages the display of some number of tags. -Provides the basics for a displayer, including interacting with -a collector, and tracking tables of completion to display." - :abstract t) - (define-obsolete-function-alias 'semantic-displayor-cleanup #'semantic-displayer-cleanup "27.1") (cl-defmethod semantic-displayer-cleanup ((_obj semantic-displayer-abstract)) commit 8ae173a8373c12f17acc9d7b22910cd106c12b4b Author: Stefan Monnier Date: Wed Aug 3 04:48:01 2022 -0400 Revert "; Fix last change (bug#56902)" This reverts commit 99bbc1fa23c3a54f1cbd2c56c57773dd471b3ef3. diff --git a/lisp/cedet/semantic/complete.el b/lisp/cedet/semantic/complete.el index 5895b75fa9..2597a431e1 100644 --- a/lisp/cedet/semantic/complete.el +++ b/lisp/cedet/semantic/complete.el @@ -313,6 +313,26 @@ HISTORY is a symbol representing a variable to story the history in." +;; Abstract baseclass for any displayer which supports focus +(defclass semantic-displayer-focus-abstract (semantic-displayer-abstract) + ((focus :type number + :protection :protected + :documentation "A tag index from `table' which has focus. +Multiple calls to the display function can choose to focus on a +given tag, by highlighting its location.") + (find-file-focus + :allocation :class + :initform nil + :documentation + "Non-nil if focusing requires a tag's buffer be in memory.") + ) + "Abstract displayer supporting `focus'. +A displayer which has the ability to focus in on one tag. +Focusing is a way of differentiating among multiple tags +which have the same name." + :abstract t) + + (defun semantic-complete-current-match () "Calculate a match from the current completion environment. Save this in our completion variable. Make sure that variable @@ -1297,7 +1317,6 @@ Uses semanticdb for searching all tags in the current project." ;; * semantic-displayer-scroll-request ;; * semantic-displayer-focus-request - (defclass semantic-displayer-abstract () ((table :type (or null semanticdb-find-result-with-nil) :initform nil @@ -1406,25 +1425,6 @@ to click on the items to aid in completion.") ;;; Methods for any displayer which supports focus -;; Abstract baseclass for any displayer which supports focus -(defclass semantic-displayer-focus-abstract (semantic-displayer-abstract) - ((focus :type number - :protection :protected - :documentation "A tag index from `table' which has focus. -Multiple calls to the display function can choose to focus on a -given tag, by highlighting its location.") - (find-file-focus - :allocation :class - :initform nil - :documentation - "Non-nil if focusing requires a tag's buffer be in memory.") - ) - "Abstract displayer supporting `focus'. -A displayer which has the ability to focus in on one tag. -Focusing is a way of differentiating among multiple tags -which have the same name." - :abstract t) - (define-obsolete-function-alias 'semantic-displayor-next-action #'semantic-displayer-next-action "27.1") (cl-defmethod semantic-displayer-next-action ((obj semantic-displayer-focus-abstract)) commit 20ee17385f06a050aa45985fb4da2ff3f27925d5 (refs/remotes/origin/emacs-28) Author: Philipp Stephani Date: Tue Jul 26 10:30:55 2022 +0200 * lisp/uniquify.el (uniquify-buffer-name-style): Quote apostrophe. diff --git a/lisp/uniquify.el b/lisp/uniquify.el index 6b48fe3df6..27a0dbd120 100644 --- a/lisp/uniquify.el +++ b/lisp/uniquify.el @@ -110,7 +110,7 @@ is a list of strings. For example the current implementation for post-forward-angle-brackets could be: (defun my-post-forward-angle-brackets (base extra-string) - (concat base \"<\" (mapconcat #'identity extra-string \"/\") \">\")) + (concat base \"<\" (mapconcat #\\='identity extra-string \"/\") \">\")) The \"mumble\" part may be stripped as well, depending on the setting of `uniquify-strip-common-suffix'. For more options that commit 33b32269754af36f8b39cf3357597bd0dd78caa9 Author: Stefan Kangas Date: Wed Aug 3 10:06:39 2022 +0200 Remove some XEmacs compat code from url-util.el These functions only exist in the XEmacs GTK support. * lisp/url/url-util.el (url-display-percentage): Remove XEmacs compat code. diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el index 993a3732ab..a6a4becceb 100644 --- a/lisp/url/url-util.el +++ b/lisp/url/url-util.el @@ -196,16 +196,12 @@ Will not do anything if `url-show-status' is nil." 'file-size-human-readable "24.4") ;;;###autoload -(defun url-display-percentage (fmt perc &rest args) +(defun url-display-percentage (fmt _perc &rest args) (when (and url-show-status (or (null url-current-object) (not (url-silent url-current-object)))) - (if (null fmt) - (if (fboundp 'clear-progress-display) - (clear-progress-display)) - (if (and (fboundp 'progress-display) perc) - (apply 'progress-display fmt perc args) - (apply 'message fmt args))))) + (when (not (null fmt)) + (apply 'message fmt args)))) ;;;###autoload (defun url-percentage (x y) commit 836ef4293fa6df71336f6e88a3e404480eb2f96c Author: Stefan Kangas Date: Wed Aug 3 10:00:34 2022 +0200 Make url-util space trimming functions obsolete * lisp/url/url-util.el (url-eat-trailing-space) (url-strip-leading-spaces): Make obsolete in favor of 'string-trim'. Update caller. diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el index 3d7d877979..125f8436f6 100644 --- a/lisp/url/url-http.el +++ b/lisp/url/url-http.el @@ -471,9 +471,7 @@ Return the number of characters removed." t ;; Instruct caller to signal an error. Bug#50511 ;; Find strongest supported auth. (dolist (this-auth auths) - (setq this-auth (url-eat-trailing-space - (url-strip-leading-spaces - this-auth))) + (setq this-auth (string-trim this-auth)) (let* ((this-type (downcase (if (string-match "[ \t]" this-auth) (substring this-auth 0 (match-beginning 0)) diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el index fc84d45176..993a3732ab 100644 --- a/lisp/url/url-util.el +++ b/lisp/url/url-util.el @@ -182,21 +182,14 @@ Will not do anything if `url-show-status' is nil." ;;;###autoload (defun url-eat-trailing-space (x) "Remove spaces/tabs at the end of a string." - (let ((y (1- (length x))) - (skip-chars (list ? ?\t ?\n))) - (while (and (>= y 0) (memq (aref x y) skip-chars)) - (setq y (1- y))) - (substring x 0 (1+ y)))) + (declare (obsolete string-trim "29.1")) + (string-trim x "")) ;;;###autoload (defun url-strip-leading-spaces (x) "Remove spaces at the front of a string." - (let ((y (1- (length x))) - (z 0) - (skip-chars (list ? ?\t ?\n))) - (while (and (<= z y) (memq (aref x z) skip-chars)) - (setq z (1+ z))) - (substring x z nil))) + (declare (obsolete string-trim "29.1")) + (string-trim x nil "")) (define-obsolete-function-alias 'url-pretty-length commit 6edb499a5eb7c5f22ceb3b8ea0e878d749c2a778 Merge: bb3e281236 f23d456039 Author: Stefan Kangas Date: Wed Aug 3 09:50:35 2022 +0200 Merge from origin/emacs-28 f23d456039 * lisp/term.el: Doc fix; don't mention rlogin. f522d2d90b ; * admin/make-tarball.txt: Minor tweaks. commit bb3e281236bd39c2fbd0702c4f3e07dfaec7afe2 Author: Po Lu Date: Wed Aug 3 15:13:14 2022 +0800 Improve X server time computation * src/xterm.c (x_sync_get_monotonic_time): Use that if available. (x_display_set_last_user_time): Compute an offset between the monotonic time and the X server time if they are not identical. * src/xterm.h (struct x_display_info): New field `server_time_offset'. diff --git a/src/xterm.c b/src/xterm.c index 2239b9fa4e..eb1a557e88 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -6645,7 +6645,11 @@ x_sync_get_monotonic_time (struct x_display_info *dpyinfo, if (dpyinfo->server_time_monotonic_p) return timestamp; - return 0; + /* This means we haven't yet initialized the server time offset. */ + if (!dpyinfo->server_time_offset) + return 0; + + return timestamp - dpyinfo->server_time_offset; } /* Return the current monotonic time in the same format as a @@ -7464,7 +7468,14 @@ x_display_set_last_user_time (struct x_display_info *dpyinfo, Time time, && time * 1000 < monotonic_time + 500 * 1000) dpyinfo->server_time_monotonic_p = true; else - dpyinfo->server_time_monotonic_p = false; + { + /* Compute an offset that can be subtracted from the server + time to estimate the monotonic time on the X server. */ + + dpyinfo->server_time_monotonic_p = false; + dpyinfo->server_time_offset + = ((int64_t) time * 1000) - monotonic_time; + } } #endif diff --git a/src/xterm.h b/src/xterm.h index b656c8dcb2..fb099e92ea 100644 --- a/src/xterm.h +++ b/src/xterm.h @@ -774,6 +774,10 @@ struct x_display_info /* Whether or not the server time is probably the same as "clock_gettime (CLOCK_MONOTONIC, ...)". */ bool server_time_monotonic_p; + + /* The time difference between the X server clock and the monotonic + clock. */ + int64_t server_time_offset; #endif }; commit f23d45603918721ec80bfcef883d22fab15cb9f1 Author: Stefan Kangas Date: Tue Aug 2 17:18:22 2022 +0200 * lisp/term.el: Doc fix; don't mention rlogin. diff --git a/lisp/term.el b/lisp/term.el index 68ec9db800..b683f22bb6 100644 --- a/lisp/term.el +++ b/lisp/term.el @@ -78,7 +78,7 @@ ;; directory/username/host tracking: the only drawback is that you will ;; have to modify your shell start-up script. It's worth it, believe me :). ;; -;; When you rlogin/su/telnet and the account you access has a modified +;; When you ssh/sudo/su and the account you access has a modified ;; startup script, you will be able to access the remote files as usual ;; with C-x C-f, if it's needed you will have to enter a password, ;; otherwise the file should get loaded straight away. commit f522d2d90b7d16f9dc285c855768ecf34ddf26f4 Author: Stefan Kangas Date: Tue Aug 2 13:45:13 2022 +0200 ; * admin/make-tarball.txt: Minor tweaks. diff --git a/admin/make-tarball.txt b/admin/make-tarball.txt index 6990f27bfa..f5b9d56c4d 100644 --- a/admin/make-tarball.txt +++ b/admin/make-tarball.txt @@ -183,12 +183,12 @@ General steps (for each step, check for possible errors): yourself, find it at . Releases are of course at . - ./admin/diff-tar-files emacs-OLD.tar.gz emacs-NEW.tar.gz + ./admin/diff-tar-files emacs-OLD.tar emacs-NEW.tar Alternatively: - tar tJf emacs-OLD.tar.xz | sed -e 's,^[^/]*,,' | sort > old_tmp - tar tJf emacs-NEW.tar.xz | sed -e 's,^[^/]*,,' | sort > new_tmp + tar tf emacs-OLD.tar | sed -e 's,^[^/]*,,' | sort > old_tmp + tar tf emacs-NEW.tar | sed -e 's,^[^/]*,,' | sort > new_tmp diff -u old_tmp new_tmp If this is the first pretest of a major release, just comparing @@ -203,7 +203,7 @@ General steps (for each step, check for possible errors): The output of this command might be easier to compare to the tarball than the one you get from find. -7. tar -xf emacs-NEW.tar; cd emacs-NEW +7. tar xf emacs-NEW.tar; cd emacs-NEW ./configure --prefix=/tmp/emacs && make check && make install Use 'script' or M-x compile to save the compilation log in @@ -288,7 +288,7 @@ General steps (for each step, check for possible errors): https://ftp.gnu.org/gnu/emacs/ for a release. Download them and check the signatures and SHA1/SHA256 checksums. - Check they build. + Check they build (./configure --with-native-compilation). 11. Send an announcement to: emacs-devel, and bcc: info-gnu-emacs@gnu.org. For a pretest, also bcc: platform-testers@gnu.org. @@ -309,8 +309,8 @@ General steps (for each step, check for possible errors): sha1sum emacs-NEW.tar.xz sha256sum emacs-NEW.tar.xz - You can optionally sign the announcement email, probably using the - same PGP key that you used for signing the tarball. + You can optionally sign the announcement email, preferably using + the same PGP key that you used for signing the tarball. (Use e.g. `M-x mml-secure-message-sign' in `message-mode' to sign an email.)