diff options
| author | Sean Whitton <spwhitton@spwhitton.name> | 2023-04-16 13:36:07 -0700 |
|---|---|---|
| committer | Sean Whitton <spwhitton@spwhitton.name> | 2023-04-16 13:36:07 -0700 |
| commit | dd8360ba5c923186bba7565fc5cf7ea98cf5f9a4 (patch) | |
| tree | 946dc3681a06ac18bd1b67fd22aca2594a7841af /lisp | |
| parent | da1956d5c9f0a8c4d795cd8e9adc48089eea58cf (diff) | |
| parent | bc61a1afdd6c3ba8a605ed46ae97b1e36b40f951 (diff) | |
| download | emacs-dd8360ba5c923186bba7565fc5cf7ea98cf5f9a4.tar.gz | |
Merge upstream Git snapshot into athena/unstable
Diffstat (limited to 'lisp')
150 files changed, 6233 insertions, 3222 deletions
diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 1e0935f565f..4aa01e77e4e 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -74,7 +74,7 @@ AUTOGENEL = ${loaddefs} ${srcdir}/cus-load.el ${srcdir}/finder-inf.el \ # Set load-prefer-newer for the benefit of the non-bootstrappers. BYTE_COMPILE_FLAGS = \ --eval "(setq load-prefer-newer t byte-compile-warnings 'all)" \ - $(BYTE_COMPILE_EXTRA_FLAGS) + --eval "(setq org--built-in-p t)" $(BYTE_COMPILE_EXTRA_FLAGS) # ... but we must prefer .elc files for those in the early bootstrap. compile-first: BYTE_COMPILE_FLAGS = $(BYTE_COMPILE_EXTRA_FLAGS) diff --git a/lisp/allout.el b/lisp/allout.el index 4d5d814ae01..be2fd632c69 100644 --- a/lisp/allout.el +++ b/lisp/allout.el @@ -5390,7 +5390,7 @@ Defaults: ;; not specified -- default it: (setq tobuf (concat "*" (buffer-name frombuf) " exposed*"))) (if (listp format) - (nreverse format)) + (setq format (reverse format))) (let* ((listified (progn (set-buffer frombuf) diff --git a/lisp/cedet/semantic.el b/lisp/cedet/semantic.el index 1c9228b0123..0c15a2a453e 100644 --- a/lisp/cedet/semantic.el +++ b/lisp/cedet/semantic.el @@ -618,21 +618,18 @@ Does nothing if the current buffer doesn't need reparsing." (lexically-safe t) ) - (unwind-protect - ;; Perform the parsing. - (progn - (when (semantic-lex-catch-errors safe-refresh - (save-excursion (semantic-fetch-tags)) - nil) - ;; If we are here, it is because the lexical step failed, - ;; probably due to unterminated lists or something like that. - - ;; We do nothing, and just wait for the next idle timer - ;; to go off. In the meantime, remember this, and make sure - ;; no other idle services can get executed. - (setq lexically-safe nil)) - ) - ) + ;; Perform the parsing. + (when (semantic-lex-catch-errors safe-refresh + (save-excursion (semantic-fetch-tags)) + nil) + ;; If we are here, it is because the lexical step failed, + ;; probably due to unterminated lists or something like that. + + ;; We do nothing, and just wait for the next idle timer + ;; to go off. In the meantime, remember this, and make sure + ;; no other idle services can get executed. + (setq lexically-safe nil)) + ;; Return if we are lexically safe lexically-safe)))) diff --git a/lisp/custom.el b/lisp/custom.el index fa77e5c2c56..083349e3591 100644 --- a/lisp/custom.el +++ b/lisp/custom.el @@ -280,7 +280,9 @@ The following keywords are meaningful: when using the Customize user interface. It takes two arguments, the symbol to set and the value to give it. The function should not modify its value argument destructively. The default choice - of function is `set-default-toplevel-value'. + of function is `set-default-toplevel-value'. If this keyword is + defined, modifying the value of SYMBOL via `setopt' will call the + function specified by VALUE to install the new value. :get VALUE should be a function to extract the value of symbol. The function takes one argument, a symbol, and should return the current value for that symbol. The default choice of function diff --git a/lisp/dired.el b/lisp/dired.el index 8e3244356fe..d1471e993a1 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -927,9 +927,9 @@ marked file, return (t FILENAME) instead of (FILENAME)." (lambda () (if ,show-progress (sit-for 0)) (setq results (cons ,body results)))) - (if (< ,arg 0) - (nreverse results) - results)) + (when (< ,arg 0) + (setq results (nreverse results))) + results) ;; non-nil, non-integer, non-marked ARG means use current file: (list ,body)) (let ((regexp (dired-marker-regexp)) next-position) diff --git a/lisp/electric.el b/lisp/electric.el index bac3f5a2b3c..cef5326852c 100644 --- a/lisp/electric.el +++ b/lisp/electric.el @@ -409,9 +409,7 @@ If multiple rules match, only first one is executed.") (goto-char pos) (funcall probe last-command-event)))) (when res (throw 'done res)))))))))) - (when (and rule - ;; Not in a string or comment. - (not (nth 8 (save-excursion (syntax-ppss pos))))) + (when rule (goto-char pos) (when (functionp rule) (setq rule (funcall rule))) (dolist (sym (if (symbolp rule) (list rule) rule)) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 3c7aeb89525..2bdd3375728 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -506,13 +506,7 @@ for speeding up processing.") ((guard (when for-effect (if-let ((tmp (byte-opt--fget fn 'side-effect-free))) (or byte-compile-delete-errors - (eq tmp 'error-free) - (progn - (byte-compile-warn-x - form - "value returned from %s is unused" - form) - nil))))) + (eq tmp 'error-free))))) (byte-compile-log " %s called for effect; deleted" fn) (byte-optimize-form (cons 'progn (cdr form)) t)) @@ -1642,98 +1636,231 @@ See Info node `(elisp) Integer Basics'." ;; I wonder if I missed any :-\) (let ((side-effect-free-fns - '(% * + - / /= 1+ 1- < <= = > >= abs acos append aref ash asin atan - assq - base64-decode-string base64-encode-string base64url-encode-string + '( + ;; alloc.c + make-bool-vector make-byte-code make-list make-record make-string + make-symbol make-vector + ;; buffer.c + buffer-base-buffer buffer-chars-modified-tick buffer-file-name + buffer-local-value buffer-local-variables buffer-modified-p + buffer-modified-tick buffer-name get-buffer next-overlay-change + overlay-buffer overlay-end overlay-get overlay-properties + overlay-start overlays-at overlays-in previous-overlay-change + ;; callint.c + prefix-numeric-value + ;; casefiddle.c + capitalize downcase upcase upcase-initials + ;; category.c + category-docstring category-set-mnemonics char-category-set + copy-category-table get-unused-category make-category-set + ;; character.c + char-width multibyte-char-to-unibyte string unibyte-char-to-multibyte + ;; charset.c + decode-char encode-char + ;; chartab.c + make-char-table + ;; data.c + % * + - / /= 1+ 1- < <= = > >= + aref ash bare-symbol bool-vector-count-consecutive bool-vector-count-population bool-vector-subsetp - boundp buffer-file-name buffer-local-variables buffer-modified-p - buffer-substring byte-code-function-p - capitalize car-less-than-car car cdr ceiling char-after char-before - char-equal char-to-string char-width compare-strings - window-configuration-equal-p concat coordinates-in-window-p - copy-alist copy-sequence copy-marker copysign cos - current-time-string current-time-zone - decode-char - decode-time default-boundp default-value documentation downcase - elt encode-char exp expt encode-time error-message-string - fboundp fceiling featurep ffloor - file-directory-p file-exists-p file-locked-p file-name-absolute-p - file-name-concat - file-newer-than-file-p file-readable-p file-symlink-p file-writable-p - float float-time floor format format-message format-time-string - frame-first-window frame-root-window frame-selected-window - frame-visible-p fround ftruncate - get gethash get-buffer get-buffer-window get-file-buffer - hash-table-count - intern-soft isnan - keymap-parent - ldexp - length length< length> length= - line-beginning-position line-end-position pos-bol pos-eol - local-variable-if-set-p local-variable-p locale-info - log logand logb logcount logior lognot logxor - make-byte-code make-list make-string make-symbol marker-buffer max - match-beginning match-end - member memq memql min minibuffer-selected-window minibuffer-window - mod multibyte-char-to-unibyte next-window nth nthcdr number-to-string - prefix-numeric-value previous-window prin1-to-string propertize - rassq rassoc read-from-string - regexp-quote region-beginning region-end reverse round - sin sqrt string string-equal string-lessp - string-search string-to-char - string-to-number string-to-syntax substring substring-no-properties - sxhash-equal sxhash-eq sxhash-eql - symbol-function symbol-name symbol-plist symbol-value - string-make-unibyte - string-make-multibyte string-as-multibyte string-as-unibyte - string-to-multibyte - take tan time-convert truncate - unibyte-char-to-multibyte upcase user-full-name - user-login-name - vconcat - window-at window-body-height - window-body-width window-buffer window-dedicated-p window-display-table - window-combination-limit window-frame window-fringes - window-hscroll - window-left-child window-left-column window-margins window-minibuffer-p - window-next-buffers window-next-sibling window-new-normal - window-new-total window-normal-size window-parameter window-parameters - window-parent window-point window-prev-buffers - window-prev-sibling window-scroll-bars - window-start window-text-height window-top-child window-top-line - window-total-height window-total-width window-use-time window-vscroll - )) + boundp car cdr default-boundp default-value fboundp + get-variable-watchers indirect-variable + local-variable-if-set-p local-variable-p + logand logcount logior lognot logxor max min mod + number-to-string position-symbol string-to-number + subr-arity subr-name subr-native-lambda-list subr-type + symbol-function symbol-name symbol-plist symbol-value + symbol-with-pos-pos variable-binding-locus + ;; doc.c + documentation + ;; editfns.c + buffer-substring buffer-substring-no-properties + byte-to-position byte-to-string + char-after char-before char-equal char-to-string + compare-buffer-substrings + format format-message + group-name + line-beginning-position line-end-position ngettext pos-bol pos-eol + propertize region-beginning region-end string-to-char + user-full-name user-login-name + ;; fileio.c + car-less-than-car directory-name-p file-directory-p file-exists-p + file-name-absolute-p file-name-concat file-newer-than-file-p + file-readable-p file-symlink-p file-writable-p + ;; filelock.c + file-locked-p + ;; floatfns.c + abs acos asin atan ceiling copysign cos exp expt fceiling ffloor + float floor fround ftruncate isnan ldexp log logb round sin sqrt tan + truncate + ;; fns.c + append assq + base64-decode-string base64-encode-string base64url-encode-string + compare-strings concat copy-alist copy-hash-table copy-sequence elt + featurep get + gethash hash-table-count hash-table-rehash-size + hash-table-rehash-threshold hash-table-size hash-table-test + hash-table-weakness + length length< length= length> + line-number-at-pos locale-info make-hash-table + member memq memql nth nthcdr + object-intervals rassoc rassq reverse + string-as-multibyte string-as-unibyte string-bytes string-distance + string-equal string-lessp string-make-multibyte string-make-unibyte + string-search string-to-multibyte substring substring-no-properties + sxhash-eq sxhash-eql sxhash-equal sxhash-equal-including-properties + take vconcat + ;; frame.c + frame-ancestor-p frame-bottom-divider-width frame-char-height + frame-char-width frame-child-frame-border-width frame-focus + frame-fringe-width frame-internal-border-width frame-native-height + frame-native-width frame-parameter frame-parameters frame-parent + frame-pointer-visible-p frame-position frame-right-divider-width + frame-scale-factor frame-scroll-bar-height frame-scroll-bar-width + frame-text-cols frame-text-height frame-text-lines frame-text-width + frame-total-cols frame-total-lines frame-visible-p + frame-window-state-change next-frame previous-frame + tool-bar-pixel-width window-system + ;; fringe.c + fringe-bitmaps-at-pos + ;; keyboard.c + posn-at-point posn-at-x-y + ;; keymap.c + copy-keymap keymap-parent keymap-prompt make-keymap make-sparse-keymap + ;; lread.c + intern-soft read-from-string + ;; marker.c + copy-marker marker-buffer marker-insertion-type marker-position + ;; minibuf.c + active-minibuffer-window assoc-string innermost-minibuffer-p + minibuffer-innermost-command-loop-p minibufferp + ;; print.c + error-message-string prin1-to-string + ;; process.c + format-network-address get-buffer-process get-process + process-buffer process-coding-system process-command process-filter + process-id process-inherit-coding-system-flag process-mark + process-name process-plist process-query-on-exit-flag + process-running-child-p process-sentinel process-thread + process-tty-name process-type + ;; search.c + match-beginning match-end regexp-quote + ;; sqlite.c + sqlite-columns sqlite-more-p sqlite-version + ;; syntax.c + char-syntax copy-syntax-table matching-paren string-to-syntax + syntax-class-to-char + ;; term.c + controlling-tty-p tty-display-color-cells tty-display-color-p + tty-top-frame tty-type + ;; terminal.c + frame-terminal terminal-list terminal-live-p terminal-name + terminal-parameter terminal-parameters + ;; textprop.c + get-char-property get-char-property-and-overlay get-text-property + next-char-property-change next-property-change + next-single-char-property-change next-single-property-change + previous-char-property-change previous-property-change + previous-single-char-property-change previous-single-property-change + text-properties-at text-property-any text-property-not-all + ;; thread.c + all-threads condition-mutex condition-name mutex-name thread-live-p + thread-name + ;; timefns.c + current-time-string current-time-zone decode-time encode-time + float-time format-time-string time-add time-convert time-equal-p + time-less-p time-subtract + ;; window.c + coordinates-in-window-p frame-first-window frame-root-window + frame-selected-window get-buffer-window minibuffer-selected-window + minibuffer-window next-window previous-window window-at + window-body-height window-body-width window-buffer + window-combination-limit window-configuration-equal-p + window-dedicated-p window-display-table window-frame window-fringes + window-hscroll window-left-child window-left-column window-margins + window-minibuffer-p window-new-normal window-new-total + window-next-buffers window-next-sibling window-normal-size + window-parameter window-parameters window-parent window-point + window-prev-buffers window-prev-sibling window-scroll-bars + window-start window-text-height window-top-child window-top-line + window-total-height window-total-width window-use-time window-vscroll + ;; xdisp.c + buffer-text-pixel-size current-bidi-paragraph-direction + get-display-property invisible-p line-pixel-height lookup-image-map + tab-bar-height tool-bar-height window-text-pixel-size + )) (side-effect-and-error-free-fns - '(arrayp atom - bobp bolp bool-vector-p - buffer-list buffer-size buffer-string bufferp - car-safe case-table-p cdr-safe char-or-string-p characterp - charsetp commandp cons consp - current-buffer current-global-map current-indentation - current-local-map current-minor-mode-maps current-time - eobp eolp eq equal - floatp following-char framep - hash-table-p - identity indirect-function integerp integer-or-marker-p - invocation-directory invocation-name - keymapp keywordp - list listp - make-marker mark-marker markerp max-char - natnump nlistp null number-or-marker-p numberp - overlayp - point point-marker point-min point-max preceding-char - processp proper-list-p - recent-keys recursion-depth - safe-length selected-frame selected-window sequencep - standard-case-table standard-syntax-table stringp subrp symbolp - syntax-table syntax-table-p - this-command-keys this-command-keys-vector this-single-command-keys - this-single-command-raw-keys type-of - user-real-login-name user-real-uid user-uid - vector vectorp visible-frame-list - wholenump window-configuration-p window-live-p - window-valid-p windowp))) + '( + ;; alloc.c + bool-vector cons list make-marker purecopy record vector + ;; buffer.c + buffer-list buffer-live-p current-buffer overlay-lists overlayp + ;; casetab.c + case-table-p current-case-table standard-case-table + ;; category.c + category-table category-table-p make-category-table + standard-category-table + ;; character.c + characterp max-char + ;; charset.c + charsetp + ;; data.c + arrayp atom bare-symbol-p bool-vector-p bufferp byte-code-function-p + byteorder car-safe cdr-safe char-or-string-p char-table-p + condition-variable-p consp eq floatp indirect-function + integer-or-marker-p integerp keywordp listp markerp + module-function-p multibyte-string-p mutexp natnump nlistp null + number-or-marker-p numberp recordp remove-pos-from-symbol + sequencep stringp subr-native-elisp-p subrp symbol-with-pos-p symbolp + threadp type-of user-ptrp vector-or-char-table-p vectorp wholenump + ;; editfns.c + bobp bolp buffer-size buffer-string current-message emacs-pid + eobp eolp following-char gap-position gap-size group-gid + group-real-gid mark-marker point point-marker point-max point-min + position-bytes preceding-char system-name + user-real-login-name user-real-uid user-uid + ;; emacs.c + invocation-directory invocation-name + ;; eval.c + commandp functionp + ;; fileio.c + default-file-modes + ;; fns.c + eql equal hash-table-p identity proper-list-p safe-length + secure-hash-algorithms + ;; frame.c + frame-list frame-live-p framep last-nonminibuffer-frame + old-selected-frame selected-frame visible-frame-list + ;; image.c + imagep + ;; indent.c + current-column current-indentation + ;; keyboard.c + current-idle-time current-input-mode recent-keys recursion-depth + this-command-keys this-command-keys-vector this-single-command-keys + this-single-command-raw-keys + ;; keymap.c + current-global-map current-local-map current-minor-mode-maps keymapp + ;; minibuf.c + minibuffer-contents minibuffer-contents-no-properties minibuffer-depth + minibuffer-prompt minibuffer-prompt-end + ;; process.c + process-list processp signal-names waiting-for-user-input-p + ;; sqlite.c + sqlite-available-p sqlitep + ;; syntax.c + standard-syntax-table syntax-table syntax-table-p + ;; thread.c + current-thread + ;; timefns.c + current-time + ;; window.c + selected-window window-configuration-p window-live-p window-valid-p + windowp + ;; xdisp.c + long-line-optimizations-p + ))) (while side-effect-free-fns (put (car side-effect-free-fns) 'side-effect-free t) (setq side-effect-free-fns (cdr side-effect-free-fns))) @@ -1758,41 +1885,34 @@ See Info node `(elisp) Integer Basics'." ;; values if a marker is moved. (let ((pure-fns - '(concat regexp-quote - string-to-char string-to-syntax symbol-name - eq eql - = /= < <= >= > min max - + - * / % mod abs ash 1+ 1- sqrt - logand logior lognot logxor logcount - copysign isnan ldexp float logb - floor ceiling round truncate - ffloor fceiling fround ftruncate - string-equal string-lessp - string-search - consp atom listp nlistp proper-list-p - sequencep arrayp vectorp stringp bool-vector-p hash-table-p - null - numberp integerp floatp natnump characterp - integer-or-marker-p number-or-marker-p char-or-string-p - symbolp keywordp - type-of - identity - - ;; The following functions are pure up to mutation of their - ;; arguments. This is pure enough for the purposes of - ;; constant folding, but not necessarily for all kinds of - ;; code motion. - car cdr car-safe cdr-safe nth nthcdr take - equal - length safe-length - memq memql member - ;; `assoc' and `assoc-default' are excluded since they are - ;; impure if the test function is (consider `string-match'). - assq rassq rassoc - aref elt - base64-decode-string base64-encode-string base64url-encode-string - bool-vector-subsetp - bool-vector-count-population bool-vector-count-consecutive + '( + ;; character.c + characterp + ;; data.c + % * + - / /= 1+ 1- < <= = > >= aref arrayp ash atom bare-symbol + bool-vector-count-consecutive bool-vector-count-population + bool-vector-p bool-vector-subsetp + bufferp car car-safe cdr cdr-safe char-or-string-p char-table-p + condition-variable-p consp eq floatp integer-or-marker-p integerp + keywordp listp logand logcount logior lognot logxor markerp max min + mod multibyte-string-p mutexp natnump nlistp null number-or-marker-p + numberp recordp remove-pos-from-symbol sequencep stringp symbol-name + symbolp threadp type-of vector-or-char-table-p vectorp + ;; editfns.c + string-to-char + ;; floatfns.c + abs ceiling copysign fceiling ffloor float floor fround ftruncate + isnan ldexp logb round sqrt truncate + ;; fns.c + assq base64-decode-string base64-encode-string base64url-encode-string + concat elt eql equal hash-table-p identity length length< length= + length> member memq memql nth nthcdr proper-list-p rassoc rassq + safe-length string-bytes string-distance string-equal string-lessp + string-search take + ;; search.c + regexp-quote + ;; syntax.c + string-to-syntax ))) (while pure-fns (put (car pure-fns) 'pure t) @@ -2765,7 +2885,9 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (or (memq (caar tmp) '(byte-discard byte-discardN)) ;; Make sure we don't hoist a discardN-preserve-tos ;; that really should be merged or deleted instead. - (and (eq (caar tmp) 'byte-discardN-preserve-tos) + (and (or (eq (caar tmp) 'byte-discardN-preserve-tos) + (and (eq (caar tmp) 'byte-stack-set) + (eql (cdar tmp) 1))) (let ((next (cadr tmp))) (not (or (memq (car next) '(byte-discardN-preserve-tos diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 9345665eea8..fd9913d1be8 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -650,11 +650,8 @@ in `byte-compile-warning-types'; see the variable `byte-compile-warnings' for a fuller explanation of the warning types. The types that can be suppressed with this macro are `free-vars', `callargs', `redefine', `obsolete', -`interactive-only', `lexical', `mapcar', `constants', -`suspicious' and `empty-body'. - -For the `mapcar' case, only the `mapcar' function can be used in -the symbol list." +`interactive-only', `lexical', `ignored-return-value', `constants', +`suspicious' and `empty-body'." ;; Note: during compilation, this definition is overridden by the one in ;; byte-compile-initial-macro-environment. (declare (debug (sexp body)) (indent 1)) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index a122e81ba3c..c84c70971b3 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -317,7 +317,9 @@ Elements of the list may be: lexical-dynamic lexically bound variable declared dynamic elsewhere make-local calls to `make-variable-buffer-local' that may be incorrect. - mapcar mapcar called for effect. + ignored-return-value + function called without using the return value where this + is likely to be a mistake not-unused warning about using variables with symbol names starting with _. constants let-binding of, or assignment to, constants/nonvariables. docstrings docstrings that are too wide (longer than @@ -330,7 +332,7 @@ Elements of the list may be: empty-body body argument to a special form or macro is empty. If the list begins with `not', then the remaining elements specify warnings to -suppress. For example, (not mapcar) will suppress warnings about mapcar. +suppress. For example, (not free-vars) will suppress the `free-vars' warning. The t value means \"all non experimental warning types\", and excludes the types in `byte-compile--emacs-build-warning-types'. @@ -3490,6 +3492,89 @@ lambda-expression." (byte-compile-report-error (format-message "`%s' defined after use in %S (missing `require' of a library file?)" (car form) form))) + + (when byte-compile--for-effect + (let ((sef (function-get (car form) 'side-effect-free))) + (cond + ((and sef (or (eq sef 'error-free) + byte-compile-delete-errors)) + ;; This transform is normally done in the Lisp optimiser, + ;; so maybe we don't need to bother about it here? + (setq form (cons 'progn (cdr form))) + (setq handler #'byte-compile-progn)) + ((and (or sef + (memq (car form) + ;; FIXME: Use a function property (declaration) + ;; instead of this list. + '( + ;; Functions that are side-effect-free + ;; except for the behaviour of + ;; functions passed as argument. + mapcar mapcan mapconcat + cl-mapcar cl-mapcan cl-maplist cl-map cl-mapcon + cl-reduce + assoc assoc-default plist-get plist-member + cl-assoc cl-assoc-if cl-assoc-if-not + cl-rassoc cl-rassoc-if cl-rassoc-if-not + cl-member cl-member-if cl-member-if-not + cl-adjoin + cl-mismatch cl-search + cl-find cl-find-if cl-find-if-not + cl-position cl-position-if cl-position-if-not + cl-count cl-count-if cl-count-if-not + cl-remove cl-remove-if cl-remove-if-not + cl-member cl-member-if cl-member-if-not + cl-remove-duplicates + cl-subst cl-subst-if cl-subst-if-not + cl-substitute cl-substitute-if + cl-substitute-if-not + cl-sublis + cl-union cl-intersection + cl-set-difference cl-set-exclusive-or + cl-subsetp + cl-every cl-some cl-notevery cl-notany + cl-tree-equal + + ;; Functions that mutate and return a list. + cl-delete-if cl-delete-if-not + ;; `delete-dups' and `delete-consecutive-dups' + ;; never delete the first element so it's + ;; safe to ignore their return value, but + ;; this isn't the case with + ;; `cl-delete-duplicates'. + cl-delete-duplicates + cl-nsubst cl-nsubst-if cl-nsubst-if-not + cl-nsubstitute cl-nsubstitute-if + cl-nsubstitute-if-not + cl-nunion cl-nintersection + cl-nset-difference cl-nset-exclusive-or + cl-nreconc cl-nsublis + cl-merge + ;; It's safe to ignore the value of `sort' + ;; and `nreverse' when used on arrays, + ;; but most calls pass lists. + nreverse + sort cl-sort cl-stable-sort + + ;; Adding the following functions yields many + ;; positives; evaluate how many of them are + ;; false first. + + ;;delq delete cl-delete + ;;nconc plist-put + ))) + ;; Don't warn for arguments to `ignore'. + (not (eq byte-compile--for-effect 'for-effect-no-warn)) + (byte-compile-warning-enabled-p + 'ignored-return-value (car form))) + (byte-compile-warn-x + (car form) + "value from call to `%s' is unused%s" + (car form) + (cond ((eq (car form) 'mapcar) + "; use `mapc' or `dolist' instead") + (t ""))))))) + (if (and handler ;; Make sure that function exists. (and (functionp handler) @@ -3523,11 +3608,7 @@ lambda-expression." (byte-compile-callargs-warn form)) (if byte-compile-generate-call-tree (byte-compile-annotate-call-tree form)) - (when (and byte-compile--for-effect (eq (car form) 'mapcar) - (byte-compile-warning-enabled-p 'mapcar 'mapcar)) - (byte-compile-warn-x - (car form) - "`mapcar' called for effect; use `mapc' or `dolist' instead")) + (byte-compile-push-constant (car form)) (mapc 'byte-compile-form (cdr form)) ; wasteful, but faster. (byte-compile-out 'byte-call (length (cdr form)))) @@ -4367,7 +4448,8 @@ This function is never called when `lexical-binding' is nil." (defun byte-compile-ignore (form) (dolist (arg (cdr form)) - (byte-compile-form arg t)) + ;; Compile each argument for-effect but suppress unused-value warnings. + (byte-compile-form arg 'for-effect-no-warn)) (byte-compile-form nil)) ;; Return the list of items in CONDITION-PARAM that match PRED-LIST. diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index de5eb9c2d92..a89bbc3a748 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -408,6 +408,7 @@ Other non-digit chars are considered junk. RADIX is an integer between 2 and 36, the default is 10. Signal an error if the substring between START and END cannot be parsed as an integer unless JUNK-ALLOWED is non-nil." + (declare (side-effect-free t)) (cl-check-type string string) (let* ((start (or start 0)) (len (length string)) @@ -566,6 +567,7 @@ too large if positive or too small if negative)." ;;;###autoload (defun cl-revappend (x y) "Equivalent to (append (reverse X) Y)." + (declare (side-effect-free t)) (nconc (reverse x) y)) ;;;###autoload diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 95a51a4bdde..7fee780a735 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -459,6 +459,7 @@ Thus, `(cl-list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to (defun cl-copy-list (list) "Return a copy of LIST, which may be a dotted list. The elements of LIST are not copied, just the list structure itself." + (declare (side-effect-free error-free)) (if (consp list) (let ((res nil)) (while (consp list) (push (pop list) res)) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index cffe8b09f53..5382e0a0a52 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2758,26 +2758,29 @@ Each PLACE may be a symbol, or any generalized variable allowed by `setf'. ;; Common-Lisp's `psetf' does the first, so we'll do the same. (if (null bindings) (if (and (null binds) (null simplebinds)) (macroexp-progn body) + (let ((body-form + (macroexp-progn + (append + (delq nil + (mapcar (lambda (x) + (pcase x + ;; If there's no vnew, do nothing. + (`(,_vold ,_getter ,setter ,vnew) + (funcall setter vnew)))) + binds)) + body)))) `(let* (,@(mapcar (lambda (x) (pcase-let ((`(,vold ,getter ,_setter ,_vnew) x)) (list vold getter))) binds) ,@simplebinds) - (unwind-protect - ,(macroexp-progn - (append - (delq nil - (mapcar (lambda (x) - (pcase x - ;; If there's no vnew, do nothing. - (`(,_vold ,_getter ,setter ,vnew) - (funcall setter vnew)))) - binds)) - body)) - ,@(mapcar (lambda (x) - (pcase-let ((`(,vold ,_getter ,setter ,_vnew) x)) - (funcall setter vold))) - binds)))) + ,(if binds + `(unwind-protect ,body-form + ,@(mapcar (lambda (x) + (pcase-let ((`(,vold ,_getter ,setter ,_vnew) x)) + (funcall setter vold))) + binds)) + body-form)))) (let* ((binding (car bindings)) (place (car binding))) (gv-letplace (getter setter) place @@ -2888,45 +2891,14 @@ The function's arguments should be treated as immutable. ,(format "compiler-macro for inlining `%s'." name) (cl--defsubst-expand ',argns '(cl-block ,name ,@(cdr (macroexp-parse-body body))) - ;; We used to pass `simple' as - ;; (not (or unsafe (cl-expr-access-order pbody argns))) - ;; But this is much too simplistic since it - ;; does not pay attention to the argvs (and - ;; cl-expr-access-order itself is also too naive). nil ,(and (memq '&key args) 'cl-whole) nil ,@argns))) (cl-defun ,name ,args ,@body)))) -(defun cl--defsubst-expand (argns body simple whole _unsafe &rest argvs) - (if (and whole (not (cl--safe-expr-p (cons 'progn argvs)))) whole - (if (cl--simple-exprs-p argvs) (setq simple t)) - (let* ((substs ()) - (lets (delq nil - (cl-mapcar (lambda (argn argv) - (if (or simple (macroexp-const-p argv)) - (progn (push (cons argn argv) substs) - nil) - (list argn argv))) - argns argvs)))) - ;; FIXME: `sublis/subst' will happily substitute the symbol - ;; `argn' in places where it's not used as a reference - ;; to a variable. - ;; FIXME: `sublis/subst' will happily copy `argv' to a different - ;; scope, leading to name capture. - (setq body (cond ((null substs) body) - ((null (cdr substs)) - (cl-subst (cdar substs) (caar substs) body)) - (t (cl--sublis substs body)))) - (if lets `(let ,lets ,body) body)))) - -(defun cl--sublis (alist tree) - "Perform substitutions indicated by ALIST in TREE (non-destructively)." - (let ((x (assq tree alist))) - (cond - (x (cdr x)) - ((consp tree) - (cons (cl--sublis alist (car tree)) (cl--sublis alist (cdr tree)))) - (t tree)))) +(defun cl--defsubst-expand (argns body _simple whole _unsafe &rest argvs) + (if (and whole (not (cl--safe-expr-p (cons 'progn argvs)))) + whole + `(let ,(cl-mapcar #'list argns argvs) ,body))) ;;; Structures. @@ -3241,19 +3213,8 @@ To see the documentation for a defined struct type, use (let* ((anames (cl--arglist-args args)) (make (cl-mapcar (lambda (s d) (if (memq s anames) s d)) slots defaults)) - ;; `cl-defsubst' is fundamentally broken: it substitutes - ;; its arguments into the body's `sexp' much too naively - ;; when inlinling, which results in various problems. - ;; For example it generates broken code if your - ;; argument's name happens to be the same as some - ;; function used within the body. - ;; E.g. (cl-defsubst sm-foo (list) (list list)) - ;; will expand `(sm-foo 1)' to `(1 1)' rather than to `(list t)'! - ;; Try to catch this known case! - (con-fun (or type #'record)) - (unsafe-cl-defsubst - (or (memq con-fun args) (assq con-fun args)))) - (push `(,(if unsafe-cl-defsubst 'cl-defun cldefsym) ,cname + (con-fun (or type #'record))) + (push `(,cldefsym ,cname (&cl-defs (nil ,@descs) ,@args) ,(if (stringp doc) doc (format "Constructor for objects of type `%s'." name)) @@ -3687,14 +3648,14 @@ macro that returns its `&whole' argument." ;;; Things that are side-effect-free. (mapc (lambda (x) (function-put x 'side-effect-free t)) - '(cl-oddp cl-evenp cl-signum last butlast cl-ldiff cl-pairlis cl-gcd + '(cl-oddp cl-evenp cl-signum cl-ldiff cl-pairlis cl-gcd cl-lcm cl-isqrt cl-floor cl-ceiling cl-truncate cl-round cl-mod cl-rem cl-subseq cl-list-length cl-get cl-getf)) ;;; Things that are side-effect-and-error-free. (mapc (lambda (x) (function-put x 'side-effect-free 'error-free)) - '(eql cl-list* cl-subst cl-acons cl-equalp - cl-random-state-p copy-tree cl-sublis)) + '(cl-list* cl-acons cl-equalp + cl-random-state-p copy-tree)) ;;; Types and assertions. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9f4118dfc86..025d21631bb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -186,8 +186,9 @@ and above." :type '(repeat string) :version "28.1") -(defcustom native-comp-driver-options (when (eq system-type 'darwin) - '("-Wl,-w")) +(defcustom native-comp-driver-options + (cond ((eq system-type 'darwin) '("-Wl,-w")) + ((eq system-type 'cygwin) '("-Wl,-dynamicbase"))) "Options passed verbatim to the native compiler's back-end driver. Note that not all options are meaningful; typically only the options affecting the assembler and linker are likely to be useful. @@ -1711,6 +1712,10 @@ Return value is the fall-through block name." (defun comp-jump-table-optimizable (jmp-table) "Return t if JMP-TABLE can be optimized out." + ;; Identify LAP sequences like: + ;; (byte-constant #s(hash-table size 3 test eq rehash-size 1.5 rehash-threshold 0.8125 purecopy t data (created 126 deleted 126 changed 126)) . 24) + ;; (byte-switch) + ;; (TAG 126 . 10) (cl-loop with labels = (cl-loop for target-label being each hash-value of jmp-table collect target-label) @@ -1718,7 +1723,10 @@ Return value is the fall-through block name." for l in (cdr-safe labels) unless (= l x) return nil - finally return t)) + finally return (pcase (nth (1+ (comp-limplify-pc comp-pass)) + (comp-func-lap comp-func)) + (`(TAG ,label . ,_label-sp) + (= label l))))) (defun comp-emit-switch (var last-insn) "Emit a Limple for a lap jump table given VAR and LAST-INSN." @@ -1763,27 +1771,32 @@ Return value is the fall-through block name." (_ (signal 'native-ice '("missing previous setimm while creating a switch"))))) +(defun comp--func-arity (subr-name) + "Like `func-arity' but invariant against primitive redefinitions. +SUBR-NAME is the name of function." + (or (gethash subr-name comp-subr-arities-h) + (func-arity subr-name))) + (defun comp-emit-set-call-subr (subr-name sp-delta) "Emit a call for SUBR-NAME. SP-DELTA is the stack adjustment." - (let ((subr (symbol-function subr-name)) - (nargs (1+ (- sp-delta)))) - (let* ((arity (func-arity subr)) - (minarg (car arity)) - (maxarg (cdr arity))) - (when (eq maxarg 'unevalled) - (signal 'native-ice (list "subr contains unevalled args" subr-name))) - (if (eq maxarg 'many) - ;; callref case. - (comp-emit-set-call (comp-callref subr-name nargs (comp-sp))) - ;; Normal call. - (unless (and (>= maxarg nargs) (<= minarg nargs)) - (signal 'native-ice - (list "incoherent stack adjustment" nargs maxarg minarg))) - (let* ((subr-name subr-name) - (slots (cl-loop for i from 0 below maxarg - collect (comp-slot-n (+ i (comp-sp)))))) - (comp-emit-set-call (apply #'comp-call (cons subr-name slots)))))))) + (let* ((nargs (1+ (- sp-delta))) + (arity (comp--func-arity subr-name)) + (minarg (car arity)) + (maxarg (cdr arity))) + (when (eq maxarg 'unevalled) + (signal 'native-ice (list "subr contains unevalled args" subr-name))) + (if (eq maxarg 'many) + ;; callref case. + (comp-emit-set-call (comp-callref subr-name nargs (comp-sp))) + ;; Normal call. + (unless (and (>= maxarg nargs) (<= minarg nargs)) + (signal 'native-ice + (list "incoherent stack adjustment" nargs maxarg minarg))) + (let* ((subr-name subr-name) + (slots (cl-loop for i from 0 below maxarg + collect (comp-slot-n (+ i (comp-sp)))))) + (comp-emit-set-call (apply #'comp-call (cons subr-name slots))))))) (eval-when-compile (defun comp-op-to-fun (x) diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 77f4b26d9bb..84e131147cd 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -452,15 +452,23 @@ No problems result if this variable is not bound. TURN-ON is a function that will be called with no args in every buffer and that should try to turn MODE on if applicable for that buffer. -Each of KEY VALUE is a pair of CL-style keyword arguments. :predicate -specifies which major modes the globalized minor mode should be switched on -in. As the minor mode defined by this function is always global, any -:global keyword is ignored. Other keywords have the same meaning as in -`define-minor-mode', which see. In particular, :group specifies the custom -group. The most useful keywords are those that are passed on to the -`defcustom'. It normally makes no sense to pass the :lighter or :keymap -keywords to `define-globalized-minor-mode', since these are usually passed -to the buffer-local version of the minor mode. +Each of KEY VALUE is a pair of CL-style keyword arguments. +The :predicate argument specifies in which major modes should the +globalized minor mode be switched on. The value should be t (meaning +switch on the minor mode in all major modes), nil (meaning don't +switch on in any major mode), a list of modes (meaning switch on only +in those modes and their descendants), or a list (not MODES...), +meaning switch on in any major mode except MODES. The value can also +mix all of these forms, see the info node `Defining Minor Modes' for +details. +As the minor mode defined by this function is always global, any +:global keyword is ignored. +Other keywords have the same meaning as in `define-minor-mode', +which see. In particular, :group specifies the custom group. +The most useful keywords are those that are passed on to the `defcustom'. +It normally makes no sense to pass the :lighter or :keymap keywords +to `define-globalized-minor-mode', since these are usually passed to +the buffer-local version of the minor mode. BODY contains code to execute each time the mode is enabled or disabled. It is executed after toggling the mode, and before running @@ -512,7 +520,7 @@ on if the hook has explicitly disabled it. (setq turn-on-function `(lambda () (require 'easy-mmode) - (when (easy-mmode--globalized-predicate-p ,(car predicate)) + (when (easy-mmode--globalized-predicate-p ,MODE-predicate) (funcall ,turn-on-function))))) (_ (push keyw extra-keywords) (push (pop body) extra-keywords)))) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 552526b6efc..9a06807bcdc 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -2853,81 +2853,81 @@ See `edebug-behavior-alist' for implementations.") edebug-inside-windows ) - (unwind-protect - (let ( - ;; Declare global values local but using the same global value. - ;; We could set these to the values for previous edebug call. - (last-command last-command) - (this-command this-command) - (current-prefix-arg nil) - - (last-input-event nil) - (last-command-event nil) - (last-event-frame nil) - (last-nonmenu-event nil) - (track-mouse nil) - - (standard-output t) - (standard-input t) - - ;; Don't keep reading from an executing kbd macro - ;; within edebug unless edebug-continue-kbd-macro is - ;; non-nil. Again, local binding may not be best. - (executing-kbd-macro - (if edebug-continue-kbd-macro executing-kbd-macro)) - - ;; Don't get confused by the user's keymap changes. - (overriding-local-map nil) - (overriding-terminal-local-map nil) - ;; Override other minor modes that may bind the keys - ;; edebug uses. - (minor-mode-overriding-map-alist - (list (cons 'edebug-mode edebug-mode-map))) - - ;; Bind again to outside values. - (debug-on-error edebug-outside-debug-on-error) - (debug-on-quit edebug-outside-debug-on-quit) - - ;; Don't keep defining a kbd macro. - (defining-kbd-macro - (if edebug-continue-kbd-macro defining-kbd-macro)) - - ;; others?? - ) - (if (and (eq edebug-execution-mode 'go) - (not (memq arg-mode '(after error)))) - (message "Break")) - - (setq signal-hook-function nil) - - (edebug-mode 1) - (unwind-protect - (recursive-edit) ; <<<<<<<<<< Recursive edit - - ;; Do the following, even if quit occurs. - (setq signal-hook-function #'edebug-signal) - (if edebug-backtrace-buffer - (kill-buffer edebug-backtrace-buffer)) - - ;; Remember selected-window after recursive-edit. - ;; (setq edebug-inside-window (selected-window)) - - (set-match-data edebug-outside-match-data) - - ;; Recursive edit may have changed buffers, - ;; so set it back before exiting let. - (if (buffer-name edebug-buffer) ; if it still exists - (progn - (set-buffer edebug-buffer) - (when (memq edebug-execution-mode '(go Go-nonstop)) - (edebug-overlay-arrow) - (sit-for 0)) - (edebug-mode -1)) - ;; gotta have a buffer to let its buffer local variables be set - (get-buffer-create " bogus edebug buffer")) - ));; inner let - ))) + (let ( + ;; Declare global values local but using the same global value. + ;; We could set these to the values for previous edebug call. + (last-command last-command) + (this-command this-command) + (current-prefix-arg nil) + + (last-input-event nil) + (last-command-event nil) + (last-event-frame nil) + (last-nonmenu-event nil) + (track-mouse nil) + + (standard-output t) + (standard-input t) + + ;; Don't keep reading from an executing kbd macro + ;; within edebug unless edebug-continue-kbd-macro is + ;; non-nil. Again, local binding may not be best. + (executing-kbd-macro + (if edebug-continue-kbd-macro executing-kbd-macro)) + + ;; Don't get confused by the user's keymap changes. + (overriding-local-map nil) + (overriding-terminal-local-map nil) + ;; Override other minor modes that may bind the keys + ;; edebug uses. + (minor-mode-overriding-map-alist + (list (cons 'edebug-mode edebug-mode-map))) + + ;; Bind again to outside values. + (debug-on-error edebug-outside-debug-on-error) + (debug-on-quit edebug-outside-debug-on-quit) + + ;; Don't keep defining a kbd macro. + (defining-kbd-macro + (if edebug-continue-kbd-macro defining-kbd-macro)) + + ;; others?? + ) + + (if (and (eq edebug-execution-mode 'go) + (not (memq arg-mode '(after error)))) + (message "Break")) + + (setq signal-hook-function nil) + + (edebug-mode 1) + (unwind-protect + (recursive-edit) ; <<<<<<<<<< Recursive edit + + ;; Do the following, even if quit occurs. + (setq signal-hook-function #'edebug-signal) + (if edebug-backtrace-buffer + (kill-buffer edebug-backtrace-buffer)) + + ;; Remember selected-window after recursive-edit. + ;; (setq edebug-inside-window (selected-window)) + + (set-match-data edebug-outside-match-data) + + ;; Recursive edit may have changed buffers, + ;; so set it back before exiting let. + (if (buffer-name edebug-buffer) ; if it still exists + (progn + (set-buffer edebug-buffer) + (when (memq edebug-execution-mode '(go Go-nonstop)) + (edebug-overlay-arrow) + (sit-for 0)) + (edebug-mode -1)) + ;; gotta have a buffer to let its buffer local variables be set + (get-buffer-create " bogus edebug buffer")) + ));; inner let + )) ;;; Display related functions diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index 74bef264bf1..18d3eb37af3 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -5,7 +5,7 @@ ;; Author: Noah Friedman <friedman@splode.com> ;; Keywords: extensions ;; Created: 1995-10-06 -;; Version: 1.13.0 +;; Version: 1.14.0 ;; Package-Requires: ((emacs "26.3")) ;; This is a GNU ELPA :core package. Avoid functionality that is not @@ -437,7 +437,7 @@ documentation-producing backend to cooperate with specific documentation-displaying frontends. For example, KEY can be: * `:thing', VALUE being a short string or symbol designating what - is being reported on. It can, for example be the name of the + DOCSTRING reports on. It can, for example be the name of the function whose signature is being documented, or the name of the variable whose docstring is being documented. `eldoc-display-in-echo-area', a member of @@ -448,6 +448,17 @@ documentation-displaying frontends. For example, KEY can be: `eldoc-display-in-echo-area' and `eldoc-display-in-buffer' will use when displaying `:thing''s value. +* `:echo', controlling how `eldoc-display-in-echo-area' should + present this documentation item in the echo area, to save + space. If VALUE is a string, echo it instead of DOCSTRING. If + a number, only echo DOCSTRING up to that character position. + If `skip', don't echo DOCSTRING at all. + +The additional KEY `:origin' is always added by ElDoc, its VALUE +being the member of `eldoc-documentation-functions' where +DOCSTRING originated. `eldoc-display-functions' may use this +information to organize display of multiple docstrings. + Finally, major modes should modify this hook locally, for example: (add-hook \\='eldoc-documentation-functions #\\='foo-mode-eldoc nil t) @@ -471,8 +482,6 @@ directly from the user or from ElDoc's automatic mechanisms'.") (defvar eldoc--doc-buffer nil "Buffer displaying latest ElDoc-produced docs.") -(defvar eldoc--doc-buffer-docs nil "Documentation items in `eldoc--doc-buffer'.") - (defun eldoc-doc-buffer (&optional interactive) "Get or display ElDoc documentation buffer. @@ -490,46 +499,70 @@ If INTERACTIVE, display it. Else, return said buffer." (display-buffer (current-buffer))) (t (current-buffer))))) +(defvar eldoc-doc-buffer-separator + (concat "\n" (propertize "\n" 'face '(:inherit separator-line :extend t)) "\n") + "String used to separate items in Eldoc documentation buffer.") + (defun eldoc--format-doc-buffer (docs) "Ensure DOCS are displayed in an *eldoc* buffer." (with-current-buffer (if (buffer-live-p eldoc--doc-buffer) eldoc--doc-buffer (setq eldoc--doc-buffer (get-buffer-create " *eldoc*"))) - (unless (eq docs eldoc--doc-buffer-docs) - (setq-local eldoc--doc-buffer-docs docs) - (let ((inhibit-read-only t) - (things-reported-on)) - (special-mode) - (erase-buffer) - (setq-local nobreak-char-display nil) - (cl-loop for (docs . rest) on docs - for (this-doc . plist) = docs - for thing = (plist-get plist :thing) - when thing do - (cl-pushnew thing things-reported-on) - (setq this-doc - (concat - (propertize (format "%s" thing) - 'face (plist-get plist :face)) - ": " - this-doc)) - do (insert this-doc) - when rest do (insert "\n") - finally (goto-char (point-min))) - ;; Rename the buffer, taking into account whether it was - ;; hidden or not - (rename-buffer (format "%s*eldoc%s*" - (if (string-match "^ " (buffer-name)) " " "") - (if things-reported-on - (format " for %s" - (mapconcat - (lambda (s) (format "%s" s)) - things-reported-on - ", ")) - "")))))) + (let ((inhibit-read-only t) + (things-reported-on)) + (special-mode) + (erase-buffer) + (setq-local nobreak-char-display nil) + (cl-loop for (docs . rest) on docs + for (this-doc . plist) = docs + for thing = (plist-get plist :thing) + when thing do + (cl-pushnew thing things-reported-on) + (setq this-doc + (concat + (propertize (format "%s" thing) + 'face (plist-get plist :face)) + ": " + this-doc)) + do (insert this-doc) + when rest do + (insert eldoc-doc-buffer-separator) + finally (goto-char (point-min))) + ;; Rename the buffer, taking into account whether it was + ;; hidden or not + (rename-buffer (format "%s*eldoc%s*" + (if (string-match "^ " (buffer-name)) " " "") + (if things-reported-on + (format " for %s" + (mapconcat + (lambda (s) (format "%s" s)) + things-reported-on + ", ")) + ""))))) eldoc--doc-buffer) +(defun eldoc--echo-area-render (docs) + "Similar to `eldoc--format-doc-buffer', but for echo area. +Helper for `eldoc-display-in-echo-area'." + (cl-loop for (item . rest) on docs + for (this-doc . plist) = item + for echo = (plist-get plist :echo) + for thing = (plist-get plist :thing) + unless (eq echo 'skip) do + (setq this-doc + (cond ((integerp echo) (substring this-doc 0 echo)) + ((stringp echo) echo) + (t this-doc))) + (when thing (setq this-doc + (concat + (propertize (format "%s" thing) + 'face (plist-get plist :face)) + ": " + this-doc))) + (insert this-doc) + (when rest (insert "\n")))) + (defun eldoc--echo-area-substring (available) "Given AVAILABLE lines, get buffer substring to display in echo area. Helper for `eldoc-display-in-echo-area'." @@ -615,15 +648,15 @@ Honor `eldoc-echo-area-use-multiline-p' and single-doc) ((and (numberp available) (cl-plusp available)) - ;; Else, given a positive number of logical lines, we - ;; format the *eldoc* buffer, using as most of its - ;; contents as we know will fit. - (with-current-buffer (eldoc--format-doc-buffer docs) - (save-excursion - (eldoc--echo-area-substring available)))) + ;; Else, given a positive number of logical lines, grab + ;; as many as we can. + (with-temp-buffer + (eldoc--echo-area-render docs) + (eldoc--echo-area-substring available))) (t ;; this is the "truncate brutally" situation (let ((string - (with-current-buffer (eldoc--format-doc-buffer docs) + (with-temp-buffer + (eldoc--echo-area-render docs) (buffer-substring (goto-char (point-min)) (progn (end-of-visible-line) (point)))))) @@ -644,38 +677,45 @@ If INTERACTIVE is t, also display the buffer." (defun eldoc-documentation-default () "Show the first non-nil documentation string for item at point. This is the default value for `eldoc-documentation-strategy'." - (run-hook-with-args-until-success 'eldoc-documentation-functions - (eldoc--make-callback :patient))) - -(defun eldoc--documentation-compose-1 (eagerlyp) - "Helper function for composing multiple doc strings. -If EAGERLYP is non-nil show documentation as soon as possible, -else wait for all doc strings." (run-hook-wrapped 'eldoc-documentation-functions (lambda (f) - (let* ((callback (eldoc--make-callback - (if eagerlyp :eager :patient))) - (str (funcall f callback))) - (if (or (null str) (stringp str)) (funcall callback str)) - nil))) - t) + (funcall f (eldoc--make-callback :eager f))))) (defun eldoc-documentation-compose () "Show multiple documentation strings together after waiting for all of them. This is meant to be used as a value for `eldoc-documentation-strategy'." - (eldoc--documentation-compose-1 nil)) + (let (fns-and-callbacks) + ;; Make all the callbacks, setting up state inside + ;; `eldoc--invoke-strategy' to know how many callbacks to wait for + ;; before displaying the result (bug#62816). + (run-hook-wrapped 'eldoc-documentation-functions + (lambda (f) + (push (cons f (eldoc--make-callback :patient f)) + fns-and-callbacks) + nil)) + ;; Now call them. The last one will trigger the display. + (cl-loop for (f . callback) in fns-and-callbacks + for str = (funcall f callback) + when (or (null str) (stringp str)) do (funcall callback str))) + t) (defun eldoc-documentation-compose-eagerly () "Show multiple documentation strings one by one as soon as possible. This is meant to be used as a value for `eldoc-documentation-strategy'." - (eldoc--documentation-compose-1 t)) + (run-hook-wrapped 'eldoc-documentation-functions + (lambda (f) + (let* ((callback (eldoc--make-callback :eager f)) + (str (funcall f callback))) + (if (or (null str) (stringp str)) (funcall callback str)) + nil))) + t) (defun eldoc-documentation-enthusiast () "Show most important documentation string produced so far. This is meant to be used as a value for `eldoc-documentation-strategy'." (run-hook-wrapped 'eldoc-documentation-functions (lambda (f) - (let* ((callback (eldoc--make-callback :enthusiast)) + (let* ((callback (eldoc--make-callback :enthusiast f)) (str (funcall f callback))) (if (stringp str) (funcall callback str)) nil))) @@ -780,7 +820,7 @@ before a higher priority one.") ;; `eldoc--invoke-strategy' could be moved to ;; `eldoc-documentation-strategy' or thereabouts if/when we decide to ;; extend or publish the `make-callback' protocol. -(defun eldoc--make-callback (method) +(defun eldoc--make-callback (method origin) "Make callback suitable for `eldoc-documentation-functions'. The return value is a function FN whose lambda list is (STRING &rest PLIST) and can be called by those functions. Its @@ -800,8 +840,11 @@ have the following values: `eldoc-documentation-functions' have been collected; - `:eager' says to display STRING along with all other competing - strings so far, as soon as possible." - (funcall eldoc--make-callback method)) + strings so far, as soon as possible. + +ORIGIN is the member of `eldoc-documentation-functions' which +will be responsible for eventually calling the FN." + (funcall eldoc--make-callback method origin)) (defun eldoc--invoke-strategy (interactive) "Invoke `eldoc-documentation-strategy' function. @@ -838,9 +881,10 @@ the docstrings eventually produced, using (docs-registered '())) (cl-labels ((register-doc - (pos string plist) + (pos string plist origin) (when (and string (> (length string) 0)) - (push (cons pos (cons string plist)) docs-registered))) + (push (cons pos (cons string `(:origin ,origin ,@plist))) + docs-registered))) (display-doc () (run-hook-with-args @@ -850,7 +894,7 @@ the docstrings eventually produced, using (lambda (a b) (< (car a) (car b)))))) interactive)) (make-callback - (method) + (method origin) (let ((pos (prog1 howmany (cl-incf howmany)))) (cl-ecase method (:enthusiast @@ -858,7 +902,7 @@ the docstrings eventually produced, using (when (and string (cl-loop for (p) in docs-registered never (< p pos))) (setq docs-registered '()) - (register-doc pos string plist)) + (register-doc pos string plist origin)) (when (and (timerp eldoc--enthusiasm-curbing-timer) (memq eldoc--enthusiasm-curbing-timer timer-list)) @@ -870,19 +914,22 @@ the docstrings eventually produced, using (:patient (cl-incf want) (lambda (string &rest plist) - (register-doc pos string plist) + (register-doc pos string plist origin) (when (zerop (cl-decf want)) (display-doc)) t)) (:eager (lambda (string &rest plist) - (register-doc pos string plist) + (register-doc pos string plist origin) (display-doc) t)))))) (let* ((eldoc--make-callback #'make-callback) (res (funcall eldoc-documentation-strategy))) ;; Observe the old and the new protocol: - (cond (;; Old protocol: got string, output immediately; - (stringp res) (register-doc 0 res nil) (display-doc)) + (cond (;; Old protocol: got string, e-d-strategy is iself the + ;; origin function, and we output immediately; + (stringp res) + (register-doc 0 res nil eldoc-documentation-strategy) + (display-doc)) (;; Old protocol: got nil, clear the echo area; (null res) (eldoc--message nil)) (;; New protocol: trust callback will be called; diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index 98a017c8a8e..e8b0dd92989 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -563,9 +563,9 @@ The same keyword arguments are supported as in ;; Emacs's Makefile sets $HOME to a nonexistent value. Needed ;; in batch mode only, therefore. (when (and noninteractive (not (file-directory-p "~/"))) - (setenv "HOME" temporary-file-directory)) + (setenv "HOME" (directory-file-name temporary-file-directory))) (format "/mock::%s" temporary-file-directory)))) - "Temporary directory for remote file tests.") + "Temporary directory for remote file tests.") (provide 'ert-x) diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index dad91e92a45..ac001af06bd 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -271,7 +271,7 @@ instead the assignment is turned into something equivalent to (SETTER ARGS... temp) temp) so as to preserve the semantics of `setf'." - (declare (debug (sexp (&or symbolp lambda-expr) &optional sexp))) + (declare (debug (sexp [&or symbolp lambda-expr] &optional sexp))) (when (eq 'lambda (car-safe setter)) (message "Use `gv-define-setter' or name %s's setter function" name)) `(gv-define-setter ,name (val &rest args) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 8cb67c3b8b5..b05aba3e1a7 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -383,6 +383,11 @@ Assumes the caller has bound `macroexpand-all-environment'." (format-message "missing `while' condition") `(signal 'wrong-number-of-arguments '(while 0)) nil 'compile-only form)) + (`(unwind-protect ,expr) + (macroexp-warn-and-return + (format-message "`unwind-protect' without unwind forms") + (macroexp--expand-all expr) + (list 'suspicious 'unwind-protect) t form)) (`(setq ,(and var (pred symbolp) (pred (not booleanp)) (pred (not keywordp))) ,expr) diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 253b35f1f1a..a72bb084d31 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -41,9 +41,6 @@ ;; - Allow maintaining patches that are ported back onto regular ;; packages and maintained between versions. -;; -;; - Add a heuristic for guessing a `:lisp-dir' when cloning directly -;; from a URL. ;;; Code: @@ -58,7 +55,7 @@ (defgroup package-vc nil "Manage packages from VC checkouts." :group 'package - :link '(custom-manual "(emacs) Package from Source") + :link '(custom-manual "(emacs) Fetching Package Sources") :prefix "package-vc-" :version "29.1") @@ -115,6 +112,11 @@ the `clone' function." vc-handled-backends)) :version "29.1") +(defcustom package-vc-register-as-project t + "Non-nil means that packages should be registered as projects." + :type 'boolean + :version "30.1") + (defvar package-vc-selected-packages) ; pacify byte-compiler ;;;###autoload @@ -145,32 +147,9 @@ is a symbol designating the package and SPEC is one of: - nil, if any package version can be installed; - a version string, if that specific revision is to be installed; -- a property list, describing a package specification. Valid - key/value pairs are - - `:url' (string) - The URL of the repository used to fetch the package source. - - `:branch' (string) - If given, the name of the branch to checkout after cloning the directory. - - `:lisp-dir' (string) - The repository-relative name of the directory to use for loading the Lisp - sources. If not given, the value defaults to the root directory - of the repository. - - `:main-file' (string) - The main file of the project, relevant to gather package metadata. - If not given, the assumed default is the package name with \".el\" - appended to it. - - `:vc-backend' (symbol) - A symbol of the VC backend to use for cloning the package. The - value ought to be a member of `vc-handled-backends'. If omitted, - `vc-clone' will fall back onto the archive default or on - `package-vc-default-backend'. - - All other keys are ignored. +- a property list, describing a package specification. For more + details, please consult the subsection \"Specifying Package + Sources\" in the Info node `(emacs)Fetching Package Sources'. This user option will be automatically updated to store package specifications for packages that are not specified in any @@ -184,6 +163,7 @@ archive." (:branch string) (:lisp-dir string) (:main-file string) + (:doc string) (:vc-backend symbol))))) :version "29.1") @@ -559,6 +539,8 @@ and return nil if it cannot reasonably guess." (and url (alist-get url package-vc-heuristic-alist nil nil #'string-match-p))) +(declare-function project-remember-projects-under "project" (dir &optional recursive)) + (defun package-vc--clone (pkg-desc pkg-spec dir rev) "Clone the package PKG-DESC whose spec is PKG-SPEC into the directory DIR. REV specifies a specific revision to checkout. This overrides the `:branch' @@ -580,6 +562,11 @@ attribute in PKG-SPEC." (or (and (not (eq rev :last-release)) rev) branch)) (error "Failed to clone %s from %s" name url)))) + (when package-vc-register-as-project + (let ((default-directory dir)) + (require 'project) + (project-remember-projects-under dir))) + ;; Check out the latest release if requested (when (eq rev :last-release) (if-let ((release-rev (package-vc--release-rev pkg-desc))) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 3d2fcc55683..88047c53a41 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -1219,15 +1219,14 @@ boundaries." "Read a `define-package' form in current buffer. Return the pkg-desc, with desc-kind set to KIND." (goto-char (point-min)) - (unwind-protect - (let* ((pkg-def-parsed (read (current-buffer))) - (pkg-desc - (when (eq (car pkg-def-parsed) 'define-package) - (apply #'package-desc-from-define - (append (cdr pkg-def-parsed)))))) - (when pkg-desc - (setf (package-desc-kind pkg-desc) kind) - pkg-desc)))) + (let* ((pkg-def-parsed (read (current-buffer))) + (pkg-desc + (when (eq (car pkg-def-parsed) 'define-package) + (apply #'package-desc-from-define + (append (cdr pkg-def-parsed)))))) + (when pkg-desc + (setf (package-desc-kind pkg-desc) kind) + pkg-desc))) (declare-function tar-get-file-descriptor "tar-mode" (file)) (declare-function tar--extract "tar-mode" (descriptor)) diff --git a/lisp/emulation/viper-cmd.el b/lisp/emulation/viper-cmd.el index 2a37c383f81..c0aa9dd7b46 100644 --- a/lisp/emulation/viper-cmd.el +++ b/lisp/emulation/viper-cmd.el @@ -722,16 +722,12 @@ Vi's prefix argument will be used. Otherwise, the prefix argument passed to (let (viper-vi-kbd-minor-mode viper-insert-kbd-minor-mode viper-emacs-kbd-minor-mode) - (unwind-protect - (progn - (setq com - (key-binding (setq key (read-key-sequence nil)))) - ;; In case of binding indirection--chase definitions. - ;; Have to do it here because we execute this command under - ;; different keymaps, so command-execute may not do the - ;; right thing there - (while (vectorp com) (setq com (key-binding com)))) - nil) + (setq com (key-binding (setq key (read-key-sequence nil)))) + ;; In case of binding indirection--chase definitions. + ;; Have to do it here because we execute this command under + ;; different keymaps, so command-execute may not do the + ;; right thing there + (while (vectorp com) (setq com (key-binding com))) ;; Execute command com in the original Viper state, not in state ;; `state'. Otherwise, if we switch buffers while executing the ;; escaped to command, Viper's mode vars will remain those of @@ -1950,16 +1946,16 @@ To turn this feature off, set this variable to nil." (if found () (viper-tmp-insert-at-eob " [Please complete file name]") - (unwind-protect - (while (not (memq cmd - '(exit-minibuffer viper-exit-minibuffer))) - (setq cmd - (key-binding (setq key (read-key-sequence nil)))) - (cond ((eq cmd 'self-insert-command) - (insert key)) - ((memq cmd '(exit-minibuffer viper-exit-minibuffer)) - nil) - (t (command-execute cmd)))))))))) + + (while (not (memq cmd + '(exit-minibuffer viper-exit-minibuffer))) + (setq cmd + (key-binding (setq key (read-key-sequence nil)))) + (cond ((eq cmd 'self-insert-command) + (insert key)) + ((memq cmd '(exit-minibuffer viper-exit-minibuffer)) + nil) + (t (command-execute cmd))))))))) (defun viper-minibuffer-trim-tail () diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index 567443f5329..bdf4e2ddca2 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -415,8 +415,12 @@ This only has an effect if `erc-server-auto-reconnect' is non-nil." (defcustom erc-server-reconnect-timeout 1 "Number of seconds to wait between successive reconnect attempts. - -If a key is pressed while ERC is waiting, it will stop waiting." +If this value is too low, servers may reject your initial nick +request upon reconnecting because they haven't yet noticed that +your previous connection is dead. If this happens, try setting +this value to 120 or greater and/or exploring the option +`erc-nickname-in-use-functions', which may provide a more +proactive means of handling this situation on some servers." :type 'number) (defcustom erc-server-reconnect-function 'erc-server-delayed-reconnect @@ -427,6 +431,7 @@ dialing. Use `erc-schedule-reconnect' to instead try again later and optionally alter the attempts tally." :package-version '(ERC . "5.5") :type '(choice (function-item erc-server-delayed-reconnect) + (function-item erc-server-delayed-check-reconnect) function)) (defcustom erc-split-line-length 440 @@ -658,6 +663,30 @@ The current buffer is given by BUFFER." (run-hooks 'erc--server-post-connect-hook) (erc-login)) +(defvar erc--server-connect-function #'erc--server-propagate-failed-connection + "Function called one second after creating a server process. +Called with the newly created process just before the opening IRC +protocol exchange.") + +(defun erc--server-propagate-failed-connection (process) + "Ensure the PROCESS sentinel runs at least once on early failure. +Act as a watchdog timer to force `erc-process-sentinel' and its +finalizers, like `erc-disconnected-hook', to run when PROCESS has +a status of `failed' after one second. But only do so when its +error data is something ERC recognizes. Print an explanation to +the server buffer in any case." + (when (eq (process-status process) 'failed) + (erc-display-message + nil 'error (process-buffer process) + (format "Process exit status: %S" (process-exit-status process))) + (pcase (process-exit-status process) + (111 + (erc-process-sentinel process "failed with code 111\n")) + (`(file-error . ,_) + (erc-process-sentinel process "failed with code -523\n")) + ((rx "tls" (+ nonl) "failed") + (erc-process-sentinel process "failed with code -525\n"))))) + (defvar erc--server-connect-dumb-ipv6-regexp ;; Not for validation (gives false positives). (rx bot "[" (group (+ (any xdigit digit ":.")) (? "%" (+ alnum))) "]" eot)) @@ -710,7 +739,9 @@ TLS (see `erc-session-client-certificate' for more details)." ;; MOTD line) (if (eq (process-status process) 'connect) ;; waiting for a non-blocking connect - keep the user informed - (erc-display-message nil nil buffer "Opening connection..\n") + (progn + (erc-display-message nil nil buffer "Opening connection..\n") + (run-at-time 1 nil erc--server-connect-function process)) (message "%s...done" msg) (erc--register-connection)))) @@ -744,6 +775,78 @@ Make sure you are in an ERC buffer when running this." (with-current-buffer buffer (erc-server-reconnect)))) +(defvar-local erc--server-reconnect-timeout nil) +(defvar-local erc--server-reconnect-timeout-check 10) +(defvar-local erc--server-reconnect-timeout-scale-function + #'erc--server-reconnect-timeout-double) + +(defun erc--server-reconnect-timeout-double (existing) + "Double EXISTING timeout, but cap it at 5 minutes." + (min 300 (* existing 2))) + +;; This may appear to hang at various places. It's assumed that when +;; *Messages* contains "Waiting for socket ..." or similar, progress +;; will be made eventually. + +(defun erc-server-delayed-check-reconnect (buffer) + "Wait for internet connectivity before trying to reconnect. +Expect BUFFER to be the server buffer for the current connection." + (when (buffer-live-p buffer) + (with-current-buffer buffer + (setq erc--server-reconnect-timeout + (funcall erc--server-reconnect-timeout-scale-function + (or erc--server-reconnect-timeout + erc-server-reconnect-timeout))) + (let* ((reschedule (lambda (proc) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (let ((erc-server-reconnect-timeout + erc--server-reconnect-timeout)) + (delete-process proc) + (erc-display-message nil 'error buffer + "Nobody home...") + (erc-schedule-reconnect buffer 0)))))) + (conchk-exp (time-add erc--server-reconnect-timeout-check + (current-time))) + (conchk-timer nil) + (conchk (lambda (proc) + (let ((status (process-status proc)) + (xprdp (time-less-p conchk-exp (current-time)))) + (when (or (not (eq 'connect status)) xprdp) + (cancel-timer conchk-timer)) + (when (buffer-live-p buffer) + (cond (xprdp (erc-display-message + nil 'error buffer + "Timed out while dialing...") + (delete-process proc) + (funcall reschedule proc)) + ((eq 'failed status) + (funcall reschedule proc))))))) + (sentinel (lambda (proc event) + (pcase event + ("open\n" + (run-at-time nil nil #'send-string proc + (format "PING %d\r\n" + (time-convert nil 'integer)))) + ((or "connection broken by remote peer\n" + (rx bot "failed")) + (funcall reschedule proc))))) + (filter (lambda (proc _) + (delete-process proc) + (with-current-buffer buffer + (setq erc--server-reconnect-timeout nil)) + (run-at-time nil nil #'erc-server-delayed-reconnect + buffer)))) + (condition-case _ + (let ((proc (funcall erc-session-connector + "*erc-connectivity-check*" nil + erc-session-server erc-session-port + :nowait t))) + (setq conchk-timer (run-at-time 1 1 conchk proc)) + (set-process-filter proc filter) + (set-process-sentinel proc sentinel)) + (file-error (funcall reschedule nil))))))) + (defun erc-server-filter-function (process string) "The process filter for the ERC server." (with-current-buffer (process-buffer process) @@ -823,11 +926,16 @@ When `erc-server-reconnect-attempts' is a number, increment `erc-server-reconnect-count' by INCR unconditionally." (let ((count (and (integerp erc-server-reconnect-attempts) (- erc-server-reconnect-attempts - (cl-incf erc-server-reconnect-count (or incr 1)))))) - (erc-display-message nil 'error (current-buffer) 'reconnecting + (cl-incf erc-server-reconnect-count (or incr 1))))) + (proc (buffer-local-value 'erc-server-process buffer))) + (erc-display-message nil 'error buffer 'reconnecting ?m erc-server-reconnect-timeout ?i (if count erc-server-reconnect-count "N") ?n (if count erc-server-reconnect-attempts "A")) + (set-process-sentinel proc #'ignore) + (set-process-filter proc nil) + (delete-process proc) + (erc-update-mode-line) (setq erc-server-reconnecting nil erc--server-reconnect-timer (run-at-time erc-server-reconnect-timeout nil @@ -1876,7 +1984,7 @@ ambiguous and only useful for tokens supporting a single primitive value." (if-let* ((table (or erc--isupport-params (erc-with-server-buffer erc--isupport-params))) - (value (erc-compat--with-memoization (gethash key table) + (value (with-memoization (gethash key table) (when-let ((v (assoc (symbol-name key) erc-server-parameters))) (if (cdr v) @@ -2236,6 +2344,11 @@ See `erc-display-server-message'." nil (erc-display-message parsed '(notice error) 'active 's401 ?n nick/channel))) +(define-erc-response-handler (402) + "No such server." nil + (erc-display-message parsed '(notice error) 'active + 's402 ?c (cadr (erc-response.command-args parsed)))) + (define-erc-response-handler (403) "No such channel." nil (erc-display-message parsed '(notice error) 'active @@ -2383,7 +2496,7 @@ See `erc-display-error-notice'." nil ;; (define-erc-response-handler (323 364 365 381 382 392 393 394 395 ;; 200 201 202 203 204 205 206 208 209 211 212 213 ;; 214 215 216 217 218 219 241 242 243 244 249 261 -;; 262 302 342 351 402 407 409 411 413 414 415 +;; 262 302 342 351 407 409 411 413 414 415 ;; 423 424 436 441 443 444 467 471 472 473 KILL) ;; nil nil ;; (ignore proc parsed)) diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el index c28dddefa0e..33e69f3b0b8 100644 --- a/lisp/erc/erc-button.el +++ b/lisp/erc/erc-button.el @@ -52,14 +52,15 @@ ;;;###autoload(autoload 'erc-button-mode "erc-button" nil t) (define-erc-module button nil "This mode buttonizes all messages according to `erc-button-alist'." - ((add-hook 'erc-insert-modify-hook #'erc-button-add-buttons 'append) + ((erc-button--check-nicknames-entry) + (add-hook 'erc-insert-modify-hook #'erc-button-add-buttons 'append) (add-hook 'erc-send-modify-hook #'erc-button-add-buttons 'append) (add-hook 'erc-complete-functions #'erc-button-next-function) - (add-hook 'erc-mode-hook #'erc-button-setup)) + (erc--modify-local-map t "<backtab>" #'erc-button-previous)) ((remove-hook 'erc-insert-modify-hook #'erc-button-add-buttons) (remove-hook 'erc-send-modify-hook #'erc-button-add-buttons) (remove-hook 'erc-complete-functions #'erc-button-next-function) - (remove-hook 'erc-mode-hook #'erc-button-setup))) + (erc--modify-local-map nil "<backtab>" #'erc-button-previous))) ;;; Variables @@ -133,7 +134,7 @@ longer than `erc-fill-column'." ("[`‘]\\([a-zA-Z][-a-zA-Z_0-9!*<=>+]+\\)['’]" 1 t erc-button-describe-symbol 1) ;; pseudo links - ("\\bInfo:[\"]\\([^\"]+\\)[\"]" 0 t Info-goto-node 1) + ("\\(?:\\bInfo: ?\\|(info \\)[\"]\\(([^\"]+\\)[\"])?" 0 t info 1) ("\\b\\(Ward\\|Wiki\\|WardsWiki\\|TheWiki\\):\\([A-Z][a-z]+\\([A-Z][a-z]+\\)+\\)" 0 t (lambda (page) (browse-url (concat "http://c2.com/cgi-bin/wiki?" page))) @@ -165,8 +166,17 @@ REGEXP is the string matching text around the button or a symbol BUTTON is the number of the regexp grouping actually matching the button. This is ignored if REGEXP is `nicknames'. -FORM is a Lisp expression which must eval to true for the button to - be added. +FORM is a Lisp symbol for a special variable whose value must be + true for the button to be added. Alternatively, when REGEXP is + not `nicknames', FORM can be a function whose arguments are BEG + and END, the bounds of the button in the current buffer. It's + expected to return a cons of (possibly identical) bounds or + nil, to deny. For the extent of the call, all face options + defined for the button module are re-bound, shadowing + themselves, so the function is free to change their values. + When regexp is the special symbol `nicknames', FORM must be the + symbol `erc-button-buttonize-nicks'. Specifying anything else + is deprecated. CALLBACK is the function to call when the user push this button. CALLBACK can also be a symbol. Its variable value will be used @@ -176,7 +186,7 @@ PAR is a number of a regexp grouping whose text will be passed to CALLBACK. There can be several PAR arguments. If REGEXP is `nicknames', these are ignored, and CALLBACK will be called with the nickname matched as the argument." - :package-version '(ERC . "5.5") + :package-version '(ERC . "5.6") ; FIXME sync on release :type '(repeat (list :tag "Button" (choice :tag "Matches" @@ -233,6 +243,8 @@ constituents.") "Internal variable used to keep track of whether we've added the global-level ERC button keys yet.") +;; Maybe deprecate this function and `erc-button-keys-added' if they +;; continue to go unused for a another version (currently 5.6). (defun erc-button-setup () "Add ERC mode-level button movement keys. This is only done once." ;; Add keys. @@ -275,22 +287,127 @@ specified by `erc-button-alist'." (concat "\\<" (regexp-quote (car elem)) "\\>") entry))))))))))) +(defun erc-button--maybe-warn-arbitrary-sexp (form) + (if (and (symbolp form) (special-variable-p form)) + (symbol-value form) + (unless (get 'erc-button--maybe-warn-arbitrary-sexp 'warned-arbitrary-sexp) + (put 'erc-button--maybe-warn-arbitrary-sexp 'warned-arbitrary-sexp t) + (lwarn 'erc :warning + (concat "Arbitrary sexps for the third FORM" + " slot of `erc-button-alist' entries" + " have been deprecated."))) + (eval form t))) + +(defun erc-button--check-nicknames-entry () + ;; This helper exists because the module is defined after its options. + (when-let (((eq major-mode 'erc-mode)) + (entry (alist-get 'nicknames erc-button-alist))) + (unless (eq 'erc-button-buttonize-nicks (nth 1 entry)) + (erc-button--display-error-notice-with-keys-and-warn + "Values other than `erc-button-buttonize-nicks' in the third slot of " + "the `nicknames' entry of `erc-button-alist' are deprecated.")))) + +(defun erc-button--preserve-bounds (bounds _ server-user _) + "Return BOUNDS.\n\n(fn BOUNDS NICKNAME SERVER-USER CHANNEL-USER)" + (and server-user bounds)) + +;; This variable is intended to serve as a "core" to be wrapped by +;; (built-in) modules during setup. It's unclear whether +;; `add-function's practice of removing existing advice before +;; re-adding it is desirable when integrating modules since we're +;; mostly concerned with ensuring one "piece" precedes or follows +;; another (specific piece), which may not yet (or ever) be present. + +(defvar erc-button--modify-nick-function #'erc-button--preserve-bounds + "Function to possibly modify aspects of nick being buttonized. +Called with four args: BOUNDS NICKNAME SERVER-USER CHANNEL-USER. +BOUNDS is a cons of (BEG . END) marking the position of the nick +in the current message, which occupies the whole of the narrowed +buffer. BEG is normally also point. NICKNAME is a case-mapped +string without text properties. SERVER-USER and CHANNEL-USER are +the nick's `erc-server-users' entry and its associated (though +possibly nil) `erc-channel-user' object. The function should +return BOUNDS or a suitable replacement to indicate that +buttonizing ought to proceed, and nil if it should be inhibited.") + +(defvar-local erc-button--phantom-users nil) + +(defun erc-button--add-phantom-speaker (args) + "Maybe substitute fake `server-user' for speaker at point." + (pcase args + (`(,bounds ,downcased-nick nil ,channel-user) + (list bounds downcased-nick + ;; Like `with-memoization' but don't cache when value is nil. + (or (gethash downcased-nick erc-button--phantom-users) + (and-let* ((user (erc-button--get-user-from-speaker-naive + (car bounds)))) + (puthash downcased-nick user erc-button--phantom-users))) + channel-user)) + (_ args))) + +(define-minor-mode erc-button--phantom-users-mode + "Minor mode to recognize unknown speakers. +Expect to be used by module setup code for creating placeholder +users on the fly during history playback. Treat an unknown +PRIVMSG speaker, like <bob>, as if they were present in a 353 and +are thus a member of the channel. However, don't bother creating +an actual `erc-channel-user' object because their status prefix +is unknown. Instead, just spoof an `erc-server-user' by applying +early (outer), args-filtering advice wrapping +`erc-button--modify-nick-function'." + :interactive nil + (if erc-button--phantom-users-mode + (progn + (add-function :filter-args (local 'erc-button--modify-nick-function) + #'erc-button--add-phantom-speaker '((depth . -90))) + (setq erc-button--phantom-users (make-hash-table :test #'equal))) + (remove-function (local 'erc-button--modify-nick-function) + #'erc-button--add-phantom-speaker) + (kill-local-variable 'erc-nicks--phantom-users))) + +;; FIXME replace this after making ERC account-aware. +(defun erc-button--get-user-from-speaker-naive (point) + "Return `erc-server-user' object for nick at POINT." + (when-let* + (((eql ?< (char-before point))) + ((eq (get-text-property point 'font-lock-face) 'erc-nick-default-face)) + (parsed (erc-get-parsed-vector point))) + (pcase-let* ((`(,nick ,login ,host) + (erc-parse-user (erc-response.sender parsed)))) + (make-erc-server-user + :nickname nick + :host (and (not (string-empty-p host)) host) + :login (and (not (string-empty-p login)) login))))) + (defun erc-button-add-nickname-buttons (entry) "Search through the buffer for nicknames, and add buttons." (let ((form (nth 2 entry)) (fun (nth 3 entry)) bounds word) - (when (or (eq t form) - (eval form t)) + (when (eq form 'erc-button-buttonize-nicks) + (setq form (and (symbol-value form) erc-button--modify-nick-function))) + (when (or (functionp form) + (eq t form) + (and form (erc-button--maybe-warn-arbitrary-sexp form))) (goto-char (point-min)) (while (erc-forward-word) (when (setq bounds (erc-bounds-of-word-at-point)) (setq word (buffer-substring-no-properties (car bounds) (cdr bounds))) - (when (or (and (erc-server-buffer-p) (erc-get-server-user word)) - (and erc-channel-users (erc-get-channel-user word))) - (erc-button-add-button (car bounds) (cdr bounds) - fun t (list word)))))))) + (let* ((erc-button-face erc-button-face) + (erc-button-mouse-face erc-button-mouse-face) + (erc-button-nickname-face erc-button-nickname-face) + (down (erc-downcase word)) + (cuser (and erc-channel-users + (gethash down erc-channel-users))) + (user (or (and cuser (car cuser)) + (and erc-server-users + (gethash down erc-server-users))))) + (when (or (not (functionp form)) + (setq bounds + (funcall form bounds down user (cdr cuser)))) + (erc-button-add-button (car bounds) (cdr bounds) + fun t (list word))))))))) (defun erc-button-add-buttons-1 (regexp entry) "Search through the buffer for matches to ENTRY and add buttons." @@ -302,7 +419,14 @@ specified by `erc-button-alist'." (fun (nth 3 entry)) (data (mapcar #'match-string-no-properties (nthcdr 4 entry)))) (when (or (eq t form) - (eval form t)) + (and (functionp form) + (let* ((erc-button-face erc-button-face) + (erc-button-mouse-face erc-button-mouse-face) + (erc-button-nickname-face erc-button-nickname-face) + (rv (funcall form start end))) + (when rv + (setq end (cdr rv) start (car rv))))) + (erc-button--maybe-warn-arbitrary-sexp form)) (erc-button-add-button start end fun nil data regexp))))) (defun erc-button-remove-old-buttons () @@ -511,6 +635,70 @@ and `apropos' for other symbols." (message "@%s is %d:%02d local time" beats hours minutes))) +(defun erc-button--substitute-command-keys-in-region (beg end) + "Replace command in region with keys and return new bounds" + (let* ((o (buffer-substring beg end)) + (s (substitute-command-keys o))) + (unless (equal o s) + (setq erc-button-face nil)) + (delete-region beg end) + (insert s)) + (cons beg (point))) + +;;;###autoload +(defun erc-button--display-error-notice-with-keys (&optional parsed buffer + &rest strings) + "Add help keys to STRINGS for configuration-related admonishments. +Return inserted result. Expect PARSED to be an `erc-response' +object, a string, or nil. Expect BUFFER to be a buffer, a string, +or nil. As a special case, allow PARSED to be a buffer as long +as BUFFER is a string or nil. If STRINGS contains any trailing +non-strings, concatenate leading string members before applying +`format'. Otherwise, just concatenate everything." + (when (stringp buffer) + (push buffer strings) + (setq buffer nil)) + (when (stringp parsed) + (push parsed strings) + (setq parsed nil)) + (when (bufferp parsed) + (cl-assert (null buffer)) + (setq buffer parsed + parsed nil)) + (let* ((op (if (seq-every-p #'stringp (cdr strings)) + #'concat + (let ((head (pop strings))) + (while (stringp (car strings)) + (setq head (concat head (pop strings)))) + (push head strings)) + #'format)) + (string (apply op strings)) + (erc-insert-post-hook + (cons (lambda () + (setq string (buffer-substring (point-min) + (1- (point-max))))) + erc-insert-post-hook)) + (erc-button-alist + `((,(rx "\\[" (group (+ (not "]"))) "]") 0 + erc-button--substitute-command-keys-in-region + erc-button-describe-symbol 1) + ,@erc-button-alist))) + (erc-display-message parsed '(notice error) (or buffer 'active) string) + string)) + +;;;###autoload +(defun erc-button--display-error-notice-with-keys-and-warn (&rest args) + "Like `erc-button--display-error-notice-with-keys' but also warn." + (let ((string (apply #'erc-button--display-error-notice-with-keys args))) + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (with-syntax-table lisp-mode-syntax-table + (skip-syntax-forward "^-")) + (forward-char) + (display-warning + 'erc (buffer-substring-no-properties (point) (point-max)))))) + (provide 'erc-button) ;;; erc-button.el ends here diff --git a/lisp/erc/erc-capab.el b/lisp/erc/erc-capab.el index 650c5fa84ac..bb0921da7f0 100644 --- a/lisp/erc/erc-capab.el +++ b/lisp/erc/erc-capab.el @@ -89,6 +89,7 @@ character not found in IRC nicknames to avoid confusion." ;;; Define module: ;;;###autoload(autoload 'erc-capab-identify-mode "erc-capab" nil t) +(put 'capab-identify 'erc-group 'erc-capab) (define-erc-module capab-identify nil "Handle dancer-ircd's CAPAB IDENTIFY-MSG and IDENTIFY-CTCP." ;; append so that `erc-server-parameters' is already set by `erc-server-005' diff --git a/lisp/erc/erc-common.el b/lisp/erc/erc-common.el index 0279b0a0bc4..6c015c71ff9 100644 --- a/lisp/erc/erc-common.el +++ b/lisp/erc/erc-common.el @@ -31,12 +31,18 @@ (defvar erc-channel-users) (defvar erc-dbuf) (defvar erc-log-p) +(defvar erc-modules) (defvar erc-server-users) (defvar erc-session-server) (declare-function erc--get-isupport-entry "erc-backend" (key &optional single)) (declare-function erc-get-buffer "erc" (target &optional proc)) (declare-function erc-server-buffer "erc" nil) +(declare-function widget-apply-action "wid-edit" (widget &optional event)) +(declare-function widget-at "wid-edit" (&optional pos)) +(declare-function widget-get-sibling "wid-edit" (widget)) +(declare-function widget-move "wid-edit" (arg &optional suppress-echo)) +(declare-function widget-type "wid-edit" (widget)) (cl-defstruct erc-input string insertp sendp) @@ -85,45 +91,52 @@ (contents "" :type string) (tags '() :type list)) -;; TODO move goodies modules here after 29 is released. -(defconst erc--features-to-modules - '((erc-pcomplete completion pcomplete) - (erc-capab capab-identify) - (erc-join autojoin) - (erc-page page ctcp-page) - (erc-sound sound ctcp-sound) - (erc-stamp stamp timestamp) - (erc-services services nickserv)) - "Migration alist mapping a library feature to module names. -Keys need not be unique: a library may define more than one -module. Sometimes a module's downcased alias will be its -canonical name.") - -(defconst erc--modules-to-features - (let (pairs) - (pcase-dolist (`(,feature . ,names) erc--features-to-modules) - (dolist (name names) - (push (cons name feature) pairs))) - (nreverse pairs)) - "Migration alist mapping a module's name to its home library feature.") - -(defconst erc--module-name-migrations - (let (pairs) - (pcase-dolist (`(,_ ,canonical . ,rest) erc--features-to-modules) - (dolist (obsolete rest) - (push (cons obsolete canonical) pairs))) - pairs) - "Association list of obsolete module names to canonical names.") - +;; After dropping 28, we can use prefixed "erc-autoload" cookies. (defun erc--normalize-module-symbol (symbol) - "Return preferred SYMBOL for `erc-modules'." - (setq symbol (intern (downcase (symbol-name symbol)))) - (or (cdr (assq symbol erc--module-name-migrations)) symbol)) + "Return preferred SYMBOL for `erc--modules'." + (while-let ((canonical (get symbol 'erc--module)) + ((not (eq canonical symbol)))) + (setq symbol canonical)) + symbol) + +(defvar erc--inside-mode-toggle-p nil + "Non-nil when a module's mode toggle is updating module membership. +This serves as a flag to inhibit the mutual recursion that would +otherwise occur between an ERC-defined minor-mode function, such +as `erc-services-mode', and the custom-set function for +`erc-modules'. For historical reasons, the latter calls +`erc-update-modules', which, in turn, enables the minor-mode +functions for all member modules. Also non-nil when a mode's +widget runs its set function.") + +(defun erc--favor-changed-reverted-modules-state (name op) + "Be more nuanced in displaying Custom state of `erc-modules'. +When `customized-value' differs from `saved-value', allow widget +to behave normally and show \"SET for current session\", as +though `customize-set-variable' or similar had been applied. +However, when `customized-value' and `standard-value' match but +differ from `saved-value', prefer showing \"CHANGED outside +Customize\" to prevent the widget from seeing a `standard' +instead of a `set' state, which precludes any actual saving." + ;; Although the button "Apply and save" is fortunately grayed out, + ;; `Custom-save' doesn't actually save (users must click the magic + ;; state button instead). The default behavior described in the doc + ;; string is intentional and was introduced by bug#12864 "Make state + ;; button interaction less confusing". However, it is unfriendly to + ;; rogue libraries (like ours) that insist on mutating user options + ;; as a matter of course. + (custom-load-symbol 'erc-modules) + (funcall (get 'erc-modules 'custom-set) 'erc-modules + (funcall op (erc--normalize-module-symbol name) erc-modules)) + (when (equal (pcase (get 'erc-modules 'saved-value) + (`((quote ,saved) saved))) + erc-modules) + (customize-mark-as-set 'erc-modules))) (defun erc--assemble-toggle (localp name ablsym mode val body) (let ((arg (make-symbol "arg"))) `(defun ,ablsym ,(if localp `(&optional ,arg) '()) - ,(concat + ,(erc--fill-module-docstring (if val "Enable" "Disable") " ERC " (symbol-name name) " mode." (when localp @@ -137,14 +150,120 @@ canonical name.") (,ablsym)) (setq ,mode ,val) ,@body))) - `(,(if val - `(cl-pushnew ',(erc--normalize-module-symbol name) - erc-modules) - `(setq erc-modules (delq ',(erc--normalize-module-symbol name) - erc-modules))) + ;; No need for `default-value', etc. because a buffer-local + ;; `erc-modules' only influences the next session and + ;; doesn't survive the major-mode reset that soon follows. + `((unless + (or erc--inside-mode-toggle-p + ,@(let ((v `(memq ',(erc--normalize-module-symbol name) + erc-modules))) + `(,(if val v `(not ,v))))) + (let ((erc--inside-mode-toggle-p t)) + (erc--favor-changed-reverted-modules-state + ',name #',(if val 'cons 'delq)))) (setq ,mode ,val) ,@body))))) +;; This is a migration helper that determines a module's `:group' +;; keyword argument from its name or alias. A (global) module's minor +;; mode variable appears under the group's Custom menu. Like +;; `erc--normalize-module-symbol', it must run when the module's +;; definition (rather than that of `define-erc-module') is expanded. +;; For corner cases in which this fails or the catch-all of `erc' is +;; more inappropriate, (global) modules can declare a top-level +;; +;; (put 'foo 'erc-group 'erc-bar) +;; +;; where `erc-bar' is the group and `foo' is the normalized module. +;; Do this *before* the module's definition. If `define-erc-module' +;; ever accepts arbitrary keywords, passing an explicit `:group' will +;; obviously be preferable. + +(defun erc--find-group (&rest symbols) + (catch 'found + (dolist (s symbols) + (let* ((downed (downcase (symbol-name s))) + (known (intern-soft (concat "erc-" downed)))) + (when (and known + (or (get known 'group-documentation) + (rassq known custom-current-group-alist))) + (throw 'found known)) + (when (setq known (intern-soft (concat "erc-" downed "-mode"))) + (when-let ((found (custom-group-of-mode known))) + (throw 'found found)))) + (when-let ((found (get (erc--normalize-module-symbol s) 'erc-group))) + (throw 'found found))) + 'erc)) + +(defun erc--neuter-custom-variable-state (variable) + "Lie to Customize about VARIABLE's true state. +Do so by always returning its standard value, namely nil." + ;; Make a module's global minor-mode toggle blind to Customize, so + ;; that `customize-variable-state' never sees it as "changed", + ;; regardless of its value. This snippet is + ;; `custom--standard-value' from Emacs 28+. + (cl-assert (null (eval (car (get variable 'standard-value)) t))) + nil) + +;; This exists as a separate, top-level function to prevent the byte +;; compiler from warning about widget-related dependencies not being +;; loaded at runtime. + +(defun erc--tick-module-checkbox (name &rest _) ; `name' must be normalized + (customize-variable-other-window 'erc-modules) + ;; Move to `erc-modules' section. + (while (not (eq (widget-type (widget-at)) 'checkbox)) + (widget-move 1 t)) + ;; This search for a checkbox can fail when `name' refers to a + ;; third-party module that modifies `erc-modules' (improperly) on + ;; load. + (let (w) + (while (and (eq (widget-type (widget-at)) 'checkbox) + (not (and (setq w (widget-get-sibling (widget-at))) + (eq (widget-value w) name)))) + (setq w nil) + (widget-move 1 t)) ; the `suppress-echo' arg exists in 27.2 + (unless w + (error "Failed to find %s in `erc-modules' checklist" name)) + (widget-apply-action (widget-at)) + (message "Hit %s to apply or %s to apply and save." + (substitute-command-keys "\\[Custom-set]") + (substitute-command-keys "\\[Custom-save]")))) + +(defun erc--prepare-custom-module-type (name) + `(let* ((name (erc--normalize-module-symbol ',name)) + (fmtd (format " `%s' " name))) + `(boolean + :button-face '(custom-variable-obsolete custom-button) + :format "%{%t%}: %[Deprecated Toggle%] \n%h\n" + :documentation-property + ,(lambda (_) + (let ((hasp (memq name erc-modules))) + (concat "Setting a module's minor-mode variable is " + (propertize "ineffective" 'face 'error) + ".\nPlease " (if hasp "remove" "add") fmtd + (if hasp "from" "to") " `erc-modules' directly instead.\n" + "You can do so now by clicking the scary button above."))) + :help-echo ,(lambda (_) + (let ((hasp (memq name erc-modules))) + (concat (if hasp "Remove" "Add") fmtd + (if hasp "from" "to") " `erc-modules'."))) + :action ,(apply-partially #'erc--tick-module-checkbox name)))) + +(defun erc--fill-module-docstring (&rest strings) + (with-temp-buffer + (emacs-lisp-mode) + (insert "(defun foo ()\n" + (format "%S" (apply #'concat strings)) + "\n(ignore))") + (goto-char (point-min)) + (forward-line 2) + (let ((emacs-lisp-docstring-fill-column 65) + (sentence-end-double-space t)) + (fill-paragraph)) + (goto-char (point-min)) + (nth 3 (read (current-buffer))))) + (defmacro define-erc-module (name alias doc enable-body disable-body &optional local-p) "Define a new minor mode using ERC conventions. @@ -179,21 +298,20 @@ Example: (declare (doc-string 3) (indent defun)) (let* ((sn (symbol-name name)) (mode (intern (format "erc-%s-mode" (downcase sn)))) - (group (intern (format "erc-%s" (downcase sn)))) (enable (intern (format "erc-%s-enable" (downcase sn)))) (disable (intern (format "erc-%s-disable" (downcase sn))))) `(progn (define-minor-mode ,mode - ,(format "Toggle ERC %S mode. + ,(erc--fill-module-docstring (format "Toggle ERC %s mode. With a prefix argument ARG, enable %s if ARG is positive, and disable it otherwise. If called from Lisp, enable the mode if ARG is omitted or nil. -%s" name name doc) - ;; FIXME: We don't know if this group exists, so this `:group' may - ;; actually just silence a valid warning about the fact that the var - ;; is not associated with any group. - :global ,(not local-p) :group (quote ,group) +\n%s" name name doc)) + :global ,(not local-p) + :group (erc--find-group ',name ,(and alias (list 'quote alias))) + ,@(unless local-p '(:get #'erc--neuter-custom-variable-state)) + ,@(unless local-p `(:type ,(erc--prepare-custom-module-type name))) (if ,mode (,enable) (,disable))) @@ -249,11 +367,16 @@ See also `with-current-buffer'. "Execute BODY in the current ERC server buffer. If no server buffer exists, return nil." (declare (indent 0) (debug (body))) - (let ((buffer (make-symbol "buffer"))) + (let ((varp (and (symbolp (car body)) + (not (cdr body)) + (special-variable-p (car body)))) + (buffer (make-symbol "buffer"))) `(let ((,buffer (erc-server-buffer))) (when (buffer-live-p ,buffer) - (with-current-buffer ,buffer - ,@body))))) + ,(if varp + `(buffer-local-value ',(car body) ,buffer) + `(with-current-buffer ,buffer + ,@body)))))) (defmacro erc-with-all-buffers-of-server (process pred &rest forms) "Execute FORMS in all buffers which have same process as this server. diff --git a/lisp/erc/erc-compat.el b/lisp/erc/erc-compat.el index 5601ede27a5..29892b78a39 100644 --- a/lisp/erc/erc-compat.el +++ b/lisp/erc/erc-compat.el @@ -32,7 +32,50 @@ ;;; Code: (require 'compat nil 'noerror) -(eval-when-compile (require 'cl-lib) (require 'url-parse)) +(eval-when-compile (require 'cl-lib)) + +;; Except for the "erc-" namespacing, these two definitions should be +;; continuously updated to match the latest upstream ones verbatim. +;; Although they're pretty simple, it's likely not worth checking for +;; and possibly deferring to the non-prefixed versions. +;; +;; BEGIN Compat macros + +;;;; Macros for extended compatibility function calls + +(defmacro erc-compat-function (fun) + "Return compatibility function symbol for FUN. + +If the Emacs version provides a sufficiently recent version of +FUN, the symbol FUN is returned itself. Otherwise the macro +returns the symbol of a compatibility function which supports the +behavior and calling convention of the current stable Emacs +version. For example Compat 29.1 will provide compatibility +functions which implement the behavior and calling convention of +Emacs 29.1. + +See also `compat-call' to directly call compatibility functions." + (let ((compat (intern (format "compat--%s" fun)))) + `#',(if (fboundp compat) compat fun))) + +(defmacro erc-compat-call (fun &rest args) + "Call compatibility function or macro FUN with ARGS. + +A good example function is `plist-get' which was extended with an +additional predicate argument in Emacs 29.1. The compatibility +function, which supports this additional argument, can be +obtained via (compat-function plist-get) and called +via (compat-call plist-get plist prop predicate). It is not +possible to directly call (plist-get plist prop predicate) on +Emacs older than 29.1, since the original `plist-get' function +does not yet support the predicate argument. Note that the +Compat library never overrides existing functions. + +See also `compat-function' to lookup compatibility functions." + (let ((compat (intern (format "compat--%s" fun)))) + `(,(if (fboundp compat) compat fun) ,@args))) + +;; END Compat macros ;;;###autoload(autoload 'erc-define-minor-mode "erc-compat") (define-obsolete-function-alias 'erc-define-minor-mode @@ -368,16 +411,8 @@ If START or END is negative, it counts from the end." ;;;; Misc 29.1 -(defmacro erc-compat--with-memoization (table &rest forms) - (declare (indent defun)) - (cond - ((fboundp 'with-memoization) - `(with-memoization ,table ,@forms)) ; 29.1 - ((fboundp 'cl--generic-with-memoization) - `(cl--generic-with-memoization ,table ,@forms)) - (t `(progn ,@forms)))) - (defvar url-irc-function) +(declare-function url-type "url-parse" (cl-x)) (defun erc-compat--29-browse-url-irc (string &rest _) (require 'url-irc) @@ -409,6 +444,28 @@ If START or END is negative, it counts from the end." (cons '("\\`irc6?s?://" . erc-compat--29-browse-url-irc) existing)))))) + +;;;; Misc 28.1 + +(defvar comint-file-name-quote-list) +(defvar shell-file-name-quote-list) +(declare-function shell--parse-pcomplete-arguments "shell" nil) + +(defun erc-compat--28-split-string-shell-command (string) + (require 'comint) + (require 'shell) + (with-temp-buffer + (insert string) + (let ((comint-file-name-quote-list shell-file-name-quote-list)) + (car (shell--parse-pcomplete-arguments))))) + +(defmacro erc-compat--split-string-shell-command (string) + ;; Autoloaded in Emacs 28. + (list (if (fboundp 'split-string-shell-command) + 'split-string-shell-command + 'erc-compat--28-split-string-shell-command) + string)) + (provide 'erc-compat) ;;; erc-compat.el ends here diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el index 4c557e0e0f9..2012bcadae1 100644 --- a/lisp/erc/erc-dcc.el +++ b/lisp/erc/erc-dcc.el @@ -43,7 +43,7 @@ ;; /dcc chat nick - Either accept pending chat offer from nick, or offer ;; DCC chat to nick ;; /dcc close type [nick] - Close DCC connection (SEND/GET/CHAT) with nick -;; /dcc get [-t][-s] nick [file] - Accept DCC offer from nick +;; /dcc get [-t][-s] nick [--] file - Accept DCC offer from nick ;; /dcc list - List all DCC offers/connections ;; /dcc send nick file - Offer DCC SEND to nick @@ -389,12 +389,18 @@ If this is nil, then the current value of `default-directory' is used." :type '(choice (const :value nil :tag "Default directory") directory)) ;;;###autoload -(defun erc-cmd-DCC (cmd &rest args) +(defun erc-cmd-DCC (line &rest compat-args) "Parser for /dcc command. This figures out the dcc subcommand and calls the appropriate routine to handle it. The function dispatched should be named \"erc-dcc-do-FOO-command\", where FOO is one of CLOSE, GET, SEND, LIST, CHAT, etc." - (when cmd + (let (cmd args) + ;; Called as library function (i.e., not directly as /dcc) + (if compat-args + (setq cmd line + args compat-args) + (setq args (delete "" (erc-compat--split-string-shell-command line)) + cmd (pop args))) (let ((fn (intern-soft (concat "erc-dcc-do-" (upcase cmd) "-command")))) (if fn (apply fn erc-server-process args) @@ -404,8 +410,16 @@ where FOO is one of CLOSE, GET, SEND, LIST, CHAT, etc." (apropos "erc-dcc-do-.*-command") t)))) +(put 'erc-cmd-DCC 'do-not-parse-args t) (autoload 'pcomplete-erc-all-nicks "erc-pcomplete") +;;;###autoload(put 'erc-cmd-DCC 'erc--cmd-help 'erc-dcc--cmd-help) +(defun erc-dcc--cmd-help (&rest args) + (describe-function + (or (and args (intern-soft (concat "erc-dcc-do-" + (upcase (car args)) "-command"))) + 'erc-cmd-DCC))) + ;;;###autoload (defun pcomplete/erc-mode/DCC () "Provide completion for the /DCC command." @@ -430,15 +444,20 @@ where FOO is one of CLOSE, GET, SEND, LIST, CHAT, etc." (eq (plist-get elt :type) 'GET)) erc-dcc-list))) ('send (pcomplete-erc-all-nicks)))) + (when (equal "get" (downcase (pcomplete-arg 'first 1))) + (pcomplete-opt "-")) (pcomplete-here (pcase (intern (downcase (pcomplete-arg 'first 1))) - ('get (mapcar (lambda (elt) (plist-get elt :file)) + ('get (mapcar (lambda (elt) + (combine-and-quote-strings (list (plist-get elt :file)))) (cl-remove-if-not (lambda (elt) (and (eq (plist-get elt :type) 'GET) (erc-nick-equal-p (erc-extract-nick (plist-get elt :nick)) - (pcomplete-arg 1)))) + (pcase (pcomplete-arg 1) + ("--" (pcomplete-arg 2)) + (v v))))) erc-dcc-list))) ('close (mapcar #'erc-dcc-nick (cl-remove-if-not @@ -504,16 +523,33 @@ At least one of TYPE and NICK must be provided." ?n (erc-extract-nick (plist-get ret :nick)))))) t)) -(defun erc-dcc-do-GET-command (proc nick &rest file) - "Do a DCC GET command. NICK is the person who is sending the file. -FILE is the filename. If FILE is split into multiple arguments, -re-join the arguments, separated by a space. -PROC is the server process." - (let* ((args (seq-group-by (lambda (s) (eq ?- (aref s 0))) (cons nick file))) +(defun erc-dcc-do-GET-command (proc &rest args) + "Perform a DCC GET command. +Recognize input conforming to the following usage syntax: + + /DCC GET [-t|-s] nick [--] filename + + nick The person who is sending the file. + filename The filename to be downloaded. Can be split into multiple + arguments that are then joined by a space. + flags \"-t\" sets `:turbo' in `erc-dcc-list' + \"-s\" sets `:secure' in `erc-dcc-list' + \"--\" indicates end of options + All of which are optional. + +Expect PROC to be the server process and ARGS to contain +everything after the subcommand \"GET\" in the usage description +above." + ;; Despite the advertised syntax above, we currently respect flags + ;; in these positions: [flag] nick [flag] filename [flag] + (let* ((trailing (and-let* ((trailing (member "--" args))) + (setq args (butlast args (length trailing))) + (cdr trailing))) + (args (seq-group-by (lambda (s) (eq ?- (aref s 0))) args)) (flags (prog1 (cdr (assq t args)) - (setq args (cdr (assq nil args)) - nick (pop args) - file (and args (mapconcat #'identity args " "))))) + (setq args (nconc (cdr (assq nil args)) trailing)))) + (nick (pop args)) + (file (and args (mapconcat #'identity args " "))) (elt (erc-dcc-member :nick nick :type 'GET :file file)) (filename (or file (plist-get elt :file) "unknown"))) (if elt diff --git a/lisp/erc/erc-fill.el b/lisp/erc/erc-fill.el index e10b7d790f6..c29d292abce 100644 --- a/lisp/erc/erc-fill.el +++ b/lisp/erc/erc-fill.el @@ -28,6 +28,9 @@ ;; `erc-fill-mode' to switch it on. Customize `erc-fill-function' to ;; change the style. +;; TODO: redo `erc-fill-wrap-nudge' using transient after ERC drops +;; support for Emacs 27. + ;;; Code: (require 'erc) @@ -38,30 +41,18 @@ :group 'erc) ;;;###autoload(autoload 'erc-fill-mode "erc-fill" nil t) -(define-minor-mode erc-fill-mode - "Toggle ERC fill mode. -With a prefix argument ARG, enable ERC fill mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. - +(define-erc-module fill nil + "Manage filling in ERC buffers. ERC fill mode is a global minor mode. When enabled, messages in the channel buffers are filled." - :global t - (if erc-fill-mode - (erc-fill-enable) - (erc-fill-disable))) - -(defun erc-fill-enable () - "Setup hooks for `erc-fill-mode'." - (interactive) - (add-hook 'erc-insert-modify-hook #'erc-fill) - (add-hook 'erc-send-modify-hook #'erc-fill)) - -(defun erc-fill-disable () - "Cleanup hooks, disable `erc-fill-mode'." - (interactive) - (remove-hook 'erc-insert-modify-hook #'erc-fill) - (remove-hook 'erc-send-modify-hook #'erc-fill)) + ;; FIXME ensure a consistent ordering relative to hook members from + ;; other modules. Ideally, this module's processing should happen + ;; after "morphological" modifications to a message's text but + ;; before superficial decorations. + ((add-hook 'erc-insert-modify-hook #'erc-fill) + (add-hook 'erc-send-modify-hook #'erc-fill)) + ((remove-hook 'erc-insert-modify-hook #'erc-fill) + (remove-hook 'erc-send-modify-hook #'erc-fill))) (defcustom erc-fill-prefix nil "Values used as `fill-prefix' for `erc-fill-variable'. @@ -91,16 +82,29 @@ Static Filling with `erc-fill-static-center' of 27: These two styles are implemented using `erc-fill-variable' and `erc-fill-static'. You can, of course, define your own filling function. Narrowing to the region in question is in effect while your -function is called." +function is called. + +A third style resembles static filling but \"wraps\" instead of +fills, thanks to `visual-line-mode' mode, which ERC automatically +enables when this option is `erc-fill-wrap' or when +`erc-fill-wrap-mode' is active. Set `erc-fill-static-center' to +your preferred initial \"prefix\" width. For adjusting the width +during a session, see the command `erc-fill-wrap-nudge'." :type '(choice (const :tag "Variable Filling" erc-fill-variable) (const :tag "Static Filling" erc-fill-static) + (const :tag "Dynamic word-wrap" erc-fill-wrap) function)) (defcustom erc-fill-static-center 27 - "Column around which all statically filled messages will be centered. -This column denotes the point where the ` ' character between -<nickname> and the entered text will be put, thus aligning nick -names right and text left." + "Number of columns to \"outdent\" the first line of a message. +During early message handing, ERC prepends a span of +non-whitespace characters to every message, such as a bracketed +\"<nickname>\" or an `erc-notice-prefix'. The +`erc-fill-function' variants `erc-fill-static' and +`erc-fill-wrap' look to this option to determine the amount of +padding to apply to that portion until the filled (or wrapped) +message content aligns with the indicated column. See also +https://en.wikipedia.org/wiki/Hanging_indent." :type 'integer) (defcustom erc-fill-variable-maximum-indentation 17 @@ -130,7 +134,7 @@ You can put this on `erc-insert-modify-hook' and/or `erc-send-modify-hook'." (defun erc-fill-static () "Fills a text such that messages start at column `erc-fill-static-center'." - (save-match-data + (save-restriction (goto-char (point-min)) (looking-at "^\\(\\S-+\\)") (let ((nick (match-string 1))) @@ -167,6 +171,326 @@ You can put this on `erc-insert-modify-hook' and/or `erc-send-modify-hook'." (erc-fill-regarding-timestamp)))) (erc-restore-text-properties))) +(defvar-local erc-fill--wrap-value nil) +(defvar-local erc-fill--wrap-visual-keys nil) + +(defcustom erc-fill-wrap-use-pixels t + "Whether to calculate padding in pixels when possible. +A value of nil means ERC should use columns, which may happen +regardless, depending on the Emacs version. This option only +matters when `erc-fill-wrap-mode' is enabled." + :package-version '(ERC . "5.6") ; FIXME sync on release + :type 'boolean) + +(defcustom erc-fill-wrap-visual-keys 'non-input + "Whether to retain keys defined by `visual-line-mode'. +A value of t tells ERC to use movement commands defined by +`visual-line-mode' everywhere in an ERC buffer along with visual +editing commands in the input area. A value of nil means to +never do so. A value of `non-input' tells ERC to act like the +value is nil in the input area and t elsewhere. This option only +plays a role when `erc-fill-wrap-mode' is enabled." + :package-version '(ERC . "5.6") ; FIXME sync on release + :type '(choice (const nil) (const t) (const non-input))) + +(defcustom erc-fill-wrap-merge t + "Whether to consolidate messages from the same speaker. +This tells ERC to omit redundant speaker labels for subsequent +messages less than a day apart." + :package-version '(ERC . "5.6") ; FIXME sync on release + :type 'boolean) + +(defun erc-fill--wrap-move (normal-cmd visual-cmd arg) + (funcall (pcase erc-fill--wrap-visual-keys + ('non-input + (if (>= (point) erc-input-marker) normal-cmd visual-cmd)) + ('t visual-cmd) + (_ normal-cmd)) + arg)) + +(defun erc-fill--wrap-kill-line (arg) + "Defer to `kill-line' or `kill-visual-line'." + (interactive "P") + ;; ERC buffers are read-only outside of the input area, but we run + ;; `kill-line' anyway so that users can see the error. + (erc-fill--wrap-move #'kill-line #'kill-visual-line arg)) + +(defun erc-fill--wrap-beginning-of-line (arg) + "Defer to `move-beginning-of-line' or `beginning-of-visual-line'." + (interactive "^p") + (let ((inhibit-field-text-motion t)) + (erc-fill--wrap-move #'move-beginning-of-line + #'beginning-of-visual-line arg)) + (when (get-text-property (point) 'erc-prompt) + (goto-char erc-input-marker))) + +(defun erc-fill--wrap-end-of-line (arg) + "Defer to `move-end-of-line' or `end-of-visual-line'." + (interactive "^p") + (erc-fill--wrap-move #'move-end-of-line #'end-of-visual-line arg)) + +(defun erc-fill-wrap-cycle-visual-movement (arg) + "Cycle through `erc-fill-wrap-visual-keys' styles ARG times. +Go from nil to t to `non-input' and back around, but set internal +state instead of mutating `erc-fill-wrap-visual-keys'. When ARG +is 0, reset to value of `erc-fill-wrap-visual-keys'." + (interactive "^p") + (when (zerop arg) + (setq erc-fill--wrap-visual-keys erc-fill-wrap-visual-keys)) + (while (not (zerop arg)) + (cl-incf arg (- (abs arg))) + (setq erc-fill--wrap-visual-keys (pcase erc-fill--wrap-visual-keys + ('nil t) + ('t 'non-input) + ('non-input nil)))) + (message "erc-fill-wrap movement: %S" erc-fill--wrap-visual-keys)) + +(defvar-keymap erc-fill-wrap-mode-map ; Compat 29 + :doc "Keymap for ERC's `fill-wrap' module." + :parent visual-line-mode-map + "<remap> <kill-line>" #'erc-fill--wrap-kill-line + "<remap> <move-end-of-line>" #'erc-fill--wrap-end-of-line + "<remap> <move-beginning-of-line>" #'erc-fill--wrap-beginning-of-line + "C-c a" #'erc-fill-wrap-cycle-visual-movement + ;; Not sure if this is problematic because `erc-bol' takes no args. + "<remap> <erc-bol>" #'erc-fill--wrap-beginning-of-line) + +(defvar erc-match-mode) +(defvar erc-button-mode) +(defvar erc-match--hide-fools-offset-bounds) + +(defun erc-fill--make-module-dependency-msg (module) + (concat "Enabling default global module `" module "' needed by local" + " module `fill-wrap'. This will impact \C-]all\C-] ERC" + " sessions. Add `" module "' to `erc-modules' to avoid this" + " warning. See Info:\"(erc) Modules\" for more.")) + +;;;###autoload(put 'fill-wrap 'erc--feature 'erc-fill) +(define-erc-module fill-wrap nil + "Fill style leveraging `visual-line-mode'. +This module displays nickname labels for speakers as overhanging +leftward (and thus right-aligned) to a common offset, as +determined by the option `erc-fill-static-center'. It depends on +the `fill' and `button' modules and assumes the option +`erc-insert-timestamp-function' is `erc-insert-timestamp-right' +or `erc-insert-timestamp-left-and-right' (recommended) so that it +can display right-hand stamps in the right margin. A value of +`erc-insert-timestamp-left' is unsupported. This local module +depends on the global `fill' module. To use it, either include +`fill-wrap' in `erc-modules' or set `erc-fill-function' to +`erc-fill-wrap' (recommended). You can also manually invoke one +of the minor-mode toggles as usual." + ((let (msg) + (unless erc-fill-mode + (unless (memq 'fill erc-modules) + (setq msg + ;; FIXME use `erc-button--display-error-notice-with-keys' + ;; when bug#60933 is ready. + (erc-fill--make-module-dependency-msg "fill"))) + (erc-fill-mode +1)) + (when erc-fill-wrap-merge + (require 'erc-button) + (unless erc-button-mode + (unless (memq 'button erc-modules) + (setq msg (concat msg (and msg " ") + (erc-fill--make-module-dependency-msg "button")))) + (erc-with-server-buffer + (erc-button-mode +1)))) + ;; Set local value of user option (can we avoid this somehow?) + (unless (eq erc-fill-function #'erc-fill-wrap) + (setq-local erc-fill-function #'erc-fill-wrap)) + (when-let* ((vars (or erc--server-reconnecting erc--target-priors)) + ((alist-get 'erc-fill-wrap-mode vars))) + (setq erc-fill--wrap-visual-keys (alist-get 'erc-fill--wrap-visual-keys + vars) + erc-fill--wrap-value (alist-get 'erc-fill--wrap-value vars))) + (add-function :filter-args (local 'erc-stamp--insert-date-function) + #'erc-fill--wrap-stamp-insert-prefixed-date) + (when (or erc-stamp-mode (memq 'stamp erc-modules)) + (erc-stamp--display-margin-mode +1)) + (when (or (bound-and-true-p erc-match-mode) (memq 'match erc-modules)) + (require 'erc-match) + (setq erc-match--hide-fools-offset-bounds t)) + (setq erc-fill--wrap-value + (or erc-fill--wrap-value erc-fill-static-center)) + (visual-line-mode +1) + (unless (local-variable-p 'erc-fill--wrap-visual-keys) + (setq erc-fill--wrap-visual-keys erc-fill-wrap-visual-keys)) + (when msg + (erc-display-error-notice nil msg)))) + ((when erc-stamp--display-margin-mode + (erc-stamp--display-margin-mode -1)) + (kill-local-variable 'erc-fill--wrap-value) + (kill-local-variable 'erc-fill-function) + (kill-local-variable 'erc-fill--wrap-visual-keys) + (remove-function (local 'erc-stamp--insert-date-function) + #'erc-fill--wrap-stamp-insert-prefixed-date) + (visual-line-mode -1)) + 'local) + +(defvar-local erc-fill--wrap-length-function nil + "Function to determine length of overhanging characters. +It should return an EXPR as defined by the Info node `(elisp) +Pixel Specification'. This value should represent the width of +the overhang with all faces applied, including any enclosing +brackets (which are not normally fontified) and a trailing space. +It can also return nil to tell ERC to fall back to the default +behavior of taking the length from the first \"word\". This +variable can be converted to a public one if needed by third +parties.") + +(defvar-local erc-fill--wrap-last-msg nil) +(defvar-local erc-fill--wrap-max-lull (* 24 60 60)) + +(defun erc-fill--wrap-continued-message-p () + (prog1 (and-let* + ((m (or erc-fill--wrap-last-msg + (setq erc-fill--wrap-last-msg (point-min-marker)) + nil)) + ((< (1+ (point-min)) (- (point) 2))) + (props (save-restriction + (widen) + (when (eq 'erc-timestamp (field-at-pos m)) + (set-marker m (field-end m))) + (and (eq 'PRIVMSG (get-text-property m 'erc-command)) + (not (eq (get-text-property m 'font-lock-face) + 'erc-action-face)) + (cons (get-text-property m 'erc-timestamp) + (get-text-property (1+ m) 'erc-data))))) + (ts (pop props)) + ((not (time-less-p (erc-stamp--current-time) ts))) + ((time-less-p (time-subtract (erc-stamp--current-time) ts) + erc-fill--wrap-max-lull)) + (nick (buffer-substring-no-properties + (1+ (point-min)) (- (point) 2))) + ((equal (car props) (erc-downcase nick))))) + (set-marker erc-fill--wrap-last-msg (point-min)))) + +(defun erc-fill--wrap-stamp-insert-prefixed-date (args) + "Apply `line-prefix' property to args." + (let* ((ts-left (car args))) + (put-text-property 0 (length ts-left) 'line-prefix + `(space :width + (- erc-fill--wrap-value + ,(length (string-trim-left ts-left)))) + ts-left)) + args) + +(defun erc-fill-wrap () + "Use text props to mimic the effect of `erc-fill-static'. +See `erc-fill-wrap-mode' for details." + (unless erc-fill-wrap-mode + (erc-fill-wrap-mode +1)) + (save-excursion + (goto-char (point-min)) + (let ((len (or (and erc-fill--wrap-length-function + (funcall erc-fill--wrap-length-function)) + (progn + (skip-syntax-forward "^-") + (forward-char) + (cond ((and erc-fill-wrap-merge + (erc-fill--wrap-continued-message-p)) + (put-text-property (point-min) (point) + 'display "") + 0) + ((and erc-fill-wrap-use-pixels + (fboundp 'buffer-text-pixel-size)) + (save-restriction + (narrow-to-region (point-min) (point)) + (list (car (buffer-text-pixel-size))))) + (t (- (point) (point-min)))))))) + ;; Leaving out the final newline doesn't seem to affect anything. + (erc-put-text-properties (point-min) (point-max) + '(line-prefix wrap-prefix) nil + `((space :width (- erc-fill--wrap-value ,len)) + (space :width erc-fill--wrap-value)))))) + +;; This is an experimental helper for third-party modules. You could, +;; for example, use this to automatically resize the prefix to a +;; fraction of the window's width on some event change. Another use +;; case would be to fix lines affected by toggling a display-oriented +;; mode, like `display-line-numbers-mode'. + +(defun erc-fill--wrap-fix (&optional value) + "Re-wrap from `point-min' to `point-max'. +That is, recalculate the width of all accessible lines and reset +local prefix VALUE when non-nil." + (save-excursion + (when value + (setq erc-fill--wrap-value value)) + (let ((inhibit-field-text-motion t) + (inhibit-read-only t)) + (goto-char (point-min)) + (while (and (zerop (forward-line)) + (< (point) (min (point-max) erc-insert-marker))) + (save-restriction + (narrow-to-region (line-beginning-position) (line-end-position)) + (erc-fill-wrap)))))) + +(defun erc-fill--wrap-nudge (arg) + (when (zerop arg) + (setq arg (- erc-fill-static-center erc-fill--wrap-value))) + (cl-incf erc-fill--wrap-value arg) + arg) + +(defun erc-fill-wrap-nudge (arg) + "Adjust `erc-fill-wrap' by ARG columns. +Offer to repeat command in a manner similar to +`text-scale-adjust'. + + \\`=' Increase indentation by one column + \\`-' Decrease indentation by one column + \\`0' Reset indentation to the default + \\`+' Shift right margin rightward (shrink) by one column + \\`_' Shift right margin leftward (grow) by one column + \\`)' Reset the right margin to the default + +Note that misalignment may occur when messages contain +decorations applied by third-party modules. See +`erc-fill--wrap-fix' for a temporary workaround." + (interactive "p") + (unless erc-fill--wrap-value + (cl-assert (not erc-fill-wrap-mode)) + (user-error "Minor mode `erc-fill-wrap-mode' disabled")) + (unless (get-buffer-window) + (user-error "Command called in an undisplayed buffer")) + (let* ((total (erc-fill--wrap-nudge arg)) + (win-ratio (/ (float (- (window-point) (window-start))) + (- (window-end nil t) (window-start))))) + (when (zerop arg) + (setq arg 1)) + (erc-compat-call + set-transient-map + (let ((map (make-sparse-keymap))) + (dolist (key '(?= ?- ?0)) + (let ((a (pcase key + (?0 0) + (?- (- (abs arg))) + (_ (abs arg))))) + (define-key map (vector (list key)) + (lambda () + (interactive) + (cl-incf total (erc-fill--wrap-nudge a)) + (recenter (round (* win-ratio (window-height)))))))) + (dolist (key '(?\) ?_ ?+)) + (let ((a (pcase key + (?\) 0) + (?_ (- (abs arg))) + (?+ (abs arg))))) + (define-key map (vector (list key)) + (lambda () + (interactive) + (erc-stamp--adjust-right-margin (- a)) + (recenter (round (* win-ratio (window-height)))))))) + map) + t + (lambda () + (message "Fill prefix: %d (%+d col%s)" + erc-fill--wrap-value total (if (> (abs total) 1) "s" ""))) + "Use %k for further adjustment" + 1) + (recenter (round (* win-ratio (window-height)))))) + (defun erc-fill-regarding-timestamp () "Fills a text such that messages start at column `erc-fill-static-center'." (fill-region (point-min) (point-max) t t) diff --git a/lisp/erc/erc-goodies.el b/lisp/erc/erc-goodies.el index 05a21019042..6235de5f1c0 100644 --- a/lisp/erc/erc-goodies.el +++ b/lisp/erc/erc-goodies.el @@ -29,30 +29,13 @@ ;;; Code: -;;; Imenu support - (eval-when-compile (require 'cl-lib)) -(require 'erc-common) - -(defvar erc-controls-highlight-regexp) -(defvar erc-controls-remove-regexp) -(defvar erc-input-marker) -(defvar erc-insert-marker) -(defvar erc-server-process) -(defvar erc-modules) -(defvar erc-log-p) - -(declare-function erc-buffer-list "erc" (&optional predicate proc)) -(declare-function erc-error "erc" (&rest args)) -(declare-function erc-extract-command-from-line "erc" (line)) -(declare-function erc-beg-of-input-line "erc" nil) +(require 'erc) -(defun erc-imenu-setup () - "Setup Imenu support in an ERC buffer." - (setq-local imenu-create-index-function #'erc-create-imenu-index)) +(declare-function fringe-columns "fringe" (side &optional real)) +(declare-function pulse-available-p "pulse" nil) +(declare-function pulse-momentary-highlight-overlay "pulse" (o &optional face)) -(add-hook 'erc-mode-hook #'erc-imenu-setup) -(autoload 'erc-create-imenu-index "erc-imenu" "Imenu index creation function") ;;; Automatically scroll to bottom (defcustom erc-input-line-position nil @@ -65,6 +48,7 @@ argument to `recenter'." :group 'erc-display :type '(choice integer (const nil))) +;;;###autoload(autoload 'erc-scrolltobottom-mode "erc-goodies" nil t) (define-erc-module scrolltobottom nil "This mode causes the prompt to stay at the end of the window." ((add-hook 'erc-mode-hook #'erc-add-scroll-to-bottom) @@ -116,6 +100,7 @@ variable `erc-input-line-position'." (recenter (or erc-input-line-position -1))))))) ;;; Make read only +;;;###autoload(autoload 'erc-readonly-mode "erc-goodies" nil t) (define-erc-module readonly nil "This mode causes all inserted text to be read-only." ((add-hook 'erc-insert-post-hook #'erc-make-read-only) @@ -131,6 +116,7 @@ Put this function on `erc-insert-post-hook' and/or `erc-send-post-hook'." (put-text-property (point-min) (point-max) 'rear-nonsticky t)) ;;; Move to prompt when typing text +;;;###autoload(autoload 'erc-move-to-prompt-mode "erc-goodies" nil t) (define-erc-module move-to-prompt nil "This mode causes the point to be moved to the prompt when typing text." ((add-hook 'erc-mode-hook #'erc-move-to-prompt-setup) @@ -155,11 +141,160 @@ Put this function on `erc-insert-post-hook' and/or `erc-send-post-hook'." (add-hook 'pre-command-hook #'erc-move-to-prompt nil t)) ;;; Keep place in unvisited channels +;;;###autoload(autoload 'erc-keep-place-mode "erc-goodies" nil t) (define-erc-module keep-place nil "Leave point above un-viewed text in other channels." ((add-hook 'erc-insert-pre-hook #'erc-keep-place)) ((remove-hook 'erc-insert-pre-hook #'erc-keep-place))) +(defcustom erc-keep-place-indicator-style t + "Flavor of visual indicator applied to kept place. +For use with the `keep-place-indicator' module. A value of `arrow' +displays an arrow in the left fringe or margin. When it's +`face', ERC adds the face `erc-keep-place-indicator-line' to the +appropriate line. A value of t does both." + :group 'erc + :package-version '(ERC . "5.6") + :type '(choice (const t) (const server) (const target))) + +(defcustom erc-keep-place-indicator-buffer-type t + "ERC buffer type in which to display `keep-place-indicator'. +A value of t means \"all\" ERC buffers." + :group 'erc + :package-version '(ERC . "5.6") + :type '(choice (const t) (const server) (const target))) + +(defcustom erc-keep-place-indicator-follow nil + "Whether to sync visual kept place to window's top when reading. +For use with `erc-keep-place-indicator-mode'." + :group 'erc + :package-version '(ERC . "5.6") + :type 'boolean) + +(defface erc-keep-place-indicator-line + '((((class color) (min-colors 88) (background light) + (supports :underline (:style wave))) + (:underline (:color "PaleGreen3" :style wave))) + (((class color) (min-colors 88) (background dark) + (supports :underline (:style wave))) + (:underline (:color "PaleGreen1" :style wave))) + (t :underline t)) + "Face for option `erc-keep-place-indicator-style'." + :group 'erc-faces) + +(defface erc-keep-place-indicator-arrow + '((((class color) (min-colors 88) (background light)) + (:foreground "PaleGreen3")) + (((class color) (min-colors 88) (background dark)) + (:foreground "PaleGreen1")) + (t :inherit fringe)) + "Face for arrow value of option `erc-keep-place-indicator-style'." + :group 'erc-faces) + +(defvar-local erc--keep-place-indicator-overlay nil + "Overlay for `erc-keep-place-indicator-mode'.") + +(defun erc--keep-place-indicator-on-window-configuration-change () + "Maybe sync `erc--keep-place-indicator-overlay'. +Specifically, do so unless switching to or from another window in +the active frame." + (when erc-keep-place-indicator-follow + (unless (or (minibuffer-window-active-p (minibuffer-window)) + (eq (window-old-buffer) (current-buffer))) + (when (< (overlay-end erc--keep-place-indicator-overlay) + (window-start) + erc-insert-marker) + (erc-keep-place-move (window-start)))))) + +(defun erc--keep-place-indicator-setup () + "Initialize buffer for maintaining `erc--keep-place-indicator-overlay'." + (require 'fringe) + (setq erc--keep-place-indicator-overlay + (if-let* ((vars (or erc--server-reconnecting erc--target-priors)) + ((alist-get 'erc-keep-place-indicator-mode vars))) + (alist-get 'erc--keep-place-indicator-overlay vars) + (make-overlay 0 0))) + (add-hook 'window-configuration-change-hook + #'erc--keep-place-indicator-on-window-configuration-change nil t) + (when-let* (((memq erc-keep-place-indicator-style '(t arrow))) + (display (if (zerop (fringe-columns 'left)) + `((margin left-margin) ,overlay-arrow-string) + '(left-fringe right-triangle + erc-keep-place-indicator-arrow))) + (bef (propertize " " 'display display))) + (overlay-put erc--keep-place-indicator-overlay 'before-string bef)) + (when (memq erc-keep-place-indicator-style '(t face)) + (overlay-put erc--keep-place-indicator-overlay 'face + 'erc-keep-place-indicator-line))) + +;;;###autoload(put 'keep-place-indicator 'erc--feature 'erc-goodies) +(define-erc-module keep-place-indicator nil + "`keep-place' with a fringe arrow and/or highlighted face." + ((unless erc-keep-place-mode + (unless (memq 'keep-place erc-modules) + ;; FIXME use `erc-button--display-error-notice-with-keys' + ;; to display this message when bug#60933 is ready. + (erc-display-error-notice + nil (concat + "Local module `keep-place-indicator' needs module `keep-place'." + " Enabling now. This will affect \C-]all\C-] ERC sessions." + " Add `keep-place' to `erc-modules' to silence this message."))) + (erc-keep-place-mode +1)) + (if (pcase erc-keep-place-indicator-buffer-type + ('target erc--target) + ('server (not erc--target)) + ('t t)) + (erc--keep-place-indicator-setup) + (setq erc-keep-place-indicator-mode nil))) + ((when erc--keep-place-indicator-overlay + (delete-overlay erc--keep-place-indicator-overlay) + (remove-hook 'window-configuration-change-hook + #'erc--keep-place-indicator-on-window-configuration-change t) + (kill-local-variable 'erc--keep-place-indicator-overlay))) + 'local) + +(defun erc-keep-place-move (pos) + "Move keep-place indicator to current line or POS. +For use with `keep-place-indicator' module. When called +interactively, interpret POS as an offset. Specifically, when +POS is a raw prefix arg, like (4), move the indicator to the +window's last line. When it's the minus sign, put it on the +window's first line. Interpret an integer as an offset in lines." + (interactive + (progn + (unless erc-keep-place-indicator-mode + (user-error "`erc-keep-place-indicator-mode' not enabled")) + (list (pcase current-prefix-arg + ((and (pred integerp) v) + (save-excursion + (let ((inhibit-field-text-motion t)) + (forward-line v) + (point)))) + (`(,_) (1- (min erc-insert-marker (window-end)))) + ('- (min (1- erc-insert-marker) (window-start))))))) + (save-excursion + (let ((inhibit-field-text-motion t)) + (when pos + (goto-char pos)) + (move-overlay erc--keep-place-indicator-overlay + (line-beginning-position) + (line-end-position))))) + +(defun erc-keep-place-goto () + "Jump to keep-place indicator. +For use with `keep-place-indicator' module." + (interactive + (prog1 nil + (unless erc-keep-place-indicator-mode + (user-error "`erc-keep-place-indicator-mode' not enabled")) + (deactivate-mark) + (push-mark))) + (goto-char (overlay-start erc--keep-place-indicator-overlay)) + (recenter (truncate (* (window-height) 0.25)) t) + (require 'pulse) + (when (pulse-available-p) + (pulse-momentary-highlight-overlay erc--keep-place-indicator-overlay))) + (defun erc-keep-place (_ignored) "Move point away from the last line in a non-selected ERC buffer." (when (and (not (eq (window-buffer (selected-window)) @@ -168,6 +303,11 @@ Put this function on `erc-insert-post-hook' and/or `erc-send-post-hook'." (deactivate-mark) (goto-char (erc-beg-of-input-line)) (forward-line -1) + (when erc-keep-place-indicator-mode + (unless (or (minibuffer-window-active-p (selected-window)) + (and (frame-visible-p (selected-frame)) + (get-buffer-window (current-buffer) (selected-frame)))) + (erc-keep-place-move nil))) ;; if `switch-to-buffer-preserve-window-point' is set, ;; we cannot rely on point being saved, and must commit ;; it to window-prev-buffers. @@ -193,6 +333,7 @@ Put this function on `erc-insert-post-hook' and/or `erc-send-post-hook'." If a command's function symbol is in this list, the typed command does not appear in the ERC buffer after the user presses ENTER.") +;;;###autoload(autoload 'erc-noncommands-mode "erc-goodies" nil t) (define-erc-module noncommands nil "This mode distinguishes non-commands. Commands listed in `erc-insert-this' know how to display @@ -251,6 +392,12 @@ The value `erc-interpret-controls-p' must also be t for this to work." "ERC inverse face." :group 'erc-faces) +(defface erc-spoiler-face + '((((background light)) :foreground "DimGray" :background "DimGray") + (((background dark)) :foreground "LightGray" :background "LightGray")) + "ERC spoiler face." + :group 'erc-faces) + (defface erc-underline-face '((t :underline t)) "ERC underline face." :group 'erc-faces) @@ -353,19 +500,38 @@ The value `erc-interpret-controls-p' must also be t for this to work." "ERC face." :group 'erc-faces) +;; https://lists.gnu.org/archive/html/emacs-erc/2021-07/msg00005.html +(defvar erc--controls-additional-colors + ["#470000" "#472100" "#474700" "#324700" "#004700" "#00472c" + "#004747" "#002747" "#000047" "#2e0047" "#470047" "#47002a" + "#740000" "#743a00" "#747400" "#517400" "#007400" "#007449" + "#007474" "#004074" "#000074" "#4b0074" "#740074" "#740045" + "#b50000" "#b56300" "#b5b500" "#7db500" "#00b500" "#00b571" + "#00b5b5" "#0063b5" "#0000b5" "#7500b5" "#b500b5" "#b5006b" + "#ff0000" "#ff8c00" "#ffff00" "#b2ff00" "#00ff00" "#00ffa0" + "#00ffff" "#008cff" "#0000ff" "#a500ff" "#ff00ff" "#ff0098" + "#ff5959" "#ffb459" "#ffff71" "#cfff60" "#6fff6f" "#65ffc9" + "#6dffff" "#59b4ff" "#5959ff" "#c459ff" "#ff66ff" "#ff59bc" + "#ff9c9c" "#ffd39c" "#ffff9c" "#e2ff9c" "#9cff9c" "#9cffdb" + "#9cffff" "#9cd3ff" "#9c9cff" "#dc9cff" "#ff9cff" "#ff94d3" + "#000000" "#131313" "#282828" "#363636" "#4d4d4d" "#656565" + "#818181" "#9f9f9f" "#bcbcbc" "#e2e2e2" "#ffffff"]) + (defun erc-get-bg-color-face (n) "Fetches the right face for background color N (0-15)." (if (stringp n) (setq n (string-to-number n))) (if (not (numberp n)) (prog1 'default (erc-error "erc-get-bg-color-face: n is NaN: %S" n)) - (when (> n 16) + (when (> n 99) (erc-log (format " Wrong color: %s" n)) (setq n (mod n 16))) (cond ((and (>= n 0) (< n 16)) (intern (concat "bg:erc-color-face" (number-to-string n)))) - (t (erc-log (format " Wrong color: %s" n)) 'default)))) + ((< 15 n 99) + (list :background (aref erc--controls-additional-colors (- n 16)))) + (t (erc-log (format " Wrong color: %s" n)) '(default))))) (defun erc-get-fg-color-face (n) "Fetches the right face for foreground color N (0-15)." @@ -373,20 +539,44 @@ The value `erc-interpret-controls-p' must also be t for this to work." (if (not (numberp n)) (prog1 'default (erc-error "erc-get-fg-color-face: n is NaN: %S" n)) - (when (> n 16) + (when (> n 99) (erc-log (format " Wrong color: %s" n)) (setq n (mod n 16))) (cond ((and (>= n 0) (< n 16)) (intern (concat "fg:erc-color-face" (number-to-string n)))) - (t (erc-log (format " Wrong color: %s" n)) 'default)))) + ((< 15 n 99) + (list :foreground (aref erc--controls-additional-colors (- n 16)))) + (t (erc-log (format " Wrong color: %s" n)) '(default))))) +;;;###autoload(autoload 'erc-irccontrols-mode "erc-goodies" nil t) (define-erc-module irccontrols nil "This mode enables the interpretation of IRC control chars." ((add-hook 'erc-insert-modify-hook #'erc-controls-highlight) - (add-hook 'erc-send-modify-hook #'erc-controls-highlight)) + (add-hook 'erc-send-modify-hook #'erc-controls-highlight) + (erc--modify-local-map t "C-c C-c" #'erc-toggle-interpret-controls)) ((remove-hook 'erc-insert-modify-hook #'erc-controls-highlight) - (remove-hook 'erc-send-modify-hook #'erc-controls-highlight))) + (remove-hook 'erc-send-modify-hook #'erc-controls-highlight) + (erc--modify-local-map nil "C-c C-c" #'erc-toggle-interpret-controls))) + +;; These patterns were moved here to circumvent compiler warnings but +;; otherwise translated verbatim from their original string-literal +;; definitions (minus a small bug fix to satisfy newly added tests). +(defvar erc-controls-remove-regexp + (rx (or ?\C-b ?\C-\] ?\C-_ ?\C-v ?\C-g ?\C-o + (: ?\C-c (? (any "0-9")) (? (any "0-9")) + (? (group ?, (any "0-9") (? (any "0-9"))))))) + "Regular expression matching control characters to remove.") + +;; Before the change to `rx', group 3 used to be a sibling of group 2. +;; This was assumed to be a bug. A few minor simplifications were +;; also performed. If incorrect, please admonish. +(defvar erc-controls-highlight-regexp + (rx (group (or ?\C-b ?\C-\] ?\C-v ?\C-_ ?\C-g ?\C-o + (: ?\C-c (? (group (** 1 2 (any "0-9"))) + (? (group ?, (group (** 1 2 (any "0-9"))))))))) + (group (* (not (any ?\C-b ?\C-c ?\C-g ?\n ?\C-o ?\C-v ?\C-\] ?\C-_))))) + "Regular expression matching control chars to highlight.") (defun erc-controls-interpret (str) "Return a copy of STR after dealing with IRC control characters. @@ -440,6 +630,7 @@ See `erc-interpret-controls-p' and `erc-interpret-mirc-color' for options." s)) (t s))))) +;;;###autoload (defun erc-controls-strip (str) "Return a copy of STR with all IRC control characters removed." (when str @@ -448,16 +639,6 @@ See `erc-interpret-controls-p' and `erc-interpret-mirc-color' for options." (setq s (replace-match "" nil nil s))) s))) -(defvar erc-controls-remove-regexp - "\C-b\\|\C-]\\|\C-_\\|\C-v\\|\C-g\\|\C-o\\|\C-c[0-9]?[0-9]?\\(,[0-9][0-9]?\\)?" - "Regular expression which matches control characters to remove.") - -(defvar erc-controls-highlight-regexp - (concat "\\(\C-b\\|\C-]\\|\C-v\\|\C-_\\|\C-g\\|\C-o\\|" - "\C-c\\([0-9][0-9]?\\)?\\(,\\([0-9][0-9]?\\)\\)?\\)" - "\\([^\C-b\C-]\C-v\C-_\C-c\C-g\C-o\n]*\\)") - "Regular expression which matches control chars and the text to highlight.") - (defun erc-controls-highlight () "Highlight IRC control chars in the buffer. This is useful for `erc-insert-modify-hook' and `erc-send-modify-hook'. @@ -514,6 +695,13 @@ Also see `erc-interpret-controls-p' and `erc-interpret-mirc-color'." "Prepend properties from IRC control characters between FROM and TO. If optional argument STR is provided, apply to STR, otherwise prepend properties to a region in the current buffer." + (if (and fg bg (equal fg bg)) + (progn + (setq fg 'erc-spoiler-face + bg nil) + (put-text-property from to 'mouse-face 'erc-inverse-face str)) + (when fg (setq fg (erc-get-fg-color-face fg))) + (when bg (setq bg (erc-get-bg-color-face bg)))) (font-lock-prepend-text-property from to @@ -531,10 +719,10 @@ to a region in the current buffer." '(erc-underline-face) nil) (if fg - (list (erc-get-fg-color-face fg)) + (list fg) nil) (if bg - (list (erc-get-bg-color-face bg)) + (list bg) nil)) str) str) @@ -553,6 +741,7 @@ Else interpretation is turned off." (if erc-interpret-controls-p "ON" "OFF"))) ;; Smiley +;;;###autoload(autoload 'erc-smiley-mode "erc-goodies" nil t) (define-erc-module smiley nil "This mode translates text-smileys such as :-) into pictures. This requires the function `smiley-region', which is defined in @@ -569,6 +758,7 @@ This function should be used with `erc-insert-modify-hook'." (smiley-region (point-min) (point-max)))) ;; Unmorse +;;;###autoload(autoload 'erc-unmorse-mode "erc-goodies" nil t) (define-erc-module unmorse nil "This mode causes morse code in the current channel to be unmorsed." ((add-hook 'erc-insert-modify-hook #'erc-unmorse)) @@ -611,3 +801,7 @@ servers. If called from a program, PROC specifies the server process." (provide 'erc-goodies) ;;; erc-goodies.el ends here + +;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" +;; End: diff --git a/lisp/erc/erc-ibuffer.el b/lisp/erc/erc-ibuffer.el index 6699afe36a0..612814ac6da 100644 --- a/lisp/erc/erc-ibuffer.el +++ b/lisp/erc/erc-ibuffer.el @@ -32,6 +32,7 @@ (require 'ibuffer) (require 'ibuf-ext) (require 'erc) +(require 'erc-goodies) ; `erc-controls-interpret' (defgroup erc-ibuffer nil "The Ibuffer group for ERC." diff --git a/lisp/erc/erc-imenu.el b/lisp/erc/erc-imenu.el index 6223cd3d06f..526afd32249 100644 --- a/lisp/erc/erc-imenu.el +++ b/lisp/erc/erc-imenu.el @@ -52,7 +52,8 @@ Don't rely on this function, read it first!" (forward-line 1) (looking-at " ")) (forward-line 1)) - (end-of-line) (point))))) + (end-of-line) (point)))) + (inhibit-read-only t)) (with-temp-buffer (insert str) (goto-char (point-min)) @@ -124,6 +125,26 @@ Don't rely on this function, read it first!" index-alist)) index-alist)) +(defvar-local erc-imenu--create-index-function nil + "Previous local value of `imenu-create-index-function', if any.") + +(defun erc-imenu-setup () + "Wire up support for Imenu in an ERC buffer." + (when (and (local-variable-p 'imenu-create-index-function) + imenu-create-index-function) + (setq erc-imenu--create-index-function imenu-create-index-function)) + (setq imenu-create-index-function #'erc-create-imenu-index)) + +;;;###autoload(autoload 'erc-imenu-mode "erc-imenu" nil t) +(define-erc-module imenu nil + "Simple Imenu integration for ERC." + ((add-hook 'erc-mode-hook #'erc-imenu-setup)) + ((remove-hook 'erc-mode-hook #'erc-imenu-setup) + (erc-with-all-buffers-of-server erc-server-process nil + (when erc-imenu--create-index-function + (setq imenu-create-index-function erc-imenu--create-index-function) + (kill-local-variable 'erc-imenu--create-index-function))))) + (provide 'erc-imenu) ;;; erc-imenu.el ends here diff --git a/lisp/erc/erc-log.el b/lisp/erc/erc-log.el index 2cb9031640d..2b58a7c56ed 100644 --- a/lisp/erc/erc-log.el +++ b/lisp/erc/erc-log.el @@ -198,6 +198,7 @@ This should ideally, be a \"catch-all\" coding system, like The function should take one argument, which is the text to filter." :type '(choice (function "Function") + (function-item erc-stamp-prefix-log-filter) (const :tag "No filtering" nil))) @@ -230,7 +231,8 @@ also be a predicate function. To only log when you are not set away, use: ;; append, so that 'erc-initialize-log-marker runs first (add-hook 'erc-connect-pre-hook #'erc-log-setup-logging 'append) (dolist (buffer (erc-buffer-list)) - (erc-log-setup-logging buffer))) + (erc-log-setup-logging buffer)) + (erc--modify-local-map t "C-c C-l" #'erc-save-buffer-in-logs)) ;; disable ((remove-hook 'erc-insert-post-hook #'erc-save-buffer-in-logs) (remove-hook 'erc-send-post-hook #'erc-save-buffer-in-logs) @@ -241,9 +243,8 @@ also be a predicate function. To only log when you are not set away, use: (remove-hook 'erc-part-hook #'erc-conditional-save-buffer) (remove-hook 'erc-connect-pre-hook #'erc-log-setup-logging) (dolist (buffer (erc-buffer-list)) - (erc-log-disable-logging buffer)))) - -(define-key erc-mode-map "\C-c\C-l" #'erc-save-buffer-in-logs) + (erc-log-disable-logging buffer)) + (erc--modify-local-map nil "C-c C-l" #'erc-save-buffer-in-logs))) ;;; functionality referenced from erc.el (defun erc-log-setup-logging (buffer) diff --git a/lisp/erc/erc-match.el b/lisp/erc/erc-match.el index 52ee5c855f3..82b821503a8 100644 --- a/lisp/erc/erc-match.el +++ b/lisp/erc/erc-match.el @@ -52,8 +52,13 @@ they are hidden or highlighted. This is controlled via the variables `erc-current-nick-highlight-type'. For all these highlighting types, you can decide whether the entire message or only the sending nick is highlighted." - ((add-hook 'erc-insert-modify-hook #'erc-match-message 'append)) - ((remove-hook 'erc-insert-modify-hook #'erc-match-message))) + ((add-hook 'erc-insert-modify-hook #'erc-match-message 'append) + (add-hook 'erc-mode-hook #'erc-match--modify-invisibility-spec) + (erc--modify-local-map t "C-c C-k" #'erc-go-to-log-matches-buffer)) + ((remove-hook 'erc-insert-modify-hook #'erc-match-message) + (remove-hook 'erc-mode-hook #'erc-match--modify-invisibility-spec) + (erc-match--modify-invisibility-spec) + (erc--modify-local-map nil "C-c C-k" #'erc-go-to-log-matches-buffer))) ;; Remaining customizations @@ -647,15 +652,22 @@ See `erc-log-match-format'." (get-buffer (car buffer-cons)))))) (switch-to-buffer buffer-name))) -(define-key erc-mode-map "\C-c\C-k" #'erc-go-to-log-matches-buffer) +(defvar-local erc-match--hide-fools-offset-bounds nil) (defun erc-hide-fools (match-type _nickuserhost _message) "Hide foolish comments. This function should be called from `erc-text-matched-hook'." - (when (eq match-type 'fool) - (erc-put-text-properties (point-min) (point-max) - '(invisible intangible) - (current-buffer)))) + (when (eq match-type 'fool) + (if erc-match--hide-fools-offset-bounds + (let ((beg (point-min)) + (end (point-max))) + (save-restriction + (widen) + (put-text-property (1- beg) (1- end) 'invisible 'erc-match))) + ;; The docs say `intangible' is deprecated, but this has been + ;; like this for ages. Should verify unneeded and remove if so. + (erc-put-text-properties (point-min) (point-max) + '(invisible intangible))))) (defun erc-beep-on-match (match-type _nickuserhost _message) "Beep when text matches. @@ -663,6 +675,13 @@ This function is meant to be called from `erc-text-matched-hook'." (when (member match-type erc-beep-match-types) (beep))) +(defun erc-match--modify-invisibility-spec () + "Add an ellipsis property to the local spec." + (if erc-match-mode + (add-to-invisibility-spec 'erc-match) + (erc-with-all-buffers-of-server nil nil + (remove-from-invisibility-spec 'erc-match)))) + (provide 'erc-match) ;;; erc-match.el ends here diff --git a/lisp/erc/erc-networks.el b/lisp/erc/erc-networks.el index 95fd8990c99..dd481032e7e 100644 --- a/lisp/erc/erc-networks.el +++ b/lisp/erc/erc-networks.el @@ -67,6 +67,9 @@ (declare-function erc-server-process-alive "erc-backend" (&optional buffer)) (declare-function erc-set-active-buffer "erc" (buffer)) +(declare-function erc-button--display-error-notice-with-keys + (parsed &rest strings)) + ;; Variables (defgroup erc-networks nil @@ -1292,7 +1295,6 @@ shutting down the connection." erc-server-announced-name "\" in `erc-networks-alist'" " or consider calling `erc-tls' with the keyword `:id'." " See Info:\"(erc) Network Identifier\" for more."))) - (require 'info) (erc-display-error-notice parsed m) (if erc-networks--allow-unknown-network (progn @@ -1311,12 +1313,11 @@ shutting down the connection." Copy source (prefix) from MOTD-ish message as a last resort." ;; The 004 handler never ran; see 2004-03-10 Diane Murray in change log (unless erc-server-announced-name - (setq erc-server-announced-name (erc-response.sender parsed)) - (erc-display-error-notice - parsed (concat "Failed to determine server name. Using \"" - erc-server-announced-name "\" instead." - " If this was unexpected, consider reporting it via " - (substitute-command-keys "\\[erc-bug]") "."))) + (require 'erc-button) + (erc-button--display-error-notice-with-keys + parsed "Failed to determine server name. Using \"" + (setq erc-server-announced-name (erc-response.sender parsed)) "\" instead" + ". If this was unexpected, consider reporting it via \\[erc-bug]" ".")) nil) (defun erc-unset-network-name (_nick _ip _reason) @@ -1494,9 +1495,9 @@ to be a false alarm. If `erc-reuse-buffers' is nil, let (memq (erc--target-symbol erc--target) erc-networks--bouncer-targets))) proc) - (let ((m (concat "Unexpected state detected. Please report via " - (substitute-command-keys "\\[erc-bug]") "."))) - (erc-display-error-notice parsed m)))) + (require 'erc-button) + (erc-button--display-error-notice-with-keys + parsed "Unexpected state detected. Please report via \\[erc-bug]."))) ;; For now, retain compatibility with erc-server-NNN-functions. (or (erc-networks--ensure-announced proc parsed) @@ -1514,7 +1515,6 @@ to be a false alarm. If `erc-reuse-buffers' is nil, let "Emit warning when the `networks' module hasn't been loaded. Ideally, do so upon opening the network process." (unless (or erc--target erc-networks-mode) - (require 'info nil t) (let ((m (concat "Required module `networks' not loaded. If this " " was unexpected, please add it to `erc-modules'."))) ;; Assume the server buffer has been marked as active. diff --git a/lisp/erc/erc-page.el b/lisp/erc/erc-page.el index 308b3784ca5..a94678e5132 100644 --- a/lisp/erc/erc-page.el +++ b/lisp/erc/erc-page.el @@ -30,10 +30,13 @@ (require 'erc) +(declare-function erc-controls-interpret "erc-goodies" (str)) + (defgroup erc-page nil "React to CTCP PAGE messages." :group 'erc) +;;;###autoload(put 'ctcp-page 'erc--module 'page) ;;;###autoload(autoload 'erc-page-mode "erc-page") (define-erc-module page ctcp-page "Process CTCP PAGE requests from IRC." @@ -69,6 +72,7 @@ SENDER and MSG, so that might be easier to use." This will call `erc-page-function', if defined, or it will just print a message and `beep'. In addition to that, the page message is also inserted into the server buffer." + (require 'erc-goodies) ; for `erc-controls-interpret' (when (and erc-page-mode (string-match "PAGE\\(\\s-+.*\\)?$" msg)) (let* ((m (match-string 1 msg)) diff --git a/lisp/erc/erc-pcomplete.el b/lisp/erc/erc-pcomplete.el index 0bce856018c..7eb7431fb91 100644 --- a/lisp/erc/erc-pcomplete.el +++ b/lisp/erc/erc-pcomplete.el @@ -56,6 +56,8 @@ add this string to nicks completed." "If t, order nickname completions with the most recent speakers first." :type 'boolean) +;;;###autoload(put 'Completion 'erc--module 'completion) +;;;###autoload(put 'pcomplete 'erc--module 'completion) ;;;###autoload(autoload 'erc-completion-mode "erc-pcomplete" nil t) (define-erc-module pcomplete Completion "In ERC Completion mode, the TAB key does completion whenever possible." diff --git a/lisp/erc/erc-sasl.el b/lisp/erc/erc-sasl.el index 9265691c2d7..bfe17285a68 100644 --- a/lisp/erc/erc-sasl.el +++ b/lisp/erc/erc-sasl.el @@ -369,9 +369,12 @@ This doesn't solicit or validate a suite of supported mechanisms." data (sasl-step-data step)) (when (string= data "") (setq data nil)) - (when data - (setq data (erc--unfun (base64-encode-string data t)))) - (erc-server-send (concat "AUTHENTICATE " (or data "+")))))) + (setq data (if data (erc--unfun (base64-encode-string data t)) "+")) + (while (not (string-empty-p data)) + (let ((end (min 400 (length data)))) + ;; For now, assume this is unlikely to block + (erc-server-send (concat "AUTHENTICATE " (substring data 0 end))) + (setq data (concat (substring data end) (and (= end 400) "+")))))))) (defun erc-sasl--destroy (proc) (run-hook-with-args 'erc-quit-hook proc) diff --git a/lisp/erc/erc-services.el b/lisp/erc/erc-services.el index 2e6959cc3f0..5408ba405db 100644 --- a/lisp/erc/erc-services.el +++ b/lisp/erc/erc-services.el @@ -102,6 +102,7 @@ You can also use \\[erc-nickserv-identify-mode] to change modes." (when (featurep 'erc-services) (erc-nickserv-identify-mode val)))) +;;;###autoload(put 'nickserv 'erc--module 'services) ;;;###autoload(autoload 'erc-services-mode "erc-services" nil t) (define-erc-module services nickserv "This mode automates communication with services." diff --git a/lisp/erc/erc-sound.el b/lisp/erc/erc-sound.el index 0abdbfd959c..9da9202f0cf 100644 --- a/lisp/erc/erc-sound.el +++ b/lisp/erc/erc-sound.el @@ -47,6 +47,7 @@ (require 'erc) +;;;###autoload(put 'ctcp-sound 'erc--module 'sound) ;;;###autoload(autoload 'erc-sound-mode "erc-sound") (define-erc-module sound ctcp-sound "In ERC sound mode, the client will respond to CTCP SOUND requests diff --git a/lisp/erc/erc-speedbar.el b/lisp/erc/erc-speedbar.el index 5fca14e2365..a9443e0ea17 100644 --- a/lisp/erc/erc-speedbar.el +++ b/lisp/erc/erc-speedbar.el @@ -36,6 +36,7 @@ ;;; Code: (require 'erc) +(require 'erc-goodies) (require 'speedbar) (condition-case nil (require 'dframe) (error nil)) diff --git a/lisp/erc/erc-stamp.el b/lisp/erc/erc-stamp.el index 0aa1590f801..61f289a8753 100644 --- a/lisp/erc/erc-stamp.el +++ b/lisp/erc/erc-stamp.el @@ -55,6 +55,9 @@ If nil, timestamping is turned off." :type '(choice (const nil) (string))) +;; FIXME remove surrounding whitespace from default value and have +;; `erc-insert-timestamp-left-and-right' add it before insertion. + (defcustom erc-timestamp-format-left "\n[%a %b %e %Y]\n" "If set to a string, messages will be timestamped. This string is processed using `format-time-string'. @@ -68,7 +71,7 @@ If nil, timestamping is turned off." :type '(choice (const nil) (string))) -(defcustom erc-timestamp-format-right " [%H:%M]" +(defcustom erc-timestamp-format-right nil "If set to a string, messages will be timestamped. This string is processed using `format-time-string'. Good examples are \"%T\" and \"%H:%M\". @@ -77,9 +80,14 @@ This timestamp is used for timestamps on the right side of the screen when `erc-insert-timestamp-function' is set to `erc-insert-timestamp-left-and-right'. -If nil, timestamping is turned off." +Unlike `erc-timestamp-format' and `erc-timestamp-format-left', if +the value of this option is nil, it falls back to using the value +of `erc-timestamp-format'." + :package-version '(ERC . "5.6") ; FIXME sync on release :type '(choice (const nil) (string))) +(make-obsolete-variable 'erc-timestamp-format-right + 'erc-timestamp-format "30.1") (defcustom erc-insert-timestamp-function 'erc-insert-timestamp-left-and-right "Function to use to insert timestamps. @@ -147,39 +155,67 @@ from entering them and instead jump over them." "ERC timestamp face." :group 'erc-faces) +;; New libraries should only autoload the minor mode for a module's +;; preferred name (rather than its alias). + +;;;###autoload(put 'timestamp 'erc--module 'stamp) ;;;###autoload(autoload 'erc-timestamp-mode "erc-stamp" nil t) (define-erc-module stamp timestamp "This mode timestamps messages in the channel buffers." ((add-hook 'erc-mode-hook #'erc-munge-invisibility-spec) (add-hook 'erc-insert-modify-hook #'erc-add-timestamp t) - (add-hook 'erc-send-modify-hook #'erc-add-timestamp t)) + (add-hook 'erc-send-modify-hook #'erc-add-timestamp t) + (add-hook 'erc-mode-hook #'erc-stamp--recover-on-reconnect)) ((remove-hook 'erc-mode-hook #'erc-munge-invisibility-spec) (remove-hook 'erc-insert-modify-hook #'erc-add-timestamp) - (remove-hook 'erc-send-modify-hook #'erc-add-timestamp))) + (remove-hook 'erc-send-modify-hook #'erc-add-timestamp) + (remove-hook 'erc-mode-hook #'erc-stamp--recover-on-reconnect))) + +(defun erc-stamp--recover-on-reconnect () + (when-let ((priors (or erc--server-reconnecting erc--target-priors))) + (dolist (var '(erc-timestamp-last-inserted + erc-timestamp-last-inserted-left + erc-timestamp-last-inserted-right)) + (when-let (existing (alist-get var priors)) + (set var existing))))) + +(defvar erc-stamp--current-time nil + "The current time when calling `erc-insert-timestamp-function'. +Specifically, this is the same lisp time object used to create +the stamp passed to `erc-insert-timestamp-function'.") + +(cl-defgeneric erc-stamp--current-time () + "Return a lisp time object to associate with an IRC message. +This becomes the message's `erc-timestamp' text property, which +may not be unique, `equal'-wise." + (erc-current-time)) + +(cl-defmethod erc-stamp--current-time :around () + (or erc-stamp--current-time (cl-call-next-method))) (defun erc-add-timestamp () "Add timestamp and text-properties to message. This function is meant to be called from `erc-insert-modify-hook' or `erc-send-modify-hook'." - (unless (get-text-property (point) 'invisible) - (let ((ct (current-time))) - (if (fboundp erc-insert-timestamp-function) - (funcall erc-insert-timestamp-function - (erc-format-timestamp ct erc-timestamp-format)) - (error "Timestamp function unbound")) + (unless (get-text-property (point-min) 'invisible) + (let* ((ct (erc-stamp--current-time)) + (erc-stamp--current-time ct)) + (funcall erc-insert-timestamp-function + (erc-format-timestamp ct erc-timestamp-format)) + ;; FIXME this will error when advice has been applied. (when (and (fboundp erc-insert-away-timestamp-function) erc-away-timestamp-format (erc-away-time) (not erc-timestamp-format)) (funcall erc-insert-away-timestamp-function (erc-format-timestamp ct erc-away-timestamp-format))) - (add-text-properties (point-min) (point-max) + (add-text-properties (point-min) (1- (point-max)) ;; It's important for the function to ;; be different on different entries (bug#22700). (list 'cursor-sensor-functions - (list (lambda (_window _before dir) - (erc-echo-timestamp dir ct)))))))) + ;; Regions are no longer contiguous ^ + '(erc--echo-ts-csf) 'erc-timestamp ct))))) (defvar-local erc-timestamp-last-window-width nil "The width of the last window that showed the current buffer. @@ -217,14 +253,113 @@ the correct column." (integer :tag "Column number") (const :tag "Unspecified" nil))) -(defcustom erc-timestamp-use-align-to (eq window-system 'x) +(defcustom erc-timestamp-use-align-to (and (display-graphic-p) t) "If non-nil, use the :align-to display property to align the stamp. This gives better results when variable-width characters (like Asian language characters and math symbols) precede a timestamp. -A side effect of enabling this is that there will only be one -space before a right timestamp in any saved logs." - :type 'boolean) +This option only matters when `erc-insert-timestamp-function' is +set to `erc-insert-timestamp-right' or that option's default, +`erc-insert-timestamp-left-and-right'. If the value is a +positive integer, alignment occurs that many columns from the +right edge. If the value is `margin', the stamp appears in the +right margin when visible. + +Enabling this option produces a side effect in that stamps aren't +indented in saved logs. When its value is an integer, this +option adds a space after the end of a message if the stamp +doesn't already start with one. And when its value is t, it adds +a single space, unconditionally. And while this option never +adds a space when its value is `margin', ERC does offer a +workaround in `erc-stamp-prefix-log-filter', which strips +trailing stamps from messages and puts them before every line." + :type '(choice boolean integer (const margin)) + :package-version '(ERC . "5.6")) ; FIXME sync on release + +(defcustom erc-stamp-right-margin-width nil + "Width in columns of the right margin. +When this option is nil, pretend its value is one column greater +than the `string-width' of the formatted `erc-timestamp-format'. +This option only matters when `erc-timestamp-use-align-to' is set +to `margin'." + :package-version '(ERC . "5.6") ; FIXME sync on release + :type '(choice (const nil) integer)) + +(defun erc-stamp--display-margin-force (orig &rest r) + (let ((erc-timestamp-use-align-to 'margin)) + (apply orig r))) + +(defun erc-stamp--adjust-right-margin (cols) + "Adjust right margin by COLS. +When COLS is zero, reset width to `erc-stamp-right-margin-width' +or one col more than the `string-width' of +`erc-timestamp-format'." + (let ((width + (if (zerop cols) + (or erc-stamp-right-margin-width + (1+ (string-width (or erc-timestamp-last-inserted-right + (erc-format-timestamp + (current-time) + erc-timestamp-format))))) + (+ right-margin-width cols)))) + (setq right-margin-width width) + (when (eq (current-buffer) (window-buffer)) + (set-window-margins nil left-margin-width width)))) + +;;;###autoload +(defun erc-stamp-prefix-log-filter (text) + "Prefix every message in the buffer with a stamp. +Remove trailing stamps as well. For now, hard code the format to +\"ZNC\"-log style, which is [HH:MM:SS]. Expect to be used as a +`erc-log-filter-function' when `erc-timestamp-use-align-to' is +non-nil." + (insert text) + (goto-char (point-min)) + (while + (progn + (when-let* (((< (point) (pos-eol))) + (end (1- (pos-eol))) + ((eq 'erc-timestamp (field-at-pos end))) + (beg (field-beginning end)) + ;; Skip a line that's just a timestamp. + ((> beg (point)))) + (delete-region beg (1+ end))) + (when-let (time (get-text-property (point) 'erc-timestamp)) + (insert (format-time-string "[%H:%M:%S] " time))) + (zerop (forward-line)))) + "") + +(declare-function erc--remove-text-properties "erc" (string)) + +;; If people want to use this directly, we can convert it into +;; a local module. +(define-minor-mode erc-stamp--display-margin-mode + "Internal minor mode for built-in modules integrating with `stamp'. +It binds `erc-timestamp-use-align-to' to `margin' around calls to +`erc-insert-timestamp-function' in the current buffer, and sets +the right window margin to `erc-stamp-right-margin-width'. It +also arranges to remove most text properties when a user kills +message text so that stamps will be visible when yanked." + :interactive nil + (if erc-stamp--display-margin-mode + (progn + (setq fringes-outside-margins t) + (when (eq (current-buffer) (window-buffer)) + (set-window-buffer (selected-window) (current-buffer))) + (erc-stamp--adjust-right-margin 0) + (add-function :filter-return (local 'filter-buffer-substring-function) + #'erc--remove-text-properties) + (add-function :around (local 'erc-insert-timestamp-function) + #'erc-stamp--display-margin-force)) + (remove-function (local 'filter-buffer-substring-function) + #'erc--remove-text-properties) + (remove-function (local 'erc-insert-timestamp-function) + #'erc-stamp--display-margin-force) + (kill-local-variable 'right-margin-width) + (kill-local-variable 'fringes-outside-margins) + (when (eq (current-buffer) (window-buffer)) + (set-window-margins nil left-margin-width nil) + (set-window-buffer (selected-window) (current-buffer))))) (defun erc-insert-timestamp-left (string) "Insert timestamps at the beginning of the line." @@ -243,6 +378,7 @@ space before a right timestamp in any saved logs." If `erc-timestamp-use-align-to' is t, use the :align-to display property to get to the POSth column." + (declare (obsolete "inlined and removed from client code path" "30.1")) (if (not erc-timestamp-use-align-to) (indent-to pos) (insert " ") @@ -253,6 +389,8 @@ property to get to the POSth column." ;; Silence byte-compiler (defvar erc-fill-column) +(defvar erc-stamp--inherited-props '(line-prefix wrap-prefix)) + (defun erc-insert-timestamp-right (string) "Insert timestamp on the right side of the screen. STRING is the timestamp to insert. This function is a possible @@ -304,30 +442,57 @@ printed just after each line's text (no alignment)." ;; some margin of error if what is displayed on the line differs ;; from the number of characters on the line. (setq col (+ col (ceiling (/ (- col (- (point) (line-beginning-position))) 1.6)))) - (if (< col pos) - (erc-insert-aligned string pos) - (newline) - (indent-to pos) - (setq from (point)) - (insert string)) + ;; For compatibility reasons, the `erc-timestamp' field includes + ;; intervening white space unless a hard break is warranted. + (pcase erc-timestamp-use-align-to + ((and 't (guard (< col pos))) + (insert " ") + (put-text-property from (point) 'display `(space :align-to ,pos))) + ((pred integerp) ; (cl-type (integer 0 *)) + (insert " ") + (when (eq ?\s (aref string 0)) + (setq string (substring string 1))) + (let ((s (+ erc-timestamp-use-align-to (string-width string)))) + (put-text-property from (point) 'display + `(space :align-to (- right ,s))))) + ('margin + (put-text-property 0 (length string) + 'display `((margin right-margin) ,string) + string)) + ((guard (>= col pos)) (newline) (indent-to pos) (setq from (point))) + (_ (indent-to pos))) + (insert string) + (dolist (p erc-stamp--inherited-props) + (when-let ((v (get-text-property (1- from) p))) + (put-text-property from (point) p v))) (erc-put-text-property from (point) 'field 'erc-timestamp) (erc-put-text-property from (point) 'rear-nonsticky t) (when erc-timestamp-intangible (erc-put-text-property from (1+ (point)) 'cursor-intangible t))))) -(defun erc-insert-timestamp-left-and-right (_string) - "This is another function that can be used with `erc-insert-timestamp-function'. -If the date is changed, it will print a blank line, the date, and -another blank line. If the time is changed, it will then print -it off to the right." - (let* ((ct (current-time)) - (ts-left (erc-format-timestamp ct erc-timestamp-format-left)) - (ts-right (erc-format-timestamp ct erc-timestamp-format-right))) +(defvar erc-stamp--insert-date-function #'insert + "Function to insert left \"left-right date\" stamp. +A local module might use this to modify text properties, +`insert-before-markers' or renarrow the region after insertion.") + +(defun erc-insert-timestamp-left-and-right (string) + "Insert a stamp on either side when it changes. +When the deprecated option `erc-timestamp-format-right' is nil, +use STRING, which originates from `erc-timestamp-format', for the +right-hand stamp. Use `erc-timestamp-format-left' for the +left-hand stamp and expect it to change less frequently." + (let* ((ct (or erc-stamp--current-time (erc-stamp--current-time))) + (ts-left (erc-format-timestamp ct erc-timestamp-format-left)) + (ts-right (with-suppressed-warnings + ((obsolete erc-timestamp-format-right)) + (if erc-timestamp-format-right + (erc-format-timestamp ct erc-timestamp-format-right) + string)))) ;; insert left timestamp (unless (string-equal ts-left erc-timestamp-last-inserted-left) (goto-char (point-min)) (erc-put-text-property 0 (length ts-left) 'field 'erc-timestamp ts-left) - (insert ts-left) + (funcall erc-stamp--insert-date-function ts-left) (setq erc-timestamp-last-inserted-left ts-left)) ;; insert right timestamp (let ((erc-timestamp-only-if-changed-flag t) @@ -336,12 +501,13 @@ it off to the right." (setq erc-timestamp-last-inserted-right ts-right)))) ;; for testing: (setq erc-timestamp-only-if-changed-flag nil) +(defvar erc-stamp--tz nil) (defun erc-format-timestamp (time format) "Return TIME formatted as string according to FORMAT. Return the empty string if FORMAT is nil." (if format - (let ((ts (format-time-string format time))) + (let ((ts (format-time-string format time erc-stamp--tz))) (erc-put-text-property 0 (length ts) 'font-lock-face 'erc-timestamp-face ts) (erc-put-text-property 0 (length ts) 'invisible 'timestamp ts) @@ -400,11 +566,16 @@ enabled when the message was inserted." (defun erc-echo-timestamp (dir stamp) "Print timestamp text-property of an IRC message." - (when (and erc-echo-timestamps (eq 'entered dir)) + ;; Could also pass an &optional `zone' arg to `format-time-string'. + (interactive (list 'entered (get-text-property (point) 'erc-timestamp))) + (when (eq 'entered dir) (when stamp (message "%s" (format-time-string erc-echo-timestamp-format stamp))))) +(defun erc--echo-ts-csf (_window _before dir) + (erc-echo-timestamp dir (get-text-property (point) 'erc-timestamp))) + (provide 'erc-stamp) ;;; erc-stamp.el ends here diff --git a/lisp/erc/erc-track.el b/lisp/erc/erc-track.el index 7fd7b53602e..e060b7039bd 100644 --- a/lisp/erc/erc-track.el +++ b/lisp/erc/erc-track.el @@ -921,7 +921,11 @@ is relative to `erc-track-switch-direction'." (unless (eq major-mode 'erc-mode) (setq erc-track-last-non-erc-buffer (current-buffer))) ;; and jump to the next active channel - (funcall fun (erc-track-get-active-buffer arg))) + (if-let ((buf (erc-track-get-active-buffer arg)) + ((buffer-live-p buf))) + (funcall fun buf) + (erc-modified-channels-update) + (erc-track--switch-buffer fun arg))) ;; if no active channels, switch back to what we were doing before ((and erc-track-last-non-erc-buffer erc-track-switch-from-erc diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 69bdb5d71b1..284990e2d43 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -12,8 +12,8 @@ ;; David Edmondson (dme@dme.org) ;; Michael Olson (mwolson@gnu.org) ;; Kelvin White (kwhite@gnu.org) -;; Version: 5.5 -;; Package-Requires: ((emacs "27.1") (compat "29.1.3.4")) +;; Version: 5.6-git +;; Package-Requires: ((emacs "27.1") (compat "29.1.4.1")) ;; Keywords: IRC, chat, client, Internet ;; URL: https://www.gnu.org/software/emacs/erc.html @@ -58,20 +58,16 @@ ;;; Code: -(load "erc-loaddefs" 'noerror 'nomessage) +(eval-and-compile (load "erc-loaddefs" 'noerror 'nomessage)) (require 'erc-networks) (require 'erc-backend) (require 'cl-lib) (require 'format-spec) -(require 'pp) -(require 'thingatpt) (require 'auth-source) -(require 'time-date) -(require 'iso8601) -(eval-when-compile (require 'subr-x) (require 'url-parse)) +(eval-when-compile (require 'subr-x)) -(defconst erc-version "5.5" +(defconst erc-version "5.6-git" "This version of ERC.") (defvar erc-official-location @@ -87,7 +83,8 @@ ("5.3" . "23.1") ("5.4" . "28.1") ("5.4.1" . "29.1") - ("5.5" . "29.1"))) + ("5.5" . "29.1") + ("5.6" . "30.1"))) (defgroup erc nil "Emacs Internet Relay Chat client." @@ -140,6 +137,17 @@ (defvar motif-version-string) (defvar gtk-version-string) +(declare-function decoded-time-period "time-date" (time)) +(declare-function iso8601-parse-duration "iso8601" (string)) +(declare-function word-at-point "thingatpt" (&optional no-properties)) +(autoload 'word-at-point "thingatpt") ; for hl-nicks + +(declare-function url-host "url-parse" (cl-x)) +(declare-function url-password "url-parse" (cl-x)) +(declare-function url-portspec "url-parse" (cl-x)) +(declare-function url-type "url-parse" (cl-x)) +(declare-function url-user "url-parse" (cl-x)) + ;; tunable connection and authentication parameters (defcustom erc-server nil @@ -391,6 +399,24 @@ Each function should accept two arguments, NEW-NICK and OLD-NICK." :group 'erc-hooks :type 'hook) +(defcustom erc-nickname-in-use-functions nil + "Function to run before trying for a different nickname. +Called with two arguments: the desired but just rejected nickname +and the alternate nickname about to be requested. Use cases +include special handling during connection registration and +wrestling with nickname services. For example, value +`erc-regain-nick-on-connect' is aimed at dealing with reaping +lingering connections that may prevent you from being issued a +requested nick immediately when reconnecting. It's meant to be +used with an `erc-server-reconnect-function' value of +`erc-server-delayed-check-reconnect' alongside SASL +authentication." + :package-version '(ERC . "5.6") + :group 'erc-hooks + :type '(choice (function-item erc-regain-nick-on-connect) + function + (const nil))) + (defcustom erc-connect-pre-hook '(erc-initialize-log-marker) "Hook called just before `erc' calls `erc-connect'. Functions are passed a buffer as the first argument." @@ -1189,7 +1215,6 @@ which the local user typed." (define-key map [home] #'erc-bol) (define-key map "\C-c\C-a" #'erc-bol) (define-key map "\C-c\C-b" #'erc-switch-to-buffer) - (define-key map "\C-c\C-c" #'erc-toggle-interpret-controls) (define-key map "\C-c\C-d" #'erc-input-action) (define-key map "\C-c\C-e" #'erc-toggle-ctcp-autoresponse) (define-key map "\C-c\C-f" #'erc-toggle-flood-control) @@ -1213,6 +1238,19 @@ which the local user typed." map) "ERC keymap.") +(defun erc--modify-local-map (mode &rest bindings) + "Modify `erc-mode-map' on behalf of a global module. +Add or remove `key-valid-p' BINDINGS when toggling MODE." + (declare (indent 1)) + (while (pcase-let* ((`(,key ,def . ,rest) bindings) + (existing (keymap-lookup erc-mode-map key))) + (if mode + (when (or (not existing) (eq existing #'undefined)) + (keymap-set erc-mode-map key def)) + (when (eq existing def) + (keymap-unset erc-mode-map key t))) + (setq bindings rest)))) + ;; Faces ; Honestly, I have a horrible sense of color and the "defaults" below @@ -1469,6 +1507,7 @@ Defaults to the server buffer." "IRC port to use for encrypted connections if it cannot be \ detected otherwise.") +(defvaralias 'erc-buffer-display 'erc-join-buffer) (defcustom erc-join-buffer 'bury "Determines how to display a newly created IRC buffer. @@ -1489,6 +1528,19 @@ The available choices are: (const :tag "Use current buffer" buffer) (const :tag "Use current buffer" t))) +(defcustom erc-interactive-display 'buffer + "How and whether to display server buffers for M-x erc. +See `erc-buffer-display' and friends for a description of +possible values." + :package-version '(ERC . "5.6") ; FIXME sync on release + :group 'erc-buffers + :type '(choice (const :tag "Use value of `erc-join-buffer'" nil) + (const :tag "Split window and select" window) + (const :tag "Split window, don't select" window-noselect) + (const :tag "New frame" frame) + (const :tag "Bury new and don't display existing" bury) + (const :tag "Use current buffer" buffer))) + (defcustom erc-reconnect-display nil "How (and whether) to display a channel buffer upon reconnecting. @@ -1521,19 +1573,35 @@ This only has effect when `erc-join-buffer' is set to `frame'." (defcustom erc-reuse-frames t "Determines whether new frames are always created. -Non-nil means that a new frame is not created to display an ERC -buffer if there is already a window displaying it. This only has -effect when `erc-join-buffer' is set to `frame'." + +A value of t means only create a frame for undisplayed buffers. +`displayed' means use any existing, potentially hidden frame +already displaying a buffer from the same network context or, +failing that, a frame showing any ERC buffer. As a last resort, +`displayed' defaults to the selected frame, except for brand new +connections, for which the invoking frame is always used. When +this option is nil, a new frame is always created. + +Regardless of its value, this option is ignored unless +`erc-join-buffer' is set to `frame'. And like most options in +the `erc-buffer' customize group, this has no effect on server +buffers while reconnecting because those are always buried." + :package-version '(ERC . "5.6") ; FIXME sync on release :group 'erc-buffers - :type 'boolean) + :type '(choice boolean + (const displayed))) (defun erc-channel-p (channel) "Return non-nil if CHANNEL seems to be an IRC channel name." (cond ((stringp channel) - (memq (aref channel 0) '(?# ?& ?+ ?!))) - ((and (bufferp channel) (buffer-live-p channel)) - (with-current-buffer channel - (erc-channel-p (erc-default-target)))) + (memq (aref channel 0) + (if-let ((types (erc--get-isupport-entry 'CHANTYPES 'single))) + (append types nil) + '(?# ?& ?+ ?!)))) + ((and-let* (((bufferp channel)) + ((buffer-live-p channel)) + (target (buffer-local-value 'erc--target channel))) + (erc-channel-p (erc--target-string target)))) (t nil))) ;; For the sake of compatibility, a historical quirk concerning this @@ -1816,9 +1884,9 @@ buffer rather than a server buffer.") ;; each item is in the format '(old . new) (delete-dups (mapcar #'erc--normalize-module-symbol mods))) -(defcustom erc-modules '(netsplit fill button match track completion readonly - networks ring autojoin noncommands irccontrols - move-to-prompt stamp menu list) +(defcustom erc-modules '( autojoin button completion fill imenu irccontrols + list match menu move-to-prompt netsplit + networks noncommands readonly ring stamp track) "A list of modules which ERC should enable. If you set the value of this without using `customize' remember to call \(erc-update-modules) after you change it. When using `customize', modules @@ -1826,12 +1894,20 @@ removed from the list will be disabled." :get (lambda (sym) ;; replace outdated names with their newer equivalents (erc-migrate-modules (symbol-value sym))) - :initialize #'custom-initialize-default + ;; Expect every built-in module to have the symbol property + ;; `erc--module' set to its canonical symbol (often itself). + :initialize (lambda (symbol exp) + ;; Use `cdddr' because (set :greedy t . ,entries) + (dolist (entry (cdddr (get 'erc-modules 'custom-type))) + (when-let* (((eq (car entry) 'const)) + (s (cadddr entry))) ; (const :tag "..." ,s) + (put s 'erc--module s))) + (custom-initialize-reset symbol exp)) :set (lambda (sym val) ;; disable modules which have just been removed (when (and (boundp 'erc-modules) erc-modules val) (dolist (module erc-modules) - (unless (member module val) + (unless (memq module val) (let ((f (intern-soft (format "erc-%s-mode" module)))) (when (and (fboundp f) (boundp f)) (when (symbol-value f) @@ -1843,10 +1919,19 @@ removed from the list will be disabled." (when (symbol-value f) (funcall f 0)) (kill-local-variable f))))))))) - (set sym val) + (let (built-in third-party) + (dolist (v val) + (setq v (erc--normalize-module-symbol v)) + (if (get v 'erc--module) + (push v built-in) + (push v third-party))) + ;; Calling `set-default-toplevel-value' complicates testing + (set sym (append (sort built-in #'string-lessp) + (nreverse third-party)))) ;; this test is for the case where erc hasn't been loaded yet (when (fboundp 'erc-update-modules) - (erc-update-modules))) + (unless erc--inside-mode-toggle-p + (erc-update-modules)))) :type '(set :greedy t @@ -1857,10 +1942,10 @@ removed from the list will be disabled." capab-identify) (const :tag "completion: Complete nicknames and commands (programmable)" completion) - (const :tag "hecomplete: Complete nicknames and commands (obsolete, use \"completion\")" hecomplete) (const :tag "dcc: Provide Direct Client-to-Client support" dcc) (const :tag "fill: Wrap long lines" fill) (const :tag "identd: Launch an identd server on port 8113" identd) + (const :tag "imenu: A simple Imenu integration" imenu) (const :tag "irccontrols: Highlight or remove IRC control characters" irccontrols) (const :tag "keep-place: Leave point above un-viewed text" keep-place) @@ -1874,11 +1959,11 @@ removed from the list will be disabled." (const :tag "networks: Provide data about IRC networks" networks) (const :tag "noncommands: Don't display non-IRC commands after evaluation" noncommands) + (const :tag "notifications: Desktop alerts on PRIVMSG or mentions" + notifications) (const :tag "notify: Notify when the online status of certain users changes" notify) - (const :tag "notifications: Send notifications on PRIVMSG or nickname mentions" - notifications) (const :tag "page: Process CTCP PAGE requests from IRC" page) (const :tag "readonly: Make displayed lines read-only" readonly) (const :tag "replace: Replace text in messages" replace) @@ -1891,13 +1976,14 @@ removed from the list will be disabled." (const :tag "smiley: Convert smileys to pretty icons" smiley) (const :tag "sound: Play sounds when you receive CTCP SOUND requests" sound) - (const :tag "stamp: Add timestamps to messages" stamp) (const :tag "spelling: Check spelling" spelling) + (const :tag "stamp: Add timestamps to messages" stamp) (const :tag "track: Track channel activity in the mode-line" track) (const :tag "truncate: Truncate buffers to a certain size" truncate) (const :tag "unmorse: Translate morse code in messages" unmorse) (const :tag "xdcc: Act as an XDCC file-server" xdcc) (repeat :tag "Others" :inline t symbol)) + :package-version '(ERC . "5.6") ; FIXME sync on release :group 'erc) (defun erc-update-modules () @@ -1906,18 +1992,57 @@ Except ignore all local modules, which were introduced in ERC 5.5." (erc--update-modules) nil) +(defun erc--find-mode (sym) + (setq sym (erc--normalize-module-symbol sym)) + (if-let* ((mode (intern-soft (concat "erc-" (symbol-name sym) "-mode"))) + ((or (boundp mode) + (and (fboundp mode) + (autoload-do-load (symbol-function mode) mode))))) + mode + (and (require (or (get sym 'erc--feature) + (intern (concat "erc-" (symbol-name sym)))) + nil 'noerror) + (setq mode (intern-soft (concat "erc-" (symbol-name sym) "-mode"))) + (fboundp mode) + mode))) + (defun erc--update-modules () (let (local-modes) (dolist (module erc-modules local-modes) - (require (or (alist-get module erc--modules-to-features) - (intern (concat "erc-" (symbol-name module)))) - nil 'noerror) ; some modules don't have a corresponding feature - (let ((mode (intern-soft (concat "erc-" (symbol-name module) "-mode")))) - (unless (and mode (fboundp mode)) - (error "`%s' is not a known ERC module" module)) - (if (custom-variable-p mode) - (funcall mode 1) - (push mode local-modes)))))) + (if-let ((mode (erc--find-mode module))) + (if (custom-variable-p mode) + (funcall mode 1) + (push mode local-modes)) + (error "`%s' is not a known ERC module" module))))) + +(defun erc--setup-buffer-first-window (frame a b) + (catch 'found + (walk-window-tree + (lambda (w) + (when (cond ((functionp a) (with-current-buffer (window-buffer w) + (funcall a b))) + (t (eq (buffer-local-value a (window-buffer w)) b))) + (throw 'found t))) + frame nil 0))) + +(defun erc--display-buffer-use-some-frame (buffer alist) + "Maybe display BUFFER in an existing frame for the same connection. +If performed, return window used; otherwise, return nil. Forward ALIST +to display-buffer machinery." + (when-let* + ((idp (lambda (value) + (and erc-networks--id + (erc-networks--id-equal-p erc-networks--id value)))) + (procp (lambda (frame) + (erc--setup-buffer-first-window frame idp erc-networks--id))) + (ercp (lambda (frame) + (erc--setup-buffer-first-window frame 'major-mode 'erc-mode))) + ((or (cdr (frame-list)) (funcall ercp (selected-frame))))) + ;; Workaround to avoid calling `window--display-buffer' directly + (or (display-buffer-use-some-frame buffer + `((frame-predicate . ,procp) ,@alist)) + (display-buffer-use-some-frame buffer + `((frame-predicate . ,ercp) ,@alist))))) (defun erc-setup-buffer (buffer) "Consults `erc-join-buffer' to find out how to display `BUFFER'." @@ -1934,15 +2059,21 @@ Except ignore all local modules, which were introduced in ERC 5.5." ('bury nil) ('frame - (when (or (not erc-reuse-frames) - (not (get-buffer-window buffer t))) + (cond + ((and (eq erc-reuse-frames 'displayed) + (not (get-buffer-window buffer t))) + (display-buffer buffer '((erc--display-buffer-use-some-frame) + (inhibit-switch-frame . t) + (inhibit-same-window . t)))) + ((or (not erc-reuse-frames) + (not (get-buffer-window buffer t))) (let ((frame (make-frame (or erc-frame-alist default-frame-alist)))) (raise-frame frame) (select-frame frame)) (switch-to-buffer buffer) (when erc-frame-dedicated-flag - (set-window-dedicated-p (selected-window) t)))) + (set-window-dedicated-p (selected-window) t))))) (_ (if (active-minibuffer-window) (display-buffer buffer) @@ -1967,6 +2098,35 @@ nil." (cons (nreverse (car out)) (nreverse (cdr out)))) (list new-modes))) +;; This function doubles as a convenient helper for use in unit tests. +;; Prior to 5.6, its contents lived in `erc-open'. + +(defun erc--initialize-markers (old-point continued-session) + "Ensure prompt and its bounding markers have been initialized." + ;; FIXME erase assertions after code review and additional testing. + (setq erc-insert-marker (make-marker) + erc-input-marker (make-marker)) + (if continued-session + (progn + ;; Trust existing markers. + (set-marker erc-insert-marker + (alist-get 'erc-insert-marker continued-session)) + (set-marker erc-input-marker + (alist-get 'erc-input-marker continued-session)) + (goto-char erc-insert-marker) + (cl-assert (= (field-end) erc-input-marker)) + (goto-char old-point) + (erc--unhide-prompt)) + (cl-assert (not (get-text-property (point) 'erc-prompt))) + ;; In the original version from `erc-open', the snippet that + ;; handled these newline insertions appeared twice close in + ;; proximity, which was probably unintended. Nevertheless, we + ;; preserve the double newlines here for historical reasons. + (insert "\n\n") + (set-marker erc-insert-marker (point)) + (erc-display-prompt) + (cl-assert (= (point) (point-max))))) + (defun erc-open (&optional server port nick full-name connect passwd tgt-list channel process client-certificate user id) @@ -2000,10 +2160,13 @@ Returns the buffer for the given server or channel." (old-recon-count erc-server-reconnect-count) (old-point nil) (delayed-modules nil) - (continued-session (and erc--server-reconnecting - (with-suppressed-warnings - ((obsolete erc-reuse-buffers)) - erc-reuse-buffers)))) + (continued-session (or erc--server-reconnecting + erc--target-priors + (and-let* (((not target)) + (m (buffer-local-value + 'erc-input-marker buffer)) + ((marker-position m))) + (buffer-local-variables buffer))))) (when connect (run-hook-with-args 'erc-before-connect server port nick)) (set-buffer buffer) (setq old-point (point)) @@ -2021,21 +2184,6 @@ Returns the buffer for the given server or channel." (buffer-local-value 'erc-server-announced-name old-buffer))) ;; connection parameters (setq erc-server-process process) - (setq erc-insert-marker (make-marker)) - (setq erc-input-marker (make-marker)) - ;; go to the end of the buffer and open a new line - ;; (the buffer may have existed) - (goto-char (point-max)) - (forward-line 0) - (when (or continued-session (get-text-property (point) 'erc-prompt)) - (setq continued-session t) - (set-marker erc-input-marker - (or (next-single-property-change (point) 'erc-prompt) - (point-max)))) - (unless continued-session - (goto-char (point-max)) - (insert "\n")) - (set-marker erc-insert-marker (point)) ;; stack of default recipients (setq erc-default-recipients tgt-list) (when target @@ -2082,20 +2230,7 @@ Returns the buffer for the given server or channel." (get-buffer-create (concat "*ERC-DEBUG: " server "*")))) (erc-determine-parameters server port nick full-name user passwd) - - ;; FIXME consolidate this prompt-setup logic with the pass above. - - ;; set up prompt - (unless continued-session - (goto-char (point-max)) - (insert "\n")) - (if continued-session - (progn (goto-char old-point) - (erc--unhide-prompt)) - (set-marker erc-insert-marker (point)) - (erc-display-prompt) - (goto-char (point-max))) - + (erc--initialize-markers old-point continued-session) (save-excursion (run-mode-hooks) (dolist (mod (car delayed-modules)) (funcall mod +1)) (dolist (var (cdr delayed-modules)) (set var nil))) @@ -2177,29 +2312,12 @@ parameters SERVER and NICK." (setq input (concat "irc://" input))) input) -;; A temporary means of addressing the problem of ERC's namesake entry -;; point defaulting to a non-TLS connection with its default server -;; (bug#60428). -(defun erc--warn-unencrypted () - ;; Remove unconditionally to avoid wrong context due to races from - ;; simultaneous dialing or aborting (e.g., via `keybaord-quit'). - (remove-hook 'erc--server-post-connect-hook #'erc--warn-unencrypted) - (when (and (process-contact erc-server-process :nowait) - (equal erc-session-server erc-default-server) - (eql erc-session-port erc-default-port)) - ;; FIXME use the autoloaded `info' instead of `Info-goto-node' in - ;; `erc-button-alist'. - (require 'info nil t) - (erc-display-error-notice - nil (concat "This connection is unencrypted. Please use `erc-tls'" - " from now on. See Info:\"(erc) connecting\" for more.")))) - ;;;###autoload (defun erc-select-read-args () - "Prompt the user for values of nick, server, port, and password." - (require 'url-parse) + "Prompt the user for values of nick, server, port, and password. +With prefix arg, also prompt for user and full name." (let* ((input (let ((d (erc-compute-server))) - (read-string (format "Server (default is %S): " d) + (read-string (format "Server or URL (default is %S): " d) nil 'erc-server-history-list d))) ;; For legacy reasons, also accept a URL without a scheme. (url (url-generic-parse-url (erc--ensure-url input))) @@ -2217,20 +2335,47 @@ parameters SERVER and NICK." (let ((d (erc-compute-nick))) (read-string (format "Nickname (default is %S): " d) nil 'erc-nick-history-list d)))) + (user (and current-prefix-arg + (let ((d (erc-compute-user (url-user url)))) + (read-string (format "User (default is %S): " d) + nil nil d)))) + (full (and current-prefix-arg + (let ((d (erc-compute-full-name (url-user url)))) + (read-string (format "Full name (default is %S): " d) + nil nil d)))) (passwd (let* ((p (with-suppressed-warnings ((obsolete erc-password)) (or (url-password url) erc-password))) (m (if p (format "Server password (default is %S): " p) "Server password (optional): "))) - (if erc-prompt-for-password (read-passwd m nil p) p)))) + (if erc-prompt-for-password (read-passwd m nil p) p))) + (opener (and (or sp (eql port erc-default-port-tls) + (and (equal server erc-default-server) + (not (string-prefix-p "irc://" input)) + (eql port erc-default-port) + (y-or-n-p "Connect using TLS instead? ") + (setq port erc-default-port-tls))) + #'erc-open-tls-stream)) + env) + (when erc-interactive-display + (push `(erc-join-buffer . ,erc-interactive-display) env)) + (when opener + (push `(erc-server-connect-function . ,opener) env)) (when (and passwd (string= "" passwd)) (setq passwd nil)) - (when (and (equal server erc-default-server) - (eql port erc-default-port) - (not (eql port erc-default-port-tls)) ; not `erc-tls' - (not (string-prefix-p "irc://" input))) ; not yanked URL - (add-hook 'erc--server-post-connect-hook #'erc--warn-unencrypted)) - (list :server server :port port :nick nick :password passwd))) + `( :server ,server :port ,port :nick ,nick ,@(and user `(:user ,user)) + ,@(and passwd `(:password ,passwd)) ,@(and full `(:full-name ,full)) + ,@(and env `(&interactive-env ,env))))) + +(defmacro erc--with-entrypoint-environment (env &rest body) + "Run BODY with bindings from ENV alist." + (declare (indent 1)) + (let ((syms (make-symbol "syms")) + (vals (make-symbol "vals"))) + `(let (,syms ,vals) + (pcase-dolist (`(,k . ,v) ,env) (push k ,syms) (push v ,vals)) + (cl-progv ,syms ,vals + ,@body)))) ;;;###autoload (cl-defun erc (&key (server (erc-compute-server)) @@ -2239,7 +2384,9 @@ parameters SERVER and NICK." (user (erc-compute-user)) password (full-name (erc-compute-full-name)) - id) + id + ;; Used by interactive form + ((&interactive-env --interactive-env--))) "ERC is a powerful, modular, and extensible IRC client. This function is the main entry point for ERC. @@ -2262,9 +2409,12 @@ then the server and full-name will be set to those values, whereas `erc-compute-port' and `erc-compute-nick' will be invoked for the values of the other parameters. -See `erc-tls' for the meaning of ID." +See `erc-tls' for the meaning of ID. + +\(fn &key SERVER PORT NICK USER PASSWORD FULL-NAME ID)" (interactive (erc-select-read-args)) - (erc-open server port nick full-name t password nil nil nil nil user id)) + (erc--with-entrypoint-environment --interactive-env-- + (erc-open server port nick full-name t password nil nil nil nil user id))) ;;;###autoload (defalias 'erc-select #'erc) @@ -2278,7 +2428,9 @@ See `erc-tls' for the meaning of ID." password (full-name (erc-compute-full-name)) client-certificate - id) + id + ;; Used by interactive form + ((&interactive-env --interactive-env--))) "ERC is a powerful, modular, and extensible IRC client. This function is the main entry point for ERC over TLS. @@ -2320,12 +2472,22 @@ Example usage: When present, ID should be a symbol or a string to use for naming the server buffer and identifying the connection unequivocally. -See Info node `(erc) Network Identifier' for details. Like USER -and CLIENT-CERTIFICATE, this parameter cannot be specified -interactively." +See Info node `(erc) Network Identifier' for details. Like +CLIENT-CERTIFICATE, this parameter cannot be specified +interactively. + +\(fn &key SERVER PORT NICK USER PASSWORD FULL-NAME CLIENT-CERTIFICATE ID)" (interactive (let ((erc-default-port erc-default-port-tls)) (erc-select-read-args))) - (let ((erc-server-connect-function 'erc-open-tls-stream)) + ;; Bind `erc-server-connect-function' to `erc-open-tls-stream' + ;; around `erc-open' when a non-default value hasn't been specified + ;; by the user or the interactive form. And don't bother checking + ;; for advice, indirect functions, autoloads, etc. + (unless (or (assq 'erc-server-connect-function --interactive-env--) + (not (eq erc-server-connect-function #'erc-open-network-stream))) + (push '(erc-server-connect-function . erc-open-tls-stream) + --interactive-env--)) + (erc--with-entrypoint-environment --interactive-env-- (erc-open server port nick full-name t password nil nil nil client-certificate user id))) @@ -2521,6 +2683,16 @@ this option to nil." :type 'boolean :group 'erc) +(define-inline erc--assert-input-bounds () + (inline-quote + (progn (when (and (processp erc-server-process) + (eq (current-buffer) (process-buffer erc-server-process))) + ;; It's believed that these only need syncing immediately + ;; following the first two insertions in a server buffer. + (set-marker (process-mark erc-server-process) erc-insert-marker)) + (cl-assert (< erc-insert-marker erc-input-marker)) + (cl-assert (= (field-end erc-insert-marker) erc-input-marker))))) + (defun erc-display-line-1 (string buffer) "Display STRING in `erc-mode' BUFFER. Auxiliary function used in `erc-display-line'. The line gets filtered to @@ -2530,8 +2702,7 @@ Afterwards, `erc-insert-modify' and `erc-insert-post-hook' get called. If STRING is nil, the function does nothing." (when string (with-current-buffer (or buffer (process-buffer erc-server-process)) - (let ((insert-position (or (marker-position erc-insert-marker) - (point-max)))) + (let ((insert-position (marker-position erc-insert-marker))) (let ((string string) ;; FIXME! Can this be removed? (buffer-undo-list t) (inhibit-read-only t)) @@ -2556,6 +2727,7 @@ If STRING is nil, the function does nothing." (widen) (goto-char insert-position) (insert-before-markers string) + (erc--assert-input-bounds) ;; run insertion hook, with point at restored location (save-restriction (narrow-to-region insert-position (point)) @@ -2563,7 +2735,8 @@ If STRING is nil, the function does nothing." (run-hooks 'erc-insert-post-hook) (when erc-remove-parsed-property (remove-text-properties (point-min) (point-max) - '(erc-parsed nil)))))))) + '(erc-parsed nil)))) + (erc--assert-input-bounds))))) (run-hooks 'erc-insert-done-hook) (erc-update-undo-list (- (or (marker-position erc-insert-marker) (point-max)) @@ -2868,7 +3041,9 @@ See also `erc-format-message' and `erc-display-line'." (erc-display-line string buffer) (unless (erc-hide-current-message-p parsed) (erc-put-text-property 0 (length string) 'erc-parsed parsed string) - (erc-put-text-property 0 (length string) 'rear-sticky t string) + (put-text-property + 0 (length string) 'erc-command + (erc--get-eq-comparable-cmd (erc-response.command parsed)) string) (when (erc-response.tags parsed) (erc-put-text-property 0 (length string) 'tags (erc-response.tags parsed) string)) @@ -3054,6 +3229,8 @@ returns the time spec converted to a number of seconds." (string-to-number period)) ;; Parse as a time spec. (t + (require 'time-date) + (require 'iso8601) (let ((time (condition-case nil (iso8601-parse-duration (concat (cond @@ -3203,7 +3380,7 @@ VERSION and so on. It is called with ARGS." (erc-send-ctcp-message nick str) t)) -(defun erc-cmd-HELP (&optional func) +(defun erc-cmd-HELP (&optional func &rest rest) "Popup help information. If FUNC contains a valid function or variable, help about that @@ -3236,6 +3413,10 @@ For a list of user commands (/join /part, ...): nil))))) (if sym (cond + ((get sym 'erc--cmd-help) + (when (autoloadp (symbol-function sym)) + (autoload-do-load (symbol-function sym))) + (apply (get sym 'erc--cmd-help) rest)) ((boundp sym) (describe-variable sym)) ((fboundp sym) (describe-function sym)) (t nil)) @@ -4046,6 +4227,22 @@ means that the user has a +o flag in the channel's access list)." (t (erc-server-send "TIME")))) (defalias 'erc-cmd-DATE #'erc-cmd-TIME) +(defun erc-cmd-MOTD (&optional target) + "Ask server to send the current MOTD. +Some IRCds simply ignore TARGET." + (letrec ((oneoff (lambda (proc parsed) + (with-current-buffer (erc-server-buffer) + (cl-assert (eq (current-buffer) (process-buffer proc))) + (remove-hook 'erc-server-402-functions h402 t) + (remove-hook 'erc-server-376-functions h376 t) + (remove-hook 'erc-server-422-functions h422 t)) + (erc-server-MOTD proc parsed) + t)) + (h402 (erc-once-with-server-event 402 oneoff)) + (h376 (erc-once-with-server-event 376 oneoff)) + (h422 (erc-once-with-server-event 422 oneoff))) + (erc-server-send (concat "MOTD" (and target " ") target)))) + (defun erc-cmd-TOPIC (topic) "Set or request the topic for a channel. LINE has the format: \"#CHANNEL TOPIC\", \"#CHANNEL\", \"TOPIC\" @@ -4246,6 +4443,30 @@ Eventually add a # in front of it, if that turns it into a valid channel name." channel (concat "#" channel))) +(defvar erc--own-property-names + '( tags erc-parsed display ; core + ;; `erc-display-prompt' + rear-nonsticky erc-prompt field front-sticky read-only + ;; stamp + cursor-intangible cursor-sensor-functions isearch-open-invisible + ;; match + invisible intangible + ;; button + erc-callback erc-data mouse-face keymap + ;; fill-wrap + line-prefix wrap-prefix) + "Props added by ERC that should not survive killing. +Among those left behind by default are `font-lock-face' and +`erc-secret'.") + +(defun erc--remove-text-properties (string) + "Remove text properties in STRING added by ERC. +Specifically, remove any that aren't members of +`erc--own-property-names'." + (remove-list-of-text-properties 0 (length string) + erc--own-property-names string) + string) + (defun erc-grab-region (start end) "Copy the region between START and END in a recreatable format. @@ -4297,7 +4518,7 @@ If FACE is non-nil, it will be used to propertize the prompt. If it is nil, (setq prompt (propertize prompt 'rear-nonsticky t 'erc-prompt t - 'field t + 'field 'erc-prompt 'front-sticky t 'read-only t)) (erc-put-text-property 0 (1- (length prompt)) @@ -4507,6 +4728,7 @@ To change how this query window is displayed, use `let' to bind (with-current-buffer server-buffer (erc--open-target target))) +(defvaralias 'erc-receive-query-display 'erc-auto-query) (defcustom erc-auto-query 'window-noselect "If non-nil, create a query buffer each time you receive a private message. If the buffer doesn't already exist, it is created. @@ -4573,6 +4795,34 @@ E.g. \"Read error to Nick [user@some.host]: 110\" would be shortened to (match-string 1 reason)) reason)) +(defun erc-regain-nick-on-connect (want temp) + "Try at most once to grab nickname WANT after settling for TEMP. +Only do so during connection registration, likely prior to +authenticating with SASL. Assume the prior connection was lost +due to connectivity failure and that the server hasn't yet +noticed. Also assume that the server won't process any +authentication-related messages until it has accepted a mulligan +nick or at least sent a 433 and thus triggered +`erc-nickname-in-use-functions'. Expect authentication to have +succeeded by the time a logical IRC connection has been +established and that the contending connection may otherwise +still be alive and require manual intervention involving +NickServ." + (unless erc-server-connected + (letrec ((after-connect + (lambda (_ nick) + (remove-hook 'erc-after-connect after-connect t) + (when (equal temp nick) + (erc-cmd-NICK want)))) + (on-900 + (lambda (_ parsed) + (remove-hook 'erc-server-900-functions on-900 t) + (unless erc-server-connected + (when (equal (car (erc-response.command-args parsed)) temp) + (add-hook 'erc-after-connect after-connect nil t))) + nil))) + (add-hook 'erc-server-900-functions on-900 nil t)))) + (defun erc-nickname-in-use (nick reason) "If NICK is unavailable, tell the user the REASON. @@ -4606,6 +4856,7 @@ See also `erc-display-error-notice'." ;; established a connection yet (- 9 (length erc-nick-uniquifier)))) erc-nick-uniquifier))) + (run-hook-with-args 'erc-nickname-in-use-functions nick newnick) (erc-cmd-NICK newnick) (erc-display-error-notice nil @@ -5669,7 +5920,7 @@ See also variable `erc-notice-highlight-type'." (erc-put-text-property 0 (length s) 'font-lock-face 'erc-error-face s) s) -(defun erc-put-text-property (start end property value &optional object) +(defalias 'erc-put-text-property 'put-text-property "Set text-property for an object (usually a string). START and END define the characters covered. PROPERTY is the text-property set, usually the symbol `face'. @@ -5679,14 +5930,9 @@ OBJECT is a string which will be modified and returned. OBJECT is modified without being copied first. You can redefine or `defadvice' this function in order to add -EmacsSpeak support." - (put-text-property start end property value object)) +EmacsSpeak support.") -(defun erc-list (thing) - "Return THING if THING is a list, or a list with THING as its element." - (if (listp thing) - thing - (list thing))) +(defalias 'erc-list 'ensure-list) (defun erc-parse-user (string) "Parse STRING as a user specification (nick!login@host). @@ -5843,8 +6089,7 @@ When the returned value is a string, pass it to `erc-error'.") (progn ; unprogn this during next major surgery (erc-set-active-buffer (current-buffer)) ;; Kill the input and the prompt - (delete-region (erc-beg-of-input-line) - (erc-end-of-input-line)) + (delete-region erc-input-marker (erc-end-of-input-line)) (unwind-protect (erc-send-input str 'skip-ws-chk) ;; Fix the buffer if the command didn't kill it @@ -5852,12 +6097,7 @@ When the returned value is a string, pass it to `erc-error'.") (with-current-buffer old-buf (save-restriction (widen) - (goto-char (point-max)) - (when (processp erc-server-process) - (set-marker (process-mark erc-server-process) (point))) - (set-marker erc-insert-marker (point)) (let ((buffer-modified (buffer-modified-p))) - (erc-display-prompt) (set-buffer-modified-p buffer-modified)))))) ;; Only when last hook has been run... @@ -5943,21 +6183,21 @@ Return non-nil only if we actually send anything." (defun erc-display-msg (line) "Display LINE as a message of the user to the current target at point." (when erc-insert-this - (let ((insert-position (point))) - (insert (erc-format-my-nick)) - (let ((beg (point))) - (insert line) - (erc-put-text-property beg (point) - 'font-lock-face 'erc-input-face)) - (insert "\n") - (when (processp erc-server-process) - (set-marker (process-mark erc-server-process) (point))) - (set-marker erc-insert-marker (point)) - (save-excursion + (save-excursion + (erc--assert-input-bounds) + (let ((insert-position (marker-position erc-insert-marker)) + beg) + (goto-char insert-position) + (insert-before-markers (erc-format-my-nick)) + (setq beg (point)) + (insert-before-markers line) + (erc-put-text-property beg (point) 'font-lock-face 'erc-input-face) + (insert-before-markers "\n") (save-restriction (narrow-to-region insert-position (point)) (run-hooks 'erc-send-modify-hook) - (run-hooks 'erc-send-post-hook)))))) + (run-hooks 'erc-send-post-hook)) + (erc--assert-input-bounds))))) (defun erc-command-symbol (command) "Return the ERC command symbol for COMMAND if it exists and is bound." @@ -6836,8 +7076,6 @@ shortened server name instead." (cond (lag (format "lag:%.0f" lag)) (t "")))) -;; erc-goodies is required at end of this file. - ;; TODO when ERC drops Emacs 28, replace the expressions in the format ;; spec below with functions. (defun erc-update-mode-line-buffer (buffer) @@ -7131,6 +7369,7 @@ All windows are opened in the current frame." (s379 . "%c: Forwarded to %f") (s391 . "The time at %s is %t") (s401 . "%n: No such nick/channel") + (s402 . "%c: No such server") (s403 . "%c: No such channel") (s404 . "%c: Cannot send to channel") (s405 . "%c: You have joined too many channels") @@ -7280,10 +7519,11 @@ This function should be on `erc-kill-channel-hook'." (defun erc-restore-text-properties () "Restore the property `erc-parsed' for the region." - (let ((parsed-posn (erc-find-parsed-property))) - (put-text-property - (point-min) (point-max) - 'erc-parsed (when parsed-posn (erc-get-parsed-vector parsed-posn))))) + (when-let* ((parsed-posn (erc-find-parsed-property)) + (found (erc-get-parsed-vector parsed-posn))) + (put-text-property (point-min) (point-max) 'erc-parsed found) + (when-let ((tags (get-text-property parsed-posn 'tags))) + (put-text-property (point-min) (point-max) 'tags tags)))) (defun erc-get-parsed-vector (point) "Return the whole parsed vector on POINT." @@ -7303,6 +7543,13 @@ This function should be on `erc-kill-channel-hook'." (and vect (erc-response.command vect))) +(defun erc--get-eq-comparable-cmd (command) + "Return a symbol or a fixnum representing a message's COMMAND. +See also `erc-message-type'." + ;; IRC numerics are three-digit numbers, possibly with leading 0s. + ;; To invert: (if (numberp o) (format "%03d" o) (symbol-name o)) + (if-let* ((n (string-to-number command)) ((zerop n))) (intern command) n)) + ;; Teach url.el how to open irc:// URLs with ERC. ;; To activate, customize `url-irc-function' to `url-irc-erc'. @@ -7386,6 +7633,4 @@ Customize `erc-url-connect-function' to override this." (provide 'erc) -;; FIXME this is a temporary stopgap for Emacs 29. -(require 'erc-goodies) ;;; erc.el ends here diff --git a/lisp/eshell/em-cmpl.el b/lisp/eshell/em-cmpl.el index b65652019d4..732bbb3f1fa 100644 --- a/lisp/eshell/em-cmpl.el +++ b/lisp/eshell/em-cmpl.el @@ -306,9 +306,24 @@ to writing a completion function." (defun eshell-complete--eval-argument-form (arg) "Evaluate a single Eshell argument form ARG for the purposes of completion." - (let ((result (eshell-do-eval `(eshell-commands ,arg) t))) - (cl-assert (eq (car result) 'quote)) - (cadr result))) + (condition-case err + (let* (;; Don't allow running commands; they could have + ;; arbitrary side effects, which we don't want when we're + ;; just performing completions! + (eshell-allow-commands) + ;; Handle errors ourselves so that we can properly catch + ;; `eshell-commands-forbidden'. + (eshell-handle-errors) + (result (eshell-do-eval `(eshell-commands ,arg) t))) + (cl-assert (eq (car result) 'quote)) + (cadr result)) + (eshell-commands-forbidden + (propertize "\0" 'eshell-argument-stub + (intern (format "%s-command" (cadr err))))) + (error + (lwarn 'eshell :error + "Failed to evaluate argument form during completion: %S" arg) + (propertize "\0" 'eshell-argument-stub 'error)))) (defun eshell-complete-parse-arguments () "Parse the command line arguments for `pcomplete-argument'." @@ -325,23 +340,28 @@ to writing a completion function." (if (= begin end) (end-of-line)) (setq end (point-marker))) - (if (setq delim - (catch 'eshell-incomplete - (ignore - (setq args (eshell-parse-arguments begin end))))) - (cond ((member (car delim) '("{" "${" "$<")) - (setq begin (1+ (cadr delim)) - args (eshell-parse-arguments begin end))) - ((member (car delim) '("$'" "$\"" "#<")) - ;; Add the (incomplete) argument to our arguments, and - ;; note its position. - (setq args (append (nth 2 delim) (list (car delim))) - incomplete-arg t) - (push (- (nth 1 delim) 2) posns)) - ((member (car delim) '("(" "$(")) - (throw 'pcompleted (elisp-completion-at-point))) - (t - (eshell--pcomplete-insert-tab)))) + ;; Don't expand globs when parsing arguments; we want to pass any + ;; globs to Pcomplete unaltered. + (declare-function eshell-parse-glob-chars "em-glob" ()) + (let ((eshell-parse-argument-hook (remq #'eshell-parse-glob-chars + eshell-parse-argument-hook))) + (if (setq delim + (catch 'eshell-incomplete + (ignore + (setq args (eshell-parse-arguments begin end))))) + (cond ((member (car delim) '("{" "${" "$<")) + (setq begin (1+ (cadr delim)) + args (eshell-parse-arguments begin end))) + ((member (car delim) '("$'" "$\"" "#<")) + ;; Add the (incomplete) argument to our arguments, and + ;; note its position. + (setq args (append (nth 2 delim) (list (car delim))) + incomplete-arg t) + (push (- (nth 1 delim) 2) posns)) + ((member (car delim) '("(" "$(")) + (throw 'pcompleted (elisp-completion-at-point))) + (t + (eshell--pcomplete-insert-tab))))) (when (get-text-property (1- end) 'comment) (eshell--pcomplete-insert-tab)) (let ((pos (1- end))) diff --git a/lisp/eshell/em-dirs.el b/lisp/eshell/em-dirs.el index 4bc6342d422..5284df9ab59 100644 --- a/lisp/eshell/em-dirs.el +++ b/lisp/eshell/em-dirs.el @@ -253,12 +253,21 @@ Thus, this does not include the current directory.") (throw 'eshell-replace-command (eshell-parse-command "cd" (flatten-tree args))))) -(defun eshell-expand-user-reference (file) +(defun eshell-expand-user-reference-1 (file) "Expand a user reference in FILE to its real directory name." (replace-regexp-in-string (rx bos (group "~" (*? anychar)) (or "/" eos)) #'expand-file-name file)) +(defun eshell-expand-user-reference (file) + "Expand a user reference in FILE to its real directory name. +FILE can be either a string or a list of strings to expand." + ;; If the argument was a glob pattern, then FILE is a list, so + ;; expand each element of the glob's resulting list. + (if (listp file) + (mapcar #'eshell-expand-user-reference-1 file) + (eshell-expand-user-reference-1 file))) + (defun eshell-parse-user-reference () "An argument beginning with ~ is a filename to be expanded." (when (and (not eshell-current-argument) diff --git a/lisp/eshell/em-glob.el b/lisp/eshell/em-glob.el index 8a2ba13b2ad..9402df43065 100644 --- a/lisp/eshell/em-glob.el +++ b/lisp/eshell/em-glob.el @@ -145,16 +145,6 @@ This mimics the behavior of zsh if non-nil, but bash if nil." (defun eshell-add-glob-modifier () "Add `eshell-extended-glob' to the argument modifier list." - (when (memq 'expand-file-name eshell-current-modifiers) - (setq eshell-current-modifiers - (delq 'expand-file-name eshell-current-modifiers)) - ;; if this is a glob pattern than needs to be expanded, then it - ;; will need to expand each member of the resulting glob list - (add-to-list 'eshell-current-modifiers - (lambda (list) - (if (listp list) - (mapcar 'expand-file-name list) - (expand-file-name list))))) (add-to-list 'eshell-current-modifiers 'eshell-extended-glob)) (defun eshell-parse-glob-chars () diff --git a/lisp/eshell/em-unix.el b/lisp/eshell/em-unix.el index d550910f4f0..a792493e071 100644 --- a/lisp/eshell/em-unix.el +++ b/lisp/eshell/em-unix.el @@ -145,9 +145,10 @@ Otherwise, Emacs will attempt to use rsh to invoke du on the remote machine." (add-hook 'pcomplete-try-first-hook 'eshell-complete-host-reference nil t)) (setq-local eshell-complex-commands - (append '("grep" "egrep" "fgrep" "agrep" "glimpse" "locate" - "cat" "time" "cp" "mv" "make" "du" "diff") - eshell-complex-commands))) + (append '("grep" "egrep" "fgrep" "agrep" "rgrep" + "glimpse" "locate" "cat" "time" "cp" "mv" + "make" "du" "diff") + eshell-complex-commands))) (defalias 'eshell/date 'current-time-string) (defalias 'eshell/basename 'file-name-nondirectory) @@ -773,6 +774,10 @@ external command." "Use Emacs grep facility instead of calling external agrep." (eshell-grep "agrep" args)) +(defun eshell/rgrep (&rest args) + "Use Emacs grep facility instead of calling external rgrep." + (eshell-grep "grep" (append '("-rH") args) t)) + (defun eshell/glimpse (&rest args) "Use Emacs grep facility instead of calling external glimpse." (let (null-device) diff --git a/lisp/eshell/esh-cmd.el b/lisp/eshell/esh-cmd.el index 93f2616020c..94aa2ed8906 100644 --- a/lisp/eshell/esh-cmd.el +++ b/lisp/eshell/esh-cmd.el @@ -293,6 +293,17 @@ CDR are the same process. When the process in the CDR completes, resume command evaluation.") +(defvar eshell-allow-commands t + "If non-nil, allow evaluating command forms (including Lisp forms). +If you want to forbid command forms, you can let-bind this to a +non-nil value before calling `eshell-do-eval'. Then, any command +forms will signal `eshell-commands-forbidden'. This is useful +if, for example, you want to evaluate simple expressions like +variable expansions, but not fully-evaluate the command. See +also `eshell-complete-parse-arguments'.") + +(define-error 'eshell-commands-forbidden "Commands forbidden") + ;;; Functions: (defsubst eshell-interactive-process-p () @@ -410,7 +421,8 @@ hooks should be run before and after the command." (string= (car eshell--sep-terms) ";")) (eshell-parse-pipeline cmd) `(eshell-do-subjob - (list ,(eshell-parse-pipeline cmd))))) + (cons :eshell-background + ,(eshell-parse-pipeline cmd))))) (setq eshell--sep-terms (cdr eshell--sep-terms)) (if eshell-in-pipeline-p cmd @@ -531,9 +543,10 @@ of its argument (i.e., use of a Lisp special form), it must be implemented via rewriting, rather than as a function." (if (and (equal (car terms) "for") (equal (nth 2 terms) "in")) - (let ((body (car (last terms)))) + (let ((for-items (make-symbol "for-items")) + (body (car (last terms)))) (setcdr (last terms 2) nil) - `(let ((for-items + `(let ((,for-items (append ,@(mapcar (lambda (elem) @@ -541,13 +554,13 @@ implemented via rewriting, rather than as a function." elem `(list ,elem))) (nthcdr 3 terms))))) - (while for-items - (let ((,(intern (cadr terms)) (car for-items)) + (while ,for-items + (let ((,(intern (cadr terms)) (car ,for-items)) (eshell--local-vars (cons ',(intern (cadr terms)) eshell--local-vars))) (eshell-protect ,(eshell-invokify-arg body t))) - (setq for-items (cdr for-items))) + (setq ,for-items (cdr ,for-items))) (eshell-close-handles))))) (defun eshell-structure-basic-command (func names keyword test body @@ -675,13 +688,13 @@ This means an exit code of 0." (or (= (point-max) (1+ (point))) (not (eq (char-after (1+ (point))) ?\})))) (let ((end (eshell-find-delimiter ?\{ ?\}))) - (if (not end) - (throw 'eshell-incomplete "{") - (when (eshell-arg-delimiter (1+ end)) - (prog1 - `(eshell-as-subcommand - ,(eshell-parse-command (cons (1+ (point)) end))) - (goto-char (1+ end)))))))) + (unless end + (throw 'eshell-incomplete "{")) + (when (eshell-arg-delimiter (1+ end)) + (prog1 + `(eshell-as-subcommand + ,(eshell-parse-command (cons (1+ (point)) end))) + (goto-char (1+ end))))))) (defun eshell-parse-lisp-argument () "Parse a Lisp expression which is specified as an argument." @@ -881,7 +894,7 @@ This is used on systems where async subprocesses are not supported." (set headproc nil) (set tailproc nil) (progn - ,(if (fboundp 'make-process) + ,(if eshell-supports-asynchronous-processes `(eshell-do-pipelines ,pipeline) `(let ((tail-handles (eshell-duplicate-handles eshell-current-handles))) @@ -890,28 +903,33 @@ This is used on systems where async subprocesses are not supported." (symbol-value tailproc)))))) (defmacro eshell-as-subcommand (command) - "Execute COMMAND using a temp buffer. -This is used so that certain Lisp commands, such as `cd', when -executed in a subshell, do not disturb the environment of the main -Eshell buffer." + "Execute COMMAND as a subcommand. +A subcommand creates a local environment so that any changes to +the environment don't propagate outside of the subcommand's +scope. This lets you use commands like `cd' within a subcommand +without changing the current directory of the main Eshell +buffer." `(let ,eshell-subcommand-bindings ,command)) (defmacro eshell-do-command-to-value (object) "Run a subcommand prepared by `eshell-command-to-value'. This avoids the need to use `let*'." + (declare (obsolete nil "30.1")) `(let ((eshell-current-handles (eshell-create-handles value 'overwrite))) (progn ,object (symbol-value value)))) -(defmacro eshell-command-to-value (object) - "Run OBJECT synchronously, returning its result as a string. -Returns a string comprising the output from the command." - `(let ((value (make-symbol "eshell-temp")) - (eshell-in-pipeline-p nil)) - (eshell-do-command-to-value ,object))) +(defmacro eshell-command-to-value (command) + "Run an Eshell COMMAND synchronously, returning its output." + (let ((value (make-symbol "eshell-temp"))) + `(let ((eshell-in-pipeline-p nil) + (eshell-current-handles + (eshell-create-handles ',value 'overwrite))) + ,command + ,value))) ;;;_* Iterative evaluation ;; @@ -1019,7 +1037,12 @@ produced by `eshell-parse-command'." (cadr result))) (defun eshell-eval-command (command &optional input) - "Evaluate the given COMMAND iteratively." + "Evaluate the given COMMAND iteratively. +Return the process (or head and tail processes) created by +COMMAND, if any. If COMMAND is a background command, return the +process(es) in a cons cell like: + + (:eshell-background . PROCESS)" (if eshell-current-command ;; We can just stick the new command at the end of the current ;; one, and everything will happen as it should. @@ -1035,20 +1058,12 @@ produced by `eshell-parse-command'." (erase-buffer) (insert "command: \"" input "\"\n"))) (setq eshell-current-command command) - (let* ((delim (catch 'eshell-incomplete - (eshell-resume-eval))) - (val (car-safe delim))) - ;; If the return value of `eshell-resume-eval' is wrapped in a - ;; list, it indicates that the command was run asynchronously. - ;; In that case, unwrap the value before checking the delimiter - ;; value. - (if (and val - (not (eshell-processp val)) - (not (eq val t))) - (error "Unmatched delimiter: %S" val) - ;; Eshell-command expect a list like (<process>) to know if the - ;; command should be async or not. - (or (and (eshell-processp val) delim) val))))) + (let* (result + (delim (catch 'eshell-incomplete + (ignore (setq result (eshell-resume-eval)))))) + (when delim + (error "Unmatched delimiter: %S" delim)) + result))) (defun eshell-resume-command (proc status) "Resume the current command when a process ends." @@ -1168,7 +1183,7 @@ have been replaced by constants." (setcar (cdr args) (eshell-do-eval (cadr args) synchronous-p)) (eval form)) ((eq (car form) 'let) - (when (not (eq (car (cadr args)) 'eshell-do-eval)) + (unless (eq (car-safe (cadr args)) 'eshell-do-eval) (eshell-manipulate "evaluating let args" (dolist (letarg (car args)) (when (and (listp letarg) @@ -1328,6 +1343,8 @@ have been replaced by constants." (defun eshell-named-command (command &optional args) "Insert output from a plain COMMAND, using ARGS. COMMAND may result in an alias being executed, or a plain command." + (unless eshell-allow-commands + (signal 'eshell-commands-forbidden '(named))) (setq eshell-last-arguments args eshell-last-command-name (eshell-stringify command)) (run-hook-with-args 'eshell-prepare-command-hook) @@ -1465,6 +1482,8 @@ via `eshell-errorn'." (defun eshell-lisp-command (object &optional args) "Insert Lisp OBJECT, using ARGS if a function." + (unless eshell-allow-commands + (signal 'eshell-commands-forbidden '(lisp))) (catch 'eshell-external ; deferred to an external command (setq eshell-last-command-status 0 eshell-last-arguments args) diff --git a/lisp/eshell/esh-proc.el b/lisp/eshell/esh-proc.el index a86e7502795..00e0c8014e1 100644 --- a/lisp/eshell/esh-proc.el +++ b/lisp/eshell/esh-proc.el @@ -97,6 +97,9 @@ information, for example." ;;; Internal Variables: +(defvar eshell-supports-asynchronous-processes (fboundp 'make-process) + "Non-nil if Eshell can create asynchronous processes.") + (defvar eshell-current-subjob-p nil) (defvar eshell-process-list nil @@ -296,7 +299,7 @@ Used only on systems which do not support async subprocesses.") (coding-system-change-eol-conversion locale-coding-system 'unix)))) (cond - ((fboundp 'make-process) + (eshell-supports-asynchronous-processes (unless (or ;; FIXME: It's not currently possible to use a ;; stderr process for remote files. (file-remote-p default-directory) @@ -367,6 +370,8 @@ Used only on systems which do not support async subprocesses.") (erase-buffer) (set-buffer oldbuf) (run-hook-with-args 'eshell-exec-hook command) + ;; XXX: This doesn't support sending stdout and stderr to + ;; separate places. (setq exit-status (apply #'call-process-region (append (list eshell-last-sync-output-start (point) @@ -392,10 +397,6 @@ Used only on systems which do not support async subprocesses.") (setq lbeg lend) (set-buffer proc-buf)) (set-buffer oldbuf)) - (require 'esh-mode) - (declare-function eshell-update-markers "esh-mode" (pmark)) - (defvar eshell-last-output-end) ;Defined in esh-mode.el. - (eshell-update-markers eshell-last-output-end) ;; Simulate the effect of eshell-sentinel. (eshell-close-handles (if (numberp exit-status) exit-status -1) diff --git a/lisp/eshell/esh-var.el b/lisp/eshell/esh-var.el index 5d6299af564..7dcaff1e24f 100644 --- a/lisp/eshell/esh-var.el +++ b/lisp/eshell/esh-var.el @@ -507,55 +507,56 @@ Possible variable references are: (cond ((eq (char-after) ?{) (let ((end (eshell-find-delimiter ?\{ ?\}))) - (if (not end) - (throw 'eshell-incomplete "${") - (forward-char) - (prog1 - `(eshell-apply-indices - (eshell-convert - (eshell-command-to-value - (eshell-as-subcommand - ,(let ((subcmd (or (eshell-unescape-inner-double-quote end) - (cons (point) end))) - (eshell-current-quoted nil)) - (eshell-parse-command subcmd)))) - ;; If this is a simple double-quoted form like - ;; "${COMMAND}" (i.e. no indices after the subcommand - ;; and no `#' modifier before), ensure we convert to a - ;; single string. This avoids unnecessary work - ;; (e.g. splitting the output by lines) when it would - ;; just be joined back together afterwards. - ,(when (and (not modifier-p) eshell-current-quoted) - '(not indices))) - indices ,eshell-current-quoted) - (goto-char (1+ end)))))) + (unless end + (throw 'eshell-incomplete "${")) + (forward-char) + (prog1 + `(eshell-apply-indices + (eshell-convert + (eshell-command-to-value + (eshell-as-subcommand + ,(let ((subcmd (or (eshell-unescape-inner-double-quote end) + (cons (point) end))) + (eshell-current-quoted nil)) + (eshell-parse-command subcmd)))) + ;; If this is a simple double-quoted form like + ;; "${COMMAND}" (i.e. no indices after the subcommand and + ;; no `#' modifier before), ensure we convert to a single + ;; string. This avoids unnecessary work (e.g. splitting + ;; the output by lines) when it would just be joined back + ;; together afterwards. + ,(when (and (not modifier-p) eshell-current-quoted) + '(not indices))) + indices ,eshell-current-quoted) + (goto-char (1+ end))))) ((eq (char-after) ?\<) (let ((end (eshell-find-delimiter ?\< ?\>))) - (if (not end) - (throw 'eshell-incomplete "$<") - (let* ((temp (make-temp-file temporary-file-directory)) - (cmd (concat (buffer-substring (1+ (point)) end) - " > " temp))) - (prog1 - `(let ((eshell-current-handles - (eshell-create-handles ,temp 'overwrite))) - (progn - (eshell-as-subcommand - ,(let ((eshell-current-quoted nil)) - (eshell-parse-command cmd))) - (ignore - (nconc eshell-this-command-hook - ;; Quote this lambda; it will be evaluated - ;; by `eshell-do-eval', which requires very - ;; particular forms in order to work - ;; properly. See bug#54190. - (list (function - (lambda () - (delete-file ,temp) - (when-let ((buffer (get-file-buffer ,temp))) - (kill-buffer buffer))))))) - (eshell-apply-indices ,temp indices ,eshell-current-quoted))) - (goto-char (1+ end))))))) + (unless end + (throw 'eshell-incomplete "$<")) + (forward-char) + (let* ((temp (make-temp-file temporary-file-directory)) + (subcmd (or (eshell-unescape-inner-double-quote end) + (cons (point) end)))) + (prog1 + `(let ((eshell-current-handles + (eshell-create-handles ,temp 'overwrite))) + (progn + (eshell-as-subcommand + ,(let ((eshell-current-quoted nil)) + (eshell-parse-command subcmd))) + (ignore + (nconc eshell-this-command-hook + ;; Quote this lambda; it will be evaluated by + ;; `eshell-do-eval', which requires very + ;; particular forms in order to work + ;; properly. See bug#54190. + (list (function + (lambda () + (delete-file ,temp) + (when-let ((buffer (get-file-buffer ,temp))) + (kill-buffer buffer))))))) + (eshell-apply-indices ,temp indices ,eshell-current-quoted))) + (goto-char (1+ end)))))) ((eq (char-after) ?\() (condition-case nil `(eshell-apply-indices diff --git a/lisp/eshell/eshell.el b/lisp/eshell/eshell.el index 7d2c0335db2..15fc2ae6310 100644 --- a/lisp/eshell/eshell.el +++ b/lisp/eshell/eshell.el @@ -272,43 +272,38 @@ information on Eshell, see Info node `(eshell)Top'." (declare-function eshell-add-input-to-history "em-hist" (input)) -;;;###autoload -(defun eshell-command (&optional command arg) - "Execute the Eshell command string COMMAND. -With prefix ARG, insert output into the current buffer at point." - (interactive) - (unless arg - (setq arg current-prefix-arg)) - (let ((eshell-non-interactive-p t)) +(defun eshell-read-command (&optional prompt) + "Read an Eshell command from the minibuffer, prompting with PROMPT." + (let ((prompt (or prompt "Emacs shell command: ")) + (eshell-non-interactive-p t)) ;; Enable `eshell-mode' only in this minibuffer. (minibuffer-with-setup-hook (lambda () (eshell-mode) (eshell-command-mode +1)) - (unless command - (setq command (read-from-minibuffer "Emacs shell command: ")) - (if (eshell-using-module 'eshell-hist) - (eshell-add-input-to-history command))))) - (unless command - (error "No command specified!")) - ;; redirection into the current buffer is achieved by adding an - ;; output redirection to the end of the command, of the form - ;; 'COMMAND >>> #<buffer BUFFER>'. This will not interfere with - ;; other redirections, since multiple redirections merely cause the - ;; output to be copied to multiple target locations - (if arg - (setq command - (concat command - (format " >>> #<buffer %s>" - (buffer-name (current-buffer)))))) + (let ((command (read-from-minibuffer prompt))) + (when (eshell-using-module 'eshell-hist) + (eshell-add-input-to-history command)) + command)))) + +;;;###autoload +(defun eshell-command (command &optional to-current-buffer) + "Execute the Eshell command string COMMAND. +If TO-CURRENT-BUFFER is non-nil (interactively, with the prefix +argument), then insert output into the current buffer at point." + (interactive (list (eshell-read-command) + current-prefix-arg)) (save-excursion - (let ((buf (set-buffer (generate-new-buffer " *eshell cmd*"))) + (let ((stdout (if to-current-buffer (current-buffer) t)) + (buf (set-buffer (generate-new-buffer " *eshell cmd*"))) (eshell-non-interactive-p t)) (eshell-mode) (let* ((proc (eshell-eval-command - (list 'eshell-commands - (eshell-parse-command command)))) + `(let ((eshell-current-handles + (eshell-create-handles ,stdout 'insert)) + (eshell-current-subjob-p)) + ,(eshell-parse-command command)))) intr - (bufname (if (and proc (listp proc)) + (bufname (if (eq (car-safe proc) :eshell-background) "*Eshell Async Command Output*" (setq intr t) "*Eshell Command Output*"))) @@ -326,7 +321,7 @@ With prefix ARG, insert output into the current buffer at point." (while (and (bolp) (not (bobp))) (delete-char -1))) (cl-assert (and buf (buffer-live-p buf))) - (unless arg + (unless to-current-buffer (let ((len (if (not intr) 2 (count-lines (point-min) (point-max))))) (cond diff --git a/lisp/files.el b/lisp/files.el index 6f02aac33d3..c6f53e5eaf8 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -555,7 +555,7 @@ using a transform that puts the lock files on a local file system." :version "28.1") (defcustom remote-file-name-inhibit-locks nil - "Whether to use file locks for remote files." + "Whether to create file locks for remote files." :group 'files :version "28.1" :type 'boolean) diff --git a/lisp/find-file.el b/lisp/find-file.el index e98ea621d6a..05459c3643d 100644 --- a/lisp/find-file.el +++ b/lisp/find-file.el @@ -167,7 +167,7 @@ To override this, give an argument to `ff-find-other-file'." :type 'boolean) (defcustom ff-quiet-mode nil - "If non-nil, trace which directories are being searched." + "If non-nil, do not trace which directories are being searched." :type 'boolean) ;;;###autoload @@ -351,7 +351,7 @@ Variables of interest include: If non-nil, always attempt to create the other file if it was not found. - `ff-quiet-mode' - If non-nil, traces which directories are being searched. + If non-nil, does not trace which directories are being searched. - `ff-special-constructs' A list of regular expressions specifying how to recognize special diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index ce7a4488a7f..6a7a3f41746 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -7390,6 +7390,7 @@ This is an extended text-mode. \\{gnus-article-edit-mode-map}" (make-local-variable 'gnus-article-edit-done-function) (make-local-variable 'gnus-prev-winconf) + (make-local-variable 'gnus-prev-cwc) (setq-local font-lock-defaults '(message-font-lock-keywords t)) (setq-local mail-header-separator "") (setq-local gnus-article-edit-mode t) @@ -7420,7 +7421,8 @@ groups." (defun gnus-article-edit-article (start-func exit-func &optional quiet) "Start editing the contents of the current article buffer." - (let ((winconf (current-window-configuration))) + (let ((winconf (current-window-configuration)) + (cwc gnus-current-window-configuration)) (set-buffer gnus-article-buffer) (let ((message-auto-save-directory ;; Don't associate the article buffer with a draft file. @@ -7431,6 +7433,7 @@ groups." (gnus-configure-windows 'edit-article) (setq gnus-article-edit-done-function exit-func) (setq gnus-prev-winconf winconf) + (setq gnus-prev-cwc cwc) (unless quiet (gnus-message 6 "C-c C-c to end edits")))) @@ -7440,7 +7443,8 @@ groups." (let ((func gnus-article-edit-done-function) (buf (current-buffer)) (start (window-start)) - (winconf gnus-prev-winconf)) + (winconf gnus-prev-winconf) + (cwc gnus-prev-cwc)) (widen) ;; Widen it in case that users narrowed the buffer. (funcall func arg) (set-buffer buf) @@ -7458,6 +7462,7 @@ groups." (set-text-properties (point-min) (point-max) nil) (gnus-article-mode) (set-window-configuration winconf) + (setq gnus-current-window-configuration cwc) (set-buffer buf) (set-window-start (get-buffer-window buf) start) (set-window-point (get-buffer-window buf) (point))) @@ -7479,10 +7484,12 @@ groups." (erase-buffer) (if (gnus-buffer-live-p gnus-original-article-buffer) (insert-buffer-substring gnus-original-article-buffer)) - (let ((winconf gnus-prev-winconf)) + (let ((winconf gnus-prev-winconf) + (cwc gnus-prev-cwc)) (kill-all-local-variables) (gnus-article-mode) (set-window-configuration winconf) + (setq gnus-current-window-configuration cwc) ;; Tippy-toe some to make sure that point remains where it was. (with-current-buffer curbuf (set-window-start (get-buffer-window (current-buffer)) window-start) diff --git a/lisp/gnus/gnus-eform.el b/lisp/gnus/gnus-eform.el index 958d819048f..cc5beb16a34 100644 --- a/lisp/gnus/gnus-eform.el +++ b/lisp/gnus/gnus-eform.el @@ -70,17 +70,20 @@ It is a slightly enhanced `lisp-data-mode'. (when (gnus-visual-p 'group-menu 'menu) (gnus-edit-form-make-menu-bar)) (make-local-variable 'gnus-edit-form-done-function) - (make-local-variable 'gnus-prev-winconf)) + (make-local-variable 'gnus-prev-winconf) + (make-local-variable 'gnus-prev-cwc)) (defun gnus-edit-form (form documentation exit-func &optional layout) "Edit FORM in a new buffer. Call EXIT-FUNC on exit. Display DOCUMENTATION in the beginning of the buffer. The optional LAYOUT overrides the `edit-form' window layout." - (let ((winconf (current-window-configuration))) + (let ((winconf (current-window-configuration)) + (cwc gnus-current-window-configuration)) (set-buffer (gnus-get-buffer-create gnus-edit-form-buffer)) (gnus-configure-windows (or layout 'edit-form)) (gnus-edit-form-mode) + (setq gnus-prev-cwc cwc) (setq gnus-prev-winconf winconf) (setq gnus-edit-form-done-function exit-func) (erase-buffer) @@ -113,9 +116,11 @@ The optional LAYOUT overrides the `edit-form' window layout." (defun gnus-edit-form-exit () "Kill the current buffer." (interactive nil gnus-edit-form-mode) - (let ((winconf gnus-prev-winconf)) + (let ((winconf gnus-prev-winconf) + (cwc gnus-prev-cwc)) (kill-buffer (current-buffer)) - (set-window-configuration winconf))) + (set-window-configuration winconf) + (setq gnus-current-window-configuration cwc))) (provide 'gnus-eform) diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index 070d1223e2c..8c1d7e3c86a 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -4195,7 +4195,8 @@ If DONT-SCAN is non-nil, scan non-activated groups as well." (let ((info (gnus-get-info group)) (active (gnus-active group))) (when info - (gnus-request-update-info info method)) + (gnus-request-update-info info method) + (setq active (gnus-active group))) (gnus-get-unread-articles-in-group info active) (unless (gnus-virtual-group-p group) (gnus-close-group group)) diff --git a/lisp/gnus/gnus-icalendar.el b/lisp/gnus/gnus-icalendar.el index 0d776cd1bca..adbc39547ff 100644 --- a/lisp/gnus/gnus-icalendar.el +++ b/lisp/gnus/gnus-icalendar.el @@ -165,7 +165,7 @@ (icalendar--get-event-property-attributes event field) zone-map)) (dtdate-dec (icalendar--decode-isodatetime dtdate nil dtdate-zone))) - (encode-time dtdate-dec))) + (when dtdate-dec (encode-time dtdate-dec)))) (defun gnus-icalendar-event--find-attendee (ical name-or-email) (let* ((event (car (icalendar--all-events ical))) diff --git a/lisp/gnus/gnus-search.el b/lisp/gnus/gnus-search.el index 22c84bc39cf..12d9dacf132 100644 --- a/lisp/gnus/gnus-search.el +++ b/lisp/gnus/gnus-search.el @@ -1066,7 +1066,9 @@ Responsible for handling and, or, and parenthetical expressions.") _srv query-spec groups) (let ((artlist [])) (dolist (group groups) - (let* ((gnus-newsgroup-selection (nnselect-get-artlist group)) + (let* ((gnus-newsgroup-selection + (or + (nnselect-get-artlist group) (nnselect-generate-artlist group))) (group-spec (nnselect-categorize (mapcar 'car @@ -2174,37 +2176,53 @@ remaining string, then adds all that to the top-level spec." (declare-function gnus-registry-get-id-key "gnus-registry" (id key)) -(defun gnus-search-thread (header) - "Make an nnselect group based on the thread containing the article -header. The current server will be searched. If the registry is -installed, the server that the registry reports the current -article came from is also searched." - (let* ((ids (cons (mail-header-id header) - (split-string - (or (mail-header-references header) - "")))) - (query - (list (cons 'query (mapconcat (lambda (i) - (format "id:%s" i)) - ids " or ")) - (cons 'thread t))) - (server - (list (list (gnus-method-to-server - (gnus-find-method-for-group gnus-newsgroup-name))))) - (registry-group (and - (bound-and-true-p gnus-registry-enabled) - (car (gnus-registry-get-id-key - (mail-header-id header) 'group)))) - (registry-server - (and registry-group - (gnus-method-to-server - (gnus-find-method-for-group registry-group))))) - (when registry-server - (cl-pushnew (list registry-server) server :test #'equal)) - (gnus-group-make-search-group nil (list - (cons 'search-query-spec query) - (cons 'search-group-spec server))) - (gnus-summary-goto-subject (gnus-id-to-article (mail-header-id header))))) +(defun gnus-search-thread (header &optional group server) + "Find articles in the thread containing HEADER from GROUP on SERVER. +If gnus-refer-thread-use-search is nil only the current group is +checked for articles; if t all groups on the server containing +the article's group will be searched; if a list then all servers +in this list will be searched. If possible the newly found +articles are added to the summary buffer; otherwise the full +thread is displayed in a new ephemeral nnselect buffer." + (let* ((group (or group gnus-newsgroup-name)) + (server (or server (gnus-group-server group))) + (query + (list + (cons 'query + (mapconcat (lambda (i) (format "id:%s" i)) + (cons (mail-header-id header) + (split-string + (or (mail-header-references header) ""))) + " or ")) + (cons 'thread t))) + (gnus-search-use-parsed-queries t)) + (if (not gnus-refer-thread-use-search) + ;; Search only the current group and send the headers back to + ;; the caller to add to the summary buffer. + (gnus-fetch-headers + (sort + (mapcar (lambda (x) (elt x 1)) + (gnus-search-run-query + (list (cons 'search-query-spec query) + (cons 'search-group-spec + (list (list server group)))))) + #'<) nil t) + ;; Otherwise create an ephemeral search group. If we return to + ;; the current summary buffer after exiting the thread we would + ;; end up overwriting any changes we made, so we exit the + ;; current summary buffer first. + (gnus-summary-exit) + (gnus-group-read-ephemeral-search-group + nil + (list (cons 'search-query-spec query) + (cons 'search-group-spec + (if (listp gnus-refer-thread-use-search) + gnus-refer-thread-use-search + (list (list server)))))) + (if (gnus-id-to-article (mail-header-id header)) + (gnus-summary-goto-subject + (gnus-id-to-article (mail-header-id header))) + (message "Thread search failed"))))) (defun gnus-search-get-active (srv) (let ((method (gnus-server-to-method srv)) diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index d59b5b58ceb..19b8b09de03 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -1490,7 +1490,8 @@ backend check whether the group actually exists." (gnus-request-update-info info (inline (gnus-find-method-for-group (gnus-info-group info))))) - (gnus-activate-group (gnus-info-group info) nil t)) + (gnus-activate-group (gnus-info-group info) nil t) + (setq active (gnus-active (gnus-info-group info)))) (let* ((range (gnus-info-read info)) (num 0)) diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 0e81f95cd15..35e867a3508 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -80,6 +80,8 @@ (autoload 'nnselect-article-rsv "nnselect" nil nil) (autoload 'nnselect-article-group "nnselect" nil nil) (autoload 'gnus-nnselect-group-p "nnselect" nil nil) +(autoload 'gnus-search-thread "gnus-search" nil nil) +(autoload 'gnus-search-server-to-engine "gnus-search" nil nil) (defcustom gnus-kill-summary-on-exit t "If non-nil, kill the summary buffer when you exit from it. @@ -141,12 +143,17 @@ If t, fetch all the available old headers." 'gnus-refer-thread-use-search "28.1") (defcustom gnus-refer-thread-use-search nil - "Search an entire server when referring threads. -A nil value will only search for thread-related articles in the -current group." + "Specify where to find articles when referring threads. +A nil value restricts searches for thread-related articles to the +current group; a value of t searches all groups on the server; a +list of servers and groups (where each element is a list whose +car is the server and whose cdr is a list of groups on this +server or nil to search the entire server) searches these +server/groups. This may usefully be set as a group parameter." :version "28.1" :group 'gnus-thread - :type 'boolean) + :type '(restricted-sexp :match-alternatives + (listp 't 'nil))) (defcustom gnus-refer-thread-limit-to-thread nil "If non-nil referring a thread will limit the summary buffer to @@ -1408,6 +1415,7 @@ the normal Gnus MIME machinery." (defvar gnus-newsgroup-adaptive-score-file nil) (defvar gnus-current-score-file nil) (defvar gnus-current-move-group nil) +(defvar gnus-current-move-article nil) (defvar gnus-current-copy-group nil) (defvar gnus-current-crosspost-group nil) (defvar gnus-newsgroup-display nil) @@ -8500,7 +8508,15 @@ If UNREPLIED (the prefix), limit to unreplied articles." If REVERSE, limit the summary buffer to articles that are marked with MARKS. MARKS can either be a string of marks or a list of marks. Returns how many articles were removed." - (interactive "sMarks: " gnus-summary-mode) + (interactive + (list + (completing-read "Marks:" + (let ((mark-list '())) + (mapc (lambda (datum) + (cl-pushnew (gnus-data-mark datum) mark-list)) + gnus-newsgroup-data) + (mapcar 'char-to-string mark-list))) + current-prefix-arg) gnus-summary-mode) (gnus-summary-limit-to-marks marks t)) (defun gnus-summary-limit-to-marks (marks &optional reverse) @@ -8509,7 +8525,15 @@ If REVERSE (the prefix), limit the summary buffer to articles that are not marked with MARKS. MARKS can either be a string of marks or a list of marks. Returns how many articles were removed." - (interactive "sMarks: \nP" gnus-summary-mode) + (interactive + (list + (completing-read "Marks:" + (let ((mark-list '())) + (mapc (lambda (datum) + (cl-pushnew (gnus-data-mark datum) mark-list)) + gnus-newsgroup-data) + (mapcar 'char-to-string mark-list))) + current-prefix-arg) gnus-summary-mode) (prog1 (let ((data gnus-newsgroup-data) (marks (if (listp marks) marks @@ -8992,64 +9016,72 @@ Return the number of articles fetched." (defun gnus-summary-refer-thread (&optional limit) "Fetch all articles in the current thread. -For backends that know how to search for threads (currently only -`nnimap') a non-numeric prefix arg will search the entire server; -without a prefix arg only the current group is searched. If the -variable `gnus-refer-thread-use-search' is non-nil the prefix arg -has the reverse meaning. If no backend-specific `request-thread' -function is available fetch LIMIT (the numerical prefix) old -headers. If LIMIT is non-numeric or nil fetch the number -specified by the `gnus-refer-thread-limit' variable." +A non-numeric prefix arg will search the entire server; without a +prefix arg only the current group is searched. If the variable +`gnus-refer-thread-use-search' is t the prefix arg has the +reverse meaning. If searching is not enabled for the current +group, fetch LIMIT (the numerical prefix) old headers. If LIMIT +is non-numeric or nil fetch the number specified by the +`gnus-refer-thread-limit' variable." (interactive "P" gnus-summary-mode) - (let* ((header (gnus-summary-article-header)) - (id (mail-header-id header)) - (gnus-inhibit-demon t) - (gnus-summary-ignore-duplicates t) - (gnus-read-all-available-headers t) - (gnus-refer-thread-use-search - (if (and (not (null limit)) (listp limit)) - (not gnus-refer-thread-use-search) gnus-refer-thread-use-search)) - (new-headers - (if (gnus-check-backend-function - 'request-thread gnus-newsgroup-name) - (gnus-request-thread header gnus-newsgroup-name) - (let* ((limit (if (numberp limit) (prefix-numeric-value limit) - gnus-refer-thread-limit)) - (last (if (numberp limit) - (min (+ (mail-header-number header) - limit) - gnus-newsgroup-highest) - gnus-newsgroup-highest)) - (subject (gnus-simplify-subject - (mail-header-subject header))) - (refs (split-string (or (mail-header-references header) - ""))) - (gnus-parse-headers-hook + (let* ((group gnus-newsgroup-name) + (header (gnus-summary-article-header)) + (id (mail-header-id header)) + (gnus-inhibit-demon t) + (gnus-summary-ignore-duplicates t) + (gnus-read-all-available-headers t) + (gnus-refer-thread-use-search + (if (or (null limit) (numberp limit)) + gnus-refer-thread-use-search + (if (booleanp gnus-refer-thread-use-search) + (not gnus-refer-thread-use-search) + gnus-refer-thread-use-search))) + article-ids new-unreads + (new-headers + (cond + ;; If there is a backend-specific method, use it. + ((gnus-check-backend-function + 'request-thread group) + (gnus-request-thread header group)) + ;; If a search engine is configured, use it. + ((ignore-errors + (gnus-search-server-to-engine (gnus-group-server group))) + (gnus-search-thread header)) + ;; Otherwise just retrieve some headers. + (t + (let* ((limit (if (numberp limit) + limit + gnus-refer-thread-limit)) + (last (if (numberp limit) + (min (+ (mail-header-number header) limit) + gnus-newsgroup-highest) + gnus-newsgroup-highest)) + (subject (gnus-simplify-subject + (mail-header-subject header))) + (refs (split-string + (or (mail-header-references header) ""))) + (gnus-parse-headers-hook (let ((refs (append refs (list id subject)))) - (lambda () - (goto-char (point-min)) - (keep-lines (regexp-opt refs)))))) - (gnus-fetch-headers (list last) (if (numberp limit) - (* 2 limit) limit) - t)))) - article-ids new-unreads) + (lambda () (goto-char (point-min)) + (keep-lines (regexp-opt refs)))))) + (gnus-fetch-headers + (list last) (if (numberp limit) (* 2 limit) limit) t)))))) (when (listp new-headers) (dolist (header new-headers) - (push (mail-header-number header) article-ids)) + (push (mail-header-number header) article-ids)) (setq article-ids (nreverse article-ids)) (setq new-unreads - (gnus-sorted-intersection gnus-newsgroup-unselected article-ids)) + (gnus-sorted-intersection gnus-newsgroup-unselected article-ids)) (setq gnus-newsgroup-unselected - (gnus-sorted-ndifference gnus-newsgroup-unselected new-unreads)) + (gnus-sorted-ndifference gnus-newsgroup-unselected new-unreads)) (setq gnus-newsgroup-unreads - (gnus-sorted-nunion gnus-newsgroup-unreads new-unreads)) + (gnus-sorted-nunion gnus-newsgroup-unreads new-unreads)) (setq gnus-newsgroup-headers (gnus-delete-duplicate-headers - (cl-merge - 'list gnus-newsgroup-headers new-headers - 'gnus-article-sort-by-number))) + (cl-merge 'list gnus-newsgroup-headers new-headers + 'gnus-article-sort-by-number))) (setq gnus-newsgroup-articles - (gnus-sorted-nunion gnus-newsgroup-articles article-ids)) + (gnus-sorted-nunion gnus-newsgroup-articles article-ids)) (gnus-summary-limit-include-thread id gnus-refer-thread-limit-to-thread))) (gnus-summary-show-thread)) @@ -10248,6 +10280,7 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." article gnus-newsgroup-name (current-buffer) t))) ;; run the move/copy/crosspost/respool hook + (setq gnus-current-move-article (cdr art-group)) (run-hook-with-args 'gnus-summary-article-move-hook action (gnus-data-header (gnus-data-find article)) diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index efab58437e9..fc8518512ee 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -2445,6 +2445,7 @@ are always t.") ;; Save window configuration. (defvar gnus-prev-winconf nil) +(defvar gnus-prev-cwc nil) (defvar gnus-reffed-article-number nil) diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el index 639a29582b3..582c598ac22 100644 --- a/lisp/gnus/mail-source.el +++ b/lisp/gnus/mail-source.el @@ -658,50 +658,49 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) ;; If getting from mail spool directory, use movemail to move ;; rather than just renaming, so as to interlock with the ;; mailer. - (unwind-protect - (save-excursion - (setq errors (generate-new-buffer " *mail source loss*")) - (let ((default-directory "/")) - (setq result - ;; call-process looks in exec-path, which - ;; contains exec-directory, so will find - ;; Mailutils movemail if it exists, else it will - ;; find "our" movemail in exec-directory. - ;; Bug#31737 - (apply - #'call-process - (append - (list - mail-source-movemail-program - nil errors nil from to))))) - (when (file-exists-p to) - (set-file-modes to mail-source-default-file-modes 'nofollow)) - (if (and (or (not (buffer-modified-p errors)) - (zerop (buffer-size errors))) - (and (numberp result) - (zerop result))) - ;; No output => movemail won. - t - (set-buffer errors) - ;; There may be a warning about older revisions. We - ;; ignore that. - (goto-char (point-min)) - (if (search-forward "older revision" nil t) - t - ;; Probably a real error. - (subst-char-in-region (point-min) (point-max) ?\n ?\ ) - (goto-char (point-max)) - (skip-chars-backward " \t") - (delete-region (point) (point-max)) - (goto-char (point-min)) - (when (looking-at "movemail: ") - (delete-region (point-min) (match-end 0))) - ;; Result may be a signal description string. - (unless (yes-or-no-p - (format "movemail: %s (%s return). Continue? " - (buffer-string) result)) - (error "%s" (buffer-string))) - (setq to nil))))))) + (save-excursion + (setq errors (generate-new-buffer " *mail source loss*")) + (let ((default-directory "/")) + (setq result + ;; call-process looks in exec-path, which + ;; contains exec-directory, so will find + ;; Mailutils movemail if it exists, else it will + ;; find "our" movemail in exec-directory. + ;; Bug#31737 + (apply + #'call-process + (append + (list + mail-source-movemail-program + nil errors nil from to))))) + (when (file-exists-p to) + (set-file-modes to mail-source-default-file-modes 'nofollow)) + (if (and (or (not (buffer-modified-p errors)) + (zerop (buffer-size errors))) + (and (numberp result) + (zerop result))) + ;; No output => movemail won. + t + (set-buffer errors) + ;; There may be a warning about older revisions. We + ;; ignore that. + (goto-char (point-min)) + (if (search-forward "older revision" nil t) + t + ;; Probably a real error. + (subst-char-in-region (point-min) (point-max) ?\n ?\ ) + (goto-char (point-max)) + (skip-chars-backward " \t") + (delete-region (point) (point-max)) + (goto-char (point-min)) + (when (looking-at "movemail: ") + (delete-region (point-min) (match-end 0))) + ;; Result may be a signal description string. + (unless (yes-or-no-p + (format "movemail: %s (%s return). Continue? " + (buffer-string) result)) + (error "%s" (buffer-string))) + (setq to nil)))))) (when (buffer-live-p errors) (kill-buffer errors)) ;; Return whether we moved successfully or not. diff --git a/lisp/gnus/mm-view.el b/lisp/gnus/mm-view.el index 8dfb0deb418..2c407353559 100644 --- a/lisp/gnus/mm-view.el +++ b/lisp/gnus/mm-view.el @@ -98,7 +98,7 @@ This is only used if `mm-inline-large-images' is set to (truncate (* mm-inline-large-images-proportion (- (nth 3 edges) (nth 1 edges))))))) image)) - " ") + "x") (insert "\n") (mm-handle-set-undisplayer handle diff --git a/lisp/gnus/nndiary.el b/lisp/gnus/nndiary.el index be2bdc9bb15..8728aab1def 100644 --- a/lisp/gnus/nndiary.el +++ b/lisp/gnus/nndiary.el @@ -1373,10 +1373,10 @@ all. This may very well take some time.") (setq day (+ 7 day)))) ;; Finally, if we have some days, they are valid (when days - (sort days #'>) (throw 'found (encode-time 0 minute hour - (car days) month year time-zone))) + (apply #'max days) + month year time-zone))) ))))) ;; There's an upper limit, but we didn't find any last occurrence. ;; This means that the schedule is undecidable. This can happen if diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index de942993586..81449cb58b2 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -1908,19 +1908,7 @@ If LIMIT, first try to limit the search to the N last articles." (autoload 'nnselect-search-thread "nnselect") -(deffoo nnimap-request-thread (header &optional group server) - (if gnus-refer-thread-use-search - (nnselect-search-thread header) - (when (nnimap-change-group group server) - (let* ((cmd (nnimap-make-thread-query header)) - (result (with-current-buffer (nnimap-buffer) - (nnimap-command "UID SEARCH %s" cmd)))) - (when result - (gnus-fetch-headers - (and (car result) - (delete 0 (mapcar #'string-to-number - (cdr (assoc "SEARCH" (cdr result)))))) - nil t)))))) +(make-obsolete 'nnimap-request-thread 'gnus-search-thread "29.1") (defun nnimap-change-group (group &optional server no-reconnect read-only) "Change group to GROUP if non-nil. diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el index 87cb1275313..c4fbe3a5bd2 100644 --- a/lisp/gnus/nnselect.el +++ b/lisp/gnus/nnselect.el @@ -64,6 +64,7 @@ (defvar gnus-inhibit-demon) (defvar gnus-message-group-art) +(defvar gnus-search-use-parsed-queries) ;; For future use (defvoo nnselect-directory gnus-directory @@ -85,14 +86,14 @@ (let (selection) (pcase-dolist (`(,artgroup . ,arts) (nnselect-categorize artlist #'nnselect-artitem-group)) - (let (list) + (let (list) (pcase-dolist (`(,rsv . ,articles) - (nnselect-categorize + (nnselect-categorize arts #'nnselect-artitem-rsv #'nnselect-artitem-number)) (push (cons rsv (gnus-compress-sequence (sort articles #'<))) list)) - (push (cons artgroup list) selection))) - selection))) + (push (cons artgroup (sort list 'car-less-than-car)) selection))) + (sort selection (lambda (x y) (string< (car x) (car y))))))) (defun nnselect-uncompress-artlist (artlist) "Uncompress ARTLIST." @@ -100,17 +101,20 @@ artlist (let (selection) (pcase-dolist (`(,artgroup . ,list) artlist) - (pcase-dolist (`(,artrsv . ,artseq) list) - (setq selection - (vconcat - (cl-map 'vector - (lambda (art) - (vector artgroup art artrsv)) - (gnus-uncompress-sequence artseq)) selection)))) - selection))) + (pcase-dolist (`(,artrsv . ,artseq) list) + (setq selection + (vconcat selection + (cl-map 'vector + (lambda (art) + (vector artgroup art artrsv)) + (gnus-uncompress-sequence artseq)))))) + (sort selection + (lambda (x y) + (< (nnselect-artitem-rsv x) (nnselect-artitem-rsv y))))))) (make-obsolete 'nnselect-group-server 'gnus-group-server "28.1") (make-obsolete 'nnselect-run 'nnselect-generate-artlist "29.1") +(make-obsolete 'nnselect-search-thread 'gnus-search-thread "29.1") ;; Data type article list. @@ -267,45 +271,23 @@ If this variable is nil, or if the provided function returns nil, :version "28.1" :type '(repeat function)) -(defun nnselect-generate-artlist (group &optional specs) - "Generate the artlist for GROUP using SPECS. -SPECS should be an alist including an `nnselect-function' and an -`nnselect-args'. The former applied to the latter should create -the artlist. If SPECS is nil retrieve the specs from the group -parameters." - (let* ((specs - (or specs (gnus-group-get-parameter group 'nnselect-specs t))) - (function (alist-get 'nnselect-function specs)) - (args (alist-get 'nnselect-args specs))) - (condition-case-unless-debug err - (funcall function args) - ;; Don't swallow gnus-search errors; the user should be made - ;; aware of them. - (gnus-search-error - (signal (car err) (cdr err))) - (error - (gnus-error - 3 - "nnselect-generate-artlist: %s on %s gave error %s" function args err) - [])))) - (defmacro nnselect-get-artlist (group) - "Get the list of articles for GROUP. -If the group parameter `nnselect-get-artlist-override-function' is -non-nil call this function with argument GROUP to get the + "Get the stored list of articles for GROUP. +If the group parameter `nnselect-get-artlist-override-function' +is non-nil call this function with argument GROUP to get the artlist; if the group parameter `nnselect-always-regenerate' is -non-nil, regenerate the artlist; otherwise retrieve the artlist -directly from the group parameters." +non-nil, return nil to regenerate the artlist; otherwise retrieve +the stored artlist from the group parameters." `(when (gnus-nnselect-group-p ,group) (let ((override (gnus-group-get-parameter - ,group - 'nnselect-get-artlist-override-function))) + ,group + 'nnselect-get-artlist-override-function))) (cond (override (funcall override ,group)) ((gnus-group-get-parameter ,group 'nnselect-always-regenerate) - (nnselect-generate-artlist ,group)) + nil) (t - (nnselect-uncompress-artlist + (nnselect-uncompress-artlist (gnus-group-get-parameter ,group 'nnselect-artlist t))))))) (defmacro nnselect-store-artlist (group artlist) @@ -313,17 +295,65 @@ directly from the group parameters." If the group parameter `nnselect-store-artlist-override-function' is non-nil call this function on GROUP and ARTLIST; if the group parameter `nnselect-always-regenerate' is non-nil don't store the -artlist; otherwise store the ARTLIST in the group parameters." +artlist; otherwise store the ARTLIST in the group parameters. +The active range is also stored." `(let ((override (gnus-group-get-parameter - ,group - 'nnselect-store-artlist-override-function))) + ,group + 'nnselect-store-artlist-override-function))) + (gnus-group-set-parameter ,group 'active + (cons 1 (nnselect-artlist-length ,artlist))) (cond (override (funcall override ,group ,artlist)) - ((gnus-group-get-parameter ,group 'nnselect-always-regenerate) t) + ((gnus-group-get-parameter ,group 'nnselect-always-regenerate) + (gnus-group-remove-parameter ,group 'nnselect-artlist)) (t (gnus-group-set-parameter ,group 'nnselect-artlist (nnselect-compress-artlist ,artlist)))))) +(defun nnselect-generate-artlist (group &optional specs info) + "Generate and return the artlist for GROUP using SPECS. +The artlist is sorted by rsv, lexically over groups, and by +article number. SPECS should be an alist including an +`nnselect-function' and an `nnselect-args'. The former applied +to the latter should create the artlist. If SPECS is nil +retrieve the specs from the group parameters. If INFO update the +group info." + (let* ((specs + (or specs (gnus-group-get-parameter group 'nnselect-specs t))) + (function (alist-get 'nnselect-function specs)) + (args (alist-get 'nnselect-args specs))) + (condition-case-unless-debug err + (progn + (let ((gnus-newsgroup-selection + (sort + (funcall function args) + (lambda (x y) + (let ((xgroup (nnselect-artitem-group x)) + (ygroup (nnselect-artitem-group y)) + (xrsv (nnselect-artitem-rsv x)) + (yrsv (nnselect-artitem-rsv y))) + (or (< xrsv yrsv) + (and (eql xrsv yrsv) + (or (string< xgroup ygroup) + (and (string= xgroup ygroup) + (< (nnselect-artitem-number x) + (nnselect-artitem-number y))))))))))) + (when info + (if gnus-newsgroup-selection + (nnselect-request-update-info group info) + (gnus-set-active group '(1 . 0)))) + (nnselect-store-artlist group gnus-newsgroup-selection) + gnus-newsgroup-selection)) + ;; Don't swallow gnus-search errors; the user should be made + ;; aware of them. + (gnus-search-error + (signal (car err) (cdr err))) + (error + (gnus-error + 3 + "nnselect-generate-artlist: %s on %s gave error %s" function args err) + [])))) + ;; Gnus backend interface functions. (deffoo nnselect-open-server (server &optional definitions) @@ -344,85 +374,82 @@ artlist; otherwise store the ARTLIST in the group parameters." (deffoo nnselect-request-group (group &optional _server _dont-check info) (let* ((group (nnselect-add-prefix group)) - (nnselect-artlist (nnselect-get-artlist group)) - length) - ;; Check for cached select result or run the selection and cache - ;; the result. - (unless nnselect-artlist - (nnselect-store-artlist group - (setq nnselect-artlist (nnselect-generate-artlist group))) - (nnselect-request-update-info - group (or info (gnus-get-info group)))) - (if (zerop (setq length (nnselect-artlist-length nnselect-artlist))) - (progn - (nnheader-report 'nnselect "Selection produced empty results.") - (when (gnus-ephemeral-group-p group) - (gnus-kill-ephemeral-group group) - (setq gnus-ephemeral-servers - (assq-delete-all 'nnselect gnus-ephemeral-servers))) - (nnheader-insert "")) + (length (cdr (gnus-group-get-parameter group 'active t)))) + (when (or (null length) + (gnus-group-get-parameter group 'nnselect-always-regenerate)) + (setq length (nnselect-artlist-length + (nnselect-generate-artlist group nil info)))) + (if (and (zerop length) (gnus-ephemeral-group-p group)) + (progn + (nnheader-report 'nnselect "Selection produced empty results.") + (gnus-kill-ephemeral-group group) + (setq gnus-ephemeral-servers + (assq-delete-all 'nnselect gnus-ephemeral-servers)) + (nnheader-insert "")) (with-current-buffer nntp-server-buffer - (nnheader-insert "211 %d %d %d %s\n" - length ; total # - 1 ; first # - length ; last # - group))) ; group name - nnselect-artlist)) - + (nnheader-insert "211 %d %d %d %s\n" + length ; total # + (if (zerop length) 0 1) ; first # + length ; last # + group))))) ; group name (deffoo nnselect-retrieve-headers (articles group &optional _server fetch-old) - (let ((group (nnselect-add-prefix group))) + (let ((group (nnselect-add-prefix group)) + (gnus-inhibit-demon t)) (with-current-buffer (gnus-summary-buffer-name group) - (setq gnus-newsgroup-selection (or gnus-newsgroup-selection - (nnselect-get-artlist group))) - (let ((gnus-inhibit-demon t) - (gartids (ids-by-group articles)) - headers) - (with-current-buffer nntp-server-buffer - (pcase-dolist (`(,artgroup . ,artids) gartids) - (let ((artlist (sort (mapcar #'cdr artids) #'<)) - (gnus-override-method (gnus-find-method-for-group artgroup)) - (fetch-old - (or - (car-safe - (gnus-group-find-parameter artgroup - 'gnus-fetch-old-headers t)) - fetch-old))) + (setq gnus-newsgroup-selection + (or gnus-newsgroup-selection + (nnselect-get-artlist group) + ;; maybe don't need to update the info? + ;; (nnselect-generate-artlist group nil (gnus-get-info group)))) + (nnselect-generate-artlist group))) + (let ((gartids (ids-by-group articles)) + headers) + (with-current-buffer nntp-server-buffer + (pcase-dolist (`(,artgroup . ,artids) gartids) + (let ((artlist (sort (mapcar #'cdr artids) #'<)) + (gnus-override-method (gnus-find-method-for-group artgroup)) + (fetch-old + (or + (car-safe + (gnus-group-find-parameter artgroup + 'gnus-fetch-old-headers t)) + fetch-old))) (gnus-request-group artgroup) - (erase-buffer) - (pcase (setq gnus-headers-retrieved-by - (or - (and - nnselect-retrieve-headers-override-function - (funcall - nnselect-retrieve-headers-override-function - artlist artgroup)) - (gnus-retrieve-headers - artlist artgroup fetch-old))) - ('nov - (goto-char (point-min)) - (while (not (eobp)) - (nnselect-add-novitem - (nnheader-parse-nov)) - (forward-line 1))) - ('headers - (gnus-run-hooks 'gnus-parse-headers-hook) - (let ((nnmail-extra-headers gnus-extra-headers)) - (goto-char (point-min)) - (while (not (eobp)) - (nnselect-add-novitem - (nnheader-parse-head)) - (forward-line 1)))) - ((pred listp) - (dolist (novitem gnus-headers-retrieved-by) - (nnselect-add-novitem novitem))) - (_ (error "Unknown header type %s while requesting articles \ - of group %s" gnus-headers-retrieved-by artgroup))))) - (setq headers - (sort - headers - (lambda (x y) - (< (mail-header-number x) (mail-header-number y)))))))))) + (erase-buffer) + (pcase (setq gnus-headers-retrieved-by + (or + (and + nnselect-retrieve-headers-override-function + (funcall + nnselect-retrieve-headers-override-function + artlist artgroup)) + (gnus-retrieve-headers + artlist artgroup fetch-old))) + ('nov + (goto-char (point-min)) + (while (not (eobp)) + (nnselect-add-novitem + (nnheader-parse-nov)) + (forward-line 1))) + ('headers + (gnus-run-hooks 'gnus-parse-headers-hook) + (let ((nnmail-extra-headers gnus-extra-headers)) + (goto-char (point-min)) + (while (not (eobp)) + (nnselect-add-novitem + (nnheader-parse-head)) + (forward-line 1)))) + ((pred listp) + (dolist (novitem gnus-headers-retrieved-by) + (nnselect-add-novitem novitem))) + (_ (error "Unknown header type %s while requesting articles \ + of group %s" gnus-headers-retrieved-by artgroup))))) + (setq headers + (sort + headers + (lambda (x y) + (< (mail-header-number x) (mail-header-number y)))))))))) (deffoo nnselect-request-article (article &optional _group server to-buffer) @@ -439,7 +466,7 @@ artlist; otherwise store the ARTLIST in the group parameters." (if (eq 'nnselect (car (gnus-server-to-method server))) (with-current-buffer gnus-summary-buffer (let ((thread (gnus-id-to-thread article))) - (when thread + (when (car thread) (mapc (lambda (x) (when (and x (> x 0)) @@ -477,7 +504,8 @@ artlist; otherwise store the ARTLIST in the group parameters." (deffoo nnselect-request-move-article (article _group _server accept-form &optional last _internal-move-group) - (let* ((artgroup (nnselect-article-group article)) + (let* ((nnimap-expunge 'immediately) + (artgroup (nnselect-article-group article)) (artnumber (nnselect-article-number article)) (to-newsgroup (nth 1 accept-form)) (to-method (gnus-find-method-for-group to-newsgroup)) @@ -565,9 +593,9 @@ artlist; otherwise store the ARTLIST in the group parameters." (artnumber (nnselect-article-number article)) (gmark (gnus-request-update-mark artgroup artnumber mark))) (when (and artnumber - (memq mark gnus-auto-expirable-marks) - (= mark gmark) - (gnus-group-auto-expirable-p artgroup)) + (memq mark gnus-auto-expirable-marks) + (= mark gmark) + (gnus-group-auto-expirable-p artgroup)) (setq gmark gnus-expirable-mark)) gmark)) @@ -593,116 +621,109 @@ artlist; otherwise store the ARTLIST in the group parameters." (gnus-newsgroup-selection (or gnus-newsgroup-selection (nnselect-get-artlist group))) newmarks) - (gnus-info-set-marks info nil) - (setf (gnus-info-read info) nil) - (pcase-dolist (`(,artgroup . ,nartids) - (ids-by-group - (number-sequence 1 (nnselect-artlist-length - gnus-newsgroup-selection)))) - (let* ((gnus-newsgroup-active nil) - (idmap (make-hash-table :test 'eql)) - (gactive (sort (mapcar 'cdr nartids) '<)) - (group-info (gnus-get-info artgroup)) - (marks (gnus-info-marks group-info))) - (pcase-dolist (`(,val . ,key) nartids) - (puthash key val idmap)) - (setf (gnus-info-read info) - (range-add-list - (gnus-info-read info) - (sort (mapcar (lambda (art) (gethash art idmap)) - (gnus-sorted-intersection - gactive - (range-uncompress (gnus-info-read group-info)))) - '<))) - (pcase-dolist (`(,type . ,mark-list) marks) - (let ((mark-type (gnus-article-mark-to-type type)) new) - (when - (setq new - (if (not mark-list) nil - (cond - ((eq mark-type 'tuple) - (delq nil - (mapcar - (lambda (mark) - (let ((id (gethash (car mark) idmap))) - (when id (cons id (cdr mark))))) - mark-list))) - (t - (mapcar (lambda (art) (gethash art idmap)) - (gnus-sorted-intersection - gactive (range-uncompress mark-list))))))) - (let ((previous (alist-get type newmarks))) - (if previous - (nconc previous new) - (push (cons type new) newmarks)))))))) - - ;; Clean up the marks: compress lists; - (pcase-dolist (`(,type . ,mark-list) newmarks) - (let ((mark-type (gnus-article-mark-to-type type))) - (unless (eq mark-type 'tuple) - (setf (alist-get type newmarks) - (gnus-compress-sequence (sort mark-list '<)))))) - ;; and ensure an unexist key. - (unless (assq 'unexist newmarks) - (push (cons 'unexist nil) newmarks)) - - (gnus-info-set-marks info newmarks) - (gnus-set-active group (cons 1 (nnselect-artlist-length - gnus-newsgroup-selection))))) + (when gnus-newsgroup-selection + (gnus-info-set-marks info nil) + (setf (gnus-info-read info) nil) + (pcase-dolist (`(,artgroup . ,nartids) + (ids-by-group + (number-sequence 1 (nnselect-artlist-length + gnus-newsgroup-selection)))) + (let* ((gnus-newsgroup-active nil) + (idmap (make-hash-table :test 'eql)) + (gactive (sort (mapcar 'cdr nartids) #'<)) + (group-info (gnus-get-info artgroup)) + (marks (gnus-info-marks group-info))) + (pcase-dolist (`(,val . ,key) nartids) + (puthash key val idmap)) + (setf (gnus-info-read info) + (range-add-list + (gnus-info-read info) + (sort (mapcar (lambda (art) (gethash art idmap)) + (gnus-sorted-intersection + gactive + (range-uncompress (gnus-info-read group-info)))) + #'<))) + (pcase-dolist (`(,type . ,mark-list) marks) + (let ((mark-type (gnus-article-mark-to-type type)) new) + (when + (setq new + (if (not mark-list) nil + (cond + ((eq mark-type 'tuple) + (delq nil + (mapcar + (lambda (mark) + (let ((id (gethash (car mark) idmap))) + (when id (cons id (cdr mark))))) + mark-list))) + (t + (mapcar (lambda (art) (gethash art idmap)) + (gnus-sorted-intersection + gactive (range-uncompress mark-list))))))) + (let ((previous (alist-get type newmarks))) + (if previous + (nconc previous new) + (push (cons type new) newmarks)))))))) + + ;; Clean up the marks: compress lists; + (pcase-dolist (`(,type . ,mark-list) newmarks) + (let ((mark-type (gnus-article-mark-to-type type))) + (unless (eq mark-type 'tuple) + (setf (alist-get type newmarks) + (gnus-compress-sequence (sort mark-list #'<)))))) + ;; and ensure an unexist key. + (unless (assq 'unexist newmarks) + (push (cons 'unexist nil) newmarks)) + + (gnus-info-set-marks info newmarks) + (gnus-set-active group (cons 1 (nnselect-artlist-length + gnus-newsgroup-selection)))))) (deffoo nnselect-request-thread (header &optional group server) (with-current-buffer gnus-summary-buffer - (let ((group (nnselect-add-prefix group)) - ;; find the best group for the originating article. if its a - ;; pseudo-article look for real articles in the same thread - ;; and see where they come from. - (artgroup (nnselect-article-group - (if (> (mail-header-number header) 0) - (mail-header-number header) - (if (> (gnus-summary-article-number) 0) - (gnus-summary-article-number) - (let ((thread - (gnus-id-to-thread (mail-header-id header)))) - (when thread - (cl-some (lambda (x) - (when (and x (> x 0)) x)) - (gnus-articles-in-thread thread))))))))) - ;; Check if search-based thread referral is permitted, and - ;; available. - (if (and gnus-refer-thread-use-search - (gnus-search-server-to-engine - (gnus-method-to-server - (gnus-find-method-for-group artgroup)))) - ;; If so we perform the query, massage the result, and return - ;; the new headers back to the caller to incorporate into the - ;; current summary buffer. - (let* ((group-spec - (list (delq nil (list - (or server (gnus-group-server artgroup)) - (unless gnus-refer-thread-use-search - artgroup))))) - (ids (cons (mail-header-id header) - (split-string - (or (mail-header-references header) - "")))) - (query-spec - (list (cons 'query (mapconcat (lambda (i) - (format "id:%s" i)) - ids " or ")) - (cons 'thread t))) - (last (nnselect-artlist-length gnus-newsgroup-selection)) - (first (1+ last)) - (new-nnselect-artlist - (gnus-search-run-query - (list (cons 'search-query-spec query-spec) - (cons 'search-group-spec group-spec)))) - old-arts seq - headers) - (mapc + (let* ((group (nnselect-add-prefix group)) + ;; Find the best group for the originating article. If its + ;; a pseudo-article check for real articles in the same + ;; thread to see where they come from. + (artgroup + (nnselect-article-group + (cond + ((> (mail-header-number header) 0) + (mail-header-number header)) + ((> (gnus-summary-article-number) 0) + (gnus-summary-article-number)) + (t (cl-some + (lambda (x) (when (and x (> x 0)) x)) + (gnus-articles-in-thread + (gnus-id-to-thread (mail-header-id header)))))))) + (server (or server (gnus-group-server artgroup)))) + ;; Check if search-based thread referral is available. + (if (ignore-errors (gnus-search-server-to-engine server)) + ;; We perform the query, massage the result, and return + ;; the new headers back to the caller to incorporate into + ;; the current summary buffer. + (let* ((gnus-search-use-parsed-queries t) + (group-spec + (if (not gnus-refer-thread-use-search) + (list (list server artgroup)) + (if (listp gnus-refer-thread-use-search) + gnus-refer-thread-use-search + (list (list server))))) + (ids (cons (mail-header-id header) + (split-string + (or (mail-header-references header) + "")))) + (query-spec + (list (cons 'query + (mapconcat (lambda (i) (format "id:%s" i)) + ids " or ")) (cons 'thread t))) + (last (nnselect-artlist-length gnus-newsgroup-selection)) + (first (1+ last)) + old-arts seq headers) + (mapc (lambda (article) - (if - (setq seq + (if (setq seq (cl-position article gnus-newsgroup-selection @@ -710,54 +731,68 @@ artlist; otherwise store the ARTLIST in the group parameters." (lambda (x y) (and (equal (nnselect-artitem-group x) (nnselect-artitem-group y)) - (eql (nnselect-artitem-number x) + (eql (nnselect-artitem-number x) (nnselect-artitem-number y)))))) (push (1+ seq) old-arts) (setq gnus-newsgroup-selection (vconcat gnus-newsgroup-selection (vector article))) (cl-incf last))) - new-nnselect-artlist) - (setq headers - (gnus-fetch-headers - (append (sort old-arts #'<) - (number-sequence first last)) - nil t)) - (nnselect-store-artlist group gnus-newsgroup-selection) - (when (>= last first) - (let (new-marks) - (pcase-dolist (`(,artgroup . ,artids) - (ids-by-group (number-sequence first last))) - (pcase-dolist (`(,type . ,marked) - (gnus-info-marks (gnus-get-info artgroup))) - (setq marked (gnus-uncompress-sequence marked)) - (when (setq new-marks - (delq nil - (mapcar + (gnus-search-run-query + (list (cons 'search-query-spec query-spec) + (cons 'search-group-spec group-spec)))) + (setq headers + (gnus-fetch-headers + (append (sort old-arts #'<) (number-sequence first last)) + nil t)) + (nnselect-store-artlist group gnus-newsgroup-selection) + (when (>= last first) + (let (new-marks) + (pcase-dolist (`(,artgroup . ,artids) + (ids-by-group (number-sequence first last))) + (pcase-dolist (`(,type . ,marked) + (gnus-info-marks (gnus-get-info artgroup))) + (when + (setq new-marks + (delq nil + (if (eq (gnus-article-mark-to-type type) + 'tuple) + (mapcar + (lambda (art) + (let ((mtup + (assq (cdr art) marked))) + (when mtup + (cons (car art) (cdr mtup))))) + artids) + (setq marked + (gnus-uncompress-sequence marked)) + (mapcar (lambda (art) (when (memq (cdr art) marked) (car art))) - artids))) - (nconc - (symbol-value - (intern - (format "gnus-newsgroup-%s" - (car (rassq type gnus-article-mark-lists))))) - new-marks))))) - (setq gnus-newsgroup-active - (cons 1 (nnselect-artlist-length gnus-newsgroup-selection))) - (gnus-set-active - group - (cons 1 (nnselect-artlist-length gnus-newsgroup-selection)))) - headers) - ;; If we can't or won't use search, just warp to the original - ;; group and punt back to gnus-summary-refer-thread. - (and (gnus-warp-to-article) (gnus-summary-refer-thread)))))) + artids)))) + (nconc + (symbol-value + (intern + (format "gnus-newsgroup-%s" + (car + (rassq type gnus-article-mark-lists))))) + new-marks))))) + (gnus-set-active + group + (setq + gnus-newsgroup-active + (cons 1 (nnselect-artlist-length gnus-newsgroup-selection))))) + headers) + ;; If we can't use search, just warp to the original group and + ;; punt back to gnus-summary-refer-thread. + (and (gnus-warp-to-article) (gnus-summary-refer-thread)))))) (deffoo nnselect-close-group (group &optional _server) (let ((group (nnselect-add-prefix group))) (unless gnus-group-is-exiting-without-update-p - (nnselect-push-info group)) + (when gnus-newsgroup-selection + (nnselect-push-info group))) (setq gnus-newsgroup-selection nil) (when (gnus-ephemeral-group-p group) (gnus-kill-ephemeral-group group) @@ -769,23 +804,23 @@ artlist; otherwise store the ARTLIST in the group parameters." (message "Creating nnselect group %s" group) (let* ((group (gnus-group-prefixed-name group '(nnselect "nnselect"))) (specs (assq 'nnselect-specs args)) + (artlist (alist-get 'nnselect-artlist args)) (otherargs (assq-delete-all 'nnselect-specs args)) (function-spec (or (alist-get 'nnselect-function specs) - (intern (completing-read "Function: " obarray #'functionp)))) + (intern (completing-read "Function: " obarray #'functionp)))) (args-spec (or (alist-get 'nnselect-args specs) (read-from-minibuffer "Args: " nil nil t nil "nil"))) (nnselect-specs (list (cons 'nnselect-function function-spec) - (cons 'nnselect-args args-spec)))) + (cons 'nnselect-args args-spec)))) (gnus-group-set-parameter group 'nnselect-specs nnselect-specs) (dolist (arg otherargs) (gnus-group-set-parameter group (car arg) (cdr arg))) - (nnselect-store-artlist - group - (or (alist-get 'nnselect-artlist args) - (nnselect-generate-artlist group nnselect-specs))) - (nnselect-request-update-info group (gnus-get-info group))) + (if artlist + (nnselect-store-artlist group artlist) + (nnselect-generate-artlist group nnselect-specs + (gnus-get-info group)))) t) @@ -815,11 +850,12 @@ artlist; otherwise store the ARTLIST in the group parameters." (deffoo nnselect-request-group-scan (group &optional _server _info) - (let* ((group (nnselect-add-prefix group)) - (artlist (nnselect-generate-artlist group))) - (gnus-set-active group (cons 1 (nnselect-artlist-length - artlist))) - (nnselect-store-artlist group artlist))) + (let ((group (nnselect-add-prefix group))) + (unless (gnus-group-find-parameter group 'nnselect-always-regenerate) + (let ((artlist (nnselect-generate-artlist group))) + (gnus-set-active group (cons 1 (nnselect-artlist-length + artlist)))))) + t) ;; Add any undefined required backend functions @@ -883,133 +919,136 @@ article came from is also searched." (defun nnselect-push-info (group) "Copy mark-lists from GROUP to the originating groups." (let ((select-unreads (numbers-by-group gnus-newsgroup-unreads)) - (select-reads (numbers-by-group - (gnus-info-read (gnus-get-info group)) 'range)) - (select-unseen (numbers-by-group gnus-newsgroup-unseen)) - (gnus-newsgroup-active nil) mark-list) + (select-reads (numbers-by-group + (gnus-sorted-difference gnus-newsgroup-articles + gnus-newsgroup-unreads))) + (select-unseen (numbers-by-group gnus-newsgroup-unseen)) + (quit-config (gnus-group-quit-config group)) + (gnus-newsgroup-active nil) mark-list) ;; collect the set of marked article lists categorized by ;; originating groups (pcase-dolist (`(,mark . ,type) gnus-article-mark-lists) - (let (type-list) - (when (setq type-list - (symbol-value (intern (format "gnus-newsgroup-%s" mark)))) - (push (cons - type - (numbers-by-group type-list (gnus-article-mark-to-type type))) - mark-list)))) + (let ((mark-type (gnus-article-mark-to-type type)) + (type-list (symbol-value + (intern (format "gnus-newsgroup-%s" mark))))) + (when type-list + (unless (eq 'tuple mark-type) + (setq type-list (range-list-intersection + gnus-newsgroup-articles type-list))) + (push (cons type (numbers-by-group type-list mark-type)) + mark-list)))) ;; now work on each originating group one at a time (pcase-dolist (`(,artgroup . ,artlist) - (numbers-by-group gnus-newsgroup-articles)) - (let* ((group-info (gnus-get-info artgroup)) - (old-unread (gnus-list-of-unread-articles artgroup)) - newmarked delta-marks) - (when group-info - ;; iterate over mark lists for this group - (pcase-dolist (`(,_mark . ,type) gnus-article-mark-lists) - (let ((list (cdr (assoc artgroup (alist-get type mark-list)))) - (mark-type (gnus-article-mark-to-type type))) - - ;; When the backend can store marks we collect any - ;; changes. Unlike a normal group the mark lists only - ;; include marks for articles we retrieved. - (when (and (gnus-check-backend-function - 'request-set-mark gnus-newsgroup-name) - (not (gnus-article-unpropagatable-p type))) - (let* ((old (range-list-intersection - artlist - (alist-get type (gnus-info-marks group-info)))) - (del (range-remove (copy-tree old) list)) - (add (range-remove (copy-tree list) old))) - (when add (push (list add 'add (list type)) delta-marks)) - (when del - ;; Don't delete marks from outside the active range. - ;; This shouldn't happen, but is a sanity check. - (setq del (range-intersection - (gnus-active artgroup) del)) - (push (list del 'del (list type)) delta-marks)))) - - ;; Marked sets are of mark-type 'tuple, 'list, or - ;; 'range. We merge the lists with what is already in - ;; the original info to get full list of new marks. We - ;; do this by removing all the articles we retrieved - ;; from the full list, and then add back in the newly - ;; marked ones. - (cond - ((eq mark-type 'tuple) - ;; Get rid of the entries that have the default - ;; score. - (when (and list (eq type 'score) gnus-save-score) - (let* ((arts list) - (prev (cons nil list)) - (all prev)) - (while arts - (if (or (not (consp (car arts))) - (= (cdar arts) gnus-summary-default-score)) - (setcdr prev (cdr arts)) - (setq prev arts)) - (setq arts (cdr arts))) - (setq list (cdr all)))) - ;; now merge with the original list and sort just to - ;; make sure - (setq - list (sort + (numbers-by-group gnus-newsgroup-articles)) + (setq artlist (sort artlist #'<)) + (let ((group-info (gnus-get-info artgroup)) + (old-unread (gnus-list-of-unread-articles artgroup)) + (rsm (gnus-check-backend-function 'request-set-mark artgroup)) + newmarked delta-marks) + (when group-info + ;; iterate over mark lists for this group + (pcase-dolist (`(,_mark . ,type) gnus-article-mark-lists) + (let ((list (cdr (assoc artgroup (alist-get type mark-list)))) + (mark-type (gnus-article-mark-to-type type)) + (group-marks (alist-get type (gnus-info-marks group-info)))) + + ;; When the backend can store marks we collect any + ;; changes. Unlike a normal group the mark lists only + ;; include marks for articles we retrieved. If there is + ;; no quit-config then gnus-update-marks has already + ;; been called to handle this. + (when (and quit-config rsm + (not (gnus-article-unpropagatable-p type))) + (let* ((old (range-list-intersection + artlist group-marks)) + (del (range-remove (copy-tree old) list)) + (add (range-remove (copy-tree list) old))) + (when add (push (list add 'add (list type)) delta-marks)) + (when del + ;; Don't delete marks from outside the active range. + ;; This shouldn't happen, but is a sanity check. + (setq del (range-intersection (gnus-active artgroup) del)) + (push (list del 'del (list type)) delta-marks)))) + + ;; Marked sets are of mark-type 'tuple, 'list, or + ;; 'range. We merge the lists with what is already in + ;; the original info to get full list of new marks. We + ;; do this by removing all the articles we retrieved + ;; from the full list, and then add back in the newly + ;; marked ones. + (cond + ((eq mark-type 'tuple) + ;; Get rid of the entries that have the default + ;; score. + (when (and list (eq type 'score) gnus-save-score) + (let* ((arts list) + (prev (cons nil list)) + (all prev)) + (while arts + (if (or (not (consp (car arts))) + (= (cdar arts) gnus-summary-default-score)) + (setcdr prev (cdr arts)) + (setq prev arts)) + (setq arts (cdr arts))) + (setq list (cdr all)))) + ;; now merge with the original list and sort just to + ;; make sure + (setq list + (sort (map-merge - 'alist list + 'alist list (delq nil (mapcar (lambda (x) (unless (memq (car x) artlist) x)) - (alist-get type (gnus-info-marks group-info))))) + group-marks))) 'car-less-than-car))) - (t - (setq list - (range-compress-list - (gnus-sorted-union - (gnus-sorted-difference - (gnus-uncompress-sequence - (alist-get type (gnus-info-marks group-info))) - artlist) - (sort list #'<))))) - - ;; When exiting the group, everything that's previously been - ;; unseen is now seen. - (when (eq type 'seen) - (setq list (range-concat - list (cdr (assoc artgroup select-unseen)))))) - - (when (or list (eq type 'unexist)) - (push (cons type list) newmarked)))) ;; end of mark-type loop - - (when delta-marks - (unless (gnus-check-group artgroup) - (error "Can't open server for %s" artgroup)) - (gnus-request-set-mark artgroup delta-marks)) - - (gnus-atomic-progn - (gnus-info-set-marks group-info newmarked) - ;; Cut off the end of the info if there's nothing else there. - (let ((i 5)) - (while (and (> i 2) - (not (nth i group-info))) - (when (nthcdr (cl-decf i) group-info) - (setcdr (nthcdr i group-info) nil)))) - - ;; update read and unread - (gnus-update-read-articles - artgroup - (range-uncompress - (range-add-list - (range-remove - old-unread - (cdr (assoc artgroup select-reads))) - (sort (cdr (assoc artgroup select-unreads)) #'<)))) - (gnus-get-unread-articles-in-group - group-info (gnus-active artgroup) t)) - (gnus-group-update-group - artgroup t - (equal group-info - (setq group-info (copy-sequence (gnus-get-info artgroup)) - group-info - (delq (gnus-info-params group-info) group-info))))))))) + (t + (setq list + (range-compress-list + (gnus-sorted-union + (gnus-sorted-difference + (gnus-uncompress-sequence group-marks) + artlist) + (sort list #'<)))) + + ;; When exiting the group, everything that's previously been + ;; unseen is now seen. + (when (eq type 'seen) + (setq list (range-concat + list (cdr (assoc artgroup select-unseen))))))) + + (when (or list (eq type 'unexist)) + (push (cons type list) newmarked)))) ;; end of mark-type loop + (when delta-marks + (unless (gnus-check-group artgroup) + (error "Can't open server for %s" artgroup)) + (gnus-request-set-mark artgroup delta-marks)) + (gnus-atomic-progn + (gnus-info-set-marks group-info newmarked) + ;; Cut off the end of the info if there's nothing else there. + (let ((i 5)) + (while (and (> i 2) + (not (nth i group-info))) + (when (nthcdr (cl-decf i) group-info) + (setcdr (nthcdr i group-info) nil)))) + + ;; update read and unread + (gnus-update-read-articles + artgroup + (range-uncompress + (range-add-list + (range-remove + old-unread + (cdr (assoc artgroup select-reads))) + (sort (cdr (assoc artgroup select-unreads)) #'<))))) + (gnus-get-unread-articles-in-group + group-info (gnus-active artgroup) t) + (gnus-group-update-group + artgroup t + (equal group-info + (setq group-info (copy-sequence (gnus-get-info artgroup)) + group-info + (delq (gnus-info-params group-info) group-info))))))))) (declare-function gnus-registry-get-id-key "gnus-registry" (id key)) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 50e60b68e17..a939cc0b509 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -437,7 +437,7 @@ the C sources, too." (setq file-name (locate-file file-name load-path '(".el" ".elc") 'readable))) ((and (stringp file-name) - (string-match "[.]*loaddefs.el\\'" file-name)) + (string-match "[.]*loaddefs.elc?\\'" file-name)) ;; An autoloaded variable or face. Visit loaddefs.el in a buffer ;; and try to extract the defining file. The following form is ;; from `describe-function-1' and `describe-variable'. @@ -1138,7 +1138,7 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." ;; key substitution constructs, load the library. (and (autoloadp real-def) doc-raw help-enable-autoload - (string-match "\\([^\\]=\\|[^=]\\|\\`\\)\\\\[[{<]" doc-raw) + (string-match "\\([^\\]=\\|[^=]\\|\\`\\)\\\\[[{<]\\|`.*'" doc-raw) (autoload-do-load real-def)) (help-fns--key-bindings function) diff --git a/lisp/help.el b/lisp/help.el index 83be85b1ee4..6eac037df2c 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -689,6 +689,10 @@ To record all your input, use `open-dribble-file'." (with-current-buffer standard-output (goto-char (point-min)) (let ((comment-start ";; ") + ;; Prevent 'comment-indent' from handling a single + ;; semicolon as the beginning of a comment. + (comment-start-skip ";; ") + (comment-use-syntax nil) (comment-column 24)) (while (not (eobp)) (comment-indent) @@ -717,6 +721,12 @@ Return nil if KEYS is nil." :group 'help :version "29.1") +(defcustom describe-bindings-show-prefix-commands nil + "Non-nil means show prefix commands in the output of `describe-bindings'." + :type 'boolean + :group 'help + :version "29.1") + (declare-function outline-hide-subtree "outline") (defun describe-bindings (&optional prefix buffer) @@ -1699,6 +1709,7 @@ in `describe-map-tree'." (setq vect (cdr vect)) (setq end (caar vect)))) (when (or (not (eq start end)) + describe-bindings-show-prefix-commands ;; Don't output keymap prefixes. (not (keymapp definition))) (when first diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el index ed4c8a04db7..550b5ed0e6a 100644 --- a/lisp/ibuf-ext.el +++ b/lisp/ibuf-ext.el @@ -1650,68 +1650,67 @@ a prefix argument reverses the meaning of that variable." (error "No buffer with name %s" name) (goto-char buf-point))))) +(declare-function diff-check-labels "diff" (&optional force)) +(declare-function diff-file-local-copy "diff" (file-or-buf)) (declare-function diff-sentinel "diff" (code &optional old-temp-file new-temp-file)) (defun ibuffer-diff-buffer-with-file-1 (buffer) - (let ((bufferfile (buffer-local-value 'buffer-file-name buffer)) - (tempfile (make-temp-file "buffer-content-"))) - (when bufferfile - (unwind-protect - (progn - (with-current-buffer buffer - (write-region nil nil tempfile nil 'nomessage)) - (let* ((old (expand-file-name bufferfile)) - (new (expand-file-name tempfile)) - (oldtmp (file-local-copy old)) - (newtmp (file-local-copy new)) - (switches diff-switches) - (command - (mapconcat - 'identity - `(,diff-command - ;; Use explicitly specified switches - ,@(if (listp switches) switches (list switches)) - ,@(if (or old new) - (list "-L" (shell-quote-argument old) - "-L" (shell-quote-argument - (format "Buffer %s" (buffer-name buffer))))) - ,(shell-quote-argument (or oldtmp old)) - ,(shell-quote-argument (or newtmp new))) - " "))) - (let ((inhibit-read-only t)) - (insert command "\n") - (diff-sentinel - (call-process shell-file-name nil - (current-buffer) nil - shell-command-switch command)) - (insert "\n"))))) - (sit-for 0) - (when (file-exists-p tempfile) - (delete-file tempfile))))) + "Compare BUFFER with its associated file, if any. +Unlike `diff-no-select', insert output into current buffer +without erasing it." + (when-let ((old (buffer-file-name buffer))) + (defvar diff-use-labels) + (let* ((new buffer) + (oldtmp (diff-file-local-copy old)) + (newtmp (diff-file-local-copy new)) + (switches diff-switches) + (command + (string-join + `(,diff-command + ,@(if (listp switches) switches (list switches)) + ,@(and (eq diff-use-labels t) + (list "--label" (shell-quote-argument old) + "--label" (shell-quote-argument (format "%S" new)))) + ,(shell-quote-argument (or oldtmp old)) + ,(shell-quote-argument (or newtmp new))) + " ")) + (inhibit-read-only t)) + (insert ?\n command ?\n) + (diff-sentinel (call-process shell-file-name nil t nil + shell-command-switch command) + oldtmp newtmp) + (goto-char (point-max))) + (redisplay))) ;;;###autoload (defun ibuffer-diff-with-file () "View the differences between marked buffers and their associated files. If no buffers are marked, use buffer at point. -This requires the external program \"diff\" to be in your `exec-path'." +This requires the external program `diff-command' to be in your +`exec-path'." (interactive) (require 'diff) - (let ((marked-bufs (ibuffer-get-marked-buffers))) - (when (null marked-bufs) - (setq marked-bufs (list (ibuffer-current-buffer t)))) - (with-current-buffer (get-buffer-create "*Ibuffer Diff*") - (setq buffer-read-only nil) - (buffer-disable-undo (current-buffer)) - (erase-buffer) - (buffer-enable-undo (current-buffer)) + (let ((marked-bufs (or (ibuffer-get-marked-buffers) + (list (ibuffer-current-buffer t)))) + (diff-buf (get-buffer-create "*Ibuffer Diff*"))) + (with-current-buffer diff-buf + (setq buffer-read-only t) + (buffer-disable-undo) + (let ((inhibit-read-only t)) + (erase-buffer)) + (buffer-enable-undo) (diff-mode) + (diff-check-labels) (dolist (buf marked-bufs) (unless (buffer-live-p buf) (error "Buffer %s has been killed" buf)) - (ibuffer-diff-buffer-with-file-1 buf)) - (setq buffer-read-only t))) - (switch-to-buffer "*Ibuffer Diff*")) + (ibuffer-diff-buffer-with-file-1 buf)) + (goto-char (point-min)) + (when (= (following-char) ?\n) + (let ((inhibit-read-only t)) + (delete-char 1)))) + (pop-to-buffer-same-window diff-buf))) ;;;###autoload (defun ibuffer-copy-filename-as-kill (&optional arg) diff --git a/lisp/icomplete.el b/lisp/icomplete.el index 49c0c78fe73..6ed2cbe395c 100644 --- a/lisp/icomplete.el +++ b/lisp/icomplete.el @@ -69,11 +69,12 @@ When nil, show candidates in full." :type 'boolean :version "24.4") -(defvar icomplete-tidy-shadowed-file-names nil +(defcustom icomplete-tidy-shadowed-file-names nil "If non-nil, automatically delete superfluous parts of file names. For example, if the user types ~/ after a long path name, everything preceding the ~/ is discarded so the interactive -selection process starts again from the user's $HOME.") +selection process starts again from the user's $HOME." + :type 'boolean) (defcustom icomplete-show-matches-on-no-input nil "When non-nil, show completions when first prompting for input. diff --git a/lisp/image.el b/lisp/image.el index 2372fd1ce09..08190cf86bc 100644 --- a/lisp/image.el +++ b/lisp/image.el @@ -51,7 +51,7 @@ static \\(unsigned \\)?char \\1_bits" . xbm) ("\\`\\(?:MM\0\\*\\|II\\*\0\\)" . tiff) ("\\`[\t\n\r ]*%!PS" . postscript) ("\\`\xff\xd8" . jpeg) ; used to be (image-jpeg-p . jpeg) - ("\\`RIFF....WEBPVP8" . webp) + ("\\`RIFF[^z-a][^z-a][^z-a][^z-a]WEBPVP8" . webp) (,(let* ((incomment-re "\\(?:[^-]\\|-[^-]\\)") (comment-re (concat "\\(?:!--" incomment-re "*-->[ \t\r\n]*<\\)"))) (concat "\\(?:<\\?xml[ \t\r\n]+[^>]*>\\)?[ \t\r\n]*<" @@ -172,22 +172,27 @@ or \"ffmpeg\") is installed." (define-error 'unknown-image-type "Unknown image type") -(defvar-keymap image-map - :doc "Map put into text properties on images." +(defvar-keymap image-slice-map + :doc "Map put into text properties on sliced images." "i" (define-keymap "-" #'image-decrease-size "+" #'image-increase-size - "r" #'image-rotate "o" #'image-save "c" #'image-crop - "x" #'image-cut - "h" #'image-flip-horizontally - "v" #'image-flip-vertically) + "x" #'image-cut) "C-<wheel-down>" #'image-mouse-decrease-size "C-<mouse-5>" #'image-mouse-decrease-size "C-<wheel-up>" #'image-mouse-increase-size "C-<mouse-4>" #'image-mouse-increase-size) +(defvar-keymap image-map + :doc "Map put into text properties on images." + :parent image-slice-map + "i" (define-keymap + "r" #'image-rotate + "h" #'image-flip-horizontally + "v" #'image-flip-vertically)) + (defun image-load-path-for-library (library image &optional path no-error) "Return a suitable search path for images used by LIBRARY. @@ -595,8 +600,8 @@ If nil, use the `image-scaling-factor' variable." IMAGE must be an image created with `create-image' or `defimage'. IMAGE is displayed by putting an overlay into the current buffer with a `before-string' STRING that has a `display' property whose value is the -image. STRING is defaulted if you omit it. -The overlay created will have the `put-image' property set to t. +image. STRING defaults to \"x\" if it's nil or omitted. +The overlay created by this function has the `put-image' property set to t. POS may be an integer or marker. AREA is where to display the image. AREA nil or omitted means display it in the text area, a value of `left-margin' means @@ -665,7 +670,9 @@ is non-nil, this is inhibited." image) rear-nonsticky t inhibit-isearch ,inhibit-isearch - keymap ,image-map)))) + keymap ,(if slice + image-slice-map + image-map))))) ;;;###autoload @@ -701,8 +708,8 @@ The image is automatically split into ROWS x COLS slices." (insert string) (add-text-properties start (point) `(display ,(list (list 'slice x y dx dy) image) - rear-nonsticky (display) - keymap ,image-map)) + rear-nonsticky (display keymap) + keymap ,image-slice-map)) (setq x (+ x dx)))) (setq x 0.0 y (+ y dy)) @@ -1158,9 +1165,11 @@ has no effect." "r" #'image-rotate) (defun image-increase-size (&optional n position) - "Increase the image size by a factor of N. -If N is 3, then the image size will be increased by 30%. The -default is 20%." + "Increase the image size at POSITION by a factor specified by N. +If N is 3, then the image size will be increased by 30%. More +generally, the image size is multiplied by 1 plus N divided by 10. +N defaults to 2, which increases the image size by 20%. +POSITION can be a buffer position or a marker, and defaults to point." (interactive "P") (image--delayed-change-size (if n (1+ (/ (prefix-numeric-value n) 10.0)) @@ -1179,9 +1188,11 @@ default is 20%." (run-with-idle-timer 0.3 nil #'image--change-size size position)) (defun image-decrease-size (&optional n position) - "Decrease the image size by a factor of N. -If N is 3, then the image size will be decreased by 30%. The -default is 20%." + "Decrease the image size at POSITION by a factor specified by N. +If N is 3, then the image size will be decreased by 30%. More +generally, the image size is multiplied by 1 minus N divided by 10. +N defaults to 2, which decreases the image size by 20%. +POSITION can be a buffer position or a marker, and defaults to point." (interactive "P") (image--delayed-change-size (if n (- 1 (/ (prefix-numeric-value n) 10.0)) @@ -1191,7 +1202,9 @@ default is 20%." "Use %k for further adjustments")) (defun image-mouse-increase-size (&optional event) - "Increase the image size using the mouse." + "Increase the image size using the mouse-gesture EVENT. +This increases the size of the image at the position specified by +EVENT, if any, by the default factor used by `image-increase-size'." (interactive "e") (when (listp event) (save-window-excursion @@ -1199,7 +1212,9 @@ default is 20%." (image-increase-size nil (point-marker))))) (defun image-mouse-decrease-size (&optional event) - "Decrease the image size using the mouse." + "Decrease the image size using the mouse-gesture EVENT. +This decreases the size of the image at the position specified by +EVENT, if any, by the default factor used by `image-decrease-size'." (interactive "e") (when (listp event) (save-window-excursion @@ -1207,12 +1222,24 @@ default is 20%." (image-decrease-size nil (point-marker))))) (defun image--get-image (&optional position) - "Return the image at point." - (let ((image (get-char-property (or position (point)) 'display - (when (markerp position) - (marker-buffer position))))) + "Return the image at POSITION. +POSITION can be a buffer position or a marker, and defaults to point." + (let* ((image (get-char-property (or position (point)) 'display + (when (markerp position) + (marker-buffer position)))) + (image-car (car-safe image)) + (image + (cond ((eq image-car 'image) + image) + ;; The value of the display property could be a sliced + ;; image of the form ((slice ...) (image ...)). + ;; FIXME: can we have more than 2 members in the list, + ;; so that the (image ...) part is NOT the cadr? + ((and (listp image) (consp image-car)) + (cadr image)) + (t nil)))) (unless (eq (car-safe image) 'image) - (error "No image under point")) + (error "No recognizable image under point")) image)) ;;;###autoload diff --git a/lisp/image/image-crop.el b/lisp/image/image-crop.el index be6e22bc606..9ef848c5bc8 100644 --- a/lisp/image/image-crop.el +++ b/lisp/image/image-crop.el @@ -35,6 +35,7 @@ (declare-function image-property "image.el" (image property)) (declare-function image-size "image.c" (spec &optional pixels frame)) (declare-function imagep "image.c" (spec)) +(declare-function image--get-image "image.el" (&optional position)) (defgroup image-crop () "Image cropping." @@ -113,18 +114,36 @@ and the cropped image data.") (defun image-cut (&optional color) "Cut a rectangle from the image under point, filling it with COLOR. COLOR defaults to the value of `image-cut-color'. -Interactively, with prefix argument, prompt for COLOR to use." - (interactive (list (and current-prefix-arg (read-color "Use color: ")))) +Interactively, with prefix argument, prompt for COLOR to use. + +This command presents the image with a rectangular area superimposed +on it, and allows moving and resizing the area to define which +part of it to cut. + +While moving/resizing the cutting area, the following key bindings +are available: + +`q': Exit without changing anything. +`RET': Crop/cut the image. +`m': Make mouse movements move the rectangle instead of altering the + rectangle shape. +`s': Same as `m', but make the rectangle into a square first. + +After cutting the image, you can save it by `M-x image-save' or +\\<image-map>\\[image-save] when point is over the image." + (interactive (list (and current-prefix-arg + (read-color "Color to use for filling: ")))) (image-crop (if (zerop (length color)) image-cut-color color))) ;;;###autoload (defun image-crop (&optional cut) "Crop the image under point. -If CUT is non-nil, remove a rectangle from the image instead of -cropping the image. In that case CUT should be the name of a -color to fill the rectangle. +This command presents the image with a rectangular area superimposed +on it, and allows moving and resizing the area to define which +part of it to crop. -While cropping the image, the following key bindings are available: +While moving/resizing the cropping area, the following key bindings +are available: `q': Exit without changing anything. `RET': Crop/cut the image. @@ -132,15 +151,29 @@ While cropping the image, the following key bindings are available: rectangle shape. `s': Same as `m', but make the rectangle into a square first. -After cropping an image, you can save it by `M-x image-save' or -\\<image-map>\\[image-save] when point is over the image." +After cropping the image, you can save it by `M-x image-save' or +\\<image-map>\\[image-save] when point is over the image. + +When called from Lisp, if CUT is non-nil, remove a rectangle from +the image instead of cropping the image. In that case, CUT should +be the name of a color to fill the rectangle." (interactive) (unless (image-type-available-p 'svg) - (error "SVG support is needed to crop images")) - (unless (executable-find (car image-crop-crop-command)) - (error "Couldn't find %s command to crop the image" - (car image-crop-crop-command))) - (let ((image (get-text-property (point) 'display))) + (error "SVG support is needed to crop and cut images")) + (let* ((crop-cmd (car image-crop-crop-command)) + (found (executable-find crop-cmd))) + (unless found + (error "Couldn't find `%s' command to crop/cut the image" crop-cmd)) + (if (and (memq system-type '(windows-nt ms-dos)) + ;; MS-Windows has an incompatible convert.exe, used to + ;; convert filesystems... + (string-equal crop-cmd "convert") + (= 0 (string-search "Invalid drive specification." + (shell-command-to-string + (format "%s %s" crop-cmd null-device))))) + (error "The program `%s' is not an image conversion program" + found))) + (let ((image (image--get-image))) (unless (imagep image) (user-error "No image under point")) (when (overlays-at (point)) diff --git a/lisp/imenu.el b/lisp/imenu.el index fd23a65c7b3..c51824b7ef3 100644 --- a/lisp/imenu.el +++ b/lisp/imenu.el @@ -674,8 +674,8 @@ depending on PATTERNS." (cons item (cdr menu))))) ;; Go to the start of the match, to make sure we ;; keep making progress backwards. - (goto-char start)))) - (set-syntax-table old-table))) + (goto-char start))))) + (set-syntax-table old-table)) ;; Sort each submenu by position. ;; This is in case one submenu gets items from two different regexps. (dolist (item index-alist) diff --git a/lisp/international/emoji.el b/lisp/international/emoji.el index fec3e637f0c..856c405b545 100644 --- a/lisp/international/emoji.el +++ b/lisp/international/emoji.el @@ -684,30 +684,41 @@ We prefer the earliest unique letter." (defvar-keymap emoji-zoom-map "+" #'emoji-zoom-increase - "-" #'emoji-zoom-decrease) + "-" #'emoji-zoom-decrease + "0" #'emoji-zoom-reset) ;;;###autoload (defun emoji-zoom-increase (&optional factor) "Increase the size of the character under point. FACTOR is the multiplication factor for the size." (interactive) - (set-transient-map emoji-zoom-map t nil "Zoom with %k") - (let* ((factor (or factor 1.1)) - (old (get-text-property (point) 'face)) - (height (or (and (consp old) - (plist-get old :height)) - 1.0)) - (inhibit-read-only t)) - (with-silent-modifications - (if (consp old) - (add-text-properties - (point) (1+ (point)) - (list 'face (plist-put (copy-sequence old) :height (* height factor)) - 'rear-nonsticky t)) - (add-face-text-property (point) (1+ (point)) - (list :height (* height factor))) - (put-text-property (point) (1+ (point)) - 'rear-nonsticky t))))) + (set-transient-map emoji-zoom-map t #'redisplay "Zoom with %k") + (unless (eobp) + (let* ((factor (or factor 1.1)) + (old (get-text-property (point) 'face)) + ;; The text property is either a named face, or a plist + ;; with :height, or a list starting with such a plist, + ;; followed by one or more faces. + (newheight (* (or (and (consp old) + (or (plist-get (car old) :height) + (plist-get old :height))) + 1.0) + factor)) + (inhibit-read-only t)) + (with-silent-modifications + (if (consp old) + (add-text-properties + (point) (1+ (point)) + (list 'face + (if (eq (car old) :height) + (plist-put (copy-sequence old) :height newheight) + (cons (plist-put (car old) :height newheight) + (cdr old))) + 'rear-nonsticky t)) + (add-face-text-property (point) (1+ (point)) + (list :height newheight)) + (put-text-property (point) (1+ (point)) + 'rear-nonsticky t)))))) ;;;###autoload (defun emoji-zoom-decrease () @@ -715,6 +726,19 @@ FACTOR is the multiplication factor for the size." (interactive) (emoji-zoom-increase 0.9)) +;;;###autoload +(defun emoji-zoom-reset () + "Reset the size of the character under point." + (interactive) + (with-silent-modifications + (let ((old (get-text-property (point) 'face))) + (when (and (consp old) + (remove-text-properties (point) (1+ (point)) '(rear-nonsticky nil))) + (if (eq (car old) :height) + (remove-text-properties (point) (1+ (point)) '(face nil)) + (add-text-properties (point) (1+ (point)) (list 'face + (cdr old)))))))) + (provide 'emoji) ;;; emoji.el ends here diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index 4e38b13b1a5..3d6d66970d3 100644 --- a/lisp/international/mule-cmds.el +++ b/lisp/international/mule-cmds.el @@ -3269,7 +3269,8 @@ single characters to be treated as standing for themselves." "r" #'emoji-recent "l" #'emoji-list "+" #'emoji-zoom-increase - "-" #'emoji-zoom-decrease)) + "-" #'emoji-zoom-decrease + "0" #'emoji-zoom-reset)) (defface confusingly-reordered '((((supports :underline (:style wave))) diff --git a/lisp/international/quail.el b/lisp/international/quail.el index 2ffe3392335..317ea8495de 100644 --- a/lisp/international/quail.el +++ b/lisp/international/quail.el @@ -1995,7 +1995,8 @@ Remaining args are for FUNC." (defun quail-minibuffer-message (string) (message nil) (let ((point-max (point-max)) - (inhibit-quit t)) + (inhibit-quit t) + (deactivate-mark nil)) (save-excursion (goto-char point-max) (insert string)) diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el index 3965d38bc3e..ccf0f966574 100644 --- a/lisp/jsonrpc.el +++ b/lisp/jsonrpc.el @@ -574,15 +574,14 @@ With optional CLEANUP, kill any associated buffers." (cl-return-from jsonrpc--process-filter)) (when (buffer-live-p (process-buffer proc)) (with-current-buffer (process-buffer proc) - (let* ((inhibit-read-only t) - (jsonrpc--in-process-filter t) + (let* ((jsonrpc--in-process-filter t) (connection (process-get proc 'jsonrpc-connection)) (expected-bytes (jsonrpc--expected-bytes connection))) ;; Insert the text, advancing the process marker. ;; (save-excursion (goto-char (process-mark proc)) - (insert string) + (let ((inhibit-read-only t)) (insert string)) (set-marker (process-mark proc) (point))) ;; Loop (more than one message might have arrived) ;; @@ -631,7 +630,8 @@ With optional CLEANUP, kill any associated buffers." (jsonrpc-connection-receive connection json-message))))) (goto-char message-end) - (delete-region (point-min) (point)) + (let ((inhibit-read-only t)) + (delete-region (point-min) (point))) (setq expected-bytes nil)))) (t ;; Message is still incomplete diff --git a/lisp/keymap.el b/lisp/keymap.el index 4f02639ffe2..dccc0a3cd31 100644 --- a/lisp/keymap.el +++ b/lisp/keymap.el @@ -579,14 +579,17 @@ value can also be a property list with properties `:enter' and :repeat (:enter (commands ...) :exit (commands ...)) `:enter' specifies the list of additional commands that only -enter `repeat-mode'. When the list is empty, then by default all -commands in the map enter `repeat-mode'. This is useful when -there is a command that has the `repeat-map' symbol property, but -doesn't exist in this specific map. `:exit' is a list of -commands that exit `repeat-mode'. When the list is empty, no -commands in the map exit `repeat-mode'. This is useful when a -command exists in this specific map, but it doesn't have the -`repeat-map' symbol property on its symbol. +enter `repeat-mode'. When the list is empty, then only the +commands defined in the map enter `repeat-mode'. Specifying a +list of commands is useful when there are commands that have the +`repeat-map' symbol property, but don't exist in this specific +map. + +`:exit' is a list of commands that exit `repeat-mode'. When the +list is empty, no commands in the map exit `repeat-mode'. +Specifying a list of commands is useful when those commands exist +in this specific map, but should not have the `repeat-map' symbol +property. \(fn VARIABLE-NAME &key DOC FULL PARENT SUPPRESS NAME PREFIX KEYMAP REPEAT &rest [KEY DEFINITION]...)" (declare (indent 1)) diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el index fe46b220da5..acf8a1d2556 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -3779,14 +3779,18 @@ and exists only for compatibility reasons. ;;; Generated autoloads from progmodes/cc-vars.el +(autoload 'c-string-list-p "cc-vars" "\ +Return non-nil if VAL is a list of strings. + +(fn VAL)") (put 'c-basic-offset 'safe-local-variable 'integerp) (put 'c-backslash-column 'safe-local-variable 'integerp) - (put 'c-font-lock-extra-types 'safe-local-variable #'c-list-of-strings) - (put 'c++-font-lock-extra-types 'safe-local-variable #'c-list-of-strings) - (put 'objc-font-lock-extra-types 'safe-local-variable #'c-list-of-strings) - (put 'java-font-lock-extra-types 'safe-local-variable #'c-list-of-strings) - (put 'idl-font-lock-extra-types 'safe-local-variable #'c-list-of-strings) - (put 'pike-font-lock-extra-types 'safe-local-variable #'c-list-of-strings) + (put 'c-font-lock-extra-types 'safe-local-variable #'c-string-list-p) + (put 'c++-font-lock-extra-types 'safe-local-variable #'c-string-list-p) + (put 'objc-font-lock-extra-types 'safe-local-variable #'c-string-list-p) + (put 'java-font-lock-extra-types 'safe-local-variable #'c-string-list-p) + (put 'idl-font-lock-extra-types 'safe-local-variable #'c-string-list-p) + (put 'pike-font-lock-extra-types 'safe-local-variable #'c-string-list-p) (put 'c-file-style 'safe-local-variable 'string-or-null-p) (register-definition-prefixes "cc-vars" '("awk-mode-hook" "c++-" "c-" "defcustom-c-stylevar" "idl-" "java-" "objc-" "pike-")) @@ -8234,15 +8238,23 @@ Make a global mode GLOBAL-MODE corresponding to buffer-local minor MODE. TURN-ON is a function that will be called with no args in every buffer and that should try to turn MODE on if applicable for that buffer. -Each of KEY VALUE is a pair of CL-style keyword arguments. :predicate -specifies which major modes the globalized minor mode should be switched on -in. As the minor mode defined by this function is always global, any -:global keyword is ignored. Other keywords have the same meaning as in -`define-minor-mode', which see. In particular, :group specifies the custom -group. The most useful keywords are those that are passed on to the -`defcustom'. It normally makes no sense to pass the :lighter or :keymap -keywords to `define-globalized-minor-mode', since these are usually passed -to the buffer-local version of the minor mode. +Each of KEY VALUE is a pair of CL-style keyword arguments. +The :predicate argument specifies in which major modes should the +globalized minor mode be switched on. The value should be t (meaning +switch on the minor mode in all major modes), nil (meaning don't +switch on in any major mode), a list of modes (meaning switch on only +in those modes and their descendants), or a list (not MODES...), +meaning switch on in any major mode except MODES. The value can also +mix all of these forms, see the info node `Defining Minor Modes' for +details. +As the minor mode defined by this function is always global, any +:global keyword is ignored. +Other keywords have the same meaning as in `define-minor-mode', +which see. In particular, :group specifies the custom group. +The most useful keywords are those that are passed on to the `defcustom'. +It normally makes no sense to pass the :lighter or :keymap keywords +to `define-globalized-minor-mode', since these are usually passed to +the buffer-local version of the minor mode. BODY contains code to execute each time the mode is enabled or disabled. It is executed after toggling the mode, and before running @@ -9218,7 +9230,7 @@ Turn on EDT Emulation." t) ;;; Generated autoloads from progmodes/eglot.el -(push (purecopy '(eglot 1 12)) package--builtin-versions) +(push (purecopy '(eglot 1 13)) package--builtin-versions) (autoload 'eglot "eglot" "\ Start LSP server in support of PROJECT's buffers under MANAGED-MAJOR-MODE. @@ -22454,7 +22466,7 @@ Coloring: ;;; Generated autoloads from org/org.el -(push (purecopy '(org 9 6 1)) package--builtin-versions) +(push (purecopy '(org 9 6 2)) package--builtin-versions) (autoload 'org-babel-do-load-languages "org" "\ Load the languages defined in `org-babel-load-languages'. @@ -23553,48 +23565,6 @@ DESC must be a `package-desc' object. (autoload 'package-vc-install-selected-packages "package-vc" "\ Ensure packages specified in `package-vc-selected-packages' are installed." t) -(defvar package-vc-selected-packages 'nil "\ -List of packages that must be installed. -Each member of the list is of the form (NAME . SPEC), where NAME -is a symbol designating the package and SPEC is one of: - -- nil, if any package version can be installed; -- a version string, if that specific revision is to be installed; -- a property list, describing a package specification. Valid - key/value pairs are - - `:url' (string) - The URL of the repository used to fetch the package source. - - `:branch' (string) - If given, the name of the branch to checkout after cloning the directory. - - `:lisp-dir' (string) - The repository-relative name of the directory to use for loading the Lisp - sources. If not given, the value defaults to the root directory - of the repository. - - `:main-file' (string) - The main file of the project, relevant to gather package metadata. - If not given, the assumed default is the package name with \".el\" - appended to it. - - `:vc-backend' (symbol) - A symbol of the VC backend to use for cloning the package. The - value ought to be a member of `vc-handled-backends'. If omitted, - `vc-clone' will fall back onto the archive default or on - `package-vc-default-backend'. - - All other keys are ignored. - -This user option differs from `package-selected-packages' in that -it is meant to be specified manually. If you want to install all -the packages in the list, you cal also use -`package-vc-install-selected-packages'. - -Note that this option will not override an existing source -package installation or revert the checked out revision.") -(custom-autoload 'package-vc-selected-packages "package-vc" nil) (autoload 'package-vc-update-all "package-vc" "\ Attempt to update all installed VC packages." t) (autoload 'package-vc-update "package-vc" "\ @@ -36975,7 +36945,7 @@ If LIMIT is non-nil, then do not consider characters beyond LIMIT. Go back to the previous position in xref history. To undo, use \\[xref-go-forward]." t) (autoload 'xref-go-forward "xref" "\ -Got to the point where a previous \\[xref-go-back] was invoked." t) +Go to the point where a previous \\[xref-go-back] was invoked." t) (autoload 'xref-marker-stack-empty-p "xref" "\ Whether the xref back-history is empty.") (autoload 'xref-forward-history-empty-p "xref" "\ diff --git a/lisp/leim/quail/cyrillic.el b/lisp/leim/quail/cyrillic.el index ba0b9c9ca12..d0874124fc7 100644 --- a/lisp/leim/quail/cyrillic.el +++ b/lisp/leim/quail/cyrillic.el @@ -1844,6 +1844,125 @@ Doubling the postfix separates the letter and postfix ("E**" ["У*"]) ("e**" ["у*"])) + +;; Mongolian layout: Mongolian alphabet has 2 letters: Ө Ү, +;; and the layout is quite different from other cyrillic layouts. +;; Written by Garid Zorigoo. +(quail-define-package + "cyrillic-mongolian" "Mongolian" "MN-" t + "Input method for cyrillic Mongolian" + nil t nil nil nil nil nil nil nil nil t) + +;; № - " ₮ : . _ , % ? е щ +;; Ф Ц У Ж Э Н Г Ш Ү З К Ъ +;; Й Ы Б Ө А Х Р О Л Д П +;; Я Ч Ё С М И Т Ь В Ю + + +(quail-define-rules + ;; (lowercase 1st row) + ("q" ?ф) + ("w" ?ц) + ("e" ?у) + ("r" ?ж) + ("t" ?э) + ("y" ?н) + ("u" ?г) + ("i" ?ш) + ("o" ?ү) + ("p" ?з) + ("[" ?к) + ("]" ?ъ) + ;; (lowercase 2nd row) + ("a" ?й) + ("s" ?ы) + ("d" ?б) + ("f" ?ө) + ("g" ?а) + ("h" ?х) + ("j" ?р) + ("k" ?о) + ("l" ?л) + (";" ?д) + ("'" ?п) + ;; (lowercase 3rd row) + ("z" ?я) + ("x" ?ч) + ("c" ?ё) + ("v" ?с) + ("b" ?м) + ("n" ?и) + ("m" ?т) + ("," ?ь) + ("." ?в) + ("/" ?ю) + + + ;; (uppercase 1st row) + ("Q" ?Ф) + ("W" ?Ц) + ("E" ?У) + ("R" ?Ж) + ("T" ?Э) + ("Y" ?Н) + ("U" ?Г) + ("I" ?Ш) + ("O" ?Ү) + ("P" ?З) + ("{" ?К) + ("}" ?Ъ) + ;; (uppercase 2nd row) + ("A" ?Й) + ("S" ?Ы) + ("D" ?Б) + ("F" ?Ө) + ("G" ?А) + ("H" ?Х) + ("J" ?Р) + ("K" ?О) + ("L" ?Л) + (":" ?Д) + ("\"" ?П) + ;; (uppercase 3rd row) + ("Z" ?Я) + ("X" ?Ч) + ("C" ?Ё) + ("V" ?С) + ("B" ?М) + ("N" ?И) + ("M" ?Т) + ("<" ?Ь) + (">" ?В) + ("?" ?Ю) + + + ;; (number row without shift) + ("1" ?№) + ("2" ?-) + ("3" ?\") + ("4" ?₮) + ("5" ?:) + ("6" ?.) + ("7" ?_) + ("8" ?,) + ("9" ?%) + ("0" ??) + ("-" ?е) + ("=" ?щ) + ;; (number row with shift) + ("!" ?1) + ("@" ?2) + ("#" ?3) + ("$" ?4) + ("%" ?5) + ("^" ?6) + ("&" ?7) + ("*" ?8) + ("(" ?9) + (")" ?0) + ("_" ?Е) + ("+" ?Щ)) + ;; Local Variables: ;; coding: utf-8 ;; End: diff --git a/lisp/loadup.el b/lisp/loadup.el index 46b26750cd5..1cc70348267 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -476,7 +476,13 @@ lost after dumping"))) ;; At this point, we're ready to resume undo recording for scratch. (buffer-enable-undo "*scratch*") +(defvar comp-subr-arities-h) (when (featurep 'native-compile) + ;; Save the arity for all primitives so the compiler can always + ;; retrive it even in case of redefinition. + (mapatoms (lambda (f) + (when (subr-primitive-p (symbol-function f)) + (puthash f (func-arity f) comp-subr-arities-h)))) ;; Fix the compilation unit filename to have it working when ;; installed or if the source directory got moved. This is set to be ;; a pair in the form of: diff --git a/lisp/mail/feedmail.el b/lisp/mail/feedmail.el index 97d20cca151..165aafae1f7 100644 --- a/lisp/mail/feedmail.el +++ b/lisp/mail/feedmail.el @@ -2511,22 +2511,20 @@ mapped to mostly alphanumerics for safety." feedmail-force-binary-write) 'no-conversion coding-system-for-write))) - (unwind-protect - (progn - (insert fcc) - (unless feedmail-nuke-bcc-in-fcc - (if bcc-holder (insert bcc-holder)) - (if resent-bcc-holder - (insert resent-bcc-holder))) - - (run-hooks 'feedmail-before-fcc-hook) - - (when feedmail-nuke-body-in-fcc - (goto-char eoh-marker) - (if (natnump feedmail-nuke-body-in-fcc) - (forward-line feedmail-nuke-body-in-fcc)) - (delete-region (point) (point-max))) - (mail-do-fcc eoh-marker)))))) + (insert fcc) + (unless feedmail-nuke-bcc-in-fcc + (if bcc-holder (insert bcc-holder)) + (if resent-bcc-holder + (insert resent-bcc-holder))) + + (run-hooks 'feedmail-before-fcc-hook) + + (when feedmail-nuke-body-in-fcc + (goto-char eoh-marker) + (if (natnump feedmail-nuke-body-in-fcc) + (forward-line feedmail-nuke-body-in-fcc)) + (delete-region (point) (point-max))) + (mail-do-fcc eoh-marker)))) ;; User bailed out of one-last-look. (if feedmail-queue-runner-is-active (throw 'skip-me-q 'skip-me-q) @@ -3046,30 +3044,30 @@ been weeded out." (address-blob) (this-line) (this-line-end)) - (unwind-protect - (with-current-buffer (get-buffer-create " *FQM scratch*") - (erase-buffer) - (insert-buffer-substring message-buffer header-start header-end) - (goto-char (point-min)) - (let ((case-fold-search t)) - (while (re-search-forward addr-regexp (point-max) t) - (replace-match "") - (setq this-line (match-beginning 0)) - (forward-line 1) - ;; get any continuation lines - (while (and (looking-at "^[ \t]+") (< (point) (point-max))) - (forward-line 1)) - (setq this-line-end (point-marker)) - ;; only keep if we don't have it already - (setq address-blob - (mail-strip-quoted-names (buffer-substring-no-properties this-line this-line-end))) - (while (string-match "\\([, \t\n\r]*\\)\\([^, \t\n\r]+\\)" address-blob) - (setq simple-address (substring address-blob (match-beginning 2) (match-end 2))) - (setq address-blob (replace-match "" t t address-blob)) - (if (not (member simple-address address-list)) - (push simple-address address-list))) - )) - (kill-buffer nil))) + + (with-current-buffer (get-buffer-create " *FQM scratch*") + (erase-buffer) + (insert-buffer-substring message-buffer header-start header-end) + (goto-char (point-min)) + (let ((case-fold-search t)) + (while (re-search-forward addr-regexp (point-max) t) + (replace-match "") + (setq this-line (match-beginning 0)) + (forward-line 1) + ;; get any continuation lines + (while (and (looking-at "^[ \t]+") (< (point) (point-max))) + (forward-line 1)) + (setq this-line-end (point-marker)) + ;; only keep if we don't have it already + (setq address-blob + (mail-strip-quoted-names (buffer-substring-no-properties this-line this-line-end))) + (while (string-match "\\([, \t\n\r]*\\)\\([^, \t\n\r]+\\)" address-blob) + (setq simple-address (substring address-blob (match-beginning 2) (match-end 2))) + (setq address-blob (replace-match "" t t address-blob)) + (if (not (member simple-address address-list)) + (push simple-address address-list))) + )) + (kill-buffer nil)) (identity address-list))) diff --git a/lisp/mail/mailclient.el b/lisp/mail/mailclient.el index 21ddef4b0fd..613541e5dc4 100644 --- a/lisp/mail/mailclient.el +++ b/lisp/mail/mailclient.el @@ -111,104 +111,103 @@ The mail client is taken to be the handler of mailto URLs." (let ((case-fold-search nil) delimline (mailbuf (current-buffer))) - (unwind-protect - (with-temp-buffer - (insert-buffer-substring mailbuf) - ;; Move to header delimiter - (mail-sendmail-undelimit-header) - (setq delimline (point-marker)) - (if mail-aliases - (expand-mail-aliases (point-min) delimline)) - (goto-char (point-min)) - ;; ignore any blank lines in the header - (while (and (re-search-forward "\n\n\n*" delimline t) - (< (point) delimline)) - (replace-match "\n")) - (let ((case-fold-search t) - (mime-charset-pattern - (concat - "^content-type:[ \t]*text/plain;" - "\\(?:[ \t\n]*\\(?:format\\|delsp\\)=\"?[-a-z0-9]+\"?;\\)*" - "[ \t\n]*charset=\"?\\([^ \t\n\";]+\\)\"?")) - coding-system - character-coding - ;; Use the external browser function to send the - ;; message. - (browse-url-default-handlers nil)) - ;; initialize limiter - (setq mailclient-delim-static "?") - ;; construct and call up mailto URL - (browse-url + (with-temp-buffer + (insert-buffer-substring mailbuf) + ;; Move to header delimiter + (mail-sendmail-undelimit-header) + (setq delimline (point-marker)) + (if mail-aliases + (expand-mail-aliases (point-min) delimline)) + (goto-char (point-min)) + ;; ignore any blank lines in the header + (while (and (re-search-forward "\n\n\n*" delimline t) + (< (point) delimline)) + (replace-match "\n")) + (let ((case-fold-search t) + (mime-charset-pattern (concat - (save-excursion - (narrow-to-region (point-min) delimline) - ;; We can't send multipart/* messages (i. e. with - ;; attachments or the like) via this method. - (when-let ((type (mail-fetch-field "content-type"))) - (when (and (string-match "multipart" - (car (mail-header-parse-content-type - type))) - (not (y-or-n-p "Message with attachments can't be sent via mailclient; continue anyway?"))) - (error "Choose a different `send-mail-function' to send attachments"))) - (goto-char (point-min)) - (setq coding-system - (if (re-search-forward mime-charset-pattern nil t) - (coding-system-from-name (match-string 1)) - 'undecided)) - (setq character-coding - (mail-fetch-field "content-transfer-encoding")) - (when character-coding - (setq character-coding (downcase character-coding))) - (concat - "mailto:" - ;; Some of the headers according to RFC 822 (or later). - (mailclient-gather-addresses "To" - 'drop-first-name) - (mailclient-gather-addresses "cc" ) - (mailclient-gather-addresses "bcc" ) - (mailclient-gather-addresses "Resent-To" ) - (mailclient-gather-addresses "Resent-cc" ) - (mailclient-gather-addresses "Resent-bcc" ) - (mailclient-gather-addresses "Reply-To" ) - ;; The From field is not honored for now: it's - ;; not necessarily configured. The mail client - ;; knows the user's address(es) - ;; (mailclient-gather-addresses "From" ) - ;; subject line - (let ((subj (mail-fetch-field "Subject" nil t))) - (widen) ;; so we can read the body later on - (if subj ;; if non-blank - ;; the mail client will deal with - ;; warning the user etc. - (concat (mailclient-url-delim) "subject=" - (mailclient-encode-string-as-url subj)) - "")))) - ;; body - (mailclient-url-delim) "body=" - (progn - (delete-region (point-min) delimline) - (unless (null character-coding) - ;; mailto: and clipboard need UTF-8 and cannot deal with - ;; Content-Transfer-Encoding or Content-Type. - ;; FIXME: There is code duplication here with rmail.el. - (set-buffer-multibyte nil) - (cond - ((string= character-coding "base64") - (base64-decode-region (point-min) (point-max))) - ((string= character-coding "quoted-printable") - (mail-unquote-printable-region (point-min) (point-max) - nil nil t)) - (t (error "Unsupported Content-Transfer-Encoding: %s" - character-coding))) - (decode-coding-region (point-min) (point-max) coding-system)) - (mailclient-encode-string-as-url - (if mailclient-place-body-on-clipboard-flag - (progn - (clipboard-kill-ring-save (point-min) (point-max)) - (concat - "*** E-Mail body has been placed on clipboard, " - "please paste it here! ***")) - (buffer-string))))))))))) + "^content-type:[ \t]*text/plain;" + "\\(?:[ \t\n]*\\(?:format\\|delsp\\)=\"?[-a-z0-9]+\"?;\\)*" + "[ \t\n]*charset=\"?\\([^ \t\n\";]+\\)\"?")) + coding-system + character-coding + ;; Use the external browser function to send the + ;; message. + (browse-url-default-handlers nil)) + ;; initialize limiter + (setq mailclient-delim-static "?") + ;; construct and call up mailto URL + (browse-url + (concat + (save-excursion + (narrow-to-region (point-min) delimline) + ;; We can't send multipart/* messages (i. e. with + ;; attachments or the like) via this method. + (when-let ((type (mail-fetch-field "content-type"))) + (when (and (string-match "multipart" + (car (mail-header-parse-content-type + type))) + (not (y-or-n-p "Message with attachments can't be sent via mailclient; continue anyway?"))) + (error "Choose a different `send-mail-function' to send attachments"))) + (goto-char (point-min)) + (setq coding-system + (if (re-search-forward mime-charset-pattern nil t) + (coding-system-from-name (match-string 1)) + 'undecided)) + (setq character-coding + (mail-fetch-field "content-transfer-encoding")) + (when character-coding + (setq character-coding (downcase character-coding))) + (concat + "mailto:" + ;; Some of the headers according to RFC 822 (or later). + (mailclient-gather-addresses "To" + 'drop-first-name) + (mailclient-gather-addresses "cc" ) + (mailclient-gather-addresses "bcc" ) + (mailclient-gather-addresses "Resent-To" ) + (mailclient-gather-addresses "Resent-cc" ) + (mailclient-gather-addresses "Resent-bcc" ) + (mailclient-gather-addresses "Reply-To" ) + ;; The From field is not honored for now: it's + ;; not necessarily configured. The mail client + ;; knows the user's address(es) + ;; (mailclient-gather-addresses "From" ) + ;; subject line + (let ((subj (mail-fetch-field "Subject" nil t))) + (widen) ;; so we can read the body later on + (if subj ;; if non-blank + ;; the mail client will deal with + ;; warning the user etc. + (concat (mailclient-url-delim) "subject=" + (mailclient-encode-string-as-url subj)) + "")))) + ;; body + (mailclient-url-delim) "body=" + (progn + (delete-region (point-min) delimline) + (unless (null character-coding) + ;; mailto: and clipboard need UTF-8 and cannot deal with + ;; Content-Transfer-Encoding or Content-Type. + ;; FIXME: There is code duplication here with rmail.el. + (set-buffer-multibyte nil) + (cond + ((string= character-coding "base64") + (base64-decode-region (point-min) (point-max))) + ((string= character-coding "quoted-printable") + (mail-unquote-printable-region (point-min) (point-max) + nil nil t)) + (t (error "Unsupported Content-Transfer-Encoding: %s" + character-coding))) + (decode-coding-region (point-min) (point-max) coding-system)) + (mailclient-encode-string-as-url + (if mailclient-place-body-on-clipboard-flag + (progn + (clipboard-kill-ring-save (point-min) (point-max)) + (concat + "*** E-Mail body has been placed on clipboard, " + "please paste it here! ***")) + (buffer-string)))))))))) (provide 'mailclient) diff --git a/lisp/mail/smtpmail.el b/lisp/mail/smtpmail.el index f0aa0c6ecf5..78688d170cc 100644 --- a/lisp/mail/smtpmail.el +++ b/lisp/mail/smtpmail.el @@ -1068,52 +1068,51 @@ Returns an error if the server cannot be contacted." (defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end) "Get address list suitable for smtp RCPT TO: <address>." - (unwind-protect - (with-current-buffer smtpmail-address-buffer - (erase-buffer) - (let ((case-fold-search t) - (simple-address-list "") - this-line - this-line-end - addr-regexp) - (insert-buffer-substring smtpmail-text-buffer header-start header-end) - (goto-char (point-min)) - ;; RESENT-* fields should stop processing of regular fields. - (save-excursion - (setq addr-regexp - (if (re-search-forward "^Resent-\\(To\\|Cc\\|Bcc\\):" - header-end t) - "^Resent-\\(To\\|Cc\\|Bcc\\):" - "^\\(To:\\|Cc:\\|Bcc:\\)"))) - - (while (re-search-forward addr-regexp header-end t) - (replace-match "") - (setq this-line (match-beginning 0)) - (forward-line 1) - ;; get any continuation lines - (while (and (looking-at "^[ \t]+") (< (point) header-end)) - (forward-line 1)) - (setq this-line-end (point-marker)) - (setq simple-address-list - (concat simple-address-list " " - (mail-strip-quoted-names (buffer-substring this-line this-line-end))))) - (erase-buffer) - (insert " " simple-address-list "\n") - (subst-char-in-region (point-min) (point-max) 10 ? t) ; newline --> blank - (subst-char-in-region (point-min) (point-max) ?, ? t) ; comma --> blank - (subst-char-in-region (point-min) (point-max) 9 ? t) ; tab --> blank + (with-current-buffer smtpmail-address-buffer + (erase-buffer) + (let ((case-fold-search t) + (simple-address-list "") + this-line + this-line-end + addr-regexp) + (insert-buffer-substring smtpmail-text-buffer header-start header-end) + (goto-char (point-min)) + ;; RESENT-* fields should stop processing of regular fields. + (save-excursion + (setq addr-regexp + (if (re-search-forward "^Resent-\\(To\\|Cc\\|Bcc\\):" + header-end t) + "^Resent-\\(To\\|Cc\\|Bcc\\):" + "^\\(To:\\|Cc:\\|Bcc:\\)"))) + + (while (re-search-forward addr-regexp header-end t) + (replace-match "") + (setq this-line (match-beginning 0)) + (forward-line 1) + ;; get any continuation lines + (while (and (looking-at "^[ \t]+") (< (point) header-end)) + (forward-line 1)) + (setq this-line-end (point-marker)) + (setq simple-address-list + (concat simple-address-list " " + (mail-strip-quoted-names (buffer-substring this-line this-line-end))))) + (erase-buffer) + (insert " " simple-address-list "\n") + (subst-char-in-region (point-min) (point-max) 10 ? t) ; newline --> blank + (subst-char-in-region (point-min) (point-max) ?, ? t) ; comma --> blank + (subst-char-in-region (point-min) (point-max) 9 ? t) ; tab --> blank - (goto-char (point-min)) - ;; tidiness in case hook is not robust when it looks at this - (while (re-search-forward "[ \t]+" header-end t) (replace-match " ")) + (goto-char (point-min)) + ;; tidiness in case hook is not robust when it looks at this + (while (re-search-forward "[ \t]+" header-end t) (replace-match " ")) - (goto-char (point-min)) - (let (recipient-address-list) - (while (re-search-forward " \\([^ ]+\\) " (point-max) t) - (backward-char 1) - (setq recipient-address-list (cons (buffer-substring (match-beginning 1) (match-end 1)) - recipient-address-list))) - (setq smtpmail-recipient-address-list recipient-address-list)))))) + (goto-char (point-min)) + (let (recipient-address-list) + (while (re-search-forward " \\([^ ]+\\) " (point-max) t) + (backward-char 1) + (setq recipient-address-list (cons (buffer-substring (match-beginning 1) (match-end 1)) + recipient-address-list))) + (setq smtpmail-recipient-address-list recipient-address-list))))) (defun smtpmail-do-bcc (header-end) "Delete [Resent-]Bcc: and their continuation lines from the header area. diff --git a/lisp/mail/yenc.el b/lisp/mail/yenc.el index de1e1ee283a..a836f5b71bd 100644 --- a/lisp/mail/yenc.el +++ b/lisp/mail/yenc.el @@ -111,8 +111,8 @@ (message "Warning: Size mismatch while decoding.")) (goto-char start) (delete-region start end) - (insert-buffer-substring work-buffer)))) - (and work-buffer (kill-buffer work-buffer)))))) + (insert-buffer-substring work-buffer))))) + (and work-buffer (kill-buffer work-buffer))))) ;;;###autoload (defun yenc-extract-filename () diff --git a/lisp/mh-e/mh-print.el b/lisp/mh-e/mh-print.el index 76116010b33..eeea94a69e5 100644 --- a/lisp/mh-e/mh-print.el +++ b/lisp/mh-e/mh-print.el @@ -79,8 +79,7 @@ commands \\[mh-ps-print-toggle-color] and This is the function that actually does the work. If FILE is nil, then the messages are spooled to the printer." (mh-iterate-on-range msg range - (unwind-protect - (mh-ps-spool-msg msg)) + (mh-ps-spool-msg msg) (mh-notate msg mh-note-printed mh-cmd-note)) (ps-despool file)) diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 01894689623..a3dc1b0cfbf 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -862,7 +862,18 @@ If a function returns a string, the returned string is given to the next function in the list, and if the last function returns a string, it's displayed in the echo area. If a function returns any other non-nil value, no more functions are -called from the list, and no message will be displayed in the echo area." +called from the list, and no message will be displayed in the echo area. + +Useful functions to add to this list are: + + `inhibit-message' -- if this function is the first in the list, + messages that match the value of + `inhibit-message-regexps' will be suppressed. + `set-multi-message' -- accumulate multiple messages and display them + together as a single message. + `set-minibuffer-message' -- if the minibuffer is active, display the + message at the end of the minibuffer text + (this is the default)." :type '(choice (const :tag "No special message handling" nil) (repeat (choice (function-item :tag "Inhibit some messages" @@ -884,13 +895,18 @@ called from the list, and no message will be displayed in the echo area." message) (defcustom inhibit-message-regexps nil - "List of regexps that inhibit messages by the function `inhibit-message'." + "List of regexps that inhibit messages by the function `inhibit-message'. +When the list in `set-message-functions' has `inhibit-message' as its +first element, echo-area messages which match the value of this variable +will not be displayed." :type '(repeat regexp) :version "29.1") (defun inhibit-message (message) "Don't display MESSAGE when it matches the regexp `inhibit-message-regexps'. -This function is intended to be added to `set-message-functions'." +This function is intended to be added to `set-message-functions'. +To suppress display of echo-area messages that match `inhibit-message-regexps', +make this function be the first element of `set-message-functions'." (or (and (consp inhibit-message-regexps) (string-match-p (mapconcat #'identity inhibit-message-regexps "\\|") message)) @@ -912,6 +928,10 @@ This function is intended to be added to `set-message-functions'." (defun set-multi-message (message) "Return recent messages as one string to display in the echo area. +Individual messages will be separated by a newline. +Up to `multi-message-max' messages can be accumulated, and the +accumulated messages are discarded when `multi-message-timeout' +seconds have elapsed since the first message. Note that this feature works best only when `resize-mini-windows' is at its default value `grow-only'." (let ((last-message (car multi-message-list))) diff --git a/lisp/mouse.el b/lisp/mouse.el index 9c1a72bb368..3c30361ad7d 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -533,7 +533,8 @@ Some context functions add menu items below the separator." (i 0)) (dolist (item (reverse yank-menu)) (when (consp item) - (define-key submenu (vector (setq i (1+ i))) + (define-key submenu + (vector (intern (format "kill-%d" (setq i (1+ i))))) `(menu-item ,(cadr item) ,(lambda () (interactive) (mouse-yank-from-menu click (car item))))))) diff --git a/lisp/mwheel.el b/lisp/mwheel.el index 1be52d24e34..caa74159ecd 100644 --- a/lisp/mwheel.el +++ b/lisp/mwheel.el @@ -447,13 +447,12 @@ See also `text-scale-adjust'." This invokes `global-text-scale-adjust', which see." (interactive (list last-input-event)) (let ((button (mwheel-event-button event))) - (unwind-protect - (cond ((memq button (list mouse-wheel-down-event - mouse-wheel-down-alternate-event)) - (global-text-scale-adjust 1)) - ((memq button (list mouse-wheel-up-event - mouse-wheel-up-alternate-event)) - (global-text-scale-adjust -1)))))) + (cond ((memq button (list mouse-wheel-down-event + mouse-wheel-down-alternate-event)) + (global-text-scale-adjust 1)) + ((memq button (list mouse-wheel-up-event + mouse-wheel-up-alternate-event)) + (global-text-scale-adjust -1))))) (defun mouse-wheel--add-binding (key fun) "Bind mouse wheel button KEY to function FUN. diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index f35d11db152..fff860b05c3 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -371,7 +371,11 @@ object is returned instead of a list containing this single Lisp object. (apply #'dbus-message-internal dbus-message-type-method-call bus service path interface method #'dbus-call-method-handler args)) - (result (cons :pending nil))) + (result (unless executing-kbd-macro (cons :pending nil)))) + + ;; While executing a keyboard macro, we run into an infinite loop, + ;; receiving the event -1. So we don't try to get the result. + ;; (Bug#62018) ;; Wait until `dbus-call-method-handler' has put the result into ;; `dbus-return-values-table'. If no timeout is given, use the diff --git a/lisp/net/eudcb-mab.el b/lisp/net/eudcb-mab.el index 08fc20f438a..805c742d9e0 100644 --- a/lisp/net/eudcb-mab.el +++ b/lisp/net/eudcb-mab.el @@ -86,7 +86,8 @@ RETURN-ATTRS is a list of attributes to return, defaulting to ((eq (car term) 'email) (unless (string= (cdr term) mail) (setq matched nil))) - ((eq (car term) 'phone)))) + ;; ((eq (car term) 'phone)) + )) (when matched (setq result diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 73d11c0ef52..99450356b7c 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -64,16 +64,23 @@ The action to be taken can be further customized via :version "28.1" :type 'regexp) +(defcustom eww-default-download-directory "~/Downloads/" + "Default directory where `eww' saves downloaded files. +Used by `eww--download-directory', which see." + :version "29.1" + :group 'eww + :type 'directory) + (defun eww--download-directory () - "Return the name of the download directory. -If ~/Downloads/ exists, that will be used, and if not, the -DOWNLOAD XDG user directory will be returned. If that's -undefined, ~/Downloads/ is returned anyway." - (or (and (file-exists-p "~/Downloads/") - "~/Downloads/") + "Return the name of the EWW download directory. +The default is specified by `eww-default-download-directory'; however, +if that directory doesn't exist and the DOWNLOAD XDG user directory +is defined, use the latter instead." + (or (and (file-exists-p eww-default-download-directory) + eww-default-download-directory) (when-let ((dir (xdg-user-dir "DOWNLOAD"))) (file-name-as-directory dir)) - "~/Downloads/")) + eww-default-download-directory)) (defcustom eww-download-directory 'eww--download-directory "Directory where files will downloaded. @@ -319,7 +326,7 @@ parameter, and should return the (possibly) transformed URL." "<mouse-2>" #'eww-follow-link) (defvar-keymap eww-image-link-keymap - :parent shr-map + :parent shr-image-map "RET" #'eww-follow-link) (defun eww-suggested-uris nil @@ -1008,7 +1015,7 @@ the like." (list 'base (list (cons 'href base)) (eww-highest-readability dom)) nil (current-buffer)) - (dolist (elem '(:source :url :title :next :previous :up)) + (dolist (elem '(:source :url :title :next :previous :up :peer)) (plist-put eww-data elem (plist-get old-data elem))) (eww--after-page-change))) diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 9c2ae98d77e..4e44dfbef03 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -276,7 +276,7 @@ and other things: (defvar-keymap shr-map "a" #'shr-show-alt-text - "i" #'shr-browse-image + "M-i" #'shr-browse-image "z" #'shr-zoom-image "TAB" #'shr-next-link "C-M-i" #'shr-previous-link diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index b0cfdb1ebba..1a9d8003530 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -319,7 +319,7 @@ The remote connection identified by SOURCE is flushed by (read-file-name-function #'read-file-name-default) source target) (if (null connections) - (tramp-user-error nil "There are no remote connections.") + (tramp-user-error nil "There are no remote connections") (setq source ;; Likely, the source remote connection is broken. So we ;; shall avoid any action on it. @@ -367,15 +367,15 @@ The remote connection identified by SOURCE is flushed by (list source target))) (unless (tramp-tramp-file-p source) - (tramp-user-error nil "Source %s must be remote." source)) + (tramp-user-error nil "Source %s must be remote" source)) (when (null target) (or (setq target (tramp-default-rename-file source)) (tramp-user-error nil (concat "There is no target specified. " - "Check `tramp-default-rename-alist' for a proper entry.")))) + "Check `tramp-default-rename-alist' for a proper entry")))) (when (tramp-equal-remote source target) - (tramp-user-error nil "Source and target must have different remote.")) + (tramp-user-error nil "Source and target must have different remote")) ;; Append local file name if none is specified. (when (string-equal (file-remote-p target) target) @@ -461,7 +461,7 @@ For details, see `tramp-rename-files'." nil (substitute-command-keys (concat "Current buffer is not remote. " - "Consider `\\[tramp-rename-files]' instead."))) + "Consider `\\[tramp-rename-files]' instead"))) (setq target (when (null current-prefix-arg) ;; The source remote connection shall not trigger any action. diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index 116c2b143e9..4d15695ccbf 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -436,7 +436,7 @@ Otherwise, return NAME." crypt-vec (if (eq op 'encrypt) "encode" "decode") tramp-compat-temporary-file-directory localname) (tramp-error - crypt-vec 'file-error "%s of file name %s failed." + crypt-vec 'file-error "%s of file name %s failed" (if (eq op 'encrypt) "Encoding" "Decoding") name)) (with-current-buffer (tramp-get-connection-buffer crypt-vec) (goto-char (point-min)) @@ -471,7 +471,7 @@ Raise an error if this fails." (file-name-directory infile) (concat "/" (file-name-nondirectory infile))) (tramp-error - crypt-vec 'file-error "%s of file %s failed." + crypt-vec 'file-error "%s of file %s failed" (if (eq op 'encrypt) "Encrypting" "Decrypting") infile)) (with-current-buffer (tramp-get-connection-buffer crypt-vec) (write-region nil nil outfile))))) @@ -495,11 +495,11 @@ directory. File names will be also encrypted." ;; (declare (completion tramp-crypt-command-completion-p)) (interactive "DRemote directory name: ") (unless tramp-crypt-enabled - (tramp-user-error nil "Feature is not enabled.")) + (tramp-user-error nil "Feature is not enabled")) (unless (and (tramp-tramp-file-p name) (file-directory-p name)) - (tramp-user-error nil "%s must be an existing remote directory." name)) + (tramp-user-error nil "%s must be an existing remote directory" name)) (when (file-name-quoted-p name) - (tramp-user-error nil "%s must not be quoted." name)) + (tramp-user-error nil "%s must not be quoted" name)) (setq name (file-name-as-directory (expand-file-name name))) (unless (member name tramp-crypt-directories) (setq tramp-crypt-directories (cons name tramp-crypt-directories))) @@ -518,7 +518,7 @@ kept in their encrypted form." ;; (declare (completion tramp-crypt-command-completion-p)) (interactive "DRemote directory name: ") (unless tramp-crypt-enabled - (tramp-user-error nil "Feature is not enabled.")) + (tramp-user-error nil "Feature is not enabled")) (setq name (file-name-as-directory (expand-file-name name))) (when (and (member name tramp-crypt-directories) (delete diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 7323374c607..d44fd55b225 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -119,8 +119,6 @@ (defconst tramp-gvfs-enabled (ignore-errors (and (featurep 'dbusbind) - (autoload 'zeroconf-init "zeroconf") - (tramp-compat-funcall 'dbus-get-unique-name :system) (tramp-compat-funcall 'dbus-get-unique-name :session) (or (tramp-process-running-p "gvfs-fuse-daemon") (tramp-process-running-p "gvfsd-fuse")))) @@ -210,6 +208,27 @@ They are checked during start up via tramp-gvfs-interface-mounttracker)) "The list of supported methods of the mount tracking interface.") +(defconst tramp-gvfs-listmountableinfo + (if (member "ListMountableInfo" tramp-gvfs-methods-mounttracker) + "ListMountableInfo" + "listMountableInfo") + "The name of the \"listMountableInfo\" method. +It has been changed in GVFS 1.14.") + +(defconst tramp-gvfs-listmounttypes + (if (member "ListMountTypes" tramp-gvfs-methods-mounttracker) + "ListMountTypes" + "listMountTypes") + "The name of the \"listMountTypes\" method. +It has been changed in GVFS 1.14.") + +(defconst tramp-gvfs-mounttypes + (and tramp-gvfs-enabled + (dbus-call-method + :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker + tramp-gvfs-interface-mounttracker tramp-gvfs-listmounttypes)) + "The list of supported mount types of the mount tracking interface.") + (defconst tramp-gvfs-listmounts (if (member "ListMounts" tramp-gvfs-methods-mounttracker) "ListMounts" @@ -233,6 +252,12 @@ It has been changed in GVFS 1.14.") It has been changed in GVFS 1.14.") ;; <interface name='org.gtk.vfs.MountTracker'> +;; <method name='listMountableInfo'> +;; <arg name='mountables' type='a(ssasib)' direction='out'/> +;; </method> +;; <method name='listMountTypes'> +;; <arg name='mount_types' type='as' direction='out'/> +;; </method> ;; <method name='listMounts'> ;; <arg name='mount_info_list' ;; type='a{sosssssbay{aya{say}}ay}' @@ -253,6 +278,13 @@ It has been changed in GVFS 1.14.") ;; </signal> ;; </interface> ;; +;; STRUCT mountable +;; STRING type +;; STRING scheme +;; ARRAY STRING scheme_aliases +;; INT32 default_port +;; BOOLEAN host_is_inet +;; ;; STRUCT mount_info ;; STRING dbus_id ;; OBJECT_PATH object_path @@ -872,6 +904,14 @@ arguments to pass to the OPERATION." (tramp-register-foreign-file-name-handler #'tramp-gvfs-file-name-p #'tramp-gvfs-file-name-handler))) +;; Event type `dbus-event' is added to `while-no-input-ignore-events' +;; in Emacs 29.1. If it is missing, some packages like Helm report +;; problems. So we add it here. +(when (and (featurep 'dbusbind) + (not (memq 'dbus-event while-no-input-ignore-events))) + (setq while-no-input-ignore-events + (cons 'dbus-event while-no-input-ignore-events))) + ;; D-Bus helper function. @@ -1080,7 +1120,7 @@ file names." (goto-char (point-min)) (tramp-error-with-buffer nil v 'file-error - "%s failed, see buffer `%s' for details." + "%s failed, see buffer `%s' for details" msg-operation (buffer-name))) ;; Some WebDAV server, like the one from QNAP, do @@ -2144,6 +2184,18 @@ connection if a previous connection has died for some reason." (unless (tramp-connectable-p vec) (throw 'non-essential 'non-essential)) + ;; Sanity check. + (let ((method (tramp-file-name-method vec))) + (unless (member + (or (rassoc method '(("smb" . "smb-share") + ("davs" . "dav") + ("nextcloud" . "dav") + ("afp". "afp-volume") + ("gdrive" . "google-drive"))) + method) + tramp-gvfs-mounttypes) + (tramp-error vec 'file-error "Method `%s' not supported by GVFS" method))) + ;; For password handling, we need a process bound to the connection ;; buffer. Therefore, we create a dummy process. Maybe there is a ;; better solution? @@ -2487,43 +2539,45 @@ This uses \"avahi-browse\" in case D-Bus is not enabled in Avahi." ;; Suppress D-Bus error messages and Tramp traces. (let ((tramp-verbose 0) tramp-gvfs-dbus-event-vector fun) - ;; Add completion functions for services announced by DNS-SD. - ;; See <http://www.dns-sd.org/ServiceTypes.html> for valid service types. - (zeroconf-init tramp-gvfs-zeroconf-domain) - (when (setq fun (or (and (zeroconf-list-service-types) - #'tramp-zeroconf-parse-device-names) - (and (executable-find "avahi-browse") - #'tramp-gvfs-parse-device-names))) - (when (member "afp" tramp-gvfs-methods) - (tramp-set-completion-function - "afp" `((,fun "_afpovertcp._tcp")))) - (when (member "dav" tramp-gvfs-methods) - (tramp-set-completion-function - "dav" `((,fun "_webdav._tcp") - (,fun "_webdavs._tcp")))) - (when (member "davs" tramp-gvfs-methods) - (tramp-set-completion-function - "davs" `((,fun "_webdav._tcp") - (,fun "_webdavs._tcp")))) - (when (member "ftp" tramp-gvfs-methods) - (tramp-set-completion-function - "ftp" `((,fun "_ftp._tcp")))) - (when (member "http" tramp-gvfs-methods) - (tramp-set-completion-function - "http" `((,fun "_http._tcp") - (,fun "_https._tcp")))) - (when (member "https" tramp-gvfs-methods) - (tramp-set-completion-function - "https" `((,fun "_http._tcp") - (,fun "_https._tcp")))) - (when (member "sftp" tramp-gvfs-methods) - (tramp-set-completion-function - "sftp" `((,fun "_sftp-ssh._tcp") - (,fun "_ssh._tcp") - (,fun "_workstation._tcp")))) - (when (member "smb" tramp-gvfs-methods) - (tramp-set-completion-function - "smb" `((,fun "_smb._tcp"))))) + (when (and (autoload 'zeroconf-init "zeroconf") + (tramp-compat-funcall 'dbus-get-unique-name :system)) + ;; Add completion functions for services announced by DNS-SD. + ;; See <http://www.dns-sd.org/ServiceTypes.html> for valid service types. + (zeroconf-init tramp-gvfs-zeroconf-domain) + (when (setq fun (or (and (zeroconf-list-service-types) + #'tramp-zeroconf-parse-device-names) + (and (executable-find "avahi-browse") + #'tramp-gvfs-parse-device-names))) + (when (member "afp" tramp-gvfs-methods) + (tramp-set-completion-function + "afp" `((,fun "_afpovertcp._tcp")))) + (when (member "dav" tramp-gvfs-methods) + (tramp-set-completion-function + "dav" `((,fun "_webdav._tcp") + (,fun "_webdavs._tcp")))) + (when (member "davs" tramp-gvfs-methods) + (tramp-set-completion-function + "davs" `((,fun "_webdav._tcp") + (,fun "_webdavs._tcp")))) + (when (member "ftp" tramp-gvfs-methods) + (tramp-set-completion-function + "ftp" `((,fun "_ftp._tcp")))) + (when (member "http" tramp-gvfs-methods) + (tramp-set-completion-function + "http" `((,fun "_http._tcp") + (,fun "_https._tcp")))) + (when (member "https" tramp-gvfs-methods) + (tramp-set-completion-function + "https" `((,fun "_http._tcp") + (,fun "_https._tcp")))) + (when (member "sftp" tramp-gvfs-methods) + (tramp-set-completion-function + "sftp" `((,fun "_sftp-ssh._tcp") + (,fun "_ssh._tcp") + (,fun "_workstation._tcp")))) + (when (member "smb" tramp-gvfs-methods) + (tramp-set-completion-function + "smb" `((,fun "_smb._tcp")))))) ;; Add completion functions for GNOME Online Accounts. (tramp-get-goa-accounts nil) @@ -2553,9 +2607,9 @@ This uses \"avahi-browse\" in case D-Bus is not enabled in Avahi." ;; * Host name completion for existing mount points (afp-server, ;; smb-server) or via smb-network or network. ;; +;; * What's up with the other types in `tramp-gvfs-mounttypes'? +;; ;; * Check, how two shares of the same SMB server can be mounted in ;; parallel. -;; -;; * What's up with ftps dns-sd afc admin computer? ;;; tramp-gvfs.el ends here diff --git a/lisp/net/tramp-integration.el b/lisp/net/tramp-integration.el index 5b3259eab03..d7fcd8afefa 100644 --- a/lisp/net/tramp-integration.el +++ b/lisp/net/tramp-integration.el @@ -42,9 +42,10 @@ (declare-function shortdoc-add-function "shortdoc") (declare-function tramp-dissect-file-name "tramp") (declare-function tramp-file-name-equal-p "tramp") -(declare-function tramp-tramp-file-p "tramp") (declare-function tramp-rename-files "tramp-cmds") (declare-function tramp-rename-these-files "tramp-cmds") +(declare-function tramp-set-connection-local-variables-for-buffer "tramp") +(declare-function tramp-tramp-file-p "tramp") (defvar eshell-path-env) (defvar ido-read-file-name-non-ido) (defvar info-lookup-alist) @@ -549,6 +550,14 @@ See `tramp-process-attributes-ps-format'.") '(:application tramp :machine "localhost") local-profile)) +;; Set connection-local variables for buffers visiting a file. + +(add-hook 'find-file-hook #'tramp-set-connection-local-variables-for-buffer -50) +(add-hook 'tramp-unload-hook + (lambda () + (remove-hook + 'find-file-hook #'tramp-set-connection-local-variables-for-buffer))) + (add-hook 'tramp-unload-hook (lambda () (unload-feature 'tramp-integration 'force))) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 24e90447b24..2df3006c1d9 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -106,6 +106,9 @@ detected as prompt when being sent on echoing hosts, therefore.") (defconst tramp-end-of-heredoc (md5 tramp-end-of-output) "String used to recognize end of heredoc strings.") +(define-obsolete-variable-alias + 'tramp-use-ssh-controlmaster-options 'tramp-use-connection-share "30.1") + (defcustom tramp-use-connection-share (not (eq system-type 'windows-nt)) "Whether to use connection share in ssh or PuTTY. Set it to t, if you want Tramp to apply respective options. These @@ -122,11 +125,6 @@ Set it to `suppress' if you want to disable settings in your ;; Check with (safe-local-variable-p 'tramp-use-connection-share 'suppress) :safe (lambda (val) (and (memq val '(t nil suppress)) t))) -(defvaralias 'tramp-use-connection-share 'tramp-use-ssh-controlmaster-options) -(make-obsolete-variable - 'tramp-use-ssh-controlmaster-options - "Use `tramp-use-connection-share' instead" "30.1") - (defvar tramp-ssh-controlmaster-options nil "Which ssh Control* arguments to use. @@ -1149,8 +1147,8 @@ Operations not mentioned here will be handled by the normal Emacs functions.") (unless (tramp-get-remote-ln v) (tramp-error v 'file-error - (concat "Making a symbolic link. " - "ln(1) does not exist on the remote host.")))) + (concat "Making a symbolic link: " + "ln(1) does not exist on the remote host")))) (tramp-skeleton-handle-make-symbolic-link target linkname ok-if-already-exists (and (tramp-send-command-and-check @@ -2152,7 +2150,7 @@ the uid and gid from FILENAME." cmd-result) (tramp-error-with-buffer nil v 'file-error - "Copying directly failed, see buffer `%s' for details." + "Copying directly failed, see buffer `%s' for details" (buffer-name))))) ;; We are on the local host. @@ -2207,7 +2205,7 @@ the uid and gid from FILENAME." "%s %s %s" cmd (tramp-shell-quote-argument localname1) (tramp-shell-quote-argument tmpfile)) - "Copying directly failed, see buffer `%s' for details." + "Copying directly failed, see buffer `%s' for details" (tramp-get-buffer v)) ;; We must change the ownership as remote user. ;; Since this does not work reliable, we also @@ -2240,7 +2238,7 @@ the uid and gid from FILENAME." "cp -f -p %s %s" (tramp-shell-quote-argument tmpfile) (tramp-shell-quote-argument localname2)) - "Copying directly failed, see buffer `%s' for details." + "Copying directly failed, see buffer `%s' for details" (tramp-get-buffer v))) (t1 (tramp-run-real-handler @@ -4498,7 +4496,7 @@ process to set up. VEC specifies the connection." ;; Set `remote-tty' process property. (let ((tty (tramp-send-command-and-read vec "echo \\\"`tty`\\\"" 'noerror))) - (unless (string-empty-p tty) + (unless (tramp-string-empty-or-nil-p tty) (process-put proc 'remote-tty tty) (tramp-set-connection-property proc "remote-tty" tty))) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 740841c24db..13d5e17a9ff 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -692,7 +692,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; "rmdir" does not report an error. So we check ourselves. (when (file-exists-p directory) - (tramp-error v 'file-error "`%s' not removed." directory))))) + (tramp-error v 'file-error "`%s' not removed" directory))))) (defun tramp-smb-handle-delete-file (filename &optional trash) "Like `delete-file' for Tramp files." @@ -800,32 +800,31 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (append args (list (tramp-unquote-shell-quote-argument localname) (concat "2>" (tramp-get-remote-null-device v))))) - (unwind-protect - (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 'tramp-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 'tramp-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." @@ -1401,44 +1400,43 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." "&&" "echo" "tramp_exit_status" "0" "||" "echo" "tramp_exit_status" "1"))) - (unwind-protect - (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 'tramp-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 (rx "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 'tramp-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 (rx "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." diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index 6b788c00ba6..a4f6246ec23 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -244,8 +244,8 @@ arguments to pass to the OPERATION." (setq result (insert-file-contents (tramp-fuse-local-file-name filename) visit beg end replace)) - (when visit (setq buffer-file-name filename)) - (cons filename (cdr result))))) + (when visit (setq buffer-file-name filename))) + (cons filename (cdr result)))) (defun tramp-sshfs-handle-process-file (program &optional infile destination display &rest args) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 6eff5b2ca60..3420bb76d14 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -1722,11 +1722,11 @@ default values are used." (unless (or nodefault non-essential (assoc method tramp-methods)) (tramp-user-error - v "Method `%s' is not known." method)) + v "Method `%s' is not known" method)) ;; Only some methods from tramp-sh.el do support multi-hops. (unless (or (null hop) nodefault non-essential (tramp-multi-hop-p v)) (tramp-user-error - v "Method `%s' is not supported for multi-hops." method))))))) + v "Method `%s' is not supported for multi-hops" method))))))) (put #'tramp-dissect-file-name 'tramp-suppress-trace t) @@ -1755,7 +1755,7 @@ See `tramp-dissect-file-name' for details." ;; Only some methods from tramp-sh.el do support multi-hops. (unless (or nodefault non-essential (tramp-multi-hop-p v)) (tramp-user-error - v "Method `%s' is not supported for multi-hops." + v "Method `%s' is not supported for multi-hops" (tramp-file-name-method v))) ;; Return result. v)) @@ -3936,7 +3936,7 @@ Let-bind it when necessary.") ;; Some handlers for `tramp-get-remote-uid' return nil if they ;; can't get the UID; always return -1 in this case for ;; consistency. - -1))) + tramp-unknown-id-integer))) (defun tramp-handle-access-file (filename string) "Like `access-file' for Tramp files." @@ -4791,10 +4791,12 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") (delete-file lockname) ;; Trigger the unlock error. (signal 'file-error `("Cannot remove lock file for" ,file))) - ;; `userlock--handle-unlock-error' exists since Emacs 28.1. - (error - (when create-lockfiles - (tramp-compat-funcall 'userlock--handle-unlock-error err))))) + ;; `userlock--handle-unlock-error' exists since Emacs 28.1. It + ;; checks for `create-lockfiles' since Emacs 30.1, we don't need + ;; this check here, then. + (error (unless (or (not create-lockfiles) + (bound-and-true-p remote-file-name-inhibit-locks)) + (tramp-compat-funcall 'userlock--handle-unlock-error err))))) (defun tramp-handle-load (file &optional noerror nomessage nosuffix must-suffix) "Like `load' for Tramp files." @@ -4896,7 +4898,7 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") (unless (tramp-multi-hop-p item) (setq tramp-default-proxies-alist saved-tdpa) (tramp-user-error - vec "Method `%s' is not supported for multi-hops." + vec "Method `%s' is not supported for multi-hops" (tramp-file-name-method item))))) ;; Some methods ("su", "sg", "sudo", "doas", "ksu") do not use the @@ -5815,7 +5817,7 @@ If the user quits via `C-g', it is propagated up to `tramp-file-name-handler'." (v (process-get proc 'tramp-vector))) (dolist (p (delq proc (process-list))) (when (tramp-file-name-equal-p v (process-get p 'tramp-vector)) - (accept-process-output p 0 nil t)))) + (with-local-quit (accept-process-output p 0 nil t))))) (with-current-buffer (process-buffer proc) (let ((inhibit-read-only t) diff --git a/lisp/org/ob-comint.el b/lisp/org/ob-comint.el index 54bf5127e16..adfe31c4008 100644 --- a/lisp/org/ob-comint.el +++ b/lisp/org/ob-comint.el @@ -81,19 +81,7 @@ or user `keyboard-quit' during execution of body." (let* ((string-buffer "") (comint-output-filter-functions (cons (lambda (text) - (setq string-buffer - (concat - string-buffer - ;; Upon concatenation, the prompt may no - ;; longer match `comint-prompt-regexp'. - ;; In particular, when the regexp has ^ - ;; and the output does not contain - ;; trailing newline. Use more reliable - ;; match to split the output later. - (replace-regexp-in-string - comint-prompt-regexp - ,org-babel-comint-prompt-separator - text)))) + (setq string-buffer (concat string-buffer text))) comint-output-filter-functions)) dangling-text) ;; got located, and save dangling text @@ -108,21 +96,28 @@ or user `keyboard-quit' during execution of body." (while (progn (goto-char comint-last-input-end) (not (save-excursion - (and (re-search-forward - (regexp-quote ,eoe-indicator) nil t) - (re-search-forward - comint-prompt-regexp nil t))))) + (and (re-search-forward + (regexp-quote ,eoe-indicator) nil t) + (re-search-forward + comint-prompt-regexp nil t))))) (accept-process-output (get-buffer-process (current-buffer)))) ;; replace cut dangling text (goto-char (process-mark (get-buffer-process (current-buffer)))) (insert dangling-text) - ;; Replace partially supplied input lines. - ;; This is needed when output filter spits partial lines that - ;; do not include a full prompt at a time. + ;; Filter out prompts. (setq string-buffer (replace-regexp-in-string - comint-prompt-regexp + ;; Sometimes, we get multiple agglomerated + ;; prompts together in a single output: + ;; "prompt prompt prompt output" + ;; Remove them progressively, so that + ;; possible "^" in the prompt regexp gets to + ;; work as we remove the heading prompt + ;; instance. + (if (string-prefix-p "^" comint-prompt-regexp) + (format "^\\(%s\\)+" (substring comint-prompt-regexp 1)) + comint-prompt-regexp) ,org-babel-comint-prompt-separator string-buffer)) ;; remove echo'd FULL-BODY from input diff --git a/lisp/org/ob-core.el b/lisp/org/ob-core.el index 3f6696fce77..e69ce4f1d12 100644 --- a/lisp/org/ob-core.el +++ b/lisp/org/ob-core.el @@ -2426,7 +2426,8 @@ INFO may provide the values of these header arguments (in the (delete-region (point) (org-babel-result-end))) ((member "append" result-params) (goto-char (org-babel-result-end)) (setq beg (point-marker))) - ((member "prepend" result-params))) ; already there + ;; ((member "prepend" result-params)) ; already there + ) (setq results-switches (if results-switches (concat " " results-switches) "")) (let ((wrap diff --git a/lisp/org/org-table.el b/lisp/org/org-table.el index 5116b1127f7..a38f2a283d7 100644 --- a/lisp/org/org-table.el +++ b/lisp/org/org-table.el @@ -2861,7 +2861,7 @@ list, `literal' is for the format specifier L." (if lispp (if (eq lispp 'literal) elements - (if (and (eq elements "") (not keep-empty)) + (if (and (equal elements "") (not keep-empty)) "" (prin1-to-string (if numbers (string-to-number elements) elements)))) diff --git a/lisp/org/org-version.el b/lisp/org/org-version.el index 20636a3dd04..43fdcb82832 100644 --- a/lisp/org/org-version.el +++ b/lisp/org/org-version.el @@ -5,13 +5,13 @@ (defun org-release () "The release version of Org. Inserted by installing Org mode or when a release is made." - (let ((org-release "9.6.1")) + (let ((org-release "9.6.3")) org-release)) ;;;###autoload (defun org-git-version () "The Git version of Org mode. Inserted by installing Org or when a release is made." - (let ((org-git-version "release_9.6.1-48-g92471e")) + (let ((org-git-version "release_9.6.3-2-gf2949d")) org-git-version)) (provide 'org-version) diff --git a/lisp/org/org.el b/lisp/org/org.el index 2fbb825015f..be9d0e32dd0 100644 --- a/lisp/org/org.el +++ b/lisp/org/org.el @@ -9,7 +9,7 @@ ;; URL: https://orgmode.org ;; Package-Requires: ((emacs "26.1")) -;; Version: 9.6.1 +;; Version: 9.6.3 ;; This file is part of GNU Emacs. ;; @@ -3600,13 +3600,13 @@ following symbols: (const :tag "Entities" entities)))) (defcustom org-hide-emphasis-markers nil - "Non-nil mean font-lock should hide the emphasis marker characters." + "Non-nil means font-lock should hide the emphasis marker characters." :group 'org-appearance :type 'boolean :safe #'booleanp) (defcustom org-hide-macro-markers nil - "Non-nil mean font-lock should hide the brackets marking macro calls." + "Non-nil means font-lock should hide the brackets marking macro calls." :group 'org-appearance :type 'boolean) @@ -3618,7 +3618,7 @@ When nil, the \\name form remains in the buffer." :type 'boolean) (defcustom org-pretty-entities-include-sub-superscripts t - "Non-nil means, pretty entity display includes formatting sub/superscripts." + "Non-nil means pretty entity display includes formatting sub/superscripts." :group 'org-appearance :version "24.1" :type 'boolean) @@ -10215,7 +10215,7 @@ nil." (replace-match "") (if (and (string-match "\\S-" (buffer-substring (line-beginning-position) (point))) (equal (char-before) ?\ )) - (backward-delete-char 1) + (delete-char -1) (when (string-match "^[ \t]*$" (buffer-substring (line-beginning-position) (line-end-position))) (delete-region (line-beginning-position) @@ -12006,18 +12006,17 @@ Returns the new tags string, or nil to not change the current settings." (setq current nil) (when exit-after-next (setq exit-after-next 'now))) ((= c ?\t) - (condition-case nil - (unless tab-tags - (setq tab-tags - (delq nil - (mapcar (lambda (x) - (let ((item (car-safe x))) - (and (stringp item) - (list item)))) - (org--tag-add-to-alist - (with-current-buffer buf - (org-get-buffer-tags)) - table)))))) + (unless tab-tags + (setq tab-tags + (delq nil + (mapcar (lambda (x) + (let ((item (car-safe x))) + (and (stringp item) + (list item)))) + (org--tag-add-to-alist + (with-current-buffer buf + (org-get-buffer-tags)) + table))))) (setq tg (completing-read "Tag: " tab-tags)) (when (string-match "\\S-" tg) (cl-pushnew (list tg) tab-tags :test #'equal) @@ -16532,7 +16531,7 @@ because, in this case the deletion might narrow the column." (looking-at-p ".*?|") (org-at-table-p)) (progn (forward-char -1) (org-delete-char 1)) - (backward-delete-char N) + (funcall-interactively #'backward-delete-char N) (org-fix-tags-on-the-fly)))) (defun org-delete-char (N) diff --git a/lisp/org/ox-texinfo.el b/lisp/org/ox-texinfo.el index 4ff482cc3f5..f822f3d110c 100644 --- a/lisp/org/ox-texinfo.el +++ b/lisp/org/ox-texinfo.el @@ -2037,10 +2037,13 @@ Once computed, the results remain cached." "\n"))) (with-temp-file input-file (insert input-content)) - (let* ((output-file (org-texinfo-compile input-file)) - (output-content (with-temp-buffer - (insert-file-contents output-file) - (buffer-string)))) + (when-let* ((output-file + ;; If compilation fails, consider math to + ;; be not supported. + (ignore-errors (org-texinfo-compile input-file))) + (output-content (with-temp-buffer + (insert-file-contents output-file) + (buffer-string)))) (let ((result (string-match-p (regexp-quote math-example) output-content))) (delete-file input-file) diff --git a/lisp/outline.el b/lisp/outline.el index a89985d1990..0e90c59c285 100644 --- a/lisp/outline.el +++ b/lisp/outline.el @@ -1877,7 +1877,7 @@ With a prefix argument, show headings up to that LEVEL." (save-excursion (goto-char beg) (setq beg (pos-bol))) (save-excursion (goto-char end) (setq end (pos-eol))) (remove-overlays beg end 'outline-button t) - (outline--fix-up-all-buttons beg end)) + (save-match-data (outline--fix-up-all-buttons beg end))) (defvar-keymap outline-navigation-repeat-map diff --git a/lisp/progmodes/c-ts-common.el b/lisp/progmodes/c-ts-common.el index 85db39aaeae..e0a7c46508e 100644 --- a/lisp/progmodes/c-ts-common.el +++ b/lisp/progmodes/c-ts-common.el @@ -156,10 +156,12 @@ comment." (goto-char (match-beginning 1)) (move-marker start-marker (point)) (replace-match " " nil nil nil 1)) + ;; Include whitespaces before /*. (goto-char start) (beginning-of-line) (setq start (point)) + ;; Mask spaces before "*/" if it is attached at the end ;; of a sentence rather than on its own line. (goto-char end) @@ -172,6 +174,7 @@ comment." (setq end-len (- (match-end 1) (match-beginning 1))) (replace-match (make-string end-len ?x) nil nil nil 1)) + ;; If "*/" is on its own line, don't included it in the ;; filling region. (when (not end-marker) @@ -180,13 +183,21 @@ comment." (backward-char 2) (skip-syntax-backward "-") (setq end (point)))) + ;; Let `fill-paragraph' do its thing. (goto-char orig-point) (narrow-to-region start end) - ;; We don't want to fill the region between START and - ;; START-MARKER, otherwise the filling function might delete - ;; some spaces there. - (fill-region start-marker end arg) + (let (para-start para-end) + (forward-paragraph 1) + (setq para-end (point)) + (forward-paragraph -1) + (setq para-start (point)) + ;; We don't want to fill the region between START and + ;; START-MARKER, otherwise the filling function might delete + ;; some spaces there. Also, we only fill the current + ;; paragraph. + (fill-region (max start-marker para-start) (min end para-end) arg)) + ;; Unmask. (when start-marker (goto-char start-marker) diff --git a/lisp/progmodes/c-ts-mode.el b/lisp/progmodes/c-ts-mode.el index 1c55c7fbdde..e93a0fec707 100644 --- a/lisp/progmodes/c-ts-mode.el +++ b/lisp/progmodes/c-ts-mode.el @@ -79,6 +79,7 @@ (declare-function treesit-node-type "treesit.c") (declare-function treesit-node-prev-sibling "treesit.c") (declare-function treesit-node-first-child-for-pos "treesit.c") +(declare-function treesit-node-next-sibling "treesit.c") ;;; Custom variables @@ -192,6 +193,10 @@ To set the default indent style globally, use (c-ts-mode--get-indent-style (if (derived-mode-p 'c-ts-mode) 'c 'cpp)))))) +(defvar c-ts-mode-emacs-devel nil + "If the value is t, enable Emacs source-specific features. +This needs to be set before enabling `c-ts-mode'.") + ;;; Syntax table (defvar c-ts-mode--syntax-table @@ -322,7 +327,7 @@ PARENT is the same as other anchor functions." ;; nil. parent (lambda (node) (and node - (not (string-match "preproc" (treesit-node-type node))) + (not (string-search "preproc" (treesit-node-type node))) (progn (goto-char (treesit-node-start node)) (looking-back (rx bol (* whitespace)) @@ -386,7 +391,7 @@ MODE is either `c' or `cpp'." ((parent-is "function_definition") parent-bol 0) ((parent-is "conditional_expression") first-sibling 0) ((parent-is "assignment_expression") parent-bol c-ts-mode-indent-offset) - ((parent-is "concatenated_string") parent-bol c-ts-mode-indent-offset) + ((parent-is "concatenated_string") first-sibling 0) ((parent-is "comma_expression") first-sibling 0) ((parent-is "init_declarator") parent-bol c-ts-mode-indent-offset) ((parent-is "parenthesized_expression") first-sibling 1) @@ -434,6 +439,8 @@ MODE is either `c' or `cpp'." ((parent-is "while_statement") standalone-parent c-ts-mode-indent-offset) ((parent-is "do_statement") standalone-parent c-ts-mode-indent-offset) + ((parent-is "case_statement") standalone-parent c-ts-mode-indent-offset) + ,@(when (eq mode 'cpp) `(((node-is "field_initializer_list") parent-bol ,(* c-ts-mode-indent-offset 2))))))) `((gnu @@ -800,7 +807,14 @@ Return nil if NODE is not a defun node or doesn't have a name." ((or "struct_specifier" "enum_specifier" "union_specifier" "class_specifier" "namespace_definition") - (treesit-node-child-by-field-name node "name"))) + (treesit-node-child-by-field-name node "name")) + ;; DEFUNs in Emacs source. + ("expression_statement" + (let* ((call-exp-1 (treesit-node-child node 0)) + (call-exp-2 (treesit-node-child call-exp-1 0)) + (arg-list (treesit-node-child call-exp-2 1)) + (name (treesit-node-child arg-list 1 t))) + name))) t)) ;;; Defun navigation @@ -808,28 +822,29 @@ Return nil if NODE is not a defun node or doesn't have a name." (defun c-ts-mode--defun-valid-p (node) "Return non-nil if NODE is a valid defun node. Ie, NODE is not nested." - (not (or (and (member (treesit-node-type node) - '("struct_specifier" - "enum_specifier" - "union_specifier" - "declaration")) - ;; If NODE's type is one of the above, make sure it is - ;; top-level. - (treesit-node-top-level - node (rx (or "function_definition" - "type_definition" - "struct_specifier" + (or (c-ts-mode--emacs-defun-p node) + (not (or (and (member (treesit-node-type node) + '("struct_specifier" "enum_specifier" "union_specifier" - "declaration")))) + "declaration")) + ;; If NODE's type is one of the above, make sure it is + ;; top-level. + (treesit-node-top-level + node (rx (or "function_definition" + "type_definition" + "struct_specifier" + "enum_specifier" + "union_specifier" + "declaration")))) - (and (equal (treesit-node-type node) "declaration") - ;; If NODE is a declaration, make sure it is not a - ;; function declaration. - (equal (treesit-node-type - (treesit-node-child-by-field-name - node "declarator")) - "function_declarator"))))) + (and (equal (treesit-node-type node) "declaration") + ;; If NODE is a declaration, make sure it is not a + ;; function declaration. + (equal (treesit-node-type + (treesit-node-child-by-field-name + node "declarator")) + "function_declarator")))))) (defun c-ts-mode--defun-for-class-in-imenu-p (node) "Check if NODE is a valid entry for the Class subindex. @@ -857,17 +872,85 @@ the semicolon. This function skips the semicolon." (goto-char (match-end 0))) (treesit-default-defun-skipper)) +(defun c-ts-base--before-indent (args) + (pcase-let ((`(,node ,parent ,bol) args)) + (when (null node) + (let ((smallest-node (treesit-node-at (point)))) + ;; "Virtual" closer curly added by the + ;; parser's error recovery. + (when (and (equal (treesit-node-type smallest-node) "}") + (equal (treesit-node-end smallest-node) + (treesit-node-start smallest-node))) + (setq parent (treesit-node-parent smallest-node))))) + (list node parent bol))) + +(defun c-ts-mode--emacs-defun-p (node) + "Return non-nil if NODE is a DEFUN in Emacs source files." + (and (equal (treesit-node-type node) "expression_statement") + (equal (treesit-node-text + (treesit-node-child-by-field-name + (treesit-node-child + (treesit-node-child node 0) 0) + "function") + t) + "DEFUN"))) + +(defun c-ts-mode--emacs-defun-at-point (&optional range) + "Return the current defun node. + +This function recognizes DEFUNs in Emacs source files. + +Note that for the case of a DEFUN, it is made of two separate +nodes, one for the declaration and one for the body, this +function returns the declaration node. + +If RANGE is non-nil, return (BEG . END) where BEG end END +encloses the whole defun. This solves the problem of only +returning the declaration part for DEFUN." + (or (when-let ((node (treesit-defun-at-point))) + (if range + (cons (treesit-node-start node) + (treesit-node-end node)) + node)) + (and c-ts-mode-emacs-devel + (let ((candidate-1 ; For when point is in the DEFUN statement. + (treesit-node-prev-sibling + (treesit-node-top-level + (treesit-node-at (point)) + "compound_statement"))) + (candidate-2 ; For when point is in the body. + (treesit-node-top-level + (treesit-node-at (point)) + "expression_statement"))) + (when-let + ((node (or (and (c-ts-mode--emacs-defun-p candidate-1) + candidate-1) + (and (c-ts-mode--emacs-defun-p candidate-2) + candidate-2)))) + (if range + (cons (treesit-node-start node) + (treesit-node-end + (treesit-node-next-sibling node))) + node)))))) + (defun c-ts-mode-indent-defun () "Indent the current top-level declaration syntactically. `treesit-defun-type-regexp' defines what constructs to indent." (interactive "*") (when-let ((orig-point (point-marker)) - (node (treesit-defun-at-point))) - (indent-region (treesit-node-start node) - (treesit-node-end node)) + (range (c-ts-mode--emacs-defun-at-point t))) + (indent-region (car range) (cdr range)) (goto-char orig-point))) +(defun c-ts-mode--emacs-current-defun-name () + "Return the name of the current defun. +This is used for `add-log-current-defun-function'. This +recognizes DEFUN in Emacs sources, in addition to normal function +definitions." + (or (treesit-add-log-current-defun) + (c-ts-mode--defun-name (c-ts-mode--emacs-defun-at-point)))) + ;;; Modes (defvar-keymap c-ts-base-mode-map @@ -919,20 +1002,23 @@ the semicolon. This function skips the semicolon." "goto_statement" "case_statement"))) + ;; IMO it makes more sense to define what's NOT sexp, since sexp by + ;; spirit, especially when used for movement, is like "expression" + ;; or "syntax unit". --yuan (setq-local treesit-sexp-type-regexp - (regexp-opt '("preproc" - "declarator" - "qualifier" - "type" - "parameter" - "expression" - "literal" - "string"))) + ;; It more useful to include semicolons as sexp so that + ;; users can move to the end of a statement. + (rx (not (or "{" "}" "[" "]" "(" ")" ",")))) ;; Nodes like struct/enum/union_specifier can appear in ;; function_definitions, so we need to find the top-level node. (setq-local treesit-defun-prefer-top-level t) + ;; When the code is in incomplete state, try to make a better guess + ;; about which node to indent against. + (add-function :filter-args (local 'treesit-indent-function) + #'c-ts-base--before-indent) + ;; Indent. (when (eq c-ts-mode-indent-style 'linux) (setq-local indent-tabs-mode t)) @@ -1008,7 +1094,11 @@ in your configuration." (setq-local treesit-font-lock-settings (c-ts-mode--font-lock-settings 'c)) ;; Navigation. (setq-local treesit-defun-tactic 'top-level) - (treesit-major-mode-setup))) + (treesit-major-mode-setup) + + (when c-ts-mode-emacs-devel + (setq-local add-log-current-defun-function + #'c-ts-mode--emacs-current-defun-name)))) ;;;###autoload (define-derived-mode c++-ts-mode c-ts-base-mode "C++" @@ -1025,7 +1115,11 @@ To use tree-sitter C/C++ modes by default, evaluate (add-to-list \\='major-mode-remap-alist \\='(c-or-c++-mode . c-or-c++-ts-mode)) -in your configuration." +in your configuration. + +Since this mode uses a parser, unbalanced brackets might cause +some breakage in indentation/fontification. Therefore, it's +recommended to enable `electric-pair-mode' with this mode." :group 'c++ :after-hook (c-ts-mode-set-modeline) @@ -1046,8 +1140,43 @@ in your configuration." ;; Font-lock. (setq-local treesit-font-lock-settings (c-ts-mode--font-lock-settings 'cpp)) - - (treesit-major-mode-setup))) + (treesit-major-mode-setup) + (when c-ts-mode-emacs-devel + (setq-local add-log-current-defun-function + #'c-ts-mode--emacs-current-defun-name)))) + +(easy-menu-define c-ts-mode-menu (list c-ts-mode-map c++-ts-mode-map) + "Menu for `c-ts-mode' and `c++-ts-mode'." + '("C/C++" + ["Comment Out Region" comment-region + :enable mark-active + :help "Comment out the region between the mark and point"] + ["Uncomment Region" (comment-region (region-beginning) + (region-end) '(4)) + :enable mark-active + :help "Uncomment the region between the mark and point"] + ["Indent Top-level Expression" c-ts-mode-indent-defun + :help "Indent/reindent top-level function, class, etc."] + ["Indent Line or Region" indent-for-tab-command + :help "Indent current line or region, or insert a tab"] + ["Forward Expression" forward-sexp + :help "Move forward across one balanced expression"] + ["Backward Expression" backward-sexp + :help "Move back across one balanced expression"] + "--" + ("Style..." + ["Set Indentation Style..." c-ts-mode-set-style + :help "Set C/C++ indentation style for current buffer"] + ["Show Current Indentation Style" (message "Indentation Style: %s" + c-ts-mode-indent-style) + :help "Show the name of the C/C++ indentation style for current buffer"] + ["Set Comment Style" c-ts-mode-toggle-comment-style + :help "Toglle C/C++ comment style between block and line comments"]) + "--" + ("Toggle..." + ["SubWord Mode" subword-mode + :style toggle :selected subword-mode + :help "Toggle sub-word movement and editing mode"]))) ;; We could alternatively use parsers, but if this works well, I don't ;; see the need to change. This is copied verbatim from cc-guess.el. diff --git a/lisp/progmodes/cc-defs.el b/lisp/progmodes/cc-defs.el index aa6f33e9cab..1d98b215525 100644 --- a/lisp/progmodes/cc-defs.el +++ b/lisp/progmodes/cc-defs.el @@ -2153,86 +2153,79 @@ non-nil, a caret is prepended to invert the set." ;; Record whether the `category' text property works. (if c-use-category (setq list (cons 'category-properties list))) - (let ((buf (generate-new-buffer " test")) - parse-sexp-lookup-properties - parse-sexp-ignore-comments - lookup-syntax-properties) ; XEmacs + (let ((buf (generate-new-buffer " test"))) (with-current-buffer buf - (set-syntax-table (make-syntax-table)) - - ;; For some reason we have to set some of these after the - ;; buffer has been made current. (Specifically, - ;; `parse-sexp-ignore-comments' in Emacs 21.) - (setq parse-sexp-lookup-properties t - parse-sexp-ignore-comments t - lookup-syntax-properties t) - - ;; Find out if the `syntax-table' text property works. - (modify-syntax-entry ?< ".") - (modify-syntax-entry ?> ".") - (insert "<()>") - (c-mark-<-as-paren (point-min)) - (c-mark->-as-paren (+ 3 (point-min))) - (goto-char (point-min)) - (c-forward-sexp) - (if (= (point) (+ 4 (point-min))) - (setq list (cons 'syntax-properties list)) - (error (concat - "CC Mode is incompatible with this version of Emacs - " - "support for the `syntax-table' text property " - "is required."))) - - ;; Find out if "\\s!" (generic comment delimiters) work. - (c-safe - (modify-syntax-entry ?x "!") - (if (string-match "\\s!" "x") - (setq list (cons 'gen-comment-delim list)))) - - ;; Find out if "\\s|" (generic string delimiters) work. - (c-safe - (modify-syntax-entry ?x "|") - (if (string-match "\\s|" "x") - (setq list (cons 'gen-string-delim list)))) - - ;; See if POSIX char classes work. - (when (and (string-match "[[:alpha:]]" "a") - ;; All versions of Emacs 21 so far haven't fixed - ;; char classes in `skip-chars-forward' and - ;; `skip-chars-backward'. - (progn - (delete-region (point-min) (point-max)) - (insert "foo123") - (skip-chars-backward "[:alnum:]") - (bobp)) - (= (skip-chars-forward "[:alpha:]") 3)) - (setq list (cons 'posix-char-classes list))) - - ;; See if `open-paren-in-column-0-is-defun-start' exists and - ;; isn't buggy (Emacs >= 21.4). - (when (boundp 'open-paren-in-column-0-is-defun-start) - (let ((open-paren-in-column-0-is-defun-start nil) - (parse-sexp-ignore-comments t)) - (delete-region (point-min) (point-max)) - (set-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\' "\"") - (cond - ;; XEmacs. Afaik this is currently an Emacs-only - ;; feature, but it's good to be prepared. - ((memq '8-bit list) - (modify-syntax-entry ?/ ". 1456") - (modify-syntax-entry ?* ". 23")) - ;; Emacs - ((memq '1-bit list) - (modify-syntax-entry ?/ ". 124b") - (modify-syntax-entry ?* ". 23"))) - (modify-syntax-entry ?\n "> b") - (insert "/* '\n () */") - (backward-sexp) - (if (bobp) - (setq list (cons 'col-0-paren list))))) - - (set-buffer-modified-p nil)) - (kill-buffer buf)) + (let ((parse-sexp-lookup-properties t) + (parse-sexp-ignore-comments t) + (lookup-syntax-properties t)) + (set-syntax-table (make-syntax-table)) + + ;; Find out if the `syntax-table' text property works. + (modify-syntax-entry ?< ".") + (modify-syntax-entry ?> ".") + (insert "<()>") + (c-mark-<-as-paren (point-min)) + (c-mark->-as-paren (+ 3 (point-min))) + (goto-char (point-min)) + (c-forward-sexp) + (if (= (point) (+ 4 (point-min))) + (setq list (cons 'syntax-properties list)) + (error (concat + "CC Mode is incompatible with this version of Emacs - " + "support for the `syntax-table' text property " + "is required."))) + + ;; Find out if "\\s!" (generic comment delimiters) work. + (c-safe + (modify-syntax-entry ?x "!") + (if (string-match "\\s!" "x") + (setq list (cons 'gen-comment-delim list)))) + + ;; Find out if "\\s|" (generic string delimiters) work. + (c-safe + (modify-syntax-entry ?x "|") + (if (string-match "\\s|" "x") + (setq list (cons 'gen-string-delim list)))) + + ;; See if POSIX char classes work. + (when (and (string-match "[[:alpha:]]" "a") + ;; All versions of Emacs 21 so far haven't fixed + ;; char classes in `skip-chars-forward' and + ;; `skip-chars-backward'. + (progn + (delete-region (point-min) (point-max)) + (insert "foo123") + (skip-chars-backward "[:alnum:]") + (bobp)) + (= (skip-chars-forward "[:alpha:]") 3)) + (setq list (cons 'posix-char-classes list))) + + ;; See if `open-paren-in-column-0-is-defun-start' exists and + ;; isn't buggy (Emacs >= 21.4). + (when (boundp 'open-paren-in-column-0-is-defun-start) + (let ((open-paren-in-column-0-is-defun-start nil) + (parse-sexp-ignore-comments t)) + (delete-region (point-min) (point-max)) + (set-syntax-table (make-syntax-table)) + (modify-syntax-entry ?\' "\"") + (cond + ;; XEmacs. Afaik this is currently an Emacs-only + ;; feature, but it's good to be prepared. + ((memq '8-bit list) + (modify-syntax-entry ?/ ". 1456") + (modify-syntax-entry ?* ". 23")) + ;; Emacs + ((memq '1-bit list) + (modify-syntax-entry ?/ ". 124b") + (modify-syntax-entry ?* ". 23"))) + (modify-syntax-entry ?\n "> b") + (insert "/* '\n () */") + (backward-sexp) + (if (bobp) + (setq list (cons 'col-0-paren list))))) + + (set-buffer-modified-p nil)) + (kill-buffer buf))) ;; Check how many elements `parse-partial-sexp' returns. (let ((ppss-size (or (c-safe (length diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el index 81446c3c00b..f7320da5629 100644 --- a/lisp/progmodes/cc-engine.el +++ b/lisp/progmodes/cc-engine.el @@ -146,11 +146,6 @@ ;; "typedef" keyword. It's value is a list of the identifiers that ;; the "typedef" declares as types. ;; -;; 'c-<>-c-types-set -;; This property is set on an opening angle bracket, and indicates that -;; any "," separators within the template/generic expression have been -;; marked with a 'c-type property value 'c-<>-arg-sep (see above). -;; ;; 'c-awk-NL-prop ;; Used in AWK mode to mark the various kinds of newlines. See ;; cc-awk.el. @@ -6172,12 +6167,18 @@ comment at the start of cc-engine.el for more info." (cons (point) (cons bound-<> s))))) +(defvar c-record-type-identifiers) ; Specially for `c-brace-stack-at'. + (defun c-brace-stack-at (here) ;; Given a buffer position HERE, Return the value of the brace stack there. (save-excursion (save-restriction (widen) - (let ((c c-bs-cache) + (let (c-record-type-identifiers ; In case `c-forward-<>-arglist' would + ; otherwise record identifiers outside + ; of the restriction in force before + ; this function. + (c c-bs-cache) (can-use-prev (<= c-bs-prev-pos c-bs-cache-limit)) elt stack pos npos high-elt) ;; Trim the cache to take account of buffer changes. @@ -8630,11 +8631,9 @@ multi-line strings (but not C++, for example)." ;; List that collects the positions after the argument ;; separating ',' in the arglist. arg-start-pos) - ;; If the '<' has paren open syntax then we've marked it as an angle - ;; bracket arglist before, so skip to the end. - (if (and syntax-table-prop-on-< - (or (not c-parse-and-markup-<>-arglists) - (c-get-char-property (point) 'c-<>-c-types-set))) + (if (and (not c-parse-and-markup-<>-arglists) + syntax-table-prop-on-<) + (progn (forward-char) (if (and (c-go-up-list-forward) @@ -8731,7 +8730,6 @@ multi-line strings (but not C++, for example)." (c-unmark-<->-as-paren (point))))) (c-mark-<-as-paren start) (c-mark->-as-paren (1- (point))) - (c-put-char-property start 'c-<>-c-types-set t) (c-truncate-lit-pos-cache start)) (setq res t) nil)) ; Exit the loop. @@ -9122,7 +9120,7 @@ multi-line strings (but not C++, for example)." (c-forward-syntactic-ws)) (let ((start (point)) pos res name-res id-start id-end id-range - post-prefix-pos) + post-prefix-pos prefix-end-pos) ;; Skip leading type modifiers. If any are found we know it's a ;; prefix of a type. @@ -9132,6 +9130,7 @@ multi-line strings (but not C++, for example)." (when (looking-at c-no-type-key) (setq res 'no-id))) (goto-char (match-end 1)) + (setq prefix-end-pos (point)) (setq pos (point)) (c-forward-syntactic-ws) (or (eq res 'no-id) @@ -9283,7 +9282,10 @@ multi-line strings (but not C++, for example)." (not (looking-at c-type-decl-prefix-key))))) ;; A C specifier followed by an implicit int, e.g. ;; "register count;" - (goto-char id-start) + (goto-char prefix-end-pos) + (setq pos (point)) + (unless stop-at-end + (c-forward-syntactic-ws)) (setq res 'no-id)) (name-res @@ -9291,6 +9293,7 @@ multi-line strings (but not C++, for example)." ;; A normal identifier. (goto-char id-end) (setq pos (point)) + (c-forward-syntactic-ws) (if (or res c-promote-possible-types) (progn (when (not (eq c-promote-possible-types 'just-one)) @@ -9298,7 +9301,9 @@ multi-line strings (but not C++, for example)." (when (and c-record-type-identifiers id-range) (c-record-type-id id-range)) (unless res - (setq res 'found))) + (setq res 'found)) + (when (eq res 'prefix) + (setq res t))) (setq res (if (c-check-qualified-type id-start) ;; It's an identifier that has been used as ;; a type somewhere else. @@ -9455,19 +9460,24 @@ multi-line strings (but not C++, for example)." (setq ,ps (cdr ,ps))))) (defun c-forward-over-compound-identifier () - ;; Go over a possibly compound identifier, such as C++'s Foo::Bar::Baz, - ;; returning that identifier (with any syntactic WS removed). Return nil if - ;; we're not at an identifier. - (when (c-on-identifier) + ;; Go over a possibly compound identifier (but not any following + ;; whitespace), such as C++'s Foo::Bar::Baz, returning that identifier (with + ;; any syntactic WS removed). Return nil if we're not at an identifier, in + ;; which case point is not moved. + (when + (eq (c-on-identifier) + (point)) (let ((consolidated "") (consolidated-:: "") - start end) + (here (point)) + start end end-token) (while (progn (setq start (point)) (c-forward-over-token) (setq consolidated (concat consolidated-:: - (buffer-substring-no-properties start (point)))) + (buffer-substring-no-properties start (point))) + end-token (point)) (c-forward-syntactic-ws) (and c-opt-identifier-concat-key (looking-at c-opt-identifier-concat-key) @@ -9482,7 +9492,9 @@ multi-line strings (but not C++, for example)." (concat consolidated (buffer-substring-no-properties start end)))))))) (if (equal consolidated "") - nil + (progn (goto-char here) + nil) + (goto-char end-token) consolidated)))) (defun c-back-over-compound-identifier () @@ -9655,13 +9667,16 @@ point unchanged and return nil." ;; Handling of large scale constructs like statements and declarations. -(defun c-forward-primary-expression (&optional limit) - ;; Go over the primary expression (if any) at point, moving to the next - ;; token and return non-nil. If we're not at a primary expression leave - ;; point unchanged and return nil. +(defun c-forward-primary-expression (&optional limit stop-at-end) + ;; Go over the primary expression (if any) at point, and unless STOP-AT-END + ;; is non-nil, move to the next token then return non-nil. If we're not at + ;; a primary expression leave point unchanged and return nil. ;; ;; Note that this function is incomplete, handling only those cases expected ;; to be common in a C++20 requires clause. + ;; + ;; Note also that (...) is not recognised as a primary expression if the + ;; next token is an open brace. (let ((here (point)) (c-restricted-<>-arglists t) (c-parse-and-markup-<>-arglists nil) @@ -9669,28 +9684,38 @@ point unchanged and return nil." (if (cond ((looking-at c-constant-key) (goto-char (match-end 1)) - (c-forward-syntactic-ws limit) + (unless stop-at-end (c-forward-syntactic-ws limit)) t) ((eq (char-after) ?\() (and (c-go-list-forward (point) limit) (eq (char-before) ?\)) - (progn (c-forward-syntactic-ws limit) - t))) + (let ((after-paren (point))) + (c-forward-syntactic-ws limit) + (prog1 + (not (eq (char-after) ?{)) + (when stop-at-end + (goto-char after-paren)))))) ((c-forward-over-compound-identifier) - (c-forward-syntactic-ws limit) - (while (cond - ((looking-at "<") - (prog1 - (c-forward-<>-arglist nil) - (c-forward-syntactic-ws limit))) - ((looking-at c-opt-identifier-concat-key) - (and - (zerop (c-forward-token-2 1 nil limit)) - (prog1 - (c-forward-over-compound-identifier) - (c-forward-syntactic-ws limit)))))) - t) - ((looking-at c-fun-name-substitute-key) ; "requires" + (let ((after-id (point))) + (c-forward-syntactic-ws limit) + (while (cond + ((and + (looking-at "<") + (prog1 + (and + (c-forward-<>-arglist nil) + (setq after-id (point))))) + (c-forward-syntactic-ws limit)) + ((looking-at c-opt-identifier-concat-key) + (and + (zerop (c-forward-token-2 1 nil limit)) + (prog1 + (c-forward-over-compound-identifier) + (c-forward-syntactic-ws limit)))))) + (goto-char after-id))) + ((and + (looking-at c-fun-name-substitute-key) ; "requires" + (not (eq (char-after (match-end 0)) ?_))) (goto-char (match-end 1)) (c-forward-syntactic-ws limit) (and @@ -9703,36 +9728,47 @@ point unchanged and return nil." (and (c-go-list-forward (point) limit) (eq (char-before) ?})) (progn - (c-forward-syntactic-ws limit) + (unless stop-at-end (c-forward-syntactic-ws limit)) t)))) t (goto-char here) nil))) -(defun c-forward-c++-requires-clause (&optional limit) - ;; Point is at the keyword "requires". Move forward over the requires - ;; clause to the next token after it and return non-nil. If there is no - ;; valid requires clause at point, leave point unmoved and return nil. +(defun c-forward-constraint-clause (&optional limit stop-at-end) + ;; Point is at the putative start of a constraint clause. Move to its end + ;; (when STOP-AT-END is non-zero) or the token after that (otherwise) and + ;; return non-nil. Return nil without moving if we fail to find a + ;; constraint. (let ((here (point)) final-point) (or limit (setq limit (point-max))) - (if (and - (zerop (c-forward-token-2 1 nil limit)) ; over "requires". - (prog1 - (c-forward-primary-expression limit) - (setq final-point (point)) - (while - (and (looking-at "\\(?:&&\\|||\\)") - (progn (goto-char (match-end 0)) - (c-forward-syntactic-ws limit) - (and (< (point) limit) - (c-forward-primary-expression limit)))) - (setq final-point (point))))) - (progn (goto-char final-point) - t) + (if (c-forward-primary-expression limit t) + (progn + (setq final-point (point)) + (c-forward-syntactic-ws limit) + (while + (and (looking-at "\\(?:&&\\|||\\)") + (<= (match-end 0) limit) + (progn (goto-char (match-end 0)) + (c-forward-syntactic-ws limit) + (and (<= (point) limit))) + (c-forward-primary-expression limit t) + (setq final-point (point)))) + (goto-char final-point) + (or stop-at-end (c-forward-syntactic-ws limit)) + t) (goto-char here) nil))) +(defun c-forward-c++-requires-clause (&optional limit stop-at-end) + ;; Point is at the keyword "requires". Move forward over the requires + ;; clause to its end (if STOP-AT-END is non-nil) or the next token after it + ;; (otherwise) and return non-nil. If there is no valid requires clause at + ;; point, leave point unmoved and return nil. + (or limit (setq limit (point-max))) + (and (zerop (c-forward-token-2)) ; over "requires". + (c-forward-constraint-clause limit stop-at-end))) + (defun c-forward-decl-arglist (not-top id-in-parens &optional limit) ;; Point is at an open parenthesis, assumed to be the arglist of a function ;; declaration. Move over this arglist and following syntactic whitespace, @@ -9934,7 +9970,9 @@ point unchanged and return nil." ((looking-at c-type-decl-suffix-key) (cond ((save-match-data - (looking-at c-fun-name-substitute-key)) + (and + (looking-at c-fun-name-substitute-key) + (not (eq (char-after (match-end 0)) ?_)))) (c-forward-c++-requires-clause)) ((eq (char-after) ?\() (if (c-forward-decl-arglist not-top decorated limit) @@ -10388,7 +10426,9 @@ This function might do hidden buffer changes." (when (and (c-major-mode-is 'c++-mode) (c-keyword-member kwd-sym 'c-<>-sexp-kwds) (save-match-data - (looking-at c-fun-name-substitute-key))) + (and + (looking-at c-fun-name-substitute-key) + (not (eq (char-after (match-end 0)) ?_))))) (c-forward-c++-requires-clause)) (setq kwd-clause-end (point)))) ((and c-opt-cpp-prefix @@ -10738,7 +10778,9 @@ This function might do hidden buffer changes." ((save-match-data (looking-at "\\s(")) (c-safe (c-forward-sexp 1) t)) ((save-match-data - (looking-at c-fun-name-substitute-key)) ; C++ requires + (and + (looking-at c-fun-name-substitute-key) + (not (eq (char-after (match-end 0)) ?_)))) ; C++ requires (c-forward-c++-requires-clause)) (t (goto-char (match-end 1)) t)) @@ -11200,7 +11242,7 @@ This function might do hidden buffer changes." ;; declaration. (setq maybe-expression t) (when (or (not c-asymmetry-fontification-flag) - (looking-at "=[^=]") + (looking-at "=\\([^=]\\|$\\)\\|;") (c-fdoc-assymetric-space-about-asterisk)) (when (eq at-type 'maybe) (setq unsafe-maybe t)) @@ -12861,7 +12903,9 @@ comment at the start of cc-engine.el for more info." in-paren 'in-paren)) ((looking-at c-pre-brace-non-bracelist-key) (setq braceassignp nil)) - ((looking-at c-fun-name-substitute-key) + ((and + (looking-at c-fun-name-substitute-key) + (not (eq (char-after (match-end 0)) ?_))) (setq braceassignp nil)) ((looking-at c-return-key)) ((and (looking-at c-symbol-start) @@ -12876,7 +12920,8 @@ comment at the start of cc-engine.el for more info." ;; Have we a requires with a parenthesis list? (when (save-excursion (and (zerop (c-backward-token-2 1 nil lim)) - (looking-at c-fun-name-substitute-key))) + (looking-at c-fun-name-substitute-key) + (not (eq (char-after (match-end 0)) ?_)))) (setq braceassignp nil)) nil) (t nil)) @@ -13207,6 +13252,120 @@ comment at the start of cc-engine.el for more info." (t nil))) (goto-char here)))) +(defun c-forward-concept-fragment (&optional limit stop-at-end) + ;; Are we currently at the "concept" keyword in a concept construct? If so + ;; we return the position of the first constraint expression following the + ;; "=" sign and move forward over the constraint. Otherwise we return nil. + ;; LIMIT is a forward search limit. + (let ((here (point))) + (if + (and + (looking-at c-equals-nontype-decl-key) ; "concept" + (goto-char (match-end 0)) + (progn (c-forward-syntactic-ws limit) + (not (looking-at c-keywords-regexp))) + (looking-at c-identifier-key) + (goto-char (match-end 0)) + (progn (c-forward-syntactic-ws limit) + (looking-at c-operator-re)) + (equal (match-string 0) "=") + (goto-char (match-end 0))) + (prog1 + (progn (c-forward-syntactic-ws limit) + (point)) + (c-forward-constraint-clause limit stop-at-end)) + (goto-char here) + nil))) + +(defun c-looking-at-concept (&optional limit) + ;; Are we currently at the start of a concept construct? I.e. at the + ;; "template" keyword followed by the construct? If so, we return a cons of + ;; the position of "concept" and the position of the first constraint + ;; expression following the "=" sign, otherwise we return nil. LIMIT is a + ;; forward search limit. + (save-excursion + (let (conpos) + (and (looking-at c-pre-concept-<>-key) + (goto-char (match-end 1)) + (< (point) limit) + (progn (c-forward-syntactic-ws limit) + (eq (char-after) ?<)) + (let ((c-parse-and-markup-<>-arglists t) + c-restricted-<>-arglists) + (c-forward-<>-arglist nil)) + (< (point) limit) + (progn (c-forward-syntactic-ws limit) + (looking-at c-equals-nontype-decl-key)) ; "concept" + (setq conpos (match-beginning 0)) + (goto-char (match-end 0)) + (< (point) limit) + (c-syntactic-re-search-forward + "=" limit t t) + (goto-char (match-end 0)) + (<= (point) limit) + (progn (c-forward-syntactic-ws limit) + (cons conpos (point))))))) + +(defun c-in-requires-or-at-end-of-clause (&optional pos) + ;; Is POS (default POINT) in a C++ "requires" expression or "requires" + ;; clause or at the end of a "requires" clause? If so return a cons + ;; (POSITION . END) where POSITION is that of the "requires" keyword, and + ;; END is `expression' if POS is in an expression, nil if it's in a clause + ;; or t if it's at the end of a clause. "End of a clause" means just after + ;; the non syntactic WS on the line where the clause ends. + ;; + ;; Note we can't use `c-beginning-of-statement-1' in this function because + ;; of this function's use in `c-at-vsemi-p' for C++ Mode. + (save-excursion + (if pos (goto-char pos) (setq pos (point))) + (let ((limit (max (- (point) 2000) (point-min))) + found-req req-pos found-clause res pe-start pe-end + ) + (while ; Loop around syntactically significant "requires" keywords. + (progn + (while + (and + (setq found-req (re-search-backward + c-fun-name-substitute-key + limit t)) ; Fast! + (or (not (setq found-req + (not (eq (char-after (match-end 0)) ?_)))) + (not (setq found-req (not (c-in-literal))))))) ; Slow! + (setq req-pos (point)) + (cond + ((not found-req) ; No "requires" found + nil) + ((save-excursion ; A primary expression `pos' is in + (setq pe-end nil) + (while (and (setq pe-start (point)) + (< (point) pos) + (c-forward-primary-expression nil t) + (setq pe-end (point)) + (progn (c-forward-syntactic-ws) + (looking-at "&&\\|||")) + (c-forward-over-token-and-ws))) + pe-end) + (if (<= pe-end pos) + t ; POS is not in a primary expression. + (setq res (cons pe-start 'expression)) + nil)) + ((progn + (goto-char req-pos) + (if (looking-at c-fun-name-substitute-key) + (setq found-clause (c-forward-c++-requires-clause nil t)) + (and (c-forward-concept-fragment) + (setq found-clause (point)))) + nil)) + ((and found-clause (>= (point) pos)) + (setq res (cons req-pos (eq (point) pos))) + nil) + (found-clause ; We found a constraint clause, but it did not + ; extend far enough forward to reach POS. + (c-go-up-list-backward req-pos limit)) + (t (goto-char req-pos) + t)))) + res))) + (defun c-looking-at-inexpr-block (lim containing-sexp &optional check-at-end) ;; Return non-nil if we're looking at the beginning of a block ;; inside an expression. The value returned is actually a cons of @@ -13403,6 +13562,19 @@ comment at the start of cc-engine.el for more info." (looking-at c-pre-lambda-tokens-re))) (not (c-in-literal)))) +(defun c-c++-vsemi-p (&optional pos) + ;; C++ Only - Is there a "virtual semicolon" at POS or point? + ;; (See cc-defs.el for full details of "virtual semicolons".) + ;; + ;; This is true when point is at the last non syntactic WS position on the + ;; line, and either there is a "macro with semicolon" just before it (see + ;; `c-at-macro-vsemi-p') or there is a "requires" clause which ends there. + (let (res) + (cond + ((setq res (c-in-requires-or-at-end-of-clause pos)) + (and res (eq (cdr res) t))) + ((c-at-macro-vsemi-p))))) + (defun c-at-macro-vsemi-p (&optional pos) ;; Is there a "virtual semicolon" at POS or point? ;; (See cc-defs.el for full details of "virtual semicolons".) @@ -13954,7 +14126,7 @@ comment at the start of cc-engine.el for more info." literal char-before-ip before-ws-ip char-after-ip macro-start in-macro-expr c-syntactic-context placeholder step-type tmpsymbol keyword injava-inher special-brace-list tmp-pos - tmp-pos2 containing-< + tmp-pos2 containing-< tmp constraint-detail ;; The following record some positions for the containing ;; declaration block if we're directly within one: ;; `containing-decl-open' is the position of the open @@ -14369,6 +14541,33 @@ comment at the start of cc-engine.el for more info." containing-decl-start containing-decl-kwd)) + ;; CASE 5A.7: "defun" open in a requires expression. + ((save-excursion + (goto-char indent-point) + (c-backward-syntactic-ws lim) + (and (or (not (eq (char-before) ?\))) + (c-go-list-backward nil lim)) + (progn (c-backward-syntactic-ws lim) + (zerop (c-backward-token-2 nil nil lim))) + (looking-at c-fun-name-substitute-key) + (not (eq (char-after (match-end 0)) ?_)) + (setq placeholder (point)))) + (goto-char placeholder) + (back-to-indentation) + (c-add-syntax 'defun-open (point))) + + ;; CASE 5A.6: "defun" open in concept. + ;; ((save-excursion + ;; (goto-char indent-point) + ;; (skip-chars-forward " \t") + ;; (and (eq (char-after) ?{) + ;; (eq (c-beginning-of-statement-1 lim) 'same) + ;; (setq placeholder + ;; (cdr (c-looking-at-concept indent-point))))) + ;; (goto-char placeholder) + ;; (back-to-indentation) + ;; (c-add-syntax 'defun-open (point))) + ;; CASE 5A.5: ordinary defun open (t (save-excursion @@ -14539,10 +14738,35 @@ comment at the start of cc-engine.el for more info." nil nil containing-sexp paren-state)) + ;; CASE 5F: Close of a non-class declaration level block. + ((and (eq char-after-ip ?}) + (c-keyword-member containing-decl-kwd + 'c-other-block-decl-kwds)) + ;; This is inconsistent: Should use `containing-decl-open' + ;; here if it's at boi, like in case 5J. + (goto-char containing-decl-start) + (c-add-stmt-syntax + (if (string-equal (symbol-name containing-decl-kwd) "extern") + ;; Special case for compatibility with the + ;; extern-lang syntactic symbols. + 'extern-lang-close + (intern (concat (symbol-name containing-decl-kwd) + "-close"))) + nil t + (c-most-enclosing-brace paren-state (point)) + paren-state)) + + ;; CASE 5T: Continuation of a concept clause. + ((save-excursion + (and (eq (c-beginning-of-statement-1 nil t) 'same) + (setq tmp (c-looking-at-concept indent-point)))) + (c-add-syntax 'constraint-cont (car tmp))) + ;; CASE 5D: this could be a top-level initialization, a ;; member init list continuation, or a template argument ;; list continuation. ((save-excursion + (setq constraint-detail (c-in-requires-or-at-end-of-clause)) ;; Note: We use the fact that lim is always after any ;; preceding brace sexp. (if c-recognize-<>-arglists @@ -14572,8 +14796,9 @@ comment at the start of cc-engine.el for more info." ;; clause - we assume only C++ needs it. (c-syntactic-skip-backward "^;,=" lim t)) (setq placeholder (point)) - (and (memq (char-before) '(?, ?= ?<)) - (not (c-crosses-statement-barrier-p (point) indent-point)))) + (or constraint-detail + (and (memq (char-before) '(?, ?= ?<)) + (not (c-crosses-statement-barrier-p (point) indent-point))))) (cond ;; CASE 5D.6: Something like C++11's "using foo = <type-exp>" @@ -14591,8 +14816,7 @@ comment at the start of cc-engine.el for more info." (c-on-identifier)) (setq placeholder preserve-point))))) (c-add-syntax - 'statement-cont placeholder) - ) + 'statement-cont placeholder)) ;; CASE 5D.3: perhaps a template list continuation? ((and (c-major-mode-is 'c++-mode) @@ -14642,21 +14866,10 @@ comment at the start of cc-engine.el for more info." ;; CASE 5D.7: Continuation of a "concept foo =" line in C++20 (or ;; similar). - ((and c-equals-nontype-decl-key - (save-excursion - (prog1 - (and (zerop (c-backward-token-2 1 nil lim)) - (looking-at c-operator-re) - (equal (match-string 0) "=") - (zerop (c-backward-token-2 1 nil lim)) - (looking-at c-symbol-start) - (not (looking-at c-keywords-regexp)) - (zerop (c-backward-token-2 1 nil lim)) - (looking-at c-equals-nontype-decl-key) - (eq (c-beginning-of-statement-1 lim) 'same)) - (setq placeholder (point))))) - (goto-char placeholder) - (c-add-stmt-syntax 'topmost-intro-cont nil nil containing-sexp + ((and constraint-detail + (not (eq (cdr constraint-detail) 'expression))) + (goto-char (car constraint-detail)) + (c-add-stmt-syntax 'constraint-cont nil nil containing-sexp paren-state)) ;; CASE 5D.5: Continuation of the "expression part" of a @@ -14681,24 +14894,6 @@ comment at the start of cc-engine.el for more info." nil nil containing-sexp paren-state)) )) - ;; CASE 5F: Close of a non-class declaration level block. - ((and (eq char-after-ip ?}) - (c-keyword-member containing-decl-kwd - 'c-other-block-decl-kwds)) - ;; This is inconsistent: Should use `containing-decl-open' - ;; here if it's at boi, like in case 5J. - (goto-char containing-decl-start) - (c-add-stmt-syntax - (if (string-equal (symbol-name containing-decl-kwd) "extern") - ;; Special case for compatibility with the - ;; extern-lang syntactic symbols. - 'extern-lang-close - (intern (concat (symbol-name containing-decl-kwd) - "-close"))) - nil t - (c-most-enclosing-brace paren-state (point)) - paren-state)) - ;; CASE 5G: we are looking at the brace which closes the ;; enclosing nested class decl ((and containing-sexp @@ -14911,6 +15106,16 @@ comment at the start of cc-engine.el for more info." (c-add-syntax 'topmost-intro-cont (c-point 'boi))) )) + ;; CASE 20: A C++ requires sub-clause. + ((and (setq tmp (c-in-requires-or-at-end-of-clause indent-point)) + (not (eq (cdr tmp) 'expression)) + (setq placeholder (car tmp))) + (c-add-syntax + (if (eq char-after-ip ?{) + 'substatement-open + 'substatement) + (c-point 'boi placeholder))) + ;; ((Old) CASE 6 has been removed.) ;; CASE 6: line is within a C11 _Generic expression. ((and c-generic-key @@ -15294,6 +15499,20 @@ comment at the start of cc-engine.el for more info." (c-add-syntax 'defun-close (point)) (c-add-syntax 'inline-close (point)))) + ;; CASE 16G: Do we have the closing brace of a "requires" clause + ;; of a C++20 "concept"? + ((save-excursion + (c-backward-syntactic-ws lim) + (and (or (not (eq (char-before) ?\))) + (c-go-list-backward nil lim)) + (progn (c-backward-syntactic-ws lim) + (zerop (c-backward-token-2 nil nil lim))) + (looking-at c-fun-name-substitute-key) + (not (eq (char-after (match-end 0)) ?_)))) + (goto-char containing-sexp) + (back-to-indentation) + (c-add-stmt-syntax 'defun-close nil t lim paren-state)) + ;; CASE 16F: Can be a defun-close of a function declared ;; in a statement block, e.g. in Pike or when using gcc ;; extensions, but watch out for macros followed by @@ -15444,6 +15663,21 @@ comment at the start of cc-engine.el for more info." (if (eq char-after-ip ?{) (c-add-syntax 'block-open))) + ;; CASE 17J: first "statement" inside a C++20 requires + ;; "function". + ((save-excursion + (goto-char containing-sexp) + (c-backward-syntactic-ws lim) + (and (or (not (eq (char-before) ?\))) + (c-go-list-backward nil lim)) + (progn (c-backward-syntactic-ws lim) + (zerop (c-backward-token-2 nil nil lim))) + (looking-at c-fun-name-substitute-key) + (not (eq (char-after (match-end 0)) ?_)))) + (goto-char containing-sexp) + (back-to-indentation) + (c-add-syntax 'defun-block-intro (point))) + ;; CASE 17F: first statement in an inline, or first ;; statement in a top-level defun. we can tell this is it ;; if there are no enclosing braces that haven't been diff --git a/lisp/progmodes/cc-fonts.el b/lisp/progmodes/cc-fonts.el index f726fef467e..9118e3253c2 100644 --- a/lisp/progmodes/cc-fonts.el +++ b/lisp/progmodes/cc-fonts.el @@ -1388,7 +1388,8 @@ casts and declarations are fontified. Used on level 2 and higher." (memq type '(c-decl-arg-start c-decl-type-start)))))))) ((and (zerop (c-backward-token-2)) - (looking-at c-fun-name-substitute-key))))))))) + (looking-at c-fun-name-substitute-key) + (not (eq (char-after (match-end 0)) ?_)))))))))) ;; Cache the result of this test for next time around. (c-put-char-property (1- match-pos) 'c-type 'c-decl-arg-start) (cons 'decl nil)) @@ -2678,9 +2679,7 @@ need for `c-font-lock-extra-types'.") 'same) (looking-at c-colon-type-list-re))) ;; Inherited protected member: leave unfontified - ) - (t (goto-char pos) - (c-font-lock-declarators limit nil c-label-face-name nil))) + )) (eq (char-after) ?,))) (forward-char))) ; over the comma. nil)) diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el index 28403385115..3b4fdc6e141 100644 --- a/lisp/progmodes/cc-langs.el +++ b/lisp/progmodes/cc-langs.el @@ -586,7 +586,8 @@ Such a function takes one optional parameter, a buffer position (defaults to point), and returns nil or t. This variable contains nil for languages which don't have EOL terminated statements. " t nil - (c c++ objc) 'c-at-macro-vsemi-p + (c objc) 'c-at-macro-vsemi-p + c++ 'c-c++-vsemi-p awk 'c-awk-at-vsemi-p) (c-lang-defvar c-at-vsemi-p-fn (c-lang-const c-at-vsemi-p-fn)) @@ -2634,9 +2635,12 @@ clause. An arglist may or may not follow such a keyword." c++ '("requires")) (c-lang-defconst c-fun-name-substitute-key - ;; An adorned regular expression which matches any member of + ;; An unadorned regular expression which matches any member of ;; `c-fun-name-substitute-kwds'. - t (c-make-keywords-re t (c-lang-const c-fun-name-substitute-kwds))) + t (c-make-keywords-re 'appendable (c-lang-const c-fun-name-substitute-kwds))) +;; We use 'appendable, so that we get "\\>" on the regexp, but without a further +;; character, which would mess up backward regexp search from just after the +;; keyword. If only XEmacs had \\_>. ;-( (c-lang-defvar c-fun-name-substitute-key (c-lang-const c-fun-name-substitute-key)) diff --git a/lisp/progmodes/cc-vars.el b/lisp/progmodes/cc-vars.el index afeb88c7b8a..72d4b93ee59 100644 --- a/lisp/progmodes/cc-vars.el +++ b/lisp/progmodes/cc-vars.el @@ -1094,6 +1094,8 @@ can always override the use of `c-default-style' by making calls to ;; Anchor pos: Bol at the last line of previous construct. (topmost-intro-cont . c-lineup-topmost-intro-cont) ;;Anchor pos: Bol at the topmost annotation line + (constraint-cont . +) + ;; Anchor pos: Boi of the starting requires/concept line (annotation-top-cont . 0) ;;Anchor pos: Bol at the topmost annotation line (annotation-var-cont . +) @@ -1326,6 +1328,9 @@ Here is the current list of valid syntactic element symbols: knr-argdecl -- Subsequent lines in a K&R C argument declaration. topmost-intro -- The first line in a topmost construct definition. topmost-intro-cont -- Topmost definition continuation lines. + constraint-cont -- Continuation line of a C++ requires clause (not + to be confused with a \"requires expression\") or + concept. annotation-top-cont -- Topmost definition continuation line where only annotations are on previous lines. annotation-var-cont -- A continuation of a C (or like) statement where diff --git a/lisp/progmodes/ebnf-otz.el b/lisp/progmodes/ebnf-otz.el index 9ac37b676f9..4155dc0d2cd 100644 --- a/lisp/progmodes/ebnf-otz.el +++ b/lisp/progmodes/ebnf-otz.el @@ -566,7 +566,7 @@ ;; determine suffix length (while (and (> isuf 0) (setq tail (cdr tail))) (let* ((cur head) - (tlis (nreverse + (tlis (reverse (if (eq (ebnf-node-kind (car tail)) 'ebnf-generate-sequence) (ebnf-node-list (car tail)) (list (car tail))))) @@ -577,7 +577,6 @@ (setq cur (cdr cur) this (cdr this) i (1+ i))) - (nreverse tlis) (setq isuf (min isuf i)))) (setq head (nreverse head)) (if (or (zerop isuf) (> isuf len)) diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el index fe9bc510049..24f2fda5ae5 100644 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@ -2,12 +2,12 @@ ;; Copyright (C) 2018-2023 Free Software Foundation, Inc. -;; Version: 1.13 +;; Version: 1.14 ;; Author: João Távora <joaotavora@gmail.com> ;; Maintainer: João Távora <joaotavora@gmail.com> ;; URL: https://github.com/joaotavora/eglot ;; Keywords: convenience, languages -;; Package-Requires: ((emacs "26.3") (jsonrpc "1.0.16") (flymake "1.2.1") (project "0.9.8") (xref "1.6.2") (eldoc "1.11.0") (seq "2.23") (external-completion "0.1")) +;; Package-Requires: ((emacs "26.3") (jsonrpc "1.0.16") (flymake "1.2.1") (project "0.9.8") (xref "1.6.2") (eldoc "1.14.0") (seq "2.23") (external-completion "0.1")) ;; This is a GNU ELPA :core package. Avoid adding functionality ;; that is not available in the version of Emacs recorded above or any @@ -97,34 +97,30 @@ (require 'imenu) (require 'cl-lib) -(require 'project) + (require 'url-parse) (require 'url-util) (require 'pcase) (require 'compile) ; for some faces (require 'warnings) -(require 'flymake) -(require 'xref) (eval-when-compile (require 'subr-x)) -(require 'jsonrpc) (require 'filenotify) (require 'ert) -(require 'array) -(require 'external-completion) - -;; ElDoc is preloaded in Emacs, so `require'-ing won't guarantee we are -;; using the latest version from GNU Elpa when we load eglot.el. Use an -;; heuristic to see if we need to `load' it in Emacs < 28. -(if (and (< emacs-major-version 28) - (not (boundp 'eldoc-documentation-strategy))) - (load "eldoc") - (require 'eldoc)) - -;; Similar issue as above for Emacs 26.3 and seq.el. -(if (< emacs-major-version 27) - (load "seq") - (require 'seq)) +(require 'text-property-search nil t) + +;; These dependencies are also GNU ELPA core packages. Because of +;; bug#62576, since there is a risk that M-x package-install, despite +;; having installed them, didn't correctly re-load them over the +;; built-in versions. +(eval-and-compile + (load "project") + (load "eldoc") + (load "seq") + (load "flymake") + (load "xref") + (load "jsonrpc") + (load "external-completion")) ;; forward-declare, but don't require (Emacs 28 doesn't seem to care) (defvar markdown-fontify-code-blocks-natively) @@ -221,7 +217,11 @@ chosen (interactively or automatically)." ((java-mode java-ts-mode) . ("jdtls")) (dart-mode . ("dart" "language-server" "--client-id" "emacs.eglot-dart")) - ((elixir-ts-mode elixir-mode) . ("language_server.sh")) + ((elixir-mode elixir-ts-mode heex-ts-mode) + . ,(if (and (fboundp 'w32-shell-dos-semantics) + (w32-shell-dos-semantics)) + '("language_server.bat") + '("language_server.sh"))) (ada-mode . ("ada_language_server")) (scala-mode . ,(eglot-alternatives '("metals" "metals-emacs"))) @@ -242,7 +242,7 @@ chosen (interactively or automatically)." ("css-languageserver" "--stdio")))) (html-mode . ,(eglot-alternatives '(("vscode-html-language-server" "--stdio") ("html-languageserver" "--stdio")))) ((dockerfile-mode dockerfile-ts-mode) . ("docker-langserver" "--stdio")) - ((clojure-mode clojurescript-mode clojurec-mode) + ((clojure-mode clojurescript-mode clojurec-mode clojure-ts-mode) . ("clojure-lsp")) ((csharp-mode csharp-ts-mode) . ,(eglot-alternatives @@ -250,7 +250,11 @@ chosen (interactively or automatically)." ("csharp-ls")))) (purescript-mode . ("purescript-language-server" "--stdio")) ((perl-mode cperl-mode) . ("perl" "-MPerl::LanguageServer" "-e" "Perl::LanguageServer::run")) - (markdown-mode . ("marksman" "server"))) + (markdown-mode + . ,(eglot-alternatives + '(("marksman" "server") + ("vscode-markdown-language-server" "--stdio")))) + (graphviz-dot-mode . ("dot-language-server" "--stdio"))) "How the command `eglot' guesses the server to start. An association list of (MAJOR-MODE . CONTACT) pairs. MAJOR-MODE identifies the buffers that are to be managed by a specific @@ -390,14 +394,20 @@ done by `eglot-reconnect'." "If non-nil, activate Eglot in cross-referenced non-project files." :type 'boolean) +(defcustom eglot-prefer-plaintext nil + "If non-nil, always request plaintext responses to hover requests." + :type 'boolean) + (defcustom eglot-menu-string "eglot" "String displayed in mode line when Eglot is active." :type 'string) (defcustom eglot-report-progress t - "If non-nil, show progress of long running LSP server work" + "If non-nil, show progress of long running LSP server work. +If set to `messages', use *Messages* buffer, else use Eglot's +mode line indicator." :type 'boolean - :version "29.1") + :version "1.10") (defvar eglot-withhold-process-id nil "If non-nil, Eglot will not send the Emacs process id to the language server. @@ -442,6 +452,10 @@ This can be useful when using docker to run a language server.") (if (>= emacs-major-version 27) (executable-find command remote) (executable-find command))) +(defun eglot--accepted-formats () + (if (and (not eglot-prefer-plaintext) (fboundp 'gfm-view-mode)) + ["markdown" "plaintext"] ["plaintext"])) + ;;; Message verification helpers ;;; @@ -477,9 +491,7 @@ This can be useful when using docker to run a language server.") (SymbolInformation (:name :kind :location) (:deprecated :containerName)) (DocumentSymbol (:name :range :selectionRange :kind) - ;; `:containerName' isn't really allowed , but - ;; it simplifies the impl of `eglot-imenu'. - (:detail :deprecated :children :containerName)) + (:detail :deprecated :children)) (TextDocumentEdit (:textDocument :edits) ()) (TextEdit (:range :newText)) (VersionedTextDocumentIdentifier (:uri :version) ()) @@ -772,14 +784,12 @@ treated as in `eglot--dbind'." :tagSupport (:valueSet [1])) :contextSupport t) :hover (list :dynamicRegistration :json-false - :contentFormat - (if (fboundp 'gfm-view-mode) - ["markdown" "plaintext"] - ["plaintext"])) + :contentFormat (eglot--accepted-formats)) :signatureHelp (list :dynamicRegistration :json-false :signatureInformation `(:parameterInformation (:labelOffsetSupport t) + :documentationFormat ,(eglot--accepted-formats) :activeParameterSupport t)) :references `(:dynamicRegistration :json-false) :definition (list :dynamicRegistration :json-false @@ -820,6 +830,7 @@ treated as in `eglot--dbind'." `(:valueSet [,@(mapcar #'car eglot--tag-faces)]))) + :window `(:workDoneProgress t) :general (list :positionEncodings ["utf-32" "utf-8" "utf-16"]) :experimental eglot--{}))) @@ -837,12 +848,9 @@ treated as in `eglot--dbind'." :documentation "Short nickname for the associated project." :accessor eglot--project-nickname :reader eglot-project-nickname) - (major-modes - :documentation "Major modes server is responsible for in a given project." - :accessor eglot--major-modes) - (language-id - :documentation "Language ID string for the mode." - :accessor eglot--language-id) + (languages + :documentation "Alist ((MODE . LANGUAGE-ID-STRING)...) of managed languages." + :accessor eglot--languages) (capabilities :documentation "JSON object containing server capabilities." :accessor eglot--capabilities) @@ -877,6 +885,12 @@ treated as in `eglot--dbind'." :documentation "Represents a server. Wraps a process for LSP communication.") +(defun eglot--major-modes (s) "Major modes server S is responsible for." + (mapcar #'car (eglot--languages s))) + +(defun eglot--language-ids (s) "LSP Language ID strings for server S's modes." + (mapcar #'cdr (eglot--languages s))) + (cl-defmethod initialize-instance :before ((_server eglot-lsp-server) &optional args) (cl-remf args :initializationOptions)) @@ -904,7 +918,7 @@ SERVER." (unwind-protect (progn (setf (eglot--shutdown-requested server) t) - (jsonrpc-request server :shutdown nil :timeout (or timeout 1.5)) + (eglot--request server :shutdown nil :timeout (or timeout 1.5)) (jsonrpc-notify server :exit nil)) ;; Now ask jsonrpc.el to shut down the server. (jsonrpc-shutdown server (not preserve-buffers)) @@ -962,42 +976,44 @@ PRESERVE-BUFFERS as in `eglot-shutdown', which see." (defun eglot--lookup-mode (mode) "Lookup `eglot-server-programs' for MODE. -Return (MANAGED-MODES LANGUAGE-ID CONTACT-PROXY). +Return (LANGUAGES . CONTACT-PROXY). MANAGED-MODES is a list with MODE as its first element. Subsequent elements are other major modes also potentially managed by the server that is to manage MODE. -If not specified in `eglot-server-programs' (which see), -LANGUAGE-ID is determined from MODE's name. +LANGUAGE-IDS is a list of the same length as MANAGED-MODES. Each +elem is derived from the corresponding mode name, if not +specified in `eglot-server-programs' (which see). CONTACT-PROXY is the value of the corresponding `eglot-server-programs' entry." - (cl-loop - for (modes . contact) in eglot-server-programs - for mode-symbols = (cons mode - (delete mode - (mapcar #'car - (mapcar #'eglot--ensure-list - (eglot--ensure-list modes))))) - thereis (cl-some - (lambda (spec) - (cl-destructuring-bind (probe &key language-id &allow-other-keys) - (eglot--ensure-list spec) - (and (provided-mode-derived-p mode probe) - (list - mode-symbols - (or language-id - (or (get mode 'eglot-language-id) - (get spec 'eglot-language-id) - (string-remove-suffix "-mode" (symbol-name mode)))) - contact)))) - (if (or (symbolp modes) (keywordp (cadr modes))) - (list modes) modes)))) + (cl-flet ((languages (main-mode-sym specs) + (let* ((res + (mapcar (jsonrpc-lambda (sym &key language-id &allow-other-keys) + (cons sym + (or language-id + (or (get sym 'eglot-language-id) + (replace-regexp-in-string + "\\(?:-ts\\)?-mode$" "" + (symbol-name sym)))))) + specs)) + (head (cl-find main-mode-sym res :key #'car))) + (cons head (delq head res))))) + (cl-loop + for (modes . contact) in eglot-server-programs + for specs = (mapcar #'eglot--ensure-list + (if (or (symbolp modes) (keywordp (cadr modes))) + (list modes) modes)) + thereis (cl-some (lambda (spec) + (cl-destructuring-bind (sym &key &allow-other-keys) spec + (and (provided-mode-derived-p mode sym) + (cons (languages sym specs) contact)))) + specs)))) (defun eglot--guess-contact (&optional interactive) "Helper for `eglot'. -Return (MANAGED-MODE PROJECT CLASS CONTACT LANG-ID). If INTERACTIVE is +Return (MANAGED-MODES PROJECT CLASS CONTACT LANG-IDS). If INTERACTIVE is non-nil, maybe prompt user, else error as soon as something can't be guessed." (let* ((guessed-mode (if buffer-file-name major-mode)) @@ -1015,11 +1031,10 @@ be guessed." ((not guessed-mode) (eglot--error "Can't guess mode to manage for `%s'" (current-buffer))) (t guessed-mode))) - (triplet (eglot--lookup-mode main-mode)) - (managed-modes (car triplet)) - (language-id (or (cadr triplet) - (string-remove-suffix "-mode" (symbol-name guessed-mode)))) - (guess (caddr triplet)) + (languages-and-contact (eglot--lookup-mode main-mode)) + (managed-modes (mapcar #'car (car languages-and-contact))) + (language-ids (mapcar #'cdr (car languages-and-contact))) + (guess (cdr languages-and-contact)) (guess (if (functionp guess) (funcall guess interactive) guess)) @@ -1067,7 +1082,7 @@ be guessed." full-program-invocation 'eglot-command-history))) guess))) - (list managed-modes (eglot--current-project) class contact language-id))) + (list managed-modes (eglot--current-project) class contact language-ids))) (defvar eglot-lsp-context) (put 'eglot-lsp-context 'variable-documentation @@ -1085,24 +1100,25 @@ suitable root directory for a given LSP server's purposes." `(transient . ,(expand-file-name default-directory))))) ;;;###autoload -(defun eglot (managed-major-mode project class contact language-id +(defun eglot (managed-major-modes project class contact language-ids &optional _interactive) - "Start LSP server in support of PROJECT's buffers under MANAGED-MAJOR-MODE. + "Start LSP server for PROJECT's buffers under MANAGED-MAJOR-MODES. -This starts a Language Server Protocol (LSP) server suitable for the -buffers of PROJECT whose `major-mode' is MANAGED-MAJOR-MODE. -CLASS is the class of the LSP server to start and CONTACT specifies -how to connect to the server. +This starts a Language Server Protocol (LSP) server suitable for +the buffers of PROJECT whose `major-mode' is among +MANAGED-MAJOR-MODES. CLASS is the class of the LSP server to +start and CONTACT specifies how to connect to the server. -Interactively, the command attempts to guess MANAGED-MAJOR-MODE -from the current buffer's `major-mode', CLASS and CONTACT from -`eglot-server-programs' looked up by the major mode, and PROJECT from -`project-find-functions'. The search for active projects in this -context binds `eglot-lsp-context' (which see). +Interactively, the command attempts to guess MANAGED-MAJOR-MODES, +CLASS, CONTACT, and LANGUAGE-IDS from `eglot-server-programs', +according to the current buffer's `major-mode'. PROJECT is +guessed from `project-find-functions'. The search for active +projects in this context binds `eglot-lsp-context' (which see). -If it can't guess, it prompts the user for the mode and the server. -With a single \\[universal-argument] prefix arg, it always prompts for COMMAND. -With two \\[universal-argument], it also always prompts for MANAGED-MAJOR-MODE. +If it can't guess, it prompts the user for the mode and the +server. With a single \\[universal-argument] prefix arg, it +always prompts for COMMAND. With two \\[universal-argument], it +also always prompts for MANAGED-MAJOR-MODE. The LSP server of CLASS is started (or contacted) via CONTACT. If this operation is successful, current *and future* file @@ -1120,8 +1136,8 @@ CONTACT specifies how to contact the server. It is a keyword-value plist used to initialize CLASS or a plain list as described in `eglot-server-programs', which see. -LANGUAGE-ID is the language ID string to send to the server for -MANAGED-MAJOR-MODE, which matters to a minority of servers. +LANGUAGE-IDS is a list of language ID string to send to the +server for each element in MANAGED-MAJOR-MODES. INTERACTIVE is ignored and provided for backward compatibility." (interactive @@ -1132,8 +1148,9 @@ INTERACTIVE is ignored and provided for backward compatibility." (user-error "[eglot] Connection attempt aborted by user.")) (prog1 (append (eglot--guess-contact t) '(t)) (when current-server (ignore-errors (eglot-shutdown current-server)))))) - (eglot--connect (eglot--ensure-list managed-major-mode) - project class contact language-id)) + (eglot--connect (eglot--ensure-list managed-major-modes) + project class contact + (eglot--ensure-list language-ids))) (defun eglot-reconnect (server &optional interactive) "Reconnect to SERVER. @@ -1145,7 +1162,7 @@ INTERACTIVE is t if called interactively." (eglot--project server) (eieio-object-class-name server) (eglot--saved-initargs server) - (eglot--language-id server)) + (eglot--language-ids server)) (eglot--message "Reconnected!")) (defvar eglot--managed-mode) ; forward decl @@ -1218,8 +1235,8 @@ Each function is passed the server as an argument") (defvar-local eglot--cached-server nil "A cached reference to the current Eglot server.") -(defun eglot--connect (managed-modes project class contact language-id) - "Connect to MANAGED-MODES, LANGUAGE-ID, PROJECT, CLASS and CONTACT. +(defun eglot--connect (managed-modes project class contact language-ids) + "Connect to MANAGED-MODES, LANGUAGE-IDS, PROJECT, CLASS and CONTACT. This docstring appeases checkdoc, that's all." (let* ((default-directory (project-root project)) (nickname (project-name project)) @@ -1292,8 +1309,9 @@ This docstring appeases checkdoc, that's all." (setf (eglot--saved-initargs server) initargs) (setf (eglot--project server) project) (setf (eglot--project-nickname server) nickname) - (setf (eglot--major-modes server) (eglot--ensure-list managed-modes)) - (setf (eglot--language-id server) language-id) + (setf (eglot--languages server) + (cl-loop for m in managed-modes for l in language-ids + collect (cons m l))) (setf (eglot--inferior-process server) autostart-inferior-process) (run-hook-with-args 'eglot-server-initialized-hook server) ;; Now start the handshake. To honor `eglot-sync-connect' @@ -1312,6 +1330,7 @@ This docstring appeases checkdoc, that's all." (eq (jsonrpc-process-type server) 'network)) (emacs-pid)) + :clientInfo '(:name "Eglot") ;; Maybe turn trampy `/ssh:foo@bar:/path/to/baz.py' ;; into `/path/to/baz.py', so LSP groks it. :rootPath (file-local-name @@ -1456,15 +1475,27 @@ CONNECT-ARGS are passed as additional arguments to (line-beginning-position n)))) "Return position of first character in current line.") +(cl-defun eglot--request (server method params &key + immediate + timeout cancel-on-input + cancel-on-input-retval) + "Like `jsonrpc-request', but for Eglot LSP requests. +Unless IMMEDIATE, send pending changes before making request." + (unless immediate (eglot--signal-textDocument/didChange)) + (jsonrpc-request server method params + :timeout timeout + :cancel-on-input cancel-on-input + :cancel-on-input-retval cancel-on-input-retval)) + ;;; Encoding fever ;;; (define-obsolete-function-alias - 'eglot-lsp-abiding-column 'eglot-utf-16-linepos "29.1") + 'eglot-lsp-abiding-column 'eglot-utf-16-linepos "1.12") (define-obsolete-function-alias - 'eglot-current-column 'eglot-utf-32-linepos "29.1") + 'eglot-current-column 'eglot-utf-32-linepos "1.12") (define-obsolete-variable-alias - 'eglot-current-column-function 'eglot-current-linepos-function "29.1") + 'eglot-current-column-function 'eglot-current-linepos-function "1.12") (defvar eglot-current-linepos-function #'eglot-utf-16-linepos "Function calculating position relative to line beginning. @@ -1505,11 +1536,11 @@ LBP defaults to `eglot--bol'." (funcall eglot-current-linepos-function))))) (define-obsolete-function-alias - 'eglot-move-to-current-column 'eglot-move-to-utf-32-linepos "29.1") + 'eglot-move-to-current-column 'eglot-move-to-utf-32-linepos "1.12") (define-obsolete-function-alias - 'eglot-move-to-lsp-abiding-column 'eglot-move-to-utf-16-linepos "29.1") + 'eglot-move-to-lsp-abiding-column 'eglot-move-to-utf-16-linepos "1.12") (define-obsolete-variable-alias -'eglot-move-to-column-function 'eglot-move-to-linepos-function "29.1") +'eglot-move-to-column-function 'eglot-move-to-linepos-function "1.12") (defvar eglot-move-to-linepos-function #'eglot-move-to-utf-16-linepos "Function to move to a position within a line reported by the LSP server. @@ -1605,6 +1636,7 @@ If optional MARKER, return a marker instead" (directory-file-name (file-local-name truepath)) eglot--uri-path-allowed-chars))))) +(declare-function w32-long-file-name "w32proc.c" (fn)) (defun eglot--uri-to-path (uri) "Convert URI to file path, helped by `eglot--current-server'." (when (keywordp uri) (setq uri (substring (symbol-name uri) 1))) @@ -1620,10 +1652,9 @@ If optional MARKER, return a marker instead" (normalized (if (and (not remote-prefix) (eq system-type 'windows-nt) (cl-plusp (length retval))) - (substring retval 1) + (w32-long-file-name (substring retval 1)) retval))) (concat remote-prefix normalized)) - uri))) (defun eglot--snippet-expansion-fn () @@ -1648,10 +1679,17 @@ Doubles as an indicator of snippet support." (setq-local markdown-fontify-code-blocks-natively t) (insert string) (let ((inhibit-message t) - (message-log-max nil)) - (ignore-errors (delay-mode-hooks (funcall mode)))) - (font-lock-ensure) - (string-trim (buffer-string))))) + (message-log-max nil) + match) + (ignore-errors (delay-mode-hooks (funcall mode))) + (font-lock-ensure) + (goto-char (point-min)) + (let ((inhibit-read-only t)) + (when (fboundp 'text-property-search-forward) ;; FIXME: use compat + (while (setq match (text-property-search-forward 'invisible)) + (delete-region (prop-match-beginning match) + (prop-match-end match))))) + (string-trim (buffer-string)))))) (define-obsolete-variable-alias 'eglot-ignored-server-capabilites 'eglot-ignored-server-capabilities "1.8") @@ -1749,9 +1787,9 @@ and just return it. PROMPT shouldn't end with a question mark." (defun eglot--plist-keys (plist) "Get keys of a plist." (cl-loop for (k _v) on plist by #'cddr collect k)) -(defun eglot--ensure-list (x) (if (listp x) x (list x))) -(when (fboundp 'ensure-list) ; Emacs 28 or later - (define-obsolete-function-alias 'eglot--ensure-list #'ensure-list "29.1")) +(defalias 'eglot--ensure-list + (if (fboundp 'ensure-list) #'ensure-list + (lambda (x) (if (listp x) x (list x))))) ;;; Minor modes @@ -1832,6 +1870,8 @@ Use `eglot-managed-p' to determine if current buffer is managed.") (unless (eglot--stay-out-of-p 'xref) (add-hook 'xref-backend-functions 'eglot-xref-backend nil t)) (add-hook 'completion-at-point-functions #'eglot-completion-at-point nil t) + (add-hook 'completion-in-region-mode-hook #'eglot--capf-session-flush nil t) + (add-hook 'company-after-completion-hook #'eglot--capf-session-flush nil t) (add-hook 'change-major-mode-hook #'eglot--managed-mode-off nil t) (add-hook 'post-self-insert-hook 'eglot--post-self-insert-hook nil t) (add-hook 'pre-command-hook 'eglot--pre-command-hook nil t) @@ -1863,6 +1903,8 @@ Use `eglot-managed-p' to determine if current buffer is managed.") (remove-hook 'after-save-hook 'eglot--signal-textDocument/didSave t) (remove-hook 'xref-backend-functions 'eglot-xref-backend t) (remove-hook 'completion-at-point-functions #'eglot-completion-at-point t) + (remove-hook 'completion-in-region-mode-hook #'eglot--capf-session-flush t) + (remove-hook 'company-after-completion-hook #'eglot--capf-session-flush t) (remove-hook 'change-major-mode-hook #'eglot--managed-mode-off t) (remove-hook 'post-self-insert-hook 'eglot--post-self-insert-hook t) (remove-hook 'pre-command-hook 'eglot--pre-command-hook t) @@ -1886,6 +1928,7 @@ Use `eglot-managed-p' to determine if current buffer is managed.") (defun eglot--managed-mode-off () "Turn off `eglot--managed-mode' unconditionally." (remove-overlays nil nil 'eglot--overlay t) + (eglot-inlay-hints-mode -1) (eglot--managed-mode -1)) (defun eglot-current-server () @@ -1956,8 +1999,8 @@ If it is activated, also signal textDocument/didOpen." (when update-mode-line (force-mode-line-update t))))))) -(defun eglot-manual () "Open documentation." - (declare (obsolete info "29.1")) +(defun eglot-manual () "Read Eglot's manual." + (declare (obsolete info "1.10")) (interactive) (info "(eglot)")) (easy-menu-define eglot-menu nil "Eglot" @@ -2037,7 +2080,7 @@ Uses THING, FACE, DEFS and PREPEND." mouse-face mode-line-highlight)))) (defun eglot--mode-line-format () - "Compose the Eglot's mode-line." + "Compose Eglot's mode-line." (let* ((server (eglot-current-server)) (nick (and server (eglot-project-nickname server))) (pending (and server (hash-table-count @@ -2074,7 +2117,15 @@ Uses THING, FACE, DEFS and PREPEND." '((mouse-3 eglot-forget-pending-continuations "Forget pending continuations")) "Number of outgoing, \ -still unanswered LSP requests to the server\n")))))))) +still unanswered LSP requests to the server\n"))) + ,@(cl-loop for pr hash-values of (eglot--progress-reporters server) + when (eq (car pr) 'eglot--mode-line-reporter) + append `("/" ,(eglot--mode-line-props + (format "%s%%%%" (or (nth 4 pr) "?")) + 'eglot-mode-line + nil + (format "(%s) %s %s" (nth 1 pr) + (nth 2 pr) (nth 3 pr)))))))))) (add-to-list 'mode-line-misc-info `(eglot--managed-mode (" [" eglot--mode-line-format "] "))) @@ -2122,8 +2173,8 @@ still unanswered LSP requests to the server\n")))))))) (server command arguments) "Execute COMMAND on SERVER with `:workspace/executeCommand'. COMMAND is a symbol naming the command." - (jsonrpc-request server :workspace/executeCommand - `(:command ,(format "%s" command) :arguments ,arguments))) + (eglot--request server :workspace/executeCommand + `(:command ,(format "%s" command) :arguments ,arguments))) (cl-defmethod eglot-handle-notification (_server (_method (eql window/showMessage)) &key type message) @@ -2133,13 +2184,14 @@ COMMAND is a symbol naming the command." type message)) (cl-defmethod eglot-handle-request - (_server (_method (eql window/showMessageRequest)) &key type message actions) + (_server (_method (eql window/showMessageRequest)) + &key type message actions &allow-other-keys) "Handle server request window/showMessageRequest." (let* ((actions (append actions nil)) ;; gh#627 (label (completing-read (concat (format (propertize "[eglot] Server reports (type=%s): %s" - 'face (if (<= type 1) 'error)) + 'face (if (or (not type) (<= type 1)) 'error)) type message) "\nChoose an option: ") (or (mapcar (lambda (obj) (plist-get obj :title)) actions) @@ -2163,22 +2215,31 @@ COMMAND is a symbol naming the command." (server (_method (eql $/progress)) &key token value) "Handle $/progress notification identified by TOKEN from SERVER." (when eglot-report-progress - (cl-flet ((fmt (&rest args) (mapconcat #'identity args " "))) + (cl-flet ((fmt (&rest args) (mapconcat #'identity args " ")) + (mkpr (title) + (if (eq eglot-report-progress 'messages) + (make-progress-reporter + (format "[eglot] %s %s: %s" + (eglot-project-nickname server) token title)) + (list 'eglot--mode-line-reporter token title))) + (upd (pcnt msg &optional + (pr (gethash token (eglot--progress-reporters server)))) + (cond + ((eq (car pr) 'eglot--mode-line-reporter) + (setcdr (cddr pr) (list msg pcnt)) + (force-mode-line-update t)) + (pr (progress-reporter-update pr pcnt msg))))) (eglot--dbind ((WorkDoneProgress) kind title percentage message) value (pcase kind ("begin" - (let* ((prefix (format (concat "[eglot] %s %s:" (when percentage " ")) - (eglot-project-nickname server) token)) - (pr (puthash token - (if percentage - (make-progress-reporter prefix 0 100 percentage 1 0) - (make-progress-reporter prefix nil nil nil 1 0)) - (eglot--progress-reporters server)))) - (eglot--reporter-update pr percentage (fmt title message)))) - ("report" - (when-let ((pr (gethash token (eglot--progress-reporters server)))) - (eglot--reporter-update pr percentage (fmt title message)))) - ("end" (remhash token (eglot--progress-reporters server)))))))) + (upd percentage (fmt title message) + (puthash token (mkpr title) + (eglot--progress-reporters server)))) + ("report" (upd percentage message)) + ("end" (upd (or percentage 100) message) + (run-at-time 2 nil + (lambda () + (remhash token (eglot--progress-reporters server)))))))))) (cl-defmethod eglot-handle-notification (_server (_method (eql textDocument/publishDiagnostics)) &key uri diagnostics @@ -2304,7 +2365,7 @@ THINGS are either registrations or unregisterations (sic)." (append (eglot--VersionedTextDocumentIdentifier) (list :languageId - (eglot--language-id (eglot--current-server-or-lose)) + (alist-get major-mode (eglot--languages (eglot--current-server-or-lose))) :text (eglot--widening (buffer-substring-no-properties (point-min) (point-max)))))) @@ -2417,16 +2478,6 @@ Records BEG, END and PRE-CHANGE-LENGTH locally." (run-hooks 'eglot--document-changed-hook) (setq eglot--change-idle-timer nil)))))))) -;; HACK! Launching a deferred sync request with outstanding changes is a -;; bad idea, since that might lead to the request never having a -;; chance to run, because `jsonrpc-connection-ready-p'. -(advice-add #'jsonrpc-request :before - (cl-function (lambda (_proc _method _params &key - deferred &allow-other-keys) - (when (and eglot--managed-mode deferred) - (eglot--signal-textDocument/didChange)))) - '((name . eglot--signal-textDocument/didChange))) - (defvar-local eglot-workspace-configuration () "Configure LSP servers specifically for a given project. @@ -2484,7 +2535,7 @@ use the root of SERVER's `eglot--project'." ;; Set the major mode to be the first of the managed ;; modes. This is the one the user started eglot in. (setq major-mode (car (eglot--major-modes server))) - (hack-dir-local-variables-non-file-buffer)() + (hack-dir-local-variables-non-file-buffer) (if (functionp eglot-workspace-configuration) (funcall eglot-workspace-configuration server) eglot-workspace-configuration)))) @@ -2579,8 +2630,8 @@ When called interactively, use the currently active server" (when (eglot--server-capable :textDocumentSync :willSaveWaitUntil) (ignore-errors (eglot--apply-text-edits - (jsonrpc-request server :textDocument/willSaveWaitUntil params - :timeout 0.5)))))) + (eglot--request server :textDocument/willSaveWaitUntil params + :timeout 0.5)))))) (defun eglot--signal-textDocument/didSave () "Maybe send textDocument/didSave to server." @@ -2692,8 +2743,8 @@ If BUFFER, switch to it before." (propertize (alist-get kind eglot--symbol-kind-names "Unknown") 'face 'shadow)) 'eglot--lsp-workspaceSymbol wss))) - (jsonrpc-request (eglot--current-server-or-lose) :workspace/symbol - `(:query ,pat))))) + (eglot--request (eglot--current-server-or-lose) :workspace/symbol + `(:query ,pat))))) (cl-defmethod xref-backend-identifier-completion-table ((_backend (eql eglot))) "Yet another tricky connection between LSP and Elisp completion semantics." @@ -2749,7 +2800,7 @@ If BUFFER, switch to it before." (cadr (split-string (symbol-name method) "/")))))) (let ((response - (jsonrpc-request + (eglot--request (eglot--current-server-or-lose) method (append (eglot--TextDocumentPositionParams) extra-params)))) (eglot--collecting-xrefs (collect) @@ -2812,9 +2863,9 @@ If BUFFER, switch to it before." (eglot--lambda ((SymbolInformation) name location) (eglot--dbind ((Location) uri range) location (collect (eglot--xref-make-match name uri range)))) - (jsonrpc-request (eglot--current-server-or-lose) - :workspace/symbol - `(:query ,pattern)))))) + (eglot--request (eglot--current-server-or-lose) + :workspace/symbol + `(:query ,pattern)))))) (defun eglot-format-buffer () "Format contents of current buffer." @@ -2846,7 +2897,7 @@ for which LSP on-type-formatting should be requested." '(:textDocument/formatting :documentFormattingProvider nil))))) (eglot--server-capable-or-lose cap) (eglot--apply-text-edits - (jsonrpc-request + (eglot--request (eglot--current-server-or-lose) method (cl-list* @@ -2855,8 +2906,14 @@ for which LSP on-type-formatting should be requested." :insertSpaces (if indent-tabs-mode :json-false t) :insertFinalNewline (if require-final-newline t :json-false) :trimFinalNewlines (if delete-trailing-lines t :json-false)) - args) - :deferred method)))) + args))))) + +(defvar eglot-cache-session-completions t + "If non-nil Eglot caches data during completion sessions.") + +(defvar eglot--capf-session :none "A cache used by `eglot-completion-at-point'.") + +(defun eglot--capf-session-flush (&optional _) (setq eglot--capf-session :none)) (defun eglot-completion-at-point () "Eglot's `completion-at-point' function." @@ -2873,41 +2930,50 @@ for which LSP on-type-formatting should be requested." :sortText))))) (metadata `(metadata (category . eglot) (display-sort-function . ,sort-completions))) - resp items (cached-proxies :none) + (local-cache :none) + (bounds (bounds-of-thing-at-point 'symbol)) + (orig-pos (point)) + (resolved (make-hash-table)) (proxies (lambda () - (if (listp cached-proxies) cached-proxies - (setq resp - (jsonrpc-request server - :textDocument/completion - (eglot--CompletionParams) - :deferred :textDocument/completion - :cancel-on-input t)) - (setq items (append - (if (vectorp resp) resp (plist-get resp :items)) - nil)) - (setq cached-proxies - (mapcar - (jsonrpc-lambda - (&rest item &key label insertText insertTextFormat - textEdit &allow-other-keys) - (let ((proxy - ;; Snippet or textEdit, it's safe to - ;; display/insert the label since - ;; it'll be adjusted. If no usable - ;; insertText at all, label is best, - ;; too. - (cond ((or (eql insertTextFormat 2) - textEdit - (null insertText) - (string-empty-p insertText)) - (string-trim-left label)) - (t insertText)))) - (unless (zerop (length proxy)) - (put-text-property 0 1 'eglot--lsp-item item proxy)) - proxy)) - items))))) - (resolved (make-hash-table)) + (if (listp local-cache) local-cache + (let* ((resp (eglot--request server + :textDocument/completion + (eglot--CompletionParams) + :cancel-on-input t)) + (items (append + (if (vectorp resp) resp (plist-get resp :items)) + nil)) + (cachep (and (listp resp) items + eglot-cache-session-completions + (eq (plist-get resp :isIncomplete) :json-false))) + (bounds (or bounds + (cons (point) (point)))) + (proxies + (mapcar + (jsonrpc-lambda + (&rest item &key label insertText insertTextFormat + textEdit &allow-other-keys) + (let ((proxy + ;; Snippet or textEdit, it's safe to + ;; display/insert the label since + ;; it'll be adjusted. If no usable + ;; insertText at all, label is best, + ;; too. + (cond ((or (eql insertTextFormat 2) + textEdit + (null insertText) + (string-empty-p insertText)) + (string-trim-left label)) + (t insertText)))) + (unless (zerop (length proxy)) + (put-text-property 0 1 'eglot--lsp-item item proxy)) + proxy)) + items))) + ;; (trace-values "Requested" (length proxies) cachep bounds) + (setq eglot--capf-session + (if cachep (list bounds proxies resolved orig-pos) :none)) + (setq local-cache proxies))))) (resolve-maybe ;; Maybe completion/resolve JSON object `lsp-comp' into ;; another JSON object, if at all possible. Otherwise, @@ -2918,13 +2984,21 @@ for which LSP on-type-formatting should be requested." (if (and (eglot--server-capable :completionProvider :resolveProvider) (plist-get lsp-comp :data)) - (jsonrpc-request server :completionItem/resolve - lsp-comp :cancel-on-input t) - lsp-comp))))) - (bounds (bounds-of-thing-at-point 'symbol))) + (eglot--request server :completionItem/resolve + lsp-comp :cancel-on-input t) + lsp-comp)))))) + (unless bounds (setq bounds (cons (point) (point)))) + (when (and (consp eglot--capf-session) + (= (car bounds) (car (nth 0 eglot--capf-session))) + (>= (cdr bounds) (cdr (nth 0 eglot--capf-session)))) + (setq local-cache (nth 1 eglot--capf-session) + resolved (nth 2 eglot--capf-session) + orig-pos (nth 3 eglot--capf-session)) + ;; (trace-values "Recalling cache" (length local-cache) bounds orig-pos) + ) (list - (or (car bounds) (point)) - (or (cdr bounds) (point)) + (car bounds) + (cdr bounds) (lambda (probe pred action) (cond ((eq action 'metadata) metadata) ; metadata @@ -2995,7 +3069,7 @@ for which LSP on-type-formatting should be requested." :company-require-match 'never :company-prefix-length (save-excursion - (when (car bounds) (goto-char (car bounds))) + (goto-char (car bounds)) (when (listp completion-capability) (looking-back (regexp-opt @@ -3003,6 +3077,7 @@ for which LSP on-type-formatting should be requested." (eglot--bol)))) :exit-function (lambda (proxy status) + (eglot--capf-session-flush) (when (memq status '(finished exact)) ;; To assist in using this whole `completion-at-point' ;; function inside `completion-in-region', ensure the exit @@ -3026,17 +3101,12 @@ for which LSP on-type-formatting should be requested." (let ((snippet-fn (and (eql insertTextFormat 2) (eglot--snippet-expansion-fn)))) (cond (textEdit - ;; Undo (yes, undo) the newly inserted completion. - ;; If before completion the buffer was "foo.b" and - ;; now is "foo.bar", `proxy' will be "bar". We - ;; want to delete only "ar" (`proxy' minus the - ;; symbol whose bounds we've calculated before) - ;; (github#160). - (delete-region (+ (- (point) (length proxy)) - (if bounds - (- (cdr bounds) (car bounds)) - 0)) - (point)) + ;; Revert buffer back to state when the edit + ;; was obtained from server. If a `proxy' + ;; "bar" was obtained from a buffer with + ;; "foo.b", the LSP edit applies to that' + ;; state, _not_ the current "foo.bar". + (delete-region orig-pos (point)) (eglot--dbind ((TextEdit) range newText) textEdit (pcase-let ((`(,beg . ,end) (eglot--range-region range))) @@ -3059,62 +3129,56 @@ for which LSP on-type-formatting should be requested." (mapconcat #'eglot--format-markup (if (vectorp contents) contents (list contents)) "\n")) -(defun eglot--sig-info (sigs active-sig sig-help-active-param) - (cl-loop - for (sig . moresigs) on (append sigs nil) for i from 0 - concat - (eglot--dbind ((SignatureInformation) label documentation parameters activeParameter) sig - (with-temp-buffer - (save-excursion (insert label)) - (let ((active-param (or activeParameter sig-help-active-param)) - params-start params-end) - ;; Ad-hoc attempt to parse label as <name>(<params>) - (when (looking-at "\\([^(]*\\)(\\([^)]+\\))") - (setq params-start (match-beginning 2) params-end (match-end 2)) - (add-face-text-property (match-beginning 1) (match-end 1) - 'font-lock-function-name-face)) - (when (eql i active-sig) - ;; Decide whether to add one-line-summary to signature line - (when (and (stringp documentation) - (string-match "[[:space:]]*\\([^.\r\n]+[.]?\\)" - documentation)) - (setq documentation (match-string 1 documentation)) - (unless (string-prefix-p (string-trim documentation) label) - (goto-char (point-max)) - (insert ": " (eglot--format-markup documentation)))) - ;; Decide what to do with the active parameter... - (when (and (eql i active-sig) active-param - (< -1 active-param (length parameters))) - (eglot--dbind ((ParameterInformation) label documentation) - (aref parameters active-param) - ;; ...perhaps highlight it in the formals list - (when params-start - (goto-char params-start) - (pcase-let - ((`(,beg ,end) - (if (stringp label) - (let ((case-fold-search nil)) - (and (re-search-forward - (concat "\\<" (regexp-quote label) "\\>") - params-end t) - (list (match-beginning 0) (match-end 0)))) - (mapcar #'1+ (append label nil))))) - (if (and beg end) - (add-face-text-property - beg end - 'eldoc-highlight-function-argument)))) - ;; ...and/or maybe add its doc on a line by its own. - (when documentation - (goto-char (point-max)) - (insert "\n" - (propertize - (if (stringp label) - label - (apply #'buffer-substring (mapcar #'1+ label))) - 'face 'eldoc-highlight-function-argument) - ": " (eglot--format-markup documentation)))))) - (buffer-string)))) - when moresigs concat "\n")) +(defun eglot--sig-info (sig &optional sig-active briefp) + (eglot--dbind ((SignatureInformation) + ((:label siglabel)) + ((:documentation sigdoc)) parameters activeParameter) + sig + (with-temp-buffer + (save-excursion (insert siglabel)) + ;; Ad-hoc attempt to parse label as <name>(<params>) + (when (looking-at "\\([^(]*\\)(\\([^)]+\\))") + (add-face-text-property (match-beginning 1) (match-end 1) + 'font-lock-function-name-face)) + ;; Add documentation, indented so we can distinguish multiple signatures + (when-let (doc (and (not briefp) sigdoc (eglot--format-markup sigdoc))) + (goto-char (point-max)) + (insert "\n" (replace-regexp-in-string "^" " " doc))) + ;; Now to the parameters + (cl-loop + with active-param = (or sig-active activeParameter) + for i from 0 for parameter across parameters do + (eglot--dbind ((ParameterInformation) + ((:label parlabel)) + ((:documentation pardoc))) + parameter + ;; ...perhaps highlight it in the formals list + (when (and (eq i active-param)) + (save-excursion + (goto-char (point-min)) + (pcase-let + ((`(,beg ,end) + (if (stringp parlabel) + (let ((case-fold-search nil)) + (and (search-forward parlabel (line-end-position) t) + (list (match-beginning 0) (match-end 0)))) + (mapcar #'1+ (append parlabel nil))))) + (if (and beg end) + (add-face-text-property + beg end + 'eldoc-highlight-function-argument))))) + ;; ...and/or maybe add its doc on a line by its own. + (let (fpardoc) + (when (and pardoc (not briefp) + (not (string-empty-p + (setq fpardoc (eglot--format-markup pardoc))))) + (insert "\n " + (propertize + (if (stringp parlabel) parlabel + (apply #'substring siglabel (mapcar #'1+ parlabel))) + 'face (and (eq i active-param) 'eldoc-highlight-function-argument)) + ": " fpardoc))))) + (buffer-string)))) (defun eglot-signature-eldoc-function (cb) "A member of `eldoc-documentation-functions', for signatures." @@ -3125,13 +3189,18 @@ for which LSP on-type-formatting should be requested." :textDocument/signatureHelp (eglot--TextDocumentPositionParams) :success-fn (eglot--lambda ((SignatureHelp) - signatures activeSignature activeParameter) + signatures activeSignature (activeParameter 0)) (eglot--when-buffer-window buf - (funcall cb - (unless (seq-empty-p signatures) - (eglot--sig-info signatures - activeSignature - activeParameter))))) + (let ((active-sig (and (cl-plusp (length signatures)) + (aref signatures (or activeSignature 0))))) + (if (not active-sig) (funcall cb nil) + (funcall + cb (mapconcat (lambda (s) + (eglot--sig-info s (and (eq s active-sig) + activeParameter) + nil)) + signatures "\n") + :echo (eglot--sig-info active-sig activeParameter t)))))) :deferred :textDocument/signatureHelp)) t)) @@ -3146,7 +3215,8 @@ for which LSP on-type-formatting should be requested." (eglot--when-buffer-window buf (let ((info (unless (seq-empty-p contents) (eglot--hover-info contents range)))) - (funcall cb info :buffer t)))) + (funcall cb info + :echo (and info (string-match "\n" info)))))) :deferred :textDocument/hover)) (eglot--highlight-piggyback cb) t)) @@ -3180,49 +3250,55 @@ for which LSP on-type-formatting should be requested." :deferred :textDocument/documentHighlight) nil))) +(defun eglot--imenu-SymbolInformation (res) + "Compute `imenu--index-alist' for RES vector of SymbolInformation." + (mapcar + (pcase-lambda (`(,kind . ,objs)) + (cons + (alist-get kind eglot--symbol-kind-names "Unknown") + (mapcan + (pcase-lambda (`(,container . ,objs)) + (let ((elems (mapcar + (eglot--lambda ((SymbolInformation) kind name location) + (let ((reg (eglot--range-region + (plist-get location :range))) + (kind (alist-get kind eglot--symbol-kind-names))) + (cons (propertize name + 'breadcrumb-region reg + 'breadcrumb-kind kind) + (car reg)))) + objs))) + (if container (list (cons container elems)) elems))) + (seq-group-by + (eglot--lambda ((SymbolInformation) containerName) containerName) objs)))) + (seq-group-by (eglot--lambda ((SymbolInformation) kind) kind) res))) + +(defun eglot--imenu-DocumentSymbol (res) + "Compute `imenu--index-alist' for RES vector of DocumentSymbol." + (cl-labels ((dfs (&key name children range kind &allow-other-keys) + (let* ((reg (eglot--range-region range)) + (kind (alist-get kind eglot--symbol-kind-names)) + (name (propertize name + 'breadcrumb-region reg + 'breadcrumb-kind kind))) + (if (seq-empty-p children) + (cons name (car reg)) + (cons name + (mapcar (lambda (c) (apply #'dfs c)) children)))))) + (mapcar (lambda (s) (apply #'dfs s)) res))) + (defun eglot-imenu () "Eglot's `imenu-create-index-function'. Returns a list as described in docstring of `imenu--index-alist'." - (cl-labels - ((unfurl (obj) - (eglot--dcase obj - (((SymbolInformation)) (list obj)) - (((DocumentSymbol) name children) - (cons obj - (mapcar - (lambda (c) - (plist-put - c :containerName - (let ((existing (plist-get c :containerName))) - (if existing (format "%s::%s" name existing) - name)))) - (mapcan #'unfurl children))))))) - (mapcar - (pcase-lambda (`(,kind . ,objs)) - (cons - (alist-get kind eglot--symbol-kind-names "Unknown") - (mapcan (pcase-lambda (`(,container . ,objs)) - (let ((elems (mapcar - (lambda (obj) - (cons (plist-get obj :name) - (car (eglot--range-region - (eglot--dcase obj - (((SymbolInformation) location) - (plist-get location :range)) - (((DocumentSymbol) selectionRange) - selectionRange)))))) - objs))) - (if container (list (cons container elems)) elems))) - (seq-group-by - (lambda (e) (plist-get e :containerName)) objs)))) - (seq-group-by - (lambda (obj) (plist-get obj :kind)) - (mapcan #'unfurl - (jsonrpc-request (eglot--current-server-or-lose) - :textDocument/documentSymbol - `(:textDocument - ,(eglot--TextDocumentIdentifier)) - :cancel-on-input non-essential)))))) + (let* ((res (eglot--request (eglot--current-server-or-lose) + :textDocument/documentSymbol + `(:textDocument + ,(eglot--TextDocumentIdentifier)) + :cancel-on-input non-essential)) + (head (and res (elt res 0)))) + (eglot--dcase head + (((SymbolInformation)) (eglot--imenu-SymbolInformation res)) + (((DocumentSymbol)) (eglot--imenu-DocumentSymbol res))))) (cl-defun eglot--apply-text-edits (edits &optional version) "Apply EDITS for current buffer if at VERSION, or if it's nil." @@ -3293,9 +3369,9 @@ Returns a list as described in docstring of `imenu--index-alist'." (symbol-name (symbol-at-point))))) (eglot--server-capable-or-lose :renameProvider) (eglot--apply-workspace-edit - (jsonrpc-request (eglot--current-server-or-lose) - :textDocument/rename `(,@(eglot--TextDocumentPositionParams) - :newName ,newname)) + (eglot--request (eglot--current-server-or-lose) + :textDocument/rename `(,@(eglot--TextDocumentPositionParams) + :newName ,newname)) current-prefix-arg)) (defun eglot--region-bounds () @@ -3321,7 +3397,7 @@ at point. With prefix argument, prompt for ACTION-KIND." (eglot--server-capable-or-lose :codeActionProvider) (let* ((server (eglot--current-server-or-lose)) (actions - (jsonrpc-request + (eglot--request server :textDocument/codeAction (list :textDocument (eglot--TextDocumentIdentifier) @@ -3333,8 +3409,7 @@ at point. With prefix argument, prompt for ACTION-KIND." when (cdr (assoc 'eglot-lsp-diag (eglot--diag-data diag))) collect it)] - ,@(when action-kind `(:only [,action-kind])))) - :deferred t)) + ,@(when action-kind `(:only [,action-kind])))))) ;; Redo filtering, in case the `:only' didn't go through. (actions (cl-loop for a across actions when (or (not action-kind) @@ -3435,8 +3510,9 @@ at point. With prefix argument, prompt for ACTION-KIND." (unwind-protect (progn (dolist (dir dirs-to-watch) - (push (file-notify-add-watch dir '(change) #'handle-event) - (gethash id (eglot--file-watches server)))) + (when (file-readable-p dir) + (push (file-notify-add-watch dir '(change) #'handle-event) + (gethash id (eglot--file-watches server))))) (setq success `(:message ,(format "OK, watching %s directories in %s watchers" diff --git a/lisp/progmodes/elixir-ts-mode.el b/lisp/progmodes/elixir-ts-mode.el index 286f3e39f43..c58854c41c3 100644 --- a/lisp/progmodes/elixir-ts-mode.el +++ b/lisp/progmodes/elixir-ts-mode.el @@ -55,7 +55,9 @@ (declare-function treesit-parser-list "treesit.c") (declare-function treesit-node-parent "treesit.c") (declare-function treesit-node-start "treesit.c") +(declare-function treesit-node-end "treesit.c") (declare-function treesit-query-compile "treesit.c") +(declare-function treesit-query-capture "treesit.c") (declare-function treesit-node-eq "treesit.c") (declare-function treesit-node-prev-sibling "treesit.c") @@ -169,7 +171,13 @@ (defun elixir-ts--argument-indent-offset (node _parent &rest _) "Return the argument offset position for NODE." - (if (treesit-node-prev-sibling node t) 0 elixir-ts-indent-offset)) + (if (or (treesit-node-prev-sibling node t) + ;; Don't indent if this is the first node or + ;; if the line is empty. + (save-excursion + (beginning-of-line) + (looking-at-p "[[:blank:]]*$"))) + 0 elixir-ts-indent-offset)) (defun elixir-ts--argument-indent-anchor (node parent &rest _) "Return the argument anchor position for NODE and PARENT." @@ -264,7 +272,7 @@ ;; Handle incomplete maps when parent is ERROR. ((n-p-gp "^binary_operator$" "ERROR" nil) parent-bol 0) ;; When there is an ERROR, just indent to prev-line. - ((parent-is "ERROR") prev-line 0) + ((parent-is "ERROR") prev-line ,offset) ((node-is "^binary_operator$") (lambda (node parent &rest _) (let ((top-level @@ -449,16 +457,13 @@ :override t `((sigil (sigil_name) @elixir-ts-font-sigil-name-face - quoted_start: _ @font-lock-string-face - quoted_end: _ @font-lock-string-face - (:match "^[sSwWpP]$" @elixir-ts-font-sigil-name-face)) + (:match "^[sSwWpPUD]$" @elixir-ts-font-sigil-name-face)) @font-lock-string-face (sigil + "~" @font-lock-string-face (sigil_name) @elixir-ts-font-sigil-name-face - quoted_start: _ @font-lock-regex-face - quoted_end: _ @font-lock-regex-face (:match "^[rR]$" @elixir-ts-font-sigil-name-face)) - @font-lock-regex-face + @font-lock-regexp-face (sigil "~" @font-lock-string-face (sigil_name) @elixir-ts-font-sigil-name-face @@ -547,13 +552,43 @@ Return nil if NODE is not a defun node or doesn't have a name." (_ nil)))) (_ nil))) +(defvar elixir-ts--syntax-propertize-query + (when (treesit-available-p) + (treesit-query-compile + 'elixir + '(((["\"\"\""] @quoted-text)))))) + +(defun elixir-ts--syntax-propertize (start end) + "Apply syntax text properties between START and END for `elixir-ts-mode'." + (let ((captures + (treesit-query-capture 'elixir elixir-ts--syntax-propertize-query start end))) + (pcase-dolist (`(,name . ,node) captures) + (pcase-exhaustive name + ('quoted-text + (put-text-property (1- (treesit-node-end node)) (treesit-node-end node) + 'syntax-table (string-to-syntax "$"))))))) + +(defun elixir-ts--electric-pair-string-delimiter () + "Insert corresponding multi-line string for `electric-pair-mode'." + (when (and electric-pair-mode + (eq last-command-event ?\") + (let ((count 0)) + (while (eq (char-before (- (point) count)) last-command-event) + (cl-incf count)) + (= count 3)) + (eq (char-after) last-command-event)) + (save-excursion + (insert (make-string 2 last-command-event))) + (save-excursion + (newline 1 t)))) + ;;;###autoload (define-derived-mode elixir-ts-mode prog-mode "Elixir" "Major mode for editing Elixir, powered by tree-sitter." :group 'elixir-ts :syntax-table elixir-ts--syntax-table - ;; Comments + ;; Comments. (setq-local comment-start "# ") (setq-local comment-start-skip (rx "#" (* (syntax whitespace)))) @@ -563,9 +598,13 @@ Return nil if NODE is not a defun node or doesn't have a name." (rx (* (syntax whitespace)) (group (or (syntax comment-end) "\n")))) - ;; Compile + ;; Compile. (setq-local compile-command "mix") + ;; Electric pair. + (add-hook 'post-self-insert-hook + #'elixir-ts--electric-pair-string-delimiter 'append t) + (when (treesit-ready-p 'elixir) ;; The HEEx parser has to be created first for elixir to ensure elixir ;; is the first language when looking for treesit ranges. @@ -596,14 +635,14 @@ Return nil if NODE is not a defun node or doesn't have a name." ;; Indent. (setq-local treesit-simple-indent-rules elixir-ts--indent-rules) - ;; Navigation + ;; Navigation. (setq-local forward-sexp-function #'elixir-ts--forward-sexp) (setq-local treesit-defun-type-regexp '("call" . elixir-ts--defun-p)) (setq-local treesit-defun-name-function #'elixir-ts--defun-name) - ;; Embedded Heex + ;; Embedded Heex. (when (treesit-ready-p 'heex) (setq-local treesit-range-settings elixir-ts--treesit-range-rules) @@ -627,7 +666,8 @@ Return nil if NODE is not a defun node or doesn't have a name." ( elixir-sigil elixir-string-escape elixir-string-interpolation )))) - (treesit-major-mode-setup))) + (treesit-major-mode-setup) + (setq-local syntax-propertize-function #'elixir-ts--syntax-propertize))) (if (treesit-ready-p 'elixir) (progn diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el index a352adbba19..ac408145696 100644 --- a/lisp/progmodes/flymake.el +++ b/lisp/progmodes/flymake.el @@ -4,9 +4,9 @@ ;; Author: Pavel Kobyakov <pk_at_work@yahoo.com> ;; Maintainer: João Távora <joaotavora@gmail.com> -;; Version: 1.2.2 +;; Version: 1.3.4 ;; Keywords: c languages tools -;; Package-Requires: ((emacs "26.1") (eldoc "1.1.0") (project "0.7.1")) +;; Package-Requires: ((emacs "26.1") (eldoc "1.14.0") (project "0.7.1")) ;; This is a GNU ELPA :core package. Avoid functionality that is not ;; compatible with the version of Emacs recorded above. @@ -371,6 +371,20 @@ diagnostics at BEG." (flymake--diag-accessor flymake-diagnostic-end flymake--diag-end end) (flymake--diag-accessor flymake-diagnostic-buffer flymake--diag-locus locus) +(defun flymake-diagnostic-oneliner (diag &optional nopaintp) + "Get truncated one-line text string for diagnostic DIAG. +This is useful for displaying the DIAG's text to the user in +confined spaces, such as the echo are. Unless NOPAINTP is t, +propertize returned text with the `echo-face' property of DIAG's +type." + (let* ((txt (flymake-diagnostic-text diag)) + (txt (substring txt 0 (cl-loop for i from 0 for a across txt + when (eq a ?\n) return i)))) + (if nopaintp txt + (propertize txt 'face + (flymake--lookup-type-property + (flymake-diagnostic-type diag) 'echo-face 'flymake-error))))) + (cl-defun flymake--overlays (&key beg end filter compare key) "Get flymake-related overlays. If BEG is non-nil and END is nil, consider only `overlays-at' @@ -417,6 +431,26 @@ verify FILTER, a function, and sort them by COMPARE (using KEY)." "Face used for marking note regions." :version "26.1") +(defface flymake-error-echo + '((t :inherit compilation-error)) + "Face used for showing summarized descriptions of errors." + :package-version '(Flymake . "1.3.4")) + +(defface flymake-warning-echo + '((t :inherit compilation-warning)) + "Face used for showing summarized descriptions of warnings." + :package-version '(Flymake . "1.3.4")) + +(defface flymake-note-echo + '((t :inherit flymake-note)) + "Face used for showing summarized descriptions of notes." + :package-version '(Flymake . "1.3.4")) + +(defcustom flymake-show-diagnostics-at-end-of-line nil + "If non-nil, add diagnostic summary messages at end-of-line." + :type 'boolean + :package-version '(Flymake . "1.3.4")) + (define-obsolete-face-alias 'flymake-warnline 'flymake-warning "26.1") (define-obsolete-face-alias 'flymake-errline 'flymake-error "26.1") @@ -570,19 +604,25 @@ Node `(Flymake)Flymake error types'" (put 'flymake-error 'face 'flymake-error) (put 'flymake-error 'flymake-bitmap 'flymake-error-bitmap) (put 'flymake-error 'severity (warning-numeric-level :error)) -(put 'flymake-error 'mode-line-face 'compilation-error) +(put 'flymake-error 'mode-line-face 'flymake-error-echo) +(put 'flymake-error 'echo-face 'flymake-error-echo) +(put 'flymake-error 'eol-face 'flymake-error-echo) (put 'flymake-error 'flymake-type-name "error") (put 'flymake-warning 'face 'flymake-warning) (put 'flymake-warning 'flymake-bitmap 'flymake-warning-bitmap) (put 'flymake-warning 'severity (warning-numeric-level :warning)) -(put 'flymake-warning 'mode-line-face 'compilation-warning) +(put 'flymake-warning 'mode-line-face 'flymake-warning-echo) +(put 'flymake-warning 'echo-face 'flymake-warning-echo) +(put 'flymake-warning 'eol-face 'flymake-warning-echo) (put 'flymake-warning 'flymake-type-name "warning") (put 'flymake-note 'face 'flymake-note) (put 'flymake-note 'flymake-bitmap 'flymake-note-bitmap) (put 'flymake-note 'severity (warning-numeric-level :debug)) -(put 'flymake-note 'mode-line-face 'compilation-info) +(put 'flymake-note 'mode-line-face 'flymake-note-echo) +(put 'flymake-note 'echo-face 'flymake-note-echo) +(put 'flymake-note 'eol-face 'flymake-note-echo) (put 'flymake-note 'flymake-type-name "note") (defun flymake--lookup-type-property (type prop &optional default) @@ -639,6 +679,12 @@ associated `flymake-category' return DEFAULT." flymake-diagnostic-text) always (equal (funcall comp a) (funcall comp b))))) +(defun flymake--delete-overlay (ov) + "Like `delete-overlay', delete OV, but do some more stuff." + (let ((eolov (overlay-get ov 'eol-ov))) + (when eolov (delete-overlay eolov)) + (delete-overlay ov))) + (cl-defun flymake--highlight-line (diagnostic &optional foreign) "Attempt to overlay DIAGNOSTIC in current buffer. @@ -678,6 +724,7 @@ Return nil or the overlay created." ;; diagnostic is already registered in the same place, which only ;; happens for clashes between domestic and foreign diagnostics (cl-loop for e in (flymake-diagnostics beg end) + for eov = (flymake--diag-overlay e) when (flymake--equal-diagnostic-p e diagnostic) ;; FIXME. This is an imperfect heuristic. Ideally, we'd ;; want to delete no overlays and keep annotating the @@ -693,7 +740,7 @@ Return nil or the overlay created." (flymake--diag-orig-beg e) (flymake--diag-end e) (flymake--diag-orig-end e)) - (delete-overlay (flymake--diag-overlay e)))) + (flymake--delete-overlay eov))) (setq ov (make-overlay end beg)) (setf (flymake--diag-beg diagnostic) (overlay-start ov) (flymake--diag-end diagnostic) (overlay-end ov)) @@ -711,6 +758,37 @@ Return nil or the overlay created." (flymake--lookup-type-property type 'flymake-overlay-control)) (alist-get type flymake-diagnostic-types-alist)) do (overlay-put ov ov-prop value)) + ;; Handle `flymake-show-diagnostics-at-end-of-line' + ;; + (when-let ((eol-face (and flymake-show-diagnostics-at-end-of-line + (flymake--lookup-type-property type 'eol-face)))) + (save-excursion + (goto-char (overlay-start ov)) + (let* ((start (line-end-position)) + (end (min (1+ start) (point-max))) + (eolov (car + (cl-remove-if-not + (lambda (o) (overlay-get o 'flymake-source-ovs)) + (overlays-at start)))) + (bs (flymake-diagnostic-oneliner diagnostic t))) + (setq bs (propertize bs 'face eol-face)) + ;; FIXME: 1. no checking if there are unexpectedly more than + ;; one eolov at point. 2. The first regular source ov to + ;; die also kills the eolov (very rare this matters, but + ;; could be improved). + (cond (eolov + (overlay-put eolov 'before-string + (concat (overlay-get eolov 'before-string) " " bs)) + (overlay-put eolov 'flymake-source-ovs + (cons ov (overlay-get eolov 'flymake-source-ovs)))) + (t + (setq eolov (make-overlay start end nil t nil)) + (setq bs (concat " " bs)) + (put-text-property 0 1 'cursor t bs) + (overlay-put eolov 'before-string bs) + (overlay-put eolov 'evaporate (not (= start end))) + (overlay-put eolov 'flymake-source-ovs (list ov)) + (overlay-put ov 'eol-ov eolov)))))) ;; Now ensure some essential defaults are set ;; (cl-flet ((default-maybe @@ -726,11 +804,13 @@ Return nil or the overlay created." 'flymake-bitmap (alist-get 'bitmap (alist-get type ; backward compat flymake-diagnostic-types-alist))))) + ;; (default-maybe 'after-string + ;; (flymake--diag-text diagnostic)) (default-maybe 'help-echo (lambda (window _ov pos) (with-selected-window window (mapconcat - #'flymake-diagnostic-text + #'flymake-diagnostic-oneliner (flymake-diagnostics pos) "\n")))) (default-maybe 'severity (warning-numeric-level :error)) @@ -856,7 +936,7 @@ report applies to that region." (maphash (lambda (_buffer diags) (cl-loop for d in diags when (flymake--diag-overlay d) - do (delete-overlay it))) + do (flymake--delete-overlay it))) (flymake--state-foreign-diags state)) (clrhash (flymake--state-foreign-diags state))) @@ -883,7 +963,7 @@ and other buffers." (flymake--intersects-p (overlay-start ov) (overlay-end ov) (car region) (cdr region))) - do (delete-overlay ov) + do (flymake--delete-overlay ov) else collect diag into surviving finally (setf (flymake--state-diags state) surviving))) @@ -892,7 +972,7 @@ and other buffers." (not (flymake--state-reported-p state)) (cl-loop for diag in (flymake--state-diags state) for ov = (flymake--diag-overlay diag) - when ov do (delete-overlay ov)) + when ov do (flymake--delete-overlay ov)) (setf (flymake--state-diags state) nil) ;; Also clear all overlays for `foreign-diags' in all other ;; buffers. @@ -1136,7 +1216,7 @@ special *Flymake log* buffer." :group 'flymake :lighter ;; existing diagnostic overlays, lest we forget them by blindly ;; reinitializing `flymake--state' in the next line. ;; See https://github.com/joaotavora/eglot/issues/223. - (mapc #'delete-overlay (flymake--overlays)) + (mapc #'flymake--delete-overlay (flymake--overlays)) (setq flymake--state (make-hash-table)) (setq flymake--recent-changes nil) @@ -1183,7 +1263,7 @@ special *Flymake log* buffer." :group 'flymake :lighter (when flymake-timer (cancel-timer flymake-timer) (setq flymake-timer nil)) - (mapc #'delete-overlay (flymake--overlays)) + (mapc #'flymake--delete-overlay (flymake--overlays)) (when flymake--state (maphash (lambda (_backend state) (flymake--clear-foreign-diags state)) @@ -1254,10 +1334,11 @@ START and STOP and LEN are as in `after-change-functions'." (defun flymake-eldoc-function (report-doc &rest _) "Document diagnostics at point. Intended for `eldoc-documentation-functions' (which see)." - (let ((diags (flymake-diagnostics (point)))) - (when diags - (funcall report-doc - (mapconcat #'flymake-diagnostic-text diags "\n"))))) + (when-let ((diags (flymake-diagnostics (point)))) + (funcall report-doc + (mapconcat #'flymake-diagnostic-text diags "\n") + :echo (mapconcat #'flymake-diagnostic-oneliner + diags "\n")))) (defun flymake-goto-next-error (&optional n filter interactive) "Go to Nth next Flymake diagnostic that matches FILTER. @@ -1582,8 +1663,7 @@ filename of the diagnostic relative to that directory." "\\1\\2" bname) "(anon)") 'help-echo (format "From `%s' backend" backend)) - (,(replace-regexp-in-string "\n.*" "" - (flymake-diagnostic-text diag)) + (,(flymake-diagnostic-oneliner diag t) mouse-face highlight help-echo "mouse-2: visit this diagnostic" face nil diff --git a/lisp/progmodes/go-ts-mode.el b/lisp/progmodes/go-ts-mode.el index e6e8abd6445..fda6a36e42d 100644 --- a/lisp/progmodes/go-ts-mode.el +++ b/lisp/progmodes/go-ts-mode.el @@ -255,9 +255,10 @@ (if (treesit-ready-p 'go) (add-to-list 'auto-mode-alist '("\\.go\\'" . go-ts-mode))) -(defun go-ts-mode--defun-name (node) +(defun go-ts-mode--defun-name (node &optional skip-prefix) "Return the defun name of NODE. -Return nil if there is no name or if NODE is not a defun node." +Return nil if there is no name or if NODE is not a defun node. +Methods are prefixed with the receiver name, unless SKIP-PREFIX is t." (pcase (treesit-node-type node) ("function_declaration" (treesit-node-text @@ -266,11 +267,10 @@ Return nil if there is no name or if NODE is not a defun node." t)) ("method_declaration" (let* ((receiver-node (treesit-node-child-by-field-name node "receiver")) - (type-node (treesit-search-subtree receiver-node "type_identifier")) - (name-node (treesit-node-child-by-field-name node "name"))) - (concat - "(" (treesit-node-text type-node) ")." - (treesit-node-text name-node)))) + (receiver (treesit-node-text (treesit-search-subtree receiver-node "type_identifier"))) + (method (treesit-node-text (treesit-node-child-by-field-name node "name")))) + (if skip-prefix method + (concat "(" receiver ")." method)))) ("type_declaration" (treesit-node-text (treesit-node-child-by-field-name @@ -314,7 +314,7 @@ comment already exists, jump to it." ;; go to top comment line (while (go-ts-mode--comment-on-previous-line-p) (forward-line -1)) - (insert "// " (treesit-defun-name defun-node)) + (insert "// " (go-ts-mode--defun-name defun-node t)) (newline) (backward-char)))) diff --git a/lisp/progmodes/make-mode.el b/lisp/progmodes/make-mode.el index 087974bd1f0..5ea03b9e852 100644 --- a/lisp/progmodes/make-mode.el +++ b/lisp/progmodes/make-mode.el @@ -1326,14 +1326,12 @@ Fill comments, backslashed lines, and variable definitions specially." (let ((inhibit-read-only t)) (goto-char (point-min)) (erase-buffer) - (mapconcat + (mapc (lambda (item) (insert (makefile-browser-format-target-line (car item) nil) "\n")) - targets - "") - (mapconcat + targets) + (mapc (lambda (item) (insert (makefile-browser-format-macro-line (car item) nil) "\n")) - macros - "") + macros) (sort-lines nil (point-min) (point-max)) (goto-char (1- (point-max))) (delete-char 1) ; remove unnecessary newline at eob diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 11228226592..04c67710d71 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -202,6 +202,17 @@ CL struct.") "Value to use instead of `default-directory' when detecting the project. When it is non-nil, `project-current' will always skip prompting too.") +(defcustom project-prompter #'project-prompt-project-dir + "Function to call to prompt for a project. +Called with no arguments and should return a project root dir." + :type '(choice (const :tag "Prompt for a project directory" + project-prompt-project-dir) + (const :tag "Prompt for a project name" + project-prompt-project-name) + (function :tag "Custom function" nil)) + :group 'project + :version "30.1") + ;;;###autoload (defun project-current (&optional maybe-prompt directory) "Return the project instance in DIRECTORY, defaulting to `default-directory'. @@ -226,7 +237,7 @@ of the project instance object." (pr) ((unless project-current-directory-override maybe-prompt) - (setq directory (project-prompt-project-dir) + (setq directory (funcall project-prompter) pr (project--find-in-directory directory)))) (when maybe-prompt (if pr @@ -1216,7 +1227,10 @@ To continue searching for the next match, use the command \\[fileloop-continue]." (interactive "sSearch (regexp): ") (fileloop-initialize-search - regexp (project-files (project-current t)) 'default) + regexp + ;; XXX: See the comment in project-query-replace-regexp. + (cl-delete-if-not #'file-regular-p (project-files (project-current t))) + 'default) (fileloop-continue)) ;;;###autoload @@ -1248,8 +1262,10 @@ If you exit the `query-replace', you can later continue the (defun project-prefixed-buffer-name (mode) (concat "*" - (file-name-nondirectory - (directory-file-name default-directory)) + (if-let ((proj (project-current nil))) + (project-name proj) + (file-name-nondirectory + (directory-file-name default-directory))) "-" (downcase mode) "*")) @@ -1261,7 +1277,7 @@ If non-nil, it overrides `compilation-buffer-name-function' for :version "28.1" :group 'project :type '(choice (const :tag "Default" nil) - (const :tag "Prefixed with root directory name" + (const :tag "Prefixed with project name" project-prefixed-buffer-name) (function :tag "Custom function"))) @@ -1613,7 +1629,7 @@ passed to `message' as its first argument." "Remove directory PROJECT-ROOT from the project list. PROJECT-ROOT is the root directory of a known project listed in the project list." - (interactive (list (project-prompt-project-dir))) + (interactive (list (funcall project-prompter))) (project--remove-from-project-list project-root "Project `%s' removed from known projects")) @@ -1637,6 +1653,32 @@ It's also possible to enter an arbitrary directory not in the list." (read-directory-name "Select directory: " default-directory nil t) pr-dir))) +(defun project-prompt-project-name () + "Prompt the user for a project, by name, that is one of the known project roots. +The project is chosen among projects known from the project list, +see `project-list-file'. +It's also possible to enter an arbitrary directory not in the list." + (let* ((dir-choice "... (choose a dir)") + (choices + (let (ret) + (dolist (dir (project-known-project-roots)) + ;; we filter out directories that no longer map to a project, + ;; since they don't have a clean project-name. + (if-let (proj (project--find-in-directory dir)) + (push (cons (project-name proj) proj) ret))) + ret)) + ;; XXX: Just using this for the category (for the substring + ;; completion style). + (table (project--file-completion-table (cons dir-choice choices))) + (pr-name "")) + (while (equal pr-name "") + ;; If the user simply pressed RET, do this again until they don't. + (setq pr-name (completing-read "Select project: " table nil t))) + (if (equal pr-name dir-choice) + (read-directory-name "Select directory: " default-directory nil t) + (let ((proj (assoc pr-name choices))) + (if (stringp proj) proj (project-root (cdr proj))))))) + ;;;###autoload (defun project-known-project-roots () "Return the list of root directories of all known projects." @@ -1824,7 +1866,7 @@ made from `project-switch-commands'. When called in a program, it will use the project corresponding to directory DIR." - (interactive (list (project-prompt-project-dir))) + (interactive (list (funcall project-prompter))) (let ((command (if (symbolp project-switch-commands) project-switch-commands (project--switch-project-command)))) diff --git a/lisp/progmodes/prolog.el b/lisp/progmodes/prolog.el index 1b48fe9c3a8..66dea8803b3 100644 --- a/lisp/progmodes/prolog.el +++ b/lisp/progmodes/prolog.el @@ -828,7 +828,7 @@ Relevant only when `prolog-imenu-flag' is non-nil." ((not (zerop (skip-chars-forward prolog-operator-chars)))) ((not (zerop (skip-syntax-forward "w_'")))) ;; In case of non-ASCII punctuation. - ((not (zerop (skip-syntax-forward "."))))) + (t (skip-syntax-forward "."))) (point)))) (defun prolog-smie-backward-token () @@ -842,7 +842,7 @@ Relevant only when `prolog-imenu-flag' is non-nil." ((not (zerop (skip-chars-backward prolog-operator-chars)))) ((not (zerop (skip-syntax-backward "w_'")))) ;; In case of non-ASCII punctuation. - ((not (zerop (skip-syntax-backward "."))))) + (t (skip-syntax-backward "."))) (point)))) (defconst prolog-smie-grammar diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 2fe88323c35..bbabce80b4d 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -5854,7 +5854,14 @@ statement." (save-excursion (python-nav-beginning-of-statement) (when (and (not (python-syntax-context-type)) - (looking-at (python-rx dedenter))) + (looking-at (python-rx dedenter)) + ;; Exclude the first "case" in the block. + (not (and (string= (match-string-no-properties 0) + "case") + (save-excursion + (back-to-indentation) + (python-util-forward-comment -1) + (equal (char-before) ?:))))) (point)))) (defun python-info-line-ends-backslash-p (&optional line-number) diff --git a/lisp/progmodes/ruby-mode.el b/lisp/progmodes/ruby-mode.el index d2c4da794ac..e441ffbbfe3 100644 --- a/lisp/progmodes/ruby-mode.el +++ b/lisp/progmodes/ruby-mode.el @@ -1904,13 +1904,13 @@ See `add-log-current-defun-function'." (progn (unless (string-equal "self" (car mn)) ; def self.foo ;; def C.foo - (let ((ml (nreverse mlist))) + (let ((ml (reverse mlist))) ;; If the method name references one of the ;; containing modules, drop the more nested ones. (while ml (if (string-equal (car ml) (car mn)) (setq mlist (nreverse (cdr ml)) ml nil)) - (or (setq ml (cdr ml)) (nreverse mlist)))) + (setq ml (cdr ml)))) (if mlist (setcdr (last mlist) (butlast mn)) (setq mlist (butlast mn)))) diff --git a/lisp/progmodes/ruby-ts-mode.el b/lisp/progmodes/ruby-ts-mode.el index d077c43ba52..7a00977f14a 100644 --- a/lisp/progmodes/ruby-ts-mode.el +++ b/lisp/progmodes/ruby-ts-mode.el @@ -469,7 +469,7 @@ non-nil." (let* (first-call ) (while (and parent (setq first-call (treesit-node-parent parent)) - (string-match-p "call" (treesit-node-type first-call))) + (equal "call" (treesit-node-type first-call))) (setq parent first-call)) (treesit-node-start (treesit-search-subtree parent "\\." nil t)))) @@ -883,32 +883,24 @@ a statement container is a node that matches "Return the fully qualified name of NODE." (let* ((name (ruby-ts--get-name node)) (delimiter "#")) + (when (equal (treesit-node-type node) "singleton_method") + (setq delimiter "." + name (treesit-node-text (treesit-node-child-by-field-name node "name")))) (while (setq node (treesit-parent-until node #'ruby-ts--class-or-module-p)) - (setq name (concat (ruby-ts--get-name node) delimiter name)) + (if name + (setq name (concat (ruby-ts--get-name node) delimiter name)) + (setq name (ruby-ts--get-name node))) (setq delimiter "::")) name)) -(defun ruby-ts--imenu-helper (node) - "Convert a treesit sparse tree NODE in an imenu list. -Helper for `ruby-ts--imenu' which converts a treesit sparse -NODE into a list of imenu ( name . pos ) nodes" - (let* ((ts-node (car node)) - (subtrees (mapcan #'ruby-ts--imenu-helper (cdr node))) - (name (when ts-node - (ruby-ts--full-name ts-node))) - (marker (when ts-node - (set-marker (make-marker) - (treesit-node-start ts-node))))) - (cond - ((or (null ts-node) (null name)) subtrees) - ;; Don't include the anonymous "class" and "module" nodes - ((string-match-p "(\"\\(class\\|module\\)\")" - (treesit-node-string ts-node)) - nil) - (subtrees - `((,name ,(cons name marker) ,@subtrees))) - (t - `((,name . ,marker)))))) +(defun ruby-ts--imenu-helper (tree) + "Convert a treesit sparse tree NODE in a flat imenu list." + (if (cdr tree) + ;; We only use the "leaf" values in the tree. It does include a + ;; leaf node for every class or module body. + (cl-mapcan #'ruby-ts--imenu-helper (cdr tree)) + (list (cons (ruby-ts--full-name (car tree)) + (treesit-node-start (car tree)))))) ;; For now, this is going to work like ruby-mode and return a list of ;; class, modules, def (methods), and alias. It is likely that this @@ -916,8 +908,14 @@ NODE into a list of imenu ( name . pos ) nodes" (defun ruby-ts--imenu () "Return Imenu alist for the current buffer." (let* ((root (treesit-buffer-root-node)) - (nodes (treesit-induce-sparse-tree root "^\\(method\\|alias\\|class\\|module\\)$"))) - (ruby-ts--imenu-helper nodes))) + (tree (treesit-induce-sparse-tree root + (rx bol (or "singleton_method" + "method" + "alias" + "class" + "module") + eol)))) + (ruby-ts--imenu-helper tree))) (defun ruby-ts--arrow-up-start (arg) "Move to the start ARG levels up or out." @@ -1088,6 +1086,15 @@ leading double colon is not added." (put-text-property pos (1+ pos) 'syntax-table (string-to-syntax "!")))))))) +(defun ruby-ts--sexp-p (node) + ;; Skip parenless calls (implicit parens are both non-obvious to the + ;; user, and might take over when we want to just over some physical + ;; parens/braces). + (or (not (equal (treesit-node-type node) + "argument_list")) + (equal (treesit-node-type (treesit-node-child node 0)) + "("))) + (defvar-keymap ruby-ts-mode-map :doc "Keymap used in Ruby mode" :parent prog-mode-map @@ -1116,21 +1123,43 @@ leading double colon is not added." (setq-local treesit-defun-type-regexp ruby-ts--method-regex) (setq-local treesit-sexp-type-regexp - (regexp-opt '("class" - "module" - "method" - "argument_list" - "array" - "hash" - "parenthesized_statements" - "if" - "case" - "when" - "block" - "do_block" - "begin" - "binary" - "assignment"))) + (cons (rx + bol + (or + "class" + "module" + "method" + "array" + "hash" + "parenthesized_statements" + "method_parameters" + "array_pattern" + "hash_pattern" + "if" + "unless" + "case" + "case_match" + "when" + "block" + "do_block" + "begin" + "integer" + "identifier" + "constant" + "simple_symbol" + "hash_key_symbol" + "symbol_array" + "string" + "string_array" + "heredoc_body" + "regex" + "argument_list" + "interpolation" + "instance_variable" + "global_variable" + ) + eol) + #'ruby-ts--sexp-p)) ;; AFAIK, Ruby can not nest methods (setq-local treesit-defun-prefer-top-level nil) diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el index a5428a9a714..0cde1f387e0 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el @@ -1539,13 +1539,7 @@ implementations. Currently there are two: `sh-mode' and (lambda (terminator) (if (eq terminator ?') "'\\'" - "\\"))) - ;; Parse or insert magic number for exec, and set all variables depending - ;; on the shell thus determined. - (sh-set-shell (sh--guess-shell) nil nil) - (add-hook 'flymake-diagnostic-functions #'sh-shellcheck-flymake nil t) - (add-hook 'hack-local-variables-hook - #'sh-after-hack-local-variables nil t)) + "\\")))) ;;;###autoload (define-derived-mode sh-mode sh-base-mode "Shell-script" @@ -1605,7 +1599,13 @@ with your script for an edit-interpret-debug cycle." nil nil ((?/ . "w") (?~ . "w") (?. . "w") (?- . "w") (?_ . "w")) nil (font-lock-syntactic-face-function - . ,#'sh-font-lock-syntactic-face-function)))) + . ,#'sh-font-lock-syntactic-face-function))) + ;; Parse or insert magic number for exec, and set all variables depending + ;; on the shell thus determined. + (sh-set-shell (sh--guess-shell) nil nil) + (add-hook 'flymake-diagnostic-functions #'sh-shellcheck-flymake nil t) + (add-hook 'hack-local-variables-hook + #'sh-after-hack-local-variables nil t)) ;;;###autoload (defalias 'shell-script-mode 'sh-mode) @@ -1617,6 +1617,10 @@ This mode automatically falls back to `sh-mode' if the buffer is not written in Bash or sh." :syntax-table sh-mode-syntax-table (when (treesit-ready-p 'bash) + (sh-set-shell "bash" nil nil) + (add-hook 'flymake-diagnostic-functions #'sh-shellcheck-flymake nil t) + (add-hook 'hack-local-variables-hook + #'sh-after-hack-local-variables nil t) (treesit-parser-create 'bash) (setq-local treesit-font-lock-feature-list '(( comment function) diff --git a/lisp/progmodes/typescript-ts-mode.el b/lisp/progmodes/typescript-ts-mode.el index b21b1fd2cef..3f198e9f180 100644 --- a/lisp/progmodes/typescript-ts-mode.el +++ b/lisp/progmodes/typescript-ts-mode.el @@ -41,6 +41,16 @@ :safe 'integerp :group 'typescript) +(defface typescript-ts-jsx-tag-face + '((t . (:inherit font-lock-function-call-face))) + "Face for HTML tags like <div> and <p> in JSX." + :group 'typescript) + +(defface typescript-ts-jsx-attribute-face + '((t . (:inherit font-lock-constant-face))) + "Face for HTML attributes like name and id in JSX." + :group 'typescript) + (defvar typescript-ts-mode--syntax-table (let ((table (make-syntax-table))) ;; Taken from the cc-langs version @@ -284,17 +294,17 @@ Argument LANGUAGE is either `typescript' or `tsx'." :feature 'jsx `((jsx_opening_element [(nested_identifier (identifier)) (identifier)] - @font-lock-function-call-face) + @typescript-ts-jsx-tag-face) (jsx_closing_element [(nested_identifier (identifier)) (identifier)] - @font-lock-function-call-face) + @typescript-ts-jsx-tag-face) (jsx_self_closing_element [(nested_identifier (identifier)) (identifier)] - @font-lock-function-call-face) + @typescript-ts-jsx-tag-face) - (jsx_attribute (property_identifier) @font-lock-constant-face)) + (jsx_attribute (property_identifier) @typescript-ts-jsx-attribute-face)) :language language :feature 'number @@ -438,7 +448,15 @@ See `treesit-sexp-type-regexp' for more information.") ;;;###autoload (define-derived-mode tsx-ts-mode typescript-ts-base-mode "TypeScript[TSX]" - "Major mode for editing TypeScript." + "Major mode for editing TSX and JSX documents. + +This major mode defines two additional JSX-specific faces: +`typescript-ts-jsx-attribute-face' and +`typescript-ts-jsx-attribute-face' that are used for HTML tags +and attributes, respectively. + +The JSX-specific faces are used when `treesit-font-lock-level' is +at least 3 (which is the default value)." :group 'typescript :syntax-table typescript-ts-mode--syntax-table diff --git a/lisp/progmodes/vhdl-mode.el b/lisp/progmodes/vhdl-mode.el index c5ab5013fc8..45fd17f65c4 100644 --- a/lisp/progmodes/vhdl-mode.el +++ b/lisp/progmodes/vhdl-mode.el @@ -286,7 +286,7 @@ Overrides local variable `indent-tabs-mode'." ;; counter_rtl.vhd(29):Conditional signal assignment line__29 ("ModelSim" "vcom" "-93 -work \\1" "make" "-f \\1" nil "vlib \\1; vmap \\2 \\1" "./" "work/" "Makefile" "modelsim" - ("\\(ERROR:\\|WARNING\\[[0-9]+\\]:\\|\\*\\* Error:\\|\\*\\* Warning: \\[[0-9]+\\]\\| +\\) \\([^ ]+\\)(\\([0-9]+\\)):" 2 3 nil) + ("^\\(ERROR\\|WARNING\\|\\*\\* Error\\|\\*\\* Warning\\)[^:]*:\\( *\\[[0-9]+]\\| ([^)]+)\\)? \\([^ \t\n]+\\)(\\([0-9]+\\)):" 3 4 nil) ("" 0) ("\\1/_primary.dat" "\\2/\\1.dat" "\\1/_primary.dat" "\\1/_primary.dat" "\\1/body.dat" downcase)) diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index ee4253960c5..d77024136d0 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -636,7 +636,7 @@ If SELECT is non-nil, select the target window." (defface xref-match '((t :inherit match)) "Face used to highlight matches in the xref buffer." - :version "27.1") + :version "28.1") (defmacro xref--with-dedicated-window (&rest body) `(let* ((xref-w (get-buffer-window xref-buffer-name)) @@ -1525,7 +1525,7 @@ The meanings of both arguments are the same as documented in prompt)) (xref-backend-identifier-completion-table backend) nil nil nil - 'xref--read-identifier-history def))) + 'xref--read-identifier-history def t))) (if (equal id "") (or def (user-error "There is no default identifier")) id))) diff --git a/lisp/savehist.el b/lisp/savehist.el index b532668f8a4..ea8968c771b 100644 --- a/lisp/savehist.el +++ b/lisp/savehist.el @@ -232,8 +232,9 @@ If AUTO-SAVE is non-nil, compare the saved contents to the one last saved, savehist-coding-system)) (run-hooks 'savehist-save-hook) (let ((print-length nil) - (print-level nil) - (print-quoted t)) + (print-level nil) + (print-quoted t) + (print-circle t)) ;; Save the minibuffer histories, along with the value of ;; savehist-minibuffer-history-variables itself. (when savehist-save-minibuffer-history diff --git a/lisp/saveplace.el b/lisp/saveplace.el index 7512fc87c5d..18d296ba2d9 100644 --- a/lisp/saveplace.el +++ b/lisp/saveplace.el @@ -35,6 +35,8 @@ ;;; Code: +(require 'cl-lib) + ;; this is what I was using during testing: ;; (define-key ctl-x-map "p" 'toggle-save-place-globally) @@ -87,11 +89,77 @@ this happens automatically before saving `save-place-alist' to `save-place-file'." :type 'boolean) +(defun save-place-load-alist-from-file () + (if (not save-place-loaded) + (progn + (setq save-place-loaded t) + (let ((file (expand-file-name save-place-file))) + ;; make sure that the alist does not get overwritten, and then + ;; load it if it exists: + (if (file-readable-p file) + ;; don't want to use find-file because we have been + ;; adding hooks to it. + (with-current-buffer (get-buffer-create " *Saved Places*") + (delete-region (point-min) (point-max)) + ;; Make sure our 'coding:' cookie in the save-place + ;; file will take effect, in case the caller binds + ;; coding-system-for-read. + (let (coding-system-for-read) + (insert-file-contents file)) + (goto-char (point-min)) + (setq save-place-alist + (with-demoted-errors "Error reading save-place-file: %S" + (car (read-from-string + (buffer-substring (point-min) (point-max)))))) + + ;; If there is a limit, and we're over it, then we'll + ;; have to truncate the end of the list: + (if save-place-limit + (if (<= save-place-limit 0) + ;; Zero gets special cased. I'm not thrilled + ;; with this, but the loop for >= 1 is tight. + (setq save-place-alist nil) + ;; Else the limit is >= 1, so enforce it by + ;; counting and then `setcdr'ing. + (let ((s save-place-alist) + (count 1)) + (while s + (if (>= count save-place-limit) + (setcdr s nil) + (setq count (1+ count))) + (setq s (cdr s)))))) + + (kill-buffer (current-buffer)))) + nil)))) + (defcustom save-place-abbreviate-file-names nil "If non-nil, abbreviate file names before saving them. This can simplify sharing the `save-place-file' file across -different hosts." +different hosts. + +Changing this option requires rewriting `save-place-alist' with +corresponding file name format, therefore setting this option +just using `setq' may cause out-of-sync problems. You should use +either `setopt' or M-x customize-variable to set this option." :type 'boolean + :set (lambda (sym val) + (set-default sym val) + (or save-place-loaded (save-place-load-alist-from-file)) + (let ((fun (if val #'abbreviate-file-name #'expand-file-name))) + (setq save-place-alist + (cl-delete-duplicates + (cl-loop for (k . v) in save-place-alist + collect + (cons (funcall fun k) + (if (listp v) + (cl-loop for (k1 . v1) in v + collect + (cons k1 (funcall fun v1))) + v))) + :key #'car + :from-end t + :test #'equal))) + val) :version "28.1") (defcustom save-place-save-skipped t @@ -214,7 +282,11 @@ file names." ((and (derived-mode-p 'dired-mode) directory) (let ((filename (dired-get-filename nil t))) (if filename - `((dired-filename . ,filename)) + (list + (cons 'dired-filename + (if save-place-abbreviate-file-names + (abbreviate-file-name filename) + filename))) (point)))) (t (point))))) (if cell @@ -278,49 +350,6 @@ may have changed) back to `save-place-alist'." (file-error (message "Saving places: can't write %s" file))) (kill-buffer (current-buffer)))))) -(defun save-place-load-alist-from-file () - (if (not save-place-loaded) - (progn - (setq save-place-loaded t) - (let ((file (expand-file-name save-place-file))) - ;; make sure that the alist does not get overwritten, and then - ;; load it if it exists: - (if (file-readable-p file) - ;; don't want to use find-file because we have been - ;; adding hooks to it. - (with-current-buffer (get-buffer-create " *Saved Places*") - (delete-region (point-min) (point-max)) - ;; Make sure our 'coding:' cookie in the save-place - ;; file will take effect, in case the caller binds - ;; coding-system-for-read. - (let (coding-system-for-read) - (insert-file-contents file)) - (goto-char (point-min)) - (setq save-place-alist - (with-demoted-errors "Error reading save-place-file: %S" - (car (read-from-string - (buffer-substring (point-min) (point-max)))))) - - ;; If there is a limit, and we're over it, then we'll - ;; have to truncate the end of the list: - (if save-place-limit - (if (<= save-place-limit 0) - ;; Zero gets special cased. I'm not thrilled - ;; with this, but the loop for >= 1 is tight. - (setq save-place-alist nil) - ;; Else the limit is >= 1, so enforce it by - ;; counting and then `setcdr'ing. - (let ((s save-place-alist) - (count 1)) - (while s - (if (>= count save-place-limit) - (setcdr s nil) - (setq count (1+ count))) - (setq s (cdr s)))))) - - (kill-buffer (current-buffer)))) - nil)))) - (defun save-places-to-alist () ;; go through buffer-list, saving places to alist if save-place-mode ;; is non-nil, deleting them from alist if it is nil. @@ -353,7 +382,11 @@ may have changed) back to `save-place-alist'." "Function added to `find-file-hook' by `save-place-mode'. It runs the hook `save-place-after-find-file-hook'." (or save-place-loaded (save-place-load-alist-from-file)) - (let ((cell (assoc buffer-file-name save-place-alist))) + (let ((cell (and (stringp buffer-file-name) + (assoc (if save-place-abbreviate-file-names + (abbreviate-file-name buffer-file-name) + buffer-file-name) + save-place-alist)))) (if cell (progn (or revert-buffer-in-progress-p @@ -368,25 +401,25 @@ It runs the hook `save-place-after-find-file-hook'." (defun save-place-dired-hook () "Position the point in a Dired buffer." (or save-place-loaded (save-place-load-alist-from-file)) - (let* ((directory (and (derived-mode-p 'dired-mode) - (boundp 'dired-subdir-alist) - dired-subdir-alist - (dired-current-directory))) - (cell (assoc (and directory - (expand-file-name (if (consp directory) - (car directory) - directory))) - save-place-alist))) - (if cell - (progn - (or revert-buffer-in-progress-p - (cond - ((integerp (cdr cell)) - (goto-char (cdr cell))) - ((and (listp (cdr cell)) (assq 'dired-filename (cdr cell))) - (dired-goto-file (cdr (assq 'dired-filename (cdr cell))))))) - ;; and make sure it will be saved again for later - (setq save-place-mode t))))) + (when-let ((directory (and (derived-mode-p 'dired-mode) + (boundp 'dired-subdir-alist) + dired-subdir-alist + (dired-current-directory))) + (item (expand-file-name (if (consp directory) + (car directory) + directory))) + (cell (assoc (if save-place-abbreviate-file-names + (abbreviate-file-name item) item) + save-place-alist))) + (or revert-buffer-in-progress-p + (cond + ((integerp (cdr cell)) + (goto-char (cdr cell))) + ((listp (cdr cell)) + (when-let ((elt (assq 'dired-filename (cdr cell)))) + (dired-goto-file (expand-file-name (cdr elt))))))) + ;; and make sure it will be saved again for later + (setq save-place-mode t))) (defun save-place-kill-emacs-hook () ;; First update the alist. This loads the old save-place-file if nec. diff --git a/lisp/shell.el b/lisp/shell.el index 5cf108bfa3b..b74442f1961 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -366,6 +366,12 @@ Useful for shells like zsh that has this feature." :group 'shell-directories :version "28.1") +(defcustom shell-get-old-input-include-continuation-lines nil + "Whether `shell-get-old-input' includes \"\\\" lines." + :type 'boolean + :group 'shell + :version "30.1") + (defcustom shell-kill-buffer-on-exit nil "Kill a shell buffer after the shell process terminates." :type 'boolean @@ -506,6 +512,39 @@ Useful for shells like zsh that has this feature." (push (mapconcat #'identity (nreverse arg) "") args))) (cons (nreverse args) (nreverse begins))))) +(defun shell-get-old-input () + "Default for `comint-get-old-input' in `shell-mode'. +If `comint-use-prompt-regexp' is nil, then either +return the current input field (if point is on an input field), or the +current line (if point is on an output field). +If `comint-use-prompt-regexp' is non-nil, then return +the current line, with any initial string matching the regexp +`comint-prompt-regexp' removed. +In either case, if `shell-get-old-input-include-continuation-lines' +is non-nil and the current line ends with a backslash, the next +line is also included and examined for a backslash, ending with a +final line without a backslash." + (let (field-prop bof) + (if (and (not comint-use-prompt-regexp) + ;; Make sure we're in an input rather than output field. + (not (setq field-prop (get-char-property + (setq bof (field-beginning)) 'field)))) + (field-string-no-properties bof) + (comint-bol) + (let ((start (point))) + (cond ((or comint-use-prompt-regexp + (eq field-prop 'output)) + (goto-char (line-end-position)) + (when shell-get-old-input-include-continuation-lines + ;; Include continuation lines as long as the current + ;; line ends with a backslash. + (while (and (not (eobp)) + (= (char-before) ?\\)) + (goto-char (line-end-position 2))))) + (t + (goto-char (field-end)))) + (buffer-substring-no-properties start (point)))))) + ;;;###autoload (defun split-string-shell-command (string) "Split STRING (a shell command) into a list of strings. @@ -642,6 +681,7 @@ command." (setq-local font-lock-defaults '(shell-font-lock-keywords t)) (setq-local shell-dirstack nil) (setq-local shell-last-dir nil) + (setq-local comint-get-old-input #'shell-get-old-input) ;; People expect Shell mode to keep the last line of output at ;; window bottom. (setq-local scroll-conservatively 101) diff --git a/lisp/simple.el b/lisp/simple.el index 80c75d4d7c3..b621e1603bd 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -623,7 +623,7 @@ A non-nil INTERACTIVE argument means to run the `post-self-insert-hook'." (beforepos (point)) (last-command-event ?\n) ;; Don't auto-fill if we have a prefix argument. - (auto-fill-function (if arg nil auto-fill-function)) + (inhibit-auto-fill (or inhibit-auto-fill arg)) (arg (prefix-numeric-value arg)) (procsym (make-symbol "newline-postproc")) ;(bug#46326) (postproc @@ -8919,11 +8919,15 @@ unless optional argument SOFT is non-nil." ;; If we're not inside a comment, just try to indent. (t (indent-according-to-mode)))))) +(defvar inhibit-auto-fill nil + "Non-nil means to do as if `auto-fill-mode' was disabled.") + (defun internal-auto-fill () "The function called by `self-insert-command' to perform auto-filling." - (when (or (not comment-start) - (not comment-auto-fill-only-comments) - (nth 4 (syntax-ppss))) + (unless (or inhibit-auto-fill + (and comment-start + comment-auto-fill-only-comments + (not (nth 4 (syntax-ppss))))) (funcall auto-fill-function))) (defvar normal-auto-fill-function 'do-auto-fill @@ -9108,6 +9112,13 @@ presented." "Toggle buffer size display in the mode line (Size Indication mode)." :global t :group 'mode-line) +(defcustom remote-file-name-inhibit-auto-save nil + "When nil, `auto-save-mode' will auto-save remote files. +Any other value means that it will not." + :group 'auto-save + :type 'boolean + :version "30.1") + (define-minor-mode auto-save-mode "Toggle auto-saving in the current buffer (Auto Save mode). @@ -9130,6 +9141,9 @@ For more details, see Info node `(emacs) Auto Save'." (setq buffer-auto-save-file-name (cond ((null val) nil) + ((and buffer-file-name remote-file-name-inhibit-auto-save + (file-remote-p buffer-file-name)) + nil) ((and buffer-file-name auto-save-visited-file-name (not buffer-read-only)) buffer-file-name) diff --git a/lisp/speedbar.el b/lisp/speedbar.el index 60113ca1410..29f351ca021 100644 --- a/lisp/speedbar.el +++ b/lisp/speedbar.el @@ -2591,13 +2591,12 @@ interrupted by the user." (if (not speedbar-stealthy-update-recurse) (let ((l (speedbar-initial-stealthy-functions)) (speedbar-stealthy-update-recurse t)) - (unwind-protect - (speedbar-with-writable - (while (and l (funcall (car l))) - ;;(sit-for 0) - (setq l (cdr l)))) - ;;(dframe-message "Exit with %S" (car l)) - )))) + (speedbar-with-writable + (while (and l (funcall (car l))) + ;;(sit-for 0) + (setq l (cdr l)))) + ;;(dframe-message "Exit with %S" (car l)) + ))) (defun speedbar-reset-scanners () "Reset any variables used by functions in the stealthy list as state. @@ -3572,38 +3571,36 @@ value is \"show\" then toggle the value of "For FILE, run etags and create a list of symbols extracted. Each symbol will be associated with its line position in FILE." (let ((newlist nil)) - (unwind-protect - (save-excursion - (if (get-buffer "*etags tmp*") - (kill-buffer "*etags tmp*")) ;kill to clean it up - (if (<= 1 speedbar-verbosity-level) - (dframe-message "Fetching etags...")) - (set-buffer (get-buffer-create "*etags tmp*")) - (apply 'call-process speedbar-fetch-etags-command nil - (current-buffer) nil - (append speedbar-fetch-etags-arguments (list file))) - (goto-char (point-min)) - (if (<= 1 speedbar-verbosity-level) - (dframe-message "Fetching etags...")) - (let ((expr - (let ((exprlst speedbar-fetch-etags-parse-list) - (ans nil)) - (while (and (not ans) exprlst) - (if (string-match (car (car exprlst)) file) - (setq ans (car exprlst))) - (setq exprlst (cdr exprlst))) - (cdr ans)))) - (if expr - (let (tnl) - (set-buffer (get-buffer-create "*etags tmp*")) - (while (not (save-excursion (end-of-line) (eobp))) - (save-excursion - (setq tnl (speedbar-extract-one-symbol expr))) - (if tnl (setq newlist (cons tnl newlist))) - (forward-line 1))) - (dframe-message - "Sorry, no support for a file of that extension")))) - ) + (save-excursion + (if (get-buffer "*etags tmp*") + (kill-buffer "*etags tmp*")) ;kill to clean it up + (if (<= 1 speedbar-verbosity-level) + (dframe-message "Fetching etags...")) + (set-buffer (get-buffer-create "*etags tmp*")) + (apply 'call-process speedbar-fetch-etags-command nil + (current-buffer) nil + (append speedbar-fetch-etags-arguments (list file))) + (goto-char (point-min)) + (if (<= 1 speedbar-verbosity-level) + (dframe-message "Fetching etags...")) + (let ((expr + (let ((exprlst speedbar-fetch-etags-parse-list) + (ans nil)) + (while (and (not ans) exprlst) + (if (string-match (car (car exprlst)) file) + (setq ans (car exprlst))) + (setq exprlst (cdr exprlst))) + (cdr ans)))) + (if expr + (let (tnl) + (set-buffer (get-buffer-create "*etags tmp*")) + (while (not (save-excursion (end-of-line) (eobp))) + (save-excursion + (setq tnl (speedbar-extract-one-symbol expr))) + (if tnl (setq newlist (cons tnl newlist))) + (forward-line 1))) + (dframe-message + "Sorry, no support for a file of that extension")))) (if speedbar-sort-tags (sort newlist (lambda (a b) (string< (car a) (car b)))) (reverse newlist)))) diff --git a/lisp/strokes.el b/lisp/strokes.el index fe244d448d8..293bdf0f369 100644 --- a/lisp/strokes.el +++ b/lisp/strokes.el @@ -760,27 +760,27 @@ Optional EVENT is acceptable as the starting event of the stroke." (setq safe-to-draw-p t)) (push (cdr (mouse-pixel-position)) pix-locs))) - (setq event (read--potential-mouse-event))))) - ;; protected - ;; clean up strokes buffer and then bury it. - (when (equal (buffer-name) strokes-buffer-name) - (subst-char-in-region (point-min) (point-max) - strokes-character ?\s) - (goto-char (point-min)) - (bury-buffer)))) - ;; Otherwise, don't use strokes buffer and read stroke silently - (when prompt - (message "%s" prompt) - (setq event (read--potential-mouse-event)) - (or (strokes-button-press-event-p event) - (error "You must draw with the mouse"))) - (track-mouse - (or event (setq event (read--potential-mouse-event))) - (while (not (strokes-button-release-event-p event)) - (if (strokes-mouse-event-p event) - (push (cdr (mouse-pixel-position)) - pix-locs)) - (setq event (read--potential-mouse-event)))) + (setq event (read--potential-mouse-event)))) + ;; protected + ;; clean up strokes buffer and then bury it. + (when (equal (buffer-name) strokes-buffer-name) + (subst-char-in-region (point-min) (point-max) + strokes-character ?\s) + (goto-char (point-min)) + (bury-buffer)))) + ;; Otherwise, don't use strokes buffer and read stroke silently + (when prompt + (message "%s" prompt) + (setq event (read--potential-mouse-event)) + (or (strokes-button-press-event-p event) + (error "You must draw with the mouse"))) + (track-mouse + (or event (setq event (read--potential-mouse-event))) + (while (not (strokes-button-release-event-p event)) + (if (strokes-mouse-event-p event) + (push (cdr (mouse-pixel-position)) + pix-locs)) + (setq event (read--potential-mouse-event))))) (setq grid-locs (strokes-renormalize-to-grid (nreverse pix-locs))) (strokes-fill-stroke (strokes-eliminate-consecutive-redundancies grid-locs))))) diff --git a/lisp/subr.el b/lisp/subr.el index 99ddd813867..427014cedc3 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -45,7 +45,8 @@ declaration. A FILE with an \"ext:\" prefix is an external file. `check-declare' will check such files if they are found, and skip them without error if they are not. -Optional ARGLIST specifies FN's arguments, or is t to not specify +Optional ARGLIST specifies FN's arguments, in the same form as +in `defun' (including the parentheses); or it is t to not specify FN's arguments. An omitted ARGLIST defaults to t, not nil: a nil ARGLIST specifies an empty argument list, and an explicit t ARGLIST is a placeholder that allows supplying a later arg. @@ -828,7 +829,7 @@ of course, also replace TO with a slightly larger value If TREE is a cons cell, this recursively copies both its car and its cdr. Contrast to `copy-sequence', which copies only along the cdrs. With second argument VECP, this copies vectors as well as conses." - (declare (side-effect-free t)) + (declare (side-effect-free error-free)) (if (consp tree) (let (result) (while (consp tree) @@ -1554,31 +1555,32 @@ EVENT may be an event or an event type. If EVENT is a symbol that has never been used in an event that has been read as input in the current Emacs session, then this function may fail to include the `click' modifier." - (let ((type event)) - (if (listp type) - (setq type (car type))) - (if (symbolp type) - ;; Don't read event-symbol-elements directly since we're not - ;; sure the symbol has already been parsed. - (cdr (internal-event-symbol-parse-modifiers type)) - (let ((list nil) - (char (logand type (lognot (logior ?\M-\0 ?\C-\0 ?\S-\0 - ?\H-\0 ?\s-\0 ?\A-\0))))) - (if (not (zerop (logand type ?\M-\0))) - (push 'meta list)) - (if (or (not (zerop (logand type ?\C-\0))) - (< char 32)) - (push 'control list)) - (if (or (not (zerop (logand type ?\S-\0))) - (/= char (downcase char))) - (push 'shift list)) - (or (zerop (logand type ?\H-\0)) - (push 'hyper list)) - (or (zerop (logand type ?\s-\0)) - (push 'super list)) - (or (zerop (logand type ?\A-\0)) - (push 'alt list)) - list)))) + (unless (stringp event) + (let ((type event)) + (if (listp type) + (setq type (car type))) + (if (symbolp type) + ;; Don't read event-symbol-elements directly since we're not + ;; sure the symbol has already been parsed. + (cdr (internal-event-symbol-parse-modifiers type)) + (let ((list nil) + (char (logand type (lognot (logior ?\M-\0 ?\C-\0 ?\S-\0 + ?\H-\0 ?\s-\0 ?\A-\0))))) + (if (not (zerop (logand type ?\M-\0))) + (push 'meta list)) + (if (or (not (zerop (logand type ?\C-\0))) + (< char 32)) + (push 'control list)) + (if (or (not (zerop (logand type ?\S-\0))) + (/= char (downcase char))) + (push 'shift list)) + (or (zerop (logand type ?\H-\0)) + (push 'hyper list)) + (or (zerop (logand type ?\s-\0)) + (push 'super list)) + (or (zerop (logand type ?\A-\0)) + (push 'alt list)) + list))))) (defun event-basic-type (event) "Return the basic type of the given event (all modifiers removed). @@ -1586,17 +1588,18 @@ The value is a printing character (not upper case) or a symbol. EVENT may be an event or an event type. If EVENT is a symbol that has never been used in an event that has been read as input in the current Emacs session, then this function may return nil." - (if (consp event) - (setq event (car event))) - (if (symbolp event) - (car (get event 'event-symbol-elements)) - (let* ((base (logand event (1- ?\A-\0))) - (uncontrolled (if (< base 32) (logior base 64) base))) - ;; There are some numbers that are invalid characters and - ;; cause `downcase' to get an error. - (condition-case () - (downcase uncontrolled) - (error uncontrolled))))) + (unless (stringp event) + (if (consp event) + (setq event (car event))) + (if (symbolp event) + (car (get event 'event-symbol-elements)) + (let* ((base (logand event (1- ?\A-\0))) + (uncontrolled (if (< base 32) (logior base 64) base))) + ;; There are some numbers that are invalid characters and + ;; cause `downcase' to get an error. + (condition-case () + (downcase uncontrolled) + (error uncontrolled)))))) (defsubst mouse-movement-p (object) "Return non-nil if OBJECT is a mouse movement event." @@ -3233,34 +3236,40 @@ This function is used by the `interactive' code letter \"n\"." n)) (defvar read-char-choice-use-read-key nil - "Prefer `read-key' when reading a character by `read-char-choice'. -Otherwise, use the minibuffer. + "If non-nil, use `read-key' when reading a character by `read-char-choice'. +Otherwise, use the minibuffer (this is the default). -When using the minibuffer, the user is less constrained, and can -use the normal commands available in the minibuffer, and can, for -instance, switch to another buffer, do things there, and then -switch back again to the minibuffer before entering the -character. This is not possible when using `read-key', but using -`read-key' may be less confusing to some users.") +When reading via the minibuffer, you can use the normal commands +available in the minibuffer, and can, for instance, temporarily +switch to another buffer, do things there, and then switch back +to the minibuffer before entering the character. This is not +possible when using `read-key', but using `read-key' may be less +confusing to some users.") (defun read-char-choice (prompt chars &optional inhibit-keyboard-quit) - "Read and return one of CHARS, prompting for PROMPT. -Any input that is not one of CHARS is ignored. - -By default, the minibuffer is used to read the key -non-modally (see `read-char-from-minibuffer'). If + "Read and return one of the characters in CHARS, prompting with PROMPT. +CHARS should be a list of single characters. +The function discards any input character that is not one of CHARS, +and by default shows a message to the effect that it is not one of +the expected characters. + +By default, this function uses the minibuffer to read the key +non-modally (see `read-char-from-minibuffer'), and the optional +argument INHIBIT-KEYBOARD-QUIT is ignored. However, if `read-char-choice-use-read-key' is non-nil, the modal `read-key' -function is used instead (see `read-char-choice-with-read-key')." +function is used instead (see `read-char-choice-with-read-key'), +and INHIBIT-KEYBOARD-QUIT is passed to it." (if (not read-char-choice-use-read-key) (read-char-from-minibuffer prompt chars) (read-char-choice-with-read-key prompt chars inhibit-keyboard-quit))) (defun read-char-choice-with-read-key (prompt chars &optional inhibit-keyboard-quit) - "Read and return one of CHARS, prompting for PROMPT. + "Read and return one of the characters in CHARS, prompting with PROMPT. +CHARS should be a list of single characters. Any input that is not one of CHARS is ignored. If optional argument INHIBIT-KEYBOARD-QUIT is non-nil, ignore -`keyboard-quit' events while waiting for a valid input. +`keyboard-quit' events while waiting for valid input. If you bind the variable `help-form' to a non-nil value while calling this function, then pressing `help-char' @@ -3556,22 +3565,22 @@ Also discard all previous input in the minibuffer." (sit-for 2))) (defvar y-or-n-p-use-read-key nil - "Prefer `read-key' when answering a \"y or n\" question by `y-or-n-p'. -Otherwise, use the minibuffer. + "Use `read-key' when reading answers to \"y or n\" questions by `y-or-n-p'. +Otherwise, use the `read-from-minibuffer' to read the answers. -When using the minibuffer, the user is less constrained, and can -use the normal commands available in the minibuffer, and can, for -instance, switch to another buffer, do things there, and then -switch back again to the minibuffer before entering the -character. This is not possible when using `read-key', but using -`read-key' may be less confusing to some users.") +When reading via the minibuffer, you can use the normal commands +available in the minibuffer, and can, for instance, temporarily +switch to another buffer, do things there, and then switch back +to the minibuffer before entering the character. This is not +possible when using `read-key', but using `read-key' may be less +confusing to some users.") (defvar from--tty-menu-p nil "Non-nil means the current command was invoked from a TTY menu.") (defun use-dialog-box-p () - "Say whether the current command should prompt the user via a dialog box." + "Return non-nil if the current command should prompt the user via a dialog box." (and last-input-event ; not during startup - (or (listp last-nonmenu-event) ; invoked by a mouse event + (or (consp last-nonmenu-event) ; invoked by a mouse event from--tty-menu-p) ; invoked via TTY menu use-dialog-box)) @@ -7114,7 +7123,7 @@ CONDITION is either: - the symbol t, to always match, - the symbol nil, which never matches, - a regular expression, to match a buffer name, -- a predicate function that takes a buffer object and ARG as +- a predicate function that takes BUFFER-OR-NAME and ARG as arguments, and returns non-nil if the buffer matches, - a cons-cell, where the car describes how to interpret the cdr. The car can be one of the following: @@ -7140,8 +7149,8 @@ CONDITION is either: (string-match-p condition (buffer-name buffer))) ((pred functionp) (if (eq 1 (cdr (func-arity condition))) - (funcall condition buffer) - (funcall condition buffer arg))) + (funcall condition buffer-or-name) + (funcall condition buffer-or-name arg))) (`(major-mode . ,mode) (eq (buffer-local-value 'major-mode buffer) @@ -7164,12 +7173,13 @@ CONDITION is either: (funcall match (list condition)))) (defun match-buffers (condition &optional buffers arg) - "Return a list of buffers that match CONDITION. -See `buffer-match-p' for details on CONDITION. By default all -buffers are checked, this can be restricted by passing an -optional argument BUFFERS, set to a list of buffers to check. -ARG is passed to `buffer-match', for predicate conditions in -CONDITION." + "Return a list of buffers that match CONDITION, or nil if none match. +See `buffer-match-p' for various supported CONDITIONs. +By default all buffers are checked, but the optional +argument BUFFERS can restrict that: its value should be +an explicit list of buffers to check. +Optional argument ARG is passed to `buffer-match-p', for +predicate conditions in CONDITION." (let (bufs) (dolist (buf (or buffers (buffer-list))) (when (buffer-match-p condition (get-buffer buf) arg) diff --git a/lisp/term.el b/lisp/term.el index 3e4907e8bfc..e1392908b90 100644 --- a/lisp/term.el +++ b/lisp/term.el @@ -1370,9 +1370,14 @@ Entry to this mode runs the hooks on `term-mode-hook'." (interactive "e") ;; Give temporary modes such as isearch a chance to turn off. (run-hooks 'mouse-leave-buffer-hook) - (setq this-command 'yank) (mouse-set-point click) - (term-send-raw-string (gui-get-primary-selection))) + ;; As we have moved point, bind `select-active-regions' to prevent + ;; the `deactivate-mark' call in `term-send-raw-string' from + ;; changing the primary selection (resulting in consecutive calls to + ;; `term-mouse-paste' each sending different text). (bug#58608). + ;; FIXME: Why does this command change point at all? + (let ((select-active-regions nil)) + (term-send-raw-string (gui-get-primary-selection)))) (defun term-paste () "Insert the last stretch of killed text at point." diff --git a/lisp/textmodes/html-ts-mode.el b/lisp/textmodes/html-ts-mode.el index 58dcc7d8cad..4c1f410a7ef 100644 --- a/lisp/textmodes/html-ts-mode.el +++ b/lisp/textmodes/html-ts-mode.el @@ -42,7 +42,7 @@ (defvar html-ts-mode--indent-rules `((html - ((parent-is "fragment") point-min 0) + ((parent-is "fragment") column-0 0) ((node-is "/>") parent-bol 0) ((node-is ">") parent-bol 0) ((node-is "end_tag") parent-bol 0) diff --git a/lisp/textmodes/ispell.el b/lisp/textmodes/ispell.el index bb2bcfd8052..97c4ce9f32d 100644 --- a/lisp/textmodes/ispell.el +++ b/lisp/textmodes/ispell.el @@ -214,12 +214,14 @@ Must be greater than 1." ((file-readable-p "/usr/share/lib/dict/words") "/usr/share/lib/dict/words") ((file-readable-p "/sys/dict") "/sys/dict")) - "Alternate plain word-list dictionary for spelling help." + "Alternate plain word-list dictionary for spelling help. +This is also used by `ispell-lookup-words' and `ispell-complete-word'." :type '(choice file (const :tag "None" nil))) (defcustom ispell-complete-word-dict nil "Plain word-list dictionary used for word completion if -different from `ispell-alternate-dictionary'." +different from `ispell-alternate-dictionary'. +This is also used by `ispell-lookup-words' and `ispell-complete-word'." :type '(choice file (const :tag "None" nil))) (defcustom ispell-message-dictionary-alist nil @@ -2510,7 +2512,9 @@ Otherwise the variable `ispell-grep-command' contains the command Optional second argument contains the dictionary to use; the default is `ispell-alternate-dictionary', overridden by `ispell-complete-word-dict' -if defined." +if defined. If none of LOOKUP-DICT, `ispell-alternate-dictionary', +and `ispell-complete-word-dict' name an existing word-list file, +this function signals an error." ;; We don't use the filter for this function, rather the result is written ;; into a buffer. Hence there is no need to save the filter values. (if (null lookup-dict) @@ -3685,7 +3689,12 @@ If APPEND is non-nil, don't erase previous debugging output." If optional INTERIOR-FRAG is non-nil, then the word may be a character sequence inside of a word. -Standard ispell choices are then available." +Standard ispell choices are then available. + +This command uses a word-list file specified +by `ispell-alternate-dictionary' or by `ispell-complete-word-dict'; +if none of those name an existing word-list file, this command +signals an error." ;; FIXME: completion-at-point-function. (interactive "P") (let ((case-fold-search-val case-fold-search) diff --git a/lisp/textmodes/reftex-index.el b/lisp/textmodes/reftex-index.el index 778591a8069..c7a297d5dac 100644 --- a/lisp/textmodes/reftex-index.el +++ b/lisp/textmodes/reftex-index.el @@ -1445,20 +1445,19 @@ match, the user will be asked to confirm the replacement." (as-words reftex-index-phrases-search-whole-words)) (unless macro-data (error "No macro associated with key %c" char)) - (unwind-protect - (let ((overlay-arrow-string "=>") - (overlay-arrow-position - reftex-index-phrases-marker) - (replace-count 0)) - ;; Show the overlay arrow - (move-marker reftex-index-phrases-marker - (match-beginning 0) (current-buffer)) - ;; Start the query-replace - (reftex-query-index-phrase-globally - files phrase macro-fmt - index-key repeat as-words) - (message "%s replaced" - (reftex-number replace-count "occurrence")))))) + (let ((overlay-arrow-string "=>") + (overlay-arrow-position + reftex-index-phrases-marker) + (replace-count 0)) + ;; Show the overlay arrow + (move-marker reftex-index-phrases-marker + (match-beginning 0) (current-buffer)) + ;; Start the query-replace + (reftex-query-index-phrase-globally + files phrase macro-fmt + index-key repeat as-words) + (message "%s replaced" + (reftex-number replace-count "occurrence"))))) (t (error "Cannot parse this line"))))) (defun reftex-index-all-phrases () diff --git a/lisp/textmodes/table.el b/lisp/textmodes/table.el index 2271d83eff5..50c3f461bcc 100644 --- a/lisp/textmodes/table.el +++ b/lisp/textmodes/table.el @@ -1935,8 +1935,8 @@ specific features." (if (and cell table-detect-cell-alignment) (table--detect-cell-alignment cell))) (unless (re-search-forward border end t) - (goto-char end)))))))))) - (restore-buffer-modified-p modified-flag))) + (goto-char end)))))) + (restore-buffer-modified-p modified-flag))))))) ;;;###autoload (defun table-unrecognize-region (beg end) diff --git a/lisp/transient.el b/lisp/transient.el index 96e711e950c..4affc414fa6 100644 --- a/lisp/transient.el +++ b/lisp/transient.el @@ -2516,17 +2516,22 @@ prefix argument and pivot to `transient-update'." (defun transient--invalid (msg) (ding) - (message "%s: `%s' (Use `%s' to abort, `%s' for help) [%s]" + (message "%s: `%s' (Use `%s' to abort, `%s' for help)%s" msg (propertize (key-description (this-single-command-keys)) '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)) + ;; `this-command' is `transient-undefined' or `transient-inapt'. + ;; Show the command (`this-original-command') the user actually + ;; tried to invoke. For an anonymous inapt command that is a + ;; lambda expression, which cannot be mapped to a symbol, so + ;; forgo displaying the command. + (if-let ((cmd (ignore-errors + (symbol-name (transient--suffix-symbol + this-original-command))))) + (format " [%s]" (propertize cmd 'face 'font-lock-warning-face)) + "")) (unless (and transient--transient-map (memq transient--transient-map overriding-terminal-local-map)) (let ((transient--prefix (or transient--prefix 'sic))) diff --git a/lisp/treesit.el b/lisp/treesit.el index 9bb58ec4ab1..ed7ad280684 100644 --- a/lisp/treesit.el +++ b/lisp/treesit.el @@ -88,6 +88,7 @@ (declare-function treesit-search-forward "treesit.c") (declare-function treesit-induce-sparse-tree "treesit.c") (declare-function treesit-subtree-stat "treesit.c") +(declare-function treesit-node-match-p "treesit.c") (declare-function treesit-available-p "treesit.c") @@ -106,7 +107,7 @@ indent, imenu, etc." ;; 40MB for 64-bit systems, 15 for 32-bit. (if (or (< most-positive-fixnum (* 2.0 1024 mb)) ;; 32-bit system with wide ints. - (string-match-p "--with-wide-int" system-configuration-options)) + (string-search "--with-wide-int" system-configuration-options)) (* 15 mb) (* 40 mb))) "Maximum buffer size (in bytes) for enabling tree-sitter parsing. @@ -245,21 +246,19 @@ is nil, try to guess the language at BEG using `treesit-language-at'." Specifically, return the highest parent of NODE that has the same type as it. If no such parent exists, return nil. -If PRED is non-nil, match each parent's type with PRED as a -regexp, rather than using NODE's type. PRED can also be a -function that takes the node as an argument, and return -non-nil/nil for match/no match. +If PRED is non-nil, match each parent's type with PRED rather +than using NODE's type. PRED can also be a predicate function, +and more. See `treesit-thing-settings' for details. If INCLUDE-NODE is non-nil, return NODE if it satisfies PRED." - (let ((pred (or pred (treesit-node-type node))) + (let ((pred (or pred (rx-to-string + `(bos ,(treesit-node-type node) eos)))) (result nil)) (cl-loop for cursor = (if include-node node (treesit-node-parent node)) then (treesit-node-parent cursor) while cursor - if (if (stringp pred) - (string-match-p pred (treesit-node-type cursor)) - (funcall pred cursor)) + if (treesit-node-match-p cursor pred) do (setq result cursor)) result)) @@ -324,13 +323,13 @@ If INCLUDE-NODE is non-nil, return NODE if it satisfies PRED." node)) (defun treesit-parent-while (node pred) - "Return the furthest parent of NODE that satisfies PRED. + "Return the furthest parent of NODE (including NODE) that satisfies PRED. -This function successively examines the parent of NODE, then -the parent of the parent, etc., until it finds an ancestor node -which no longer satisfies the predicate PRED; it returns the last -examined ancestor that satisfies PRED. It returns nil if no -ancestor node was found that satisfies PRED. +This function successively examines NODE, the parent of NODE, +then the parent of the parent, etc., until it finds a node which +no longer satisfies the predicate PRED; it returns the last +examined node that satisfies PRED. If no node satisfies PRED, it +returns nil. PRED should be a function that takes one argument, the node to examine, and returns a boolean value indicating whether that @@ -363,6 +362,50 @@ If NAMED is non-nil, count named child only." (idx (treesit-node-index node))) (treesit-node-field-name-for-child parent idx))) +(defun treesit-node-get (node instructions) + "Get things from NODE by INSTRUCTIONS. + +This is a convenience function that chains together multiple node +accessor functions together. For example, to get NODE's parent's +next sibling's second child's text, call + + (treesit-node-get node + \\='((parent 1) + (sibling 1 nil) + (child 1 nil) + (text nil))) + +INSTRUCTION is a list of INSTRUCTIONs of the form (FN ARG...). +The following FN's are supported: + +\(child IDX NAMED) Get the IDX'th child +\(parent N) Go to parent N times +\(field-name) Get the field name of the current node +\(type) Get the type of the current node +\(text NO-PROPERTY) Get the text of the current node +\(children NAMED) Get a list of children +\(sibling STEP NAMED) Get the nth prev/next sibling, negative STEP + means prev sibling, positive means next + +Note that arguments like NAMED and NO-PROPERTY can't be omitted, +unlike in their original functions." + (declare (indent 1)) + (while (and node instructions) + (pcase (pop instructions) + ('(field-name) (setq node (treesit-node-field-name node))) + ('(type) (setq node (treesit-node-type node))) + (`(child ,idx ,named) (setq node (treesit-node-child node idx named))) + (`(parent ,n) (dotimes (_ n) + (setq node (treesit-node-parent node)))) + (`(text ,no-property) (setq node (treesit-node-text node no-property))) + (`(children ,named) (setq node (treesit-node-children node named))) + (`(sibling ,step ,named) + (dotimes (_ (abs step)) + (setq node (if (> step 0) + (treesit-node-next-sibling node named) + (treesit-node-prev-sibling node named))))))) + node) + ;;; Query API supplement (defun treesit-query-string (string query language) @@ -1739,15 +1782,17 @@ however, smaller in scope than sentences. This is used by `treesit-forward-sexp' and friends.") (defun treesit-forward-sexp (&optional arg) + "Tree-sitter implementation for `forward-sexp-function'. +ARG is described in the docstring of `forward-sexp-function'." (interactive "^p") (or arg (setq arg 1)) (funcall (if (> arg 0) #'treesit-end-of-thing #'treesit-beginning-of-thing) - treesit-sexp-type-regexp (abs arg))) + treesit-sexp-type-regexp (abs arg) 'restricted)) (defun treesit-transpose-sexps (&optional arg) "Tree-sitter `transpose-sexps' function. -Arg is the same as in `transpose-sexps'. +ARG is the same as in `transpose-sexps'. Locate the node closest to POINT, and transpose that node with its sibling node ARG nodes away. @@ -1841,44 +1886,49 @@ nil.") "The delimiter used to connect several defun names. This is used in `treesit-add-log-current-defun'.") -(defsubst treesit--thing-unpack-pattern (pattern) - "Unpack PATTERN in the shape of `treesit-defun-type-regexp'. - -Basically, - - (unpack REGEXP) = (REGEXP . nil) - (unpack (REGEXP . PRED)) = (REGEXP . PRED)" - (if (consp pattern) - pattern - (cons pattern nil))) - -(defun treesit-beginning-of-thing (pattern &optional arg) +(defun treesit-beginning-of-thing (pred &optional arg tactic) "Like `beginning-of-defun', but generalized into things. -PATTERN is like `treesit-defun-type-regexp', ARG +PRED is like `treesit-defun-type-regexp', ARG is the same as in `beginning-of-defun'. +TACTIC determines how does this function move between things. It +can be `nested', `top-level', `restricted', or nil. `nested' +means normal nested navigation: try to move to siblings first, +and if there aren't enough siblings, move to the parent and its +siblings. `top-level' means only consider top-level things, and +nested things are ignored. `restricted' means movement is +restricted inside the thing that encloses POS (i.e., parent), +should there be one. If omitted, TACTIC is considered to be +`nested'. + Return non-nil if successfully moved, nil otherwise." (pcase-let* ((arg (or arg 1)) - (`(,regexp . ,pred) (treesit--thing-unpack-pattern - pattern)) (dest (treesit--navigate-thing - (point) (- arg) 'beg regexp pred))) + (point) (- arg) 'beg pred tactic))) (when dest (goto-char dest)))) -(defun treesit-end-of-thing (pattern &optional arg) +(defun treesit-end-of-thing (pred &optional arg tactic) "Like `end-of-defun', but generalized into things. -PATTERN is like `treesit-defun-type-regexp', ARG is the same as +PRED is like `treesit-defun-type-regexp', ARG is the same as in `end-of-defun'. +TACTIC determines how does this function move between things. It +can be `nested', `top-level', `restricted', or nil. `nested' +means normal nested navigation: try to move to siblings first, +and if there aren't enough siblings, move to the parent and its +siblings. `top-level' means only consider top-level things, and +nested things are ignored. `restricted' means movement is +restricted inside the thing that encloses POS (i.e., parent), +should there be one. If omitted, TACTIC is considered to be +`nested'. + Return non-nil if successfully moved, nil otherwise." (pcase-let* ((arg (or arg 1)) - (`(,regexp . ,pred) (treesit--thing-unpack-pattern - pattern)) (dest (treesit--navigate-thing - (point) arg 'end regexp pred))) + (point) arg 'end pred tactic))) (when dest (goto-char dest)))) @@ -1899,7 +1949,8 @@ and `treesit-defun-skipper'." (catch 'done (dotimes (_ 2) - (when (treesit-beginning-of-thing treesit-defun-type-regexp arg) + (when (treesit-beginning-of-thing + treesit-defun-type-regexp arg treesit-defun-tactic) (when treesit-defun-skipper (funcall treesit-defun-skipper) (setq success t))) @@ -1923,10 +1974,12 @@ this function depends on `treesit-defun-type-regexp' and `treesit-defun-skipper'." (interactive "^p\nd") (let ((orig-point (point))) + (if (or (null arg) (= arg 0)) (setq arg 1)) (catch 'done (dotimes (_ 2) ; Not making progress is better than infloop. - (when (treesit-end-of-thing treesit-defun-type-regexp arg) + (when (treesit-end-of-thing + treesit-defun-type-regexp arg treesit-defun-tactic) (when treesit-defun-skipper (funcall treesit-defun-skipper))) @@ -2000,7 +2053,7 @@ the current line if the beginning of the defun is indented." ;; parent: ;; 1. node covers pos ;; 2. smallest such node -(defun treesit--things-around (pos regexp &optional pred) +(defun treesit--things-around (pos pred) "Return the previous, next, and parent thing around POS. Return a list of (PREV NEXT PARENT), where PREV and NEXT are @@ -2008,7 +2061,8 @@ previous and next sibling things around POS, and PARENT is the parent thing surrounding POS. All of three could be nil if no sound things exists. -REGEXP and PRED are the same as in `treesit-thing-at-point'." +PRED can be a regexp, a predicate function, and more. See +`treesit-thing-settings' for details." (let* ((node (treesit-node-at pos)) (result (list nil nil nil))) ;; 1. Find previous and next sibling defuns. @@ -2031,9 +2085,7 @@ REGEXP and PRED are the same as in `treesit-thing-at-point'." when node do (let ((cursor node) (iter-pred (lambda (node) - (and (string-match-p - regexp (treesit-node-type node)) - (or (null pred) (funcall pred node)) + (and (treesit-node-match-p node pred) (funcall pos-pred node))))) ;; Find the node just before/after POS to start searching. (save-excursion @@ -2047,13 +2099,11 @@ REGEXP and PRED are the same as in `treesit-thing-at-point'." (setf (nth idx result) (treesit-node-top-level cursor iter-pred t)) (setq cursor (treesit-search-forward - cursor regexp backward backward))))) + cursor pred backward backward))))) ;; 2. Find the parent defun. (let ((cursor (or (nth 0 result) (nth 1 result) node)) (iter-pred (lambda (node) - (and (string-match-p - regexp (treesit-node-type node)) - (or (null pred) (funcall pred node)) + (and (treesit-node-match-p node pred) (not (treesit-node-eq node (nth 0 result))) (not (treesit-node-eq node (nth 1 result))) (< (treesit-node-start node) @@ -2063,15 +2113,6 @@ REGEXP and PRED are the same as in `treesit-thing-at-point'." (treesit-parent-until cursor iter-pred))) result)) -(defun treesit--top-level-thing (node regexp &optional pred) - "Return the top-level parent thing of NODE. -REGEXP and PRED are the same as in `treesit-thing-at-point'." - (treesit-node-top-level - node (lambda (node) - (and (string-match-p regexp (treesit-node-type node)) - (or (null pred) (funcall pred node)))) - t)) - ;; The basic idea for nested defun navigation is that we first try to ;; move across sibling defuns in the same level, if no more siblings ;; exist, we move to parents's beg/end, rinse and repeat. We never @@ -2099,7 +2140,7 @@ REGEXP and PRED are the same as in `treesit-thing-at-point'." ;; -> Obviously we don't want to go to parent's end, instead, we ;; want to go to parent's prev-sibling's end. Again, we recurse ;; in the function to do that. -(defun treesit--navigate-thing (pos arg side regexp &optional pred recursing) +(defun treesit--navigate-thing (pos arg side pred &optional tactic recursing) "Navigate thing ARG steps from POS. If ARG is positive, move forward that many steps, if negative, @@ -2110,7 +2151,18 @@ This function doesn't actually move point, it just returns the position it would move to. If there aren't enough things to move across, return nil. -REGEXP and PRED are the same as in `treesit-thing-at-point'. +PRED can be a regexp, a predicate function, and more. See +`treesit-thing-settings' for details. + +TACTIC determines how does this function move between things. It +can be `nested', `top-level', `restricted', or nil. `nested' +means normal nested navigation: try to move to siblings first, +and if there aren't enough siblings, move to the parent and its +siblings. `top-level' means only consider top-level things, and +nested things are ignored. `restricted' means movement is +restricted inside the thing that encloses POS (i.e., parent), +should there be one. If omitted, TACTIC is considered to be +`nested'. RECURSING is an internal parameter, if non-nil, it means this function is called recursively." @@ -2129,78 +2181,77 @@ function is called recursively." (while (> counter 0) (pcase-let ((`(,prev ,next ,parent) - (treesit--things-around pos regexp pred))) + (treesit--things-around pos pred))) ;; When PARENT is nil, nested and top-level are the same, if ;; there is a PARENT, make PARENT to be the top-level parent ;; and pretend there is no nested PREV and NEXT. - (when (and (eq treesit-defun-tactic 'top-level) + (when (and (eq tactic 'top-level) parent) - (setq parent (treesit--top-level-thing - parent regexp pred) + (setq parent (treesit-node-top-level parent pred t) prev nil next nil)) - ;; Move... - (if (> arg 0) - ;; ...forward. - (if (and (eq side 'beg) - ;; Should we skip the defun (recurse)? - (cond (next (and (not recursing) ; [1] (see below) - (eq pos (funcall advance next)))) - (parent t))) ; [2] - ;; Special case: go to next beg-of-defun, but point - ;; is already on beg-of-defun. Set POS to the end - ;; of next-sib/parent defun, and run one more step. - ;; If there is a next-sib defun, we only need to - ;; recurse once, so we don't need to recurse if we - ;; are already recursing [1]. If there is no - ;; next-sib but a parent, keep stepping out - ;; (recursing) until we got out of the parents until - ;; (1) there is a next sibling defun, or (2) no more - ;; parents [2]. - ;; - ;; If point on beg-of-defun but we are already - ;; recurring, that doesn't count as special case, - ;; because we have already made progress (by moving - ;; the end of next before recurring.) + ;; If TACTIC is `restricted', the implementation is very simple. + (if (eq tactic 'restricted) + (setq pos (funcall advance (if (> arg 0) next prev))) + ;; For `nested', it's a bit more work: + ;; Move... + (if (> arg 0) + ;; ...forward. + (if (and (eq side 'beg) + ;; Should we skip the defun (recurse)? + (cond (next (and (not recursing) ; [1] (see below) + (eq pos (funcall advance next)))) + (parent t))) ; [2] + ;; Special case: go to next beg-of-defun, but point + ;; is already on beg-of-defun. Set POS to the end + ;; of next-sib/parent defun, and run one more step. + ;; If there is a next-sib defun, we only need to + ;; recurse once, so we don't need to recurse if we + ;; are already recursing [1]. If there is no + ;; next-sib but a parent, keep stepping out + ;; (recursing) until we got out of the parents until + ;; (1) there is a next sibling defun, or (2) no more + ;; parents [2]. + ;; + ;; If point on beg-of-defun but we are already + ;; recurring, that doesn't count as special case, + ;; because we have already made progress (by moving + ;; the end of next before recurring.) + (setq pos (or (treesit--navigate-thing + (treesit-node-end (or next parent)) + 1 'beg pred tactic t) + (throw 'term nil))) + ;; Normal case. + (setq pos (funcall advance (or next parent)))) + ;; ...backward. + (if (and (eq side 'end) + (cond (prev (and (not recursing) + (eq pos (funcall advance prev)))) + (parent t))) + ;; Special case: go to prev end-of-defun. (setq pos (or (treesit--navigate-thing - (treesit-node-end (or next parent)) - 1 'beg regexp pred t) + (treesit-node-start (or prev parent)) + -1 'end pred tactic t) (throw 'term nil))) ;; Normal case. - (setq pos (funcall advance (or next parent)))) - ;; ...backward. - (if (and (eq side 'end) - (cond (prev (and (not recursing) - (eq pos (funcall advance prev)))) - (parent t))) - ;; Special case: go to prev end-of-defun. - (setq pos (or (treesit--navigate-thing - (treesit-node-start (or prev parent)) - -1 'end regexp pred t) - (throw 'term nil))) - ;; Normal case. - (setq pos (funcall advance (or prev parent))))) + (setq pos (funcall advance (or prev parent)))))) ;; A successful step! Decrement counter. (cl-decf counter)))) ;; Counter equal to 0 means we successfully stepped ARG steps. (if (eq counter 0) pos nil))) ;; TODO: In corporate into thing-at-point. -(defun treesit-thing-at-point (pattern tactic) +(defun treesit-thing-at-point (pred tactic) "Return the thing node at point or nil if none is found. -\"Thing\" is defined by PATTERN, which can be either a string -REGEXP or a cons cell (REGEXP . PRED): if a node's type matches -REGEXP, it is a thing. The \"thing\" could be further restricted -by PRED: if non-nil, PRED should be a function that takes a node -and returns t if the node is a \"thing\", and nil if not. +\"Thing\" is defined by PRED, which can be a regexp, a +predication function, and more, see `treesit-thing-settings' +for details. Return the top-level defun if TACTIC is `top-level', return the immediate parent thing if TACTIC is `nested'." - (pcase-let* ((`(,regexp . ,pred) - (treesit--thing-unpack-pattern pattern)) - (`(,_ ,next ,parent) - (treesit--things-around (point) regexp pred)) + (pcase-let* ((`(,_ ,next ,parent) + (treesit--things-around (point) pred)) ;; If point is at the beginning of a thing, we ;; prioritize that thing over the parent in nested ;; mode. @@ -2208,7 +2259,7 @@ immediate parent thing if TACTIC is `nested'." next) parent))) (if (eq tactic 'top-level) - (treesit--top-level-thing node regexp pred) + (treesit-node-top-level node pred t) node))) (defun treesit-defun-at-point () @@ -2939,6 +2990,9 @@ See `treesit-language-source-alist' for details." (buffer-local-value 'url-http-response-status buffer) 200))))) +(defvar treesit--install-language-grammar-out-dir-history nil + "History for OUT-DIR for `treesit-install-language-grammar'.") + ;;;###autoload (defun treesit-install-language-grammar (lang) "Build and install the tree-sitter language grammar library for LANG. @@ -2960,11 +3014,20 @@ executable programs, such as the C/C++ compiler and linker." (when-let ((recipe (or (assoc lang treesit-language-source-alist) (treesit--install-language-grammar-build-recipe - lang)))) + lang))) + (default-out-dir + (or (car treesit--install-language-grammar-out-dir-history) + (locate-user-emacs-file "tree-sitter"))) + (out-dir + (read-string + (format "Install to (default: %s): " + default-out-dir) + nil + 'treesit--install-language-grammar-out-dir-history + default-out-dir))) (condition-case err (apply #'treesit--install-language-grammar-1 - ;; The nil is OUT-DIR. - (cons nil recipe)) + (cons out-dir recipe)) (error (display-warning 'treesit @@ -3055,11 +3118,17 @@ function signals an error." (apply #'treesit--call-process-signal (if (file-exists-p "scanner.cc") c++ cc) nil t nil - `("-fPIC" "-shared" - ,@(directory-files - default-directory nil - (rx bos (+ anychar) ".o" eos)) - "-o" ,lib-name)) + (if (eq system-type 'cygwin) + `("-shared" "-Wl,-dynamicbase" + ,@(directory-files + default-directory nil + (rx bos (+ anychar) ".o" eos)) + "-o" ,lib-name) + `("-fPIC" "-shared" + ,@(directory-files + default-directory nil + (rx bos (+ anychar) ".o" eos)) + "-o" ,lib-name))) ;; Copy out. (unless (file-exists-p out-dir) (make-directory out-dir t)) @@ -3089,7 +3158,7 @@ function signals an error." (with-temp-buffer (insert-file-contents (find-library-name "treesit")) (cl-remove-if - (lambda (name) (string-match "treesit--" name)) + (lambda (name) (string-search "treesit--" name)) (cl-sort (save-excursion (goto-char (point-min)) diff --git a/lisp/url/url-mailto.el b/lisp/url/url-mailto.el index 24e64e99c9f..04d6d9681ff 100644 --- a/lisp/url/url-mailto.el +++ b/lisp/url/url-mailto.el @@ -120,11 +120,11 @@ (url-mail-goto-field nil) (url-mail-goto-field "subject"))) (if url-request-extra-headers - (mapconcat + (mapc (lambda (x) (url-mail-goto-field (car x)) (insert (cdr x))) - url-request-extra-headers "")) + url-request-extra-headers)) (goto-char (point-max)) (insert url-request-data) ;; It seems Microsoft-ish to send without warning. diff --git a/lisp/userlock.el b/lisp/userlock.el index 61f061d3e54..562bc0a0a9f 100644 --- a/lisp/userlock.el +++ b/lisp/userlock.el @@ -206,11 +206,12 @@ file, then make the change again.")) ;;;###autoload (defun userlock--handle-unlock-error (error) "Report an ERROR that occurred while unlocking a file." - (display-warning - '(unlock-file) - ;; There is no need to explain that this is an unlock error because - ;; ERROR is a `file-error' condition, which explains this. - (message "%s, ignored" (error-message-string error)) - :warning)) + (when create-lockfiles + (display-warning + '(unlock-file) + ;; There is no need to explain that this is an unlock error because + ;; ERROR is a `file-error' condition, which explains this. + (message "%s, ignored" (error-message-string error)) + :warning))) ;;; userlock.el ends here diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 90905edb887..32b0d5d7556 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -1594,7 +1594,7 @@ After check-out, runs the normal hook `vc-checkout-hook'." (vc-call make-version-backups-p file) (vc-up-to-date-p file) (vc-make-version-backup file)) - (let ((backend (vc-backend file))) + (let ((backend (or (bound-and-true-p vc-dir-backend) (vc-backend file)))) (with-vc-properties (list file) (condition-case err (vc-call-backend backend 'checkout file rev) diff --git a/lisp/window.el b/lisp/window.el index 08ce8498655..aa7520f30fa 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -7510,8 +7510,8 @@ Its value takes effect before processing the ACTION argument of If non-nil, this is an alist of elements (CONDITION . ACTION), where: - CONDITION is passed to `buffer-match-p', along with the buffer - that is to be displayed and the ACTION argument of + CONDITION is passed to `buffer-match-p', along with the name of + the buffer that is to be displayed and the ACTION argument of `display-buffer', to check if ACTION should be used. ACTION is a cons cell (FUNCTIONS . ALIST), where FUNCTIONS is an @@ -7565,15 +7565,16 @@ all fail. It should never be set by programs or users. See `display-buffer'.") (put 'display-buffer-fallback-action 'risky-local-variable t) -(defun display-buffer-assq-regexp (buffer-or-name alist action) - "Retrieve ALIST entry corresponding to buffer specified by BUFFER-OR-NAME. +(defun display-buffer-assq-regexp (buffer-name alist action) + "Retrieve ALIST entry corresponding to buffer whose name is BUFFER-NAME. This returns the cdr of the alist entry ALIST if the entry's -key (its car) and BUFFER-OR-NAME satisfy `buffer-match-p', using -the key as CONDITION argument of `buffer-match-p'. ACTION should -have the form of the action argument passed to `display-buffer'." +key (its car) and the name of the buffer designated by +BUFFER-NAME satisfy `buffer-match-p', using the key as +CONDITION argument of `buffer-match-p'. ACTION should have the +form of the action argument passed to `display-buffer'." (catch 'match (dolist (entry alist) - (when (buffer-match-p (car entry) buffer-or-name action) + (when (buffer-match-p (car entry) buffer-name action) (throw 'match (cdr entry)))))) (defvar display-buffer--same-window-action @@ -7732,6 +7733,9 @@ specified by the ACTION argument." (let ((buffer (if (bufferp buffer-or-name) buffer-or-name (get-buffer buffer-or-name))) + (buf-name (if (bufferp buffer-or-name) + (buffer-name buffer-or-name) + buffer-or-name)) ;; Make sure that when we split windows the old window keeps ;; point, bug#14829. (split-window-keep-point t) @@ -7740,7 +7744,7 @@ specified by the ACTION argument." (unless (listp action) (setq action nil)) (let* ((user-action (display-buffer-assq-regexp - buffer display-buffer-alist action)) + buf-name display-buffer-alist action)) (special-action (display-buffer--special-action buffer)) ;; Extra actions from the arguments to this function: (extra-action diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el index b213b155249..9286a1858cf 100644 --- a/lisp/x-dnd.el +++ b/lisp/x-dnd.el @@ -34,20 +34,20 @@ ;;; Customizable variables (defcustom x-dnd-test-function #'x-dnd-default-test-function - "The function drag and drop uses to determine if to accept or reject a drop. -The function takes three arguments, WINDOW, ACTION and TYPES. -WINDOW is where the mouse is when the function is called. WINDOW -may be a frame if the mouse isn't over a real window (i.e. menu -bar, tool bar or scroll bar). ACTION is the suggested action -from the drag and drop source, one of the symbols move, copy, -link or ask. TYPES is a vector of available types for the drop. - -Each element of TYPE should either be a string (containing the + "Function to be used by drag-and-drop to determine whether to accept a drop. +The function takes three arguments: WINDOW, ACTION, and TYPES. +WINDOW is where the window under the mouse is when the function is called. +WINDOW may be a frame if the mouse isn't over a real window (e.g., menu +bar, tool bar, scroll bar, etc.). +ACTION is the suggested action from the drag and drop source, one of the +symbols `move', `copy', `link' or `ask'. +TYPES is a vector of available types for the drop. +Each element of TYPES should either be a string (containing the name of the type's X atom), or a symbol, whose name will be used. The function shall return nil to reject the drop or a cons with -two values, the wanted action as car and the wanted type as cdr. -The wanted action can be copy, move, link, ask or private. +two values, the wanted action as `car' and the wanted type as `cdr'. +The wanted action can be `copy', `move', `link', `ask' or `private'. The default value for this variable is `x-dnd-default-test-function'." :version "22.1" @@ -70,14 +70,18 @@ The default value for this variable is `x-dnd-default-test-function'." (,(purecopy "DndTypeFile") . x-dnd-handle-offix-file) (,(purecopy "DndTypeFiles") . x-dnd-handle-offix-files) (,(purecopy "DndTypeText") . dnd-insert-text)) - "Which function to call to handle a drop of that type. -If the type for the drop is not present, or the function is nil, -the drop is rejected. The function takes three arguments, WINDOW, ACTION -and DATA. WINDOW is where the drop occurred, ACTION is the action for -this drop (copy, move, link, private or ask) as determined by a previous -call to `x-dnd-test-function'. DATA is the drop data. -The function shall return the action used (copy, move, link or private) -if drop is successful, nil if not." + "Functions to call to handle drag-and-drop of known types. +If the type of the drop is not present in the alist, or the +function corresponding to the type is nil, the drop of that +type will be rejected. + +Each function takes three arguments: WINDOW, ACTION, and DATA. +WINDOW is the window where the drop occurred. +ACTION is the action for this drop (`copy', `move', `link', `private' +or `ask'), as determined by a previous call to `x-dnd-test-function'. +DATA is the drop data. +The function shall return the action it used (one of the above, +excluding `ask') if drop is successful, nil if not." :version "22.1" :type 'alist :group 'x) @@ -122,22 +126,27 @@ like xterm) for text." :group 'x) (defcustom x-dnd-direct-save-function #'x-dnd-save-direct - "Function called when a file is dropped that Emacs must save. -It is called with two arguments: the first is either nil or t, -and the second is a string. - -If the first argument is t, the second argument is the name the -dropped file should be saved under. The function should return a -complete file name describing where the file should be saved. - -It can also return nil, which means to cancel the drop. - -If the first argument is nil, the second is the name of the file -that was dropped." + "Function called when a file is dropped via XDS protocol. +The value should be a function of two arguments that supports +the X Direct Save (XDS) protocol. The function will be called +twice during the protocol execution. + +When the function is called with the first argument non-nil, +it should return an absolute file name whose base name is +the value of the second argument, a string. The return value +is the file name for the dragged file to be saved. The function +can also return nil if saving the file should be refused for some +reason; in that case the drop will be canceled. + +When the function is called with the first argument nil, the +second argument specifies the file name where the file was saved; +the function should then do whatever is appropriate when such a +file is saved, like show the file in the Dired buffer or visit +the file." :version "29.1" - :type '(choice (const :tag "Prompt for name before saving" + :type '(choice (const :tag "Prompt for file name to save" x-dnd-save-direct) - (const :tag "Save and open immediately without prompting" + (const :tag "Save in `default-directory' without prompting" x-dnd-save-direct-immediately) (function :tag "Other function")) :group 'x) @@ -222,14 +231,14 @@ any protocol specific data.") (cdr (x-dnd-get-state-cons-for-frame frame-or-window))) (defun x-dnd-default-test-function (_window _action types) - "The default test function for drag and drop. + "The default test function for drag-and-drop. WINDOW is where the mouse is when this function is called. It may be a frame if the mouse is over the menu bar, scroll bar or tool bar. ACTION is the suggested action from the source, and TYPES are the types the drop data can have. This function only accepts drops with types in `x-dnd-known-types'. It always returns the action `private', unless `types' contains a value -inside `x-dnd-copy-types'." +inside `x-dnd-copy-types', in which case it may return `copy'." (let ((type (x-dnd-choose-type types))) (when type (let ((list x-dnd-copy-types)) (catch 'out @@ -1564,17 +1573,24 @@ was taken, or the direct save failed." (when (not (equal file-name original-file-name)) (delete-file file-name))))) -(defun x-dnd-save-direct (need-name name) - "Handle dropping a file that should be saved immediately. -NEED-NAME tells whether or not the file was not yet saved. NAME -is either the name of the file, or the name the drop source wants -us to save under. +(defun x-dnd-save-direct (need-name filename) + "Handle dropping a file FILENAME that should be saved first, asking the user. +NEED-NAME non-nil means the caller requests the full absolute +file name of FILENAME under which to save it; FILENAME is just +the base name in that case. The function then prompts the user +for where to save to file and returns the result to the caller. + +NEED-NAME nil means the file was saved as FILENAME (which should +be the full absolute file name in that case). The function then +refreshes the Dired display, if the current buffer is in Dired +mode, or visits the file otherwise. -Prompt the user for a file name, then open it." +This function is intended to be the value of `x-dnd-direct-save-function', +which see." (if need-name (let ((file-name (read-file-name "Write file: " default-directory - nil nil name))) + nil nil filename))) (when (file-exists-p file-name) (unless (y-or-n-p (format-message "File `%s' exists; overwrite? " file-name)) @@ -1584,18 +1600,18 @@ Prompt the user for a file name, then open it." ;; interface can be found. (if (derived-mode-p 'dired-mode) (revert-buffer) - (find-file name)))) + (find-file filename)))) -(defun x-dnd-save-direct-immediately (need-name name) - "Save and open a dropped file, like `x-dnd-save-direct'. -NEED-NAME tells whether or not the file was not yet saved. NAME -is either the name of the file, or the name the drop source wants -us to save under. +(defun x-dnd-save-direct-immediately (need-name filename) + "Handle dropping a file FILENAME that should be saved first. +Like `x-dnd-save-direct', but do not prompt for the file name; +instead, return its absolute file name for saving in the current +directory. -Unlike `x-dnd-save-direct', do not prompt for the name by which -to save the file. Simply save it in the current directory." +This function is intended to be the value of `x-dnd-direct-save-function', +which see." (if need-name - (let ((file-name (expand-file-name name))) + (let ((file-name (expand-file-name filename))) (when (file-exists-p file-name) (unless (y-or-n-p (format-message "File `%s' exists; overwrite? " file-name)) @@ -1605,7 +1621,7 @@ to save the file. Simply save it in the current directory." ;; interface can be found. (if (derived-mode-p 'dired-mode) (revert-buffer) - (find-file name)))) + (find-file filename)))) (defun x-dnd-handle-octet-stream-for-drop (save-to) "Save the contents of the XDS selection to SAVE-TO. |